Add htmlwidget serializer

.travis.yml

@@ -1,19 +1,20 @@
 language: r
 cache: packages
-r_binary_packages:
-  - testthat
-  - XML
-  - base64enc
-  - rmarkdown
-  - stringi
-  - jsonlite
-  - httpuv
 r_github_packages:
   - jimhester/covr
 after_success:
   - Rscript -e 'library(covr);codecov()'
 after_failure:
   - ./travis-tool.sh dump_logs
 r_packages:
+  - testthat
+  - XML
+  - base64enc
+  - rmarkdown
+  - stringi
+  - jsonlite
+  - httpuv
+  - htmlwidgets
   - PKI
+  - visNetwork
 warnings_are_errors: true

DESCRIPTION

@@ -25,8 +25,10 @@ Suggests:
     XML,
     rmarkdown,
     PKI,
-    base64enc
-Collate:
+    base64enc,
+    htmlwidgets,
+    visNetwork
+Collate: 
     'content-types.R'
     'cookie-parser.R'
     'globals.R'
@@ -43,6 +45,7 @@ Collate:
     'response.R'
     'serializer-content-type.R'
     'serializer-html.R'
+    'serializer-htmlwidget.R'
     'serializer-xml.R'
     'serializer.R'
     'session-cookie.R'

NEWS.md

@@ -8,6 +8,8 @@ plumber 0.3.1
 --------------------------------------------------------------------------------
 * Add a method to consume JSON on post (you can still send a query string in
   the body of a POST request as well).
+* Added `@serializer htmlwidget` to support rendering and returning a 
+  self-contained htmlwidget from a plumber endpoint.
 
 plumber 0.3.0
 --------------------------------------------------------------------------------

R/serializer-htmlwidget.R

@@ -0,0 +1,33 @@
+#' @noRd
+#' @include globals.R
+htmlwidgetSerializer <- function(){
+  function(val, req, res, errorHandler){
+    tryCatch({
+      if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+        stop("The htmlwidgets package is not available but is required in order to use the htmlwidgets serializer",
+             call. = FALSE)
+      }
+
+      # Set content type to HTML
+      res$setHeader("Content-Type", "text/html; charset=utf-8")
+
+      # Write out a temp file. htmlwidgets (or pandoc?) seems to require that this
+      # file end in .html or the selfcontained=TRUE argument has no effect.
+      file <- tempfile(fileext=".html")
+
+      # Write the widget out to a file (doesn't currently support in-memory connections)
+      # Must write a self-contained file. We're not serving a directory of assets
+      # in response to this request, just one HTML file.
+      htmlwidgets::saveWidget(val, file, selfcontained=TRUE)
+
+      # Read the file back in as a single string and return.
+      res$body <- paste(readLines(file), collapse="")
+
+      return(res$toResponse())
+    }, error=function(e){
+      errorHandler(req, res, e)
+    })
+  }
+}
+
+.globals$serializers[["htmlwidget"]] <- htmlwidgetSerializer

tests/testthat/test-serializer-htmlwidgets.R

@@ -0,0 +1,33 @@
+context("htmlwidgets serializer")
+
+# Render a simple HTML widget using the visNetwork package
+renderWidget <- function(){
+  nodes <- data.frame(id = 1:6, title = paste("node", 1:6),
+                      shape = c("dot", "square"),
+                      size = 10:15, color = c("blue", "red"))
+  edges <- data.frame(from = 1:5, to = c(5, 4, 6, 3, 3))
+  visNetwork::visNetwork(nodes, edges) %>%
+    visNetwork::visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)
+
+}
+
+test_that("htmlwidgets serialize properly", {
+  print(installed.packages())
+  w <- renderWidget()
+  val <- htmlwidgetSerializer()(w, list(), PlumberResponse$new(), stop)
+  expect_equal(val$status, 200L)
+  expect_equal(val$headers$`Content-Type`, "text/html; charset=utf-8")
+  # Check that content is encoded
+  expect_match(val$body, "<script src=\"data:application/x-javascript;base64")
+})
+
+test_that("Errors call error handler", {
+  errors <- 0
+  errHandler <- function(req, res, err){
+    errors <<- errors + 1
+  }
+
+  expect_equal(errors, 0)
+  htmlwidgetSerializer()(parse(text="hi"), list(), PlumberResponse$new("htmlwidget"), err = errHandler)
+  expect_equal(errors, 1)
+})

tests/testthat/test-serializer-json.R

@@ -1,3 +1,5 @@
+context("JSON serializer")
+
 test_that("JSON serializes properly", {
   l <- list(a=1, b=2, c="hi")
   val <- jsonSerializer()(l, list(), PlumberResponse$new(), stop)