Followup to "adds svg plot option #398" (#543)

Co-authored-by: pachamaltese <mvargas@dcc.uchile.cl>

.github/workflows/R-CMD-check.yaml

@@ -69,8 +69,16 @@ jobs:
           key: ${{ matrix.config.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
           restore-keys: ${{ matrix.config.os }}-${{ hashFiles('.github/R-version') }}-1-
 
+      # Install Cairo system dependencies
+      # used for svg testing
+      - name: Mac systemdeps
+        if: runner.os == 'macOS'
+        run: |
+          brew cask install xquartz
+          brew install cairo
+
       - name: macOS oldrel Rcpp
-        if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'oldrel'
+        if: runner.os == 'macOS' && matrix.config.r == 'oldrel'
         shell: Rscript {0}
         run: |
           remotes::install_cran("Rcpp", type = "source")

.github/workflows/test-coverage.yaml

@@ -20,6 +20,14 @@ jobs:
 
       - uses: r-lib/actions/setup-pandoc@master
 
+      # Install Cairo system dependencies
+      # used for svg testing
+      - name: Mac systemdeps
+        if: runner.os == 'macOS'
+        run: |
+          brew cask install xquartz
+          brew install cairo
+
       - name: Query dependencies
         run: |
           install.packages('remotes')

NAMESPACE

@@ -36,9 +36,6 @@ import(R6)
 import(crayon)
 import(promises)
 import(stringi)
-importFrom(grDevices,dev.off)
-importFrom(grDevices,jpeg)
-importFrom(grDevices,png)
 importFrom(httpuv,runServer)
 importFrom(jsonlite,fromJSON)
 importFrom(jsonlite,toJSON)

NEWS.md

@@ -69,6 +69,8 @@ plumber 0.5.0
 
 * Improve speed of `canServe()` method of the `PlumberEndpoint` class (@atheriel, #484)
 
+* Add support for returning svg images using `#' @svg` (and with arguments `#' @svg (width = 200, height=500)`. (@pachamaltese, #398)
+
 ### Bug fixes
 
 * Modified images serialization to use content-type serializer. Fixes issue with images pre/postserialize hooks (@meztez, #518).

R/images.R

@@ -1,6 +1,5 @@
-#' @param imageFun The function to call to setup the image device (e.g. `png`)
-#' @param args A list of supplemental arguments to be passed into jpeg()
-#' @importFrom grDevices dev.off jpeg png
+#' @param imageFun The function to call to setup the image device (Ex: `grDevices::png()`)
+#' @param args A list of supplemental arguments to be passed into `imageFun()`
 #' @noRd
 render_image <- function(imageFun, args=NULL){
   list(
@@ -12,7 +11,7 @@ render_image <- function(imageFun, args=NULL){
       do.call(imageFun, finalArgs)
     },
     postexec = function(value, req, res, data){
-      dev.off()
+      grDevices::dev.off()
       on.exit({unlink(data$file)}, add = TRUE)
       con <- file(data$file, "rb")
       on.exit({close(con)}, add = TRUE)
@@ -29,3 +28,7 @@ render_jpeg <- function(args){
 render_png <- function(args){
   render_image(grDevices::png, args)
 }
+
+render_svg <- function(args){
+  render_image(grDevices::svg, args)
+}

R/parse-block.R

@@ -150,7 +150,7 @@ parseBlock <- function(lineNum, file){
 
     }
 
-    imageMat <- stri_match(line, regex="^#['\\*]\\s*@(jpeg|png)([\\s\\(].*)?\\s*$")
+    imageMat <- stri_match(line, regex="^#['\\*]\\s*@(jpeg|png|svg)([\\s\\(].*)?\\s*$")
     if (!is.na(imageMat[1,1])){
       if (!is.null(image)){
         # Must have already assigned.
@@ -256,6 +256,9 @@ evaluateBlock <- function(srcref, file, expr, envir, addEndpoint, addFilter, mou
         } else if (block$image == "jpeg"){
           ep$registerHooks(render_jpeg(imageArgs))
           ep$serializer <- serializer_content_type("image/jpeg")
+        } else if (block$image == "svg"){
+          ep$registerHooks(render_svg(imageArgs))
+          ep$serializer <- serializer_content_type("image/svg+xml")
         } else {
           stop("Image format not found: ", block$image)
         }

inst/examples/15-swagger-spec/plumber_custom_swagger_spec.R → inst/examples/15-swagger-spec/entrypoint.R

@@ -19,7 +19,8 @@ handler <- function(num) { sum(as.integer(num)) }
 
 pr$handle("GET", "/sum", handler, serializer = serializer_json())
 
-pr$run(swagger = swagger)
+# pr$run(swagger = swagger) # TODO-barret make function for this
+
 
 # Dealing with a file parameter
 pr <- plumber$new()
@@ -44,6 +45,8 @@ handler <- function(req) {
 
 pr$handle("POST", "/upload", handler, serializer = serializer_json())
 
-pr$run(swagger = swagger)
+# pr$run(swagger = swagger) # TODO-barret make function for this
 
 #In case you have have problems, insert a `browser()` in your swagger function
+
+pr

tests/testthat/files/image.R

@@ -10,6 +10,11 @@ function() {
   plot(1:10)
 }
 
+#* @svg
+#* @get /svg
+function() {
+  plot(1:10)
+}
 
 #' @png (width = 150, height=150)
 #' @get /littlepng
@@ -22,3 +27,10 @@ function(){
 function(){
   plot(1:10)
 }
+
+#* @svg(width=4, height=4)
+#* @get /littlesvg
+function() {
+  warning("Should not test. Image size does not decrease with dimension decrease")
+  plot(1:10)
+}

tests/testthat/test-image.R

@@ -1,31 +1,39 @@
 context("Images")
 
-test_that("Images are properly rendered", {
-  r <- plumber$new(test_path("files/image.R"))
-
-  resp <- r$serve(make_req("GET", "/png"), PlumberResponse$new())
-  expect_equal(resp$status, 200)
-  expect_equal(resp$headers$`Content-Type`, "image/png")
-  fullsizePNG <- length(resp$body)
-  expect_gt(fullsizePNG, 1000) # This changes based on R ver/OS, may not be useful.
-
-  resp <- r$serve(make_req("GET", "/littlepng"), PlumberResponse$new())
-  expect_equal(resp$status, 200)
-  expect_equal(resp$headers$`Content-Type`, "image/png")
-  expect_gt(length(resp$body), 100) # This changes based on R ver/OS, may not be useful.
-  expect_lt(length(resp$body), fullsizePNG) # Should be smaller than the full one
-
-  resp <- r$serve(make_req("GET", "/jpeg"), PlumberResponse$new())
-  expect_equal(resp$status, 200)
-  expect_equal(resp$headers$`Content-Type`, "image/jpeg")
-  fullsizeJPEG <- length(resp$body)
-  expect_gt(fullsizeJPEG, 1000) # This changes based on R ver/OS, may not be useful.
-
-  resp <- r$serve(make_req("GET", "/littlejpeg"), PlumberResponse$new())
-  expect_equal(resp$status, 200)
-  expect_equal(resp$headers$`Content-Type`, "image/jpeg")
-  expect_gt(length(resp$body), 100) # This changes based on R ver/OS, may not be useful.
-  expect_lt(length(resp$body), fullsizeJPEG) # Should be smaller than the full one
+test_image <- local({
+    r <- plumber$new(test_path("files/image.R"))
+
+  function(name, content_type, capability_type = name, test_little = TRUE) {
+    if (!capabilities(capability_type)) {
+      testthat::skip("Graphics type not supported: ", name)
+    }
+
+    resp <- r$serve(make_req("GET", paste0("/", name)), PlumberResponse$new())
+    expect_equal(resp$status, 200)
+    expect_equal(resp$headers$`Content-Type`, content_type)
+    fullsize <- length(resp$body)
+    expect_gt(fullsize, 1000) # This changes based on R ver/OS, may not be useful.
+
+    if (!isTRUE(test_little)) {
+      # do not test the smaller image route
+      return()
+    }
+    resp <- r$serve(make_req("GET", paste0("/little", name)), PlumberResponse$new())
+    expect_equal(resp$status, 200)
+    expect_equal(resp$headers$`Content-Type`, content_type)
+    expect_gt(length(resp$body), 100) # This changes based on R ver/OS, may not be useful.
+    expect_lt(length(resp$body), fullsize) # Should be smaller than the full one
+  }
+})
+
+test_that("png are properly rendered", {
+  test_image("png", "image/png")
+})
+test_that("jpeg are properly rendered", {
+  test_image("jpeg", "image/jpeg")
+})
+test_that("svg are properly rendered", {
+  test_image("svg", "image/svg+xml", capability_type = "cairo", test_little = FALSE)
 })
 
 test_that("render_image arguments supplement", {
@@ -39,7 +47,7 @@ test_that("render_image arguments supplement", {
   data <- new.env()
   req <- make_req("GET", "/")
   res <- list()
-  p$pre(req, res, data)
+  p$preexec(req, res, data)
   expect_length(pngcalls, 3)
   expect_equal(pngcalls$filename, data$file)
   expect_equal(pngcalls$a, 1)