Dynamic Plot Endpoints

R/openapi-spec.R

@@ -17,8 +17,18 @@ endpointSpecification <- function(routerEndpointEntry, path = routerEndpointEntr
   funcParams <- routerEndpointEntry$getFuncParams()
   # Get the plumber decoration defined endpoint params
   endpointParams <- routerEndpointEntry$getEndpointParams()
+
+  # if legacy plumber.staticSerializers is specified then ignore all req serializer
+  # based parameters
+  if (getOption("plumber.staticSerializers", default="FALSE") == "TRUE") {
+    serializerParams <- list()
+  } else {
+    # Get the plumber serializer defined endpoint params
+    serializerParams <- routerEndpointEntry$getSerializerParams()
+  }
+
   for (verb in routerEndpointEntry$verbs) {
-    params <- parametersSpecification(endpointParams, pathParams, funcParams)
+    params <- parametersSpecification(endpointParams, pathParams, funcParams, serializerParams)
 
     # If we haven't already documented a path param, we should add it here.
     # FIXME: warning("Undocumented path parameters: ", paste0())
@@ -81,15 +91,15 @@ responsesSpecification <- function(endpts){
 #' Extract the OpenAPI parameters Specification from the endpoint
 #' paramters.
 #' @noRd
-parametersSpecification <- function(endpointParams, pathParams, funcParams = NULL){
+parametersSpecification <- function(endpointParams, pathParams, funcParams = NULL, serializerParams = NULL){
 
   params <- list(
     parameters = list(),
     requestBody = NULL
   )
   inBody <- filterApiTypes("requestBody", "location")
   inRaw <- filterApiTypes("binary", "format")
-  for (p in unique(c(names(endpointParams), pathParams$name, names(funcParams)))) {
+  for (p in unique(c(names(endpointParams), pathParams$name, names(funcParams), names(serializerParams)))) {
 
     # Dealing with priorities endpointParams > pathParams > funcParams
     # For each p, find out which source to trust for :
@@ -112,27 +122,34 @@ parametersSpecification <- function(endpointParams, pathParams, funcParams = NUL
       type <- priorizeProperty(defaultApiType,
                                pathParams[pathParams$name == p,]$type,
                                endpointParams[[p]]$type,
-                               funcParams[[p]]$type)
+                               funcParams[[p]]$type,
+                               serializerParams[[p]]$type)
       type <- plumberToApiType(type, inPath = TRUE)
       isArray <- priorizeProperty(defaultIsArray,
                                   pathParams[pathParams$name == p,]$isArray,
                                   endpointParams[[p]]$isArray,
-                                  funcParams[[p]]$isArray)
+                                  funcParams[[p]]$isArray,
+                                  serializerParams[[p]]$isArray)
     } else {
       location <- "query"
       style <- "form"
       explode <- TRUE
       type <- priorizeProperty(defaultApiType,
                                endpointParams[[p]]$type,
-                               funcParams[[p]]$type)
+                               funcParams[[p]]$type,
+                               serializerParams[[p]]$type)
       type <- plumberToApiType(type)
       isArray <- priorizeProperty(defaultIsArray,
                                   endpointParams[[p]]$isArray,
-                                  funcParams[[p]]$isArray)
+                                  funcParams[[p]]$isArray,
+                                  serializerParams[[p]]$isArray)
       required <- priorizeProperty(funcParams[[p]]$required,
-                                   endpointParams[[p]]$required)
+                                   endpointParams[[p]]$required,
+                                   serializerParams[[p]]$required)
     }
 
+    desc <- endpointParams[[p]]$desc %||% serializerParams[[p]]$desc
+
     # Building OpenAPI Specification
     if (type %in% inBody) {
       if (length(params$requestBody) == 0L) {
@@ -143,7 +160,7 @@ parametersSpecification <- function(endpointParams, pathParams, funcParams = NUL
         type = type,
         format = apiTypesInfo[[type]]$format,
         example = funcParams[[p]]$example,
-        description = endpointParams[[p]]$desc
+        description = desc
       )
       if (type %in% inRaw) {
         names(params$requestBody$content) <- "multipart/form-data"
@@ -166,7 +183,7 @@ parametersSpecification <- function(endpointParams, pathParams, funcParams = NUL
     } else {
       paramList <- list(
         name = p,
-        description = endpointParams[[p]]$desc,
+        description = desc,
         `in` = location,
         required = required,
         schema = list(

R/options_plumber.R

@@ -41,6 +41,9 @@
 #' \item{`plumber.legacyRedirects`}{Plumber will redirect legacy route `/__swagger__/` and
 #' `/__swagger__/index.html` to `../__docs__/` and `../__docs__/index.html`. You can disable this
 #' by settings this option to `FALSE`. Defaults to `TRUE`}
+#' \item{`plumber.staticSerializers`}{Plumber will use fixed serializers and
+#' will not interpret e.g. plot_width and plot_height parameters as plot image
+#' size instructions}
 #' }
 #'
 #' @param ... Ignored. Should be empty
@@ -64,7 +67,8 @@ options_plumber <- function(
   apiPath              = getOption("plumber.apiPath"),
   maxRequestSize       = getOption("plumber.maxRequestSize"),
   sharedSecret         = getOption("plumber.sharedSecret"),
-  legacyRedirects      = getOption("plumber.legacyRedirects")
+  legacyRedirects      = getOption("plumber.legacyRedirects"),
+  staticSerializers    = getOption("plumber.staticSerializers")
 ) {
   ellipsis::check_dots_empty()
 
@@ -86,6 +90,7 @@ options_plumber <- function(
     plumber.apiPath              =   apiPath,
     plumber.maxRequestSize       =   maxRequestSize,
     plumber.sharedSecret         =   sharedSecret,
-    plumber.legacyRedirects      =   legacyRedirects
+    plumber.legacyRedirects      =   legacyRedirects,
+    plumber.staticSerializers    =   staticSerializers
   )
 }

R/plumber-step.R

@@ -196,6 +196,8 @@ PlumberEndpoint <- R6Class(
     },
     #' @field params endpoint parameters
     params = NA,
+    #' @field serializer_params serializer parameters
+    serializer_params = NULL,
     #' @field tags endpoint tags
     tags = NA,
     #' @field parsers step allowed parsers
@@ -296,6 +298,13 @@ PlumberEndpoint <- R6Class(
       }
       self$params
     },
+    #' @description retrieve serializer endpoint parameters
+    getSerializerParams = function() {
+      if (is.null(self$serializer_params)) {
+        return(list())
+      }
+      return(self$serializer_params)
+    },
     # It would not make sense to have `$getPath()` and deprecate `$path`
     #' @description Updates `$path` with a sanitized `path` and updates the internal path meta-data
     #' @param path Path to set `$path`. If missing a beginning slash, one will be added.

R/serializer.R

@@ -446,6 +446,7 @@ serializer_xml <- function() {
 #' @param preexec_hook Function to be run directly before a [PlumberEndpoint] calls its route method.
 #' @param postexec_hook Function to be run directly after a [PlumberEndpoint] calls its route method.
 #' @param aroundexec_hook Function to be run around a [PlumberEndpoint] call. Must handle a `.next` argument to continue execution. \lifecycle{experimental}
+#' @param serializer_params Dynamic serializer parameters. More docs needed here!
 #'
 #' @export
 #' @examples
@@ -457,7 +458,8 @@ endpoint_serializer <- function(
   serializer,
   preexec_hook = NULL,
   postexec_hook = NULL,
-  aroundexec_hook = NULL
+  aroundexec_hook = NULL,
+  serializer_params = list()
 ) {
 
   stopifnot(is.function(serializer))
@@ -466,7 +468,8 @@ endpoint_serializer <- function(
       serializer = serializer,
       preexec_hook = preexec_hook,
       postexec_hook = postexec_hook,
-      aroundexec_hook = aroundexec_hook
+      aroundexec_hook = aroundexec_hook,
+      serializer_params = serializer_params
     ),
     class = "plumber_endpoint_serializer"
   )
@@ -475,6 +478,7 @@ endpoint_serializer <- function(
 self_set_serializer <- function(self, serializer) {
   if (inherits(serializer, "plumber_endpoint_serializer")) {
     self$serializer <- serializer$serializer
+    self$serializer_params <- serializer$serializer_params
     if (!is.null(serializer$preexec_hook)) {
       self$registerHook("preexec", serializer$preexec_hook)
     }
@@ -497,26 +501,37 @@ self_set_serializer <- function(self, serializer) {
 #' The graphics device `dev_on` function will receive any arguments supplied to the serializer in addition to `filename`.
 #' `filename` points to the temporary file name that should be used when saving content.
 #' @param dev_off Function to turn off the graphics device. Defaults to [grDevices::dev.off()]
+#' @param serializer_params More docs needed here
+#'
 #' @export
-serializer_device <- function(type, dev_on, dev_off = grDevices::dev.off) {
+serializer_device <- function(type, dev_on, dev_off = grDevices::dev.off, serializer_params = list()) {
 
   stopifnot(!missing(type))
 
   stopifnot(!missing(dev_on))
   stopifnot(is.function(dev_on))
   stopifnot(length(formals(dev_on)) > 0)
   if (!any(c("filename", "...") %in% names(formals(dev_on)))) {
-    stop("`dev_on` must contain an arugment called `filename` or have `...`")
+    stop("`dev_on` must contain an argument called `filename` or have `...`")
   }
 
+  dev_requires_req <- "req" %in% names(formals(dev_on))
+
   stopifnot(is.function(dev_off))
 
   endpoint_serializer(
     serializer = serializer_content_type(type),
     aroundexec_hook = function(..., .next) {
       tmpfile <- tempfile()
 
-      dev_on(filename = tmpfile)
+      if (dev_requires_req) {
+        dyn_args <- list(...)
+        req <- dyn_args[["req"]]
+        dev_on(filename = tmpfile, req = req)
+      } else {
+        dev_on(filename = tmpfile)
+      }
+
       device_id <- dev.cur()
       dev_off_once <- once(function() dev_off(device_id))
 
@@ -558,68 +573,142 @@ serializer_device <- function(type, dev_on, dev_off = grDevices::dev.off) {
       } else {
         success(result)
       }
-    }
+    },
+    serializer_params = serializer_params
   )
 }
 
+serializer_param_width <- function() {
+  list(plot_width = list(desc="Width of plot image in units", type="number", required=FALSE, isArray=FALSE))
+}
+serializer_param_height <- function() {
+  list(plot_height = list(desc="Height of plot image in units", type="number", required=FALSE, isArray=FALSE))
+}
+serializer_param_res <- function() {
+  list(plot_res = list(desc="Resolution of plot image", type="number", required=FALSE, isArray=FALSE))
+}
+serializer_param_units <- function() {
+  list(plot_units = list(desc="Units of plot image", type="string", required=FALSE, isArray=FALSE))
+}
+serializer_param_pointsize <- function() {
+  list(plot_pointsize = list(desc="Point size of plot image - TODO - better desc", type="number", required=FALSE, isArray=FALSE))
+}
+serializer_param_bg <- function() {
+  list(plot_bg = list(desc="Background colour of plot image", type="string", required=FALSE, isArray=FALSE))
+}
+
+serializer_param_list <- function(all_except = character()) {
+  params <- c(
+    serializer_param_width(),
+    serializer_param_height(),
+    serializer_param_res(),
+    serializer_param_units(),
+    serializer_param_pointsize(),
+    serializer_param_bg()
+  )
+
+  # oh I wish I had purrr!
+  ignored <- Map(function(x) {
+    params[[x]] <<- NULL
+  }, all_except)
+
+  params
+}
+
+
+serialize_dimensions_args_preparer <- function(req, ...) {
+
+  # if legacy plumber.staticSerializers is specified then ignore all req
+  # based parameters
+  if (getOption("staticSerializers", default="FALSE") == "TRUE") {
+    return(list(...))
+  }
+
+  as_numeric_nullable <- function(preferred, alternative) {
+    option <- preferred %||% alternative
+    if (is.null(option)) {
+      NULL
+    } else {
+      as.numeric(option)
+    }
+  }
+
+  doc_args <- list(...)
+  doc_args$width <- as_numeric_nullable(req$args$plot_width, doc_args$width)
+  doc_args$height <- as_numeric_nullable(req$args$plot_height, doc_args$height)
+  doc_args$units <- req$args$plot_units %||% doc_args$units
+  doc_args$res <- as_numeric_nullable(req$args$plot_res, doc_args$res)
+  doc_args$pointsize <- as_numeric_nullable(req$args$plot_pointsize, doc_args$pointsize)
+  doc_args$bg <- req$args$plot_bg %||% doc_args$bg
+
+  return(doc_args)
+}
+
+serializer_image_dev_on_func <- function(grFunc, ...) {
+  function(filename, req) {
+    dimension_args <- serialize_dimensions_args_preparer(req, ...)
+    rlang::exec(grFunc, filename, !!!dimension_args)
+  }
+}
+
+
 #' @describeIn serializers JPEG image serializer. See also: [grDevices::jpeg()]
 #' @export
 serializer_jpeg <- function(..., type = "image/jpeg") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::jpeg(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::jpeg, ...),
+    serializer_params = serializer_param_list()
   )
 }
+
 #' @describeIn serializers PNG image serializer. See also: [grDevices::png()]
 #' @export
 serializer_png <- function(..., type = "image/png") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::png(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::png, ...),
+    serializer_params = serializer_param_list()
   )
 }
+
 #' @describeIn serializers SVG image serializer. See also: [grDevices::svg()]
 #' @export
 serializer_svg <- function(..., type = "image/svg+xml") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::svg(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::svg, ...),
+    serializer_params = serializer_param_list(all_except = c("res"))
   )
 }
+
 #' @describeIn serializers BMP image serializer. See also: [grDevices::bmp()]
 #' @export
 serializer_bmp <- function(..., type = "image/bmp") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::bmp(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::bmp, ...),
+    serializer_params = serializer_param_list()
   )
 }
+
 #' @describeIn serializers TIFF image serializer. See also: [grDevices::tiff()]
 #' @export
 serializer_tiff <- function(..., type = "image/tiff") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::tiff(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::tiff, ...),
+    serializer_params = serializer_param_list()
   )
 }
+
 #' @describeIn serializers PDF image serializer. See also: [grDevices::pdf()]
 #' @export
 serializer_pdf <- function(..., type = "application/pdf") {
   serializer_device(
     type = type,
-    dev_on = function(filename) {
-      grDevices::pdf(filename, ...)
-    }
+    dev_on = serializer_image_dev_on_func(grDevices::pdf, ...),
+    serializer_params = serializer_param_list(all_except = c("pointsize", "res", "units"))
   )
 }