Add basic appshot.shiny.appobj functionality (#55)

* add basic appshot.shiny.appob functionality

* added schloerke a pull #55 in news and description

* added appshot.shiny.appobj and appshot.character to docs

* use callr::r_bg to take a webshot of a shiny app and checking in with observe

* add timeout

* removed processx and withr in favor of callr.  fixed rmdshot example. added docs

* clean up docs

* appshot doc cleanup

* make sure timeout is in addition to delay

* make sure all r_bg process are killed and upgrade NULL envvars to callr default env

* remove render quotes for do.call

* add shiny rmdshot example

* document

DESCRIPTION

@@ -5,6 +5,7 @@ Authors@R: c(
     person("Winston", "Chang", email = "[email protected]", role = c("aut", "cre")),
     person("Yihui", "Xie", role = "ctb"),
     person("Francois", "Guillem", role = "ctb"),
+    person("Barret", "Schloerke", role = "ctb"),
     person("Nicolas", "Perriault", role = "ctb", comment = "The CasperJS library")
     )
 Description: Takes screenshots of web pages, including Shiny applications and R
@@ -14,8 +15,7 @@ Depends:
 Imports:
     magrittr,
     jsonlite,
-    withr,
-    processx
+    callr
 Suggests:
     httpuv,
     knitr,
@@ -27,5 +27,5 @@ SystemRequirements: PhantomJS (http://phantomjs.org) for taking screenshots,
     ImageMagick (http://www.imagemagick.org) or GraphicsMagick
     (http://www.graphicsmagick.org) and OptiPNG (http://optipng.sourceforge.net)
     for manipulating images.
-RoxygenNote: 6.0.1.9000
+RoxygenNote: 6.0.1
 URL: https://github.com/wch/webshot/

NEWS.md

@@ -5,6 +5,8 @@ webshot 0.5.0.9000
 
 * Fixed [#51](https://github.com/wch/webshot/issues/51): Webshot had trouble with some sites that use HTTPS.
 
+* Added `appshot.shiny.appobj` functionality (schloerke, [#55](https://github.com/wch/webshot/pull/55))
+
 webshot 0.5.0
 =============
 

R/appshot.R

@@ -1,19 +1,40 @@
 #' Take a screenshot of a Shiny app
 #'
+#' \code{appshot} performs a \code{\link{webshot}} using two different
+#' methods depending upon the object provided.  If a 'character' is provided
+#' (pointing to an app.R file or app directory) an isolated background R
+#' process is launched to run the Shiny application.  The current R process
+#' then captures the \code{\link{webshot}}.  When a Shiny application object
+#' is supplied to \code{appshot}, the Shiny application is run in the current
+#' R process and an isolated background R process is launched to capture a
+#' \code{\link{webshot}}.  Keeping the Shiny application in a different process
+#' is ideal, shiny application objects are launched in the current R process to
+#' avoid scoping errors.
+#'
 #' @inheritParams webshot
 #' @param app A Shiny app object, or a string naming an app directory.
 #' @param port Port that Shiny will listen on.
 #' @param envvars A named character vector or named list of environment
 #'   variables and values to set for the Shiny app's R process. These will be
 #'   unset after the process exits. This can be used to pass configuration
 #'   information to a Shiny app.
+#' @param webshot_timeout The maximum number of seconds the phantom application
+#' is allowed to run before killing the process. If a delay argument is supplied (in
+#' \code{...}), the delay value is added to the timeout value.
 #'
 #' @param ... Other arguments to pass on to \code{\link{webshot}}.
 #'
+#' @rdname appshot
 #' @examples
 #' if (interactive()) {
 #'   appdir <- system.file("examples", "01_hello", package="shiny")
+#'
+#'   # With a Shiny directory
 #'   appshot(appdir, "01_hello.png")
+#'
+#'   # With a Shiny App object
+#'   shinyapp <- shiny::shinyAppDir(appdir)
+#'   appshot(shinyapp, "01_hello_app.png")
 #' }
 #'
 #' @export
@@ -22,32 +43,104 @@ appshot <- function(app, file = "webshot.png", ...,
   UseMethod("appshot")
 }
 
-#' @export
-appshot.shiny.appobj <- function(app, file = "webshot.png", ...,
-                                 port = getOption("shiny.port"), envvars = NULL) {
-  stop("appshot of Shiny app objects is not yet supported.")
-  # This would require running the app object in this R process
-}
 
+#' @rdname appshot
 #' @export
-appshot.character <- function(app, file = "webshot.png", ...,
-                              port = getOption("shiny.port"), envvars = NULL) {
+appshot.character <- function(
+  app,
+  file = "webshot.png", ...,
+  port = getOption("shiny.port"),
+  envvars = NULL
+) {
+
   port <- available_port(port)
-  cmd <- sprintf("shiny::runApp('%s', port=%d, display.mode='normal')", app, port)
 
   # Run app in background with envvars
-  withr::with_envvar(envvars, {
-    p <- processx::process$new("R", args = c("--slave", "-e", cmd))
-  })
-
+  p <- r_background_process(
+    function(...) {
+      shiny::runApp(...)
+    },
+    args = list(
+      appDir = app,
+      port = port,
+      display.mode = "normal"
+    ),
+    envvars = envvars
+  )
   on.exit({
     p$kill()
   })
 
   # Wait for app to start
   Sys.sleep(0.5)
 
+  # Get screenshot
   fileout <- webshot(sprintf("http://127.0.0.1:%d/", port), file = file, ...)
 
   invisible(fileout)
 }
+
+
+#' @rdname appshot
+#' @export
+appshot.shiny.appobj <- function(
+  app,
+  file = "webshot.png", ...,
+  port = getOption("shiny.port"),
+  envvars = NULL,
+  webshot_timeout = 60
+) {
+
+
+  port <- available_port(port)
+
+  args <- list(
+    url = sprintf("http://127.0.0.1:%d/", port),
+    file = file,
+    ...
+  )
+  p <- r_background_process(
+    function(...) {
+      # Wait for app to start
+      Sys.sleep(0.5)
+      webshot::webshot(...)
+    },
+    args,
+    envvars = envvars
+  )
+  on.exit({
+    p$kill()
+  })
+
+  # add a delay to the webshot_timeout if it exists
+  if(!is.null(args$delay)) {
+    webshot_timeout <- webshot_timeout + args$delay
+  }
+  start_time <- as.numeric(Sys.time())
+
+  # Add a shiny app observer which checks every 200ms to see if the background r session is alive
+  shiny::observe({
+    # check the r session rather than the file to avoid race cases or random issues
+    if (p$is_alive()) {
+      if ((as.numeric(Sys.time()) - start_time) <= webshot_timeout) {
+        # try again later
+        shiny::invalidateLater(200)
+      } else {
+        # timeout has occured. close the app and R session
+        message("webshot timed out")
+        p$kill()
+        shiny::stopApp()
+      }
+    } else {
+      # r_bg session has stopped, close the app
+      shiny::stopApp()
+    }
+    return()
+  })
+
+  # run the app
+  shiny::runApp(app, port = port, display.mode = "normal")
+
+  # return webshot::webshot file value
+  invisible(p$get_result()) # safe to call as the r_bg must have ended
+}

R/process.R

@@ -0,0 +1,8 @@
+
+
+r_background_process <- function(..., envvars = NULL) {
+  if (is.null(envvars)) {
+    envvars <- callr::rcmd_safe_env()
+  }
+  callr::r_bg(..., env = envvars)
+}

R/rmdshot.R

@@ -15,7 +15,15 @@
 #'
 #' @examples
 #' if (interactive()) {
-#'   rmdshot("doc.rmd", "doc.png")
+#'   # rmdshot("rmarkdown_file.Rmd", "snapshot.png")
+#'
+#'   # R Markdown file
+#'   input_file <- system.file("examples/knitr-minimal.Rmd", package = "knitr")
+#'   rmdshot(input_file, "minimal_rmd.png")
+#'
+#'   # Shiny R Markdown file
+#'   input_file <- system.file("examples/shiny.Rmd", package = "webshot")
+#'   rmdshot(input_file, "shiny_rmd.png", delay = 5)
 #' }
 #'
 #' @export
@@ -34,9 +42,7 @@ rmdshot <- function(doc, file = "webshot.png", ..., delay = NULL, rmd_args = lis
     if (is.null(delay)) delay <- 0.2
 
     outfile <- tempfile("webshot", fileext = ".html")
-    render <- rmarkdown::render
-    do.call("render", c(list(doc, output_file = outfile), rmd_args),
-            envir = parent.frame())
+    do.call(rmarkdown::render, c(list(doc, output_file = outfile), rmd_args))
     webshot(outfile, file = file, ...)
   }
 }
@@ -45,20 +51,18 @@ rmdshot <- function(doc, file = "webshot.png", ..., delay = NULL, rmd_args = lis
 rmdshot_shiny <- function(doc, file, ..., rmd_args, port, envvars) {
 
   port <- available_port(port)
-  arg_string <- list_to_arg_string(rmd_args)
-  if (nzchar(arg_string)) {
-    arg_string <- paste0(", ", arg_string)
-  }
-  cmd <- sprintf(
-    "rmarkdown::run('%s', shiny_args=list(port=%d)%s)",
-    doc, port, arg_string
-  )
 
   # Run app in background with envvars
-  withr::with_envvar(envvars, {
-    p <- processx::process$new("R", args = c("--slave", "-e", cmd))
-  })
-
+  p <- r_background_process(
+    function(...) {
+      rmarkdown::run(...)
+    },
+    args = append(
+      list(file = doc, shiny_args = list(port = port)),
+      rmd_args
+    ),
+    envvars = envvars
+  )
   on.exit({
     p$kill()
   })
@@ -72,31 +76,6 @@ rmdshot_shiny <- function(doc, file, ..., rmd_args, port, envvars) {
 }
 
 
-# Convert a list of args like list(a=1, b="xyz") to a string like 'a=1, b="xyz"'
-list_to_arg_string <- function(x) {
-
-  item_to_arg_string <- function(name, val) {
-    if (is.numeric(val))
-      as.character(val)
-    else if (is.character(val))
-      paste0('"', val, '"')
-    else
-      stop("Only know how to handle numbers and strings arguments to rmarkdown::render. ",
-        "Don't know how to handle argument `", val, "`.")
-  }
-
-  strings <- vapply(seq_along(x), function(n) item_to_arg_string(names(x)[n], x[[n]]), "")
-
-  # Convert to a vector like c("a=1", "b=2")
-  strings <- mapply(names(x), strings,
-    FUN = function(name, val) paste(name, val, sep ="="),
-    USE.NAMES = FALSE
-  )
-
-  paste(strings, collapse = ", ")
-}
-
-
 # Borrowed from rmarkdown
 is_shiny <- function (runtime) {
   !is.null(runtime) && grepl("^shiny", runtime)

R/utils.R

@@ -7,7 +7,24 @@ phantom_run <- function(args, wait = TRUE) {
   # Make sure args is a char vector
   args <- as.character(args)
 
-  system2(phantom_bin, args = args, wait = wait)
+  p <- callr::process$new(
+    phantom_bin,
+    args = args,
+    stdout = "|", stderr = "|",
+    supervise = TRUE
+  )
+
+  if (isTRUE(wait)) {
+    on.exit({
+      p$kill()
+    })
+    while(p$is_alive()) {
+      p$wait(200) # wait until min(c(time_ms, process ends))
+      cat(p$read_error_lines()) # print the errors
+      cat(p$read_output_lines()) # print the outputs
+    }
+  }
+  p$get_exit_status()
 }
 
 

R/webshot.R

@@ -227,8 +227,8 @@ webshot <- function(
     # Workaround for SSL problem: https://github.com/wch/webshot/issues/51
     # https://stackoverflow.com/questions/22461345/casperjs-status-fail-on-a-webpage
     "--ignore-ssl-errors=true",
-    shQuote(system.file("webshot.js", package = "webshot")),
-    shQuote(jsonlite::toJSON(optsList))
+    system.file("webshot.js", package = "webshot"),
+    jsonlite::toJSON(optsList)
   )
 
   res <- phantom_run(args)

inst/examples/shiny.Rmd

@@ -0,0 +1,56 @@
+---
+title: "Shiny Example"
+author: "RStudio"
+date: "2/28/2018"
+output: html_document
+runtime: shiny
+---
+
+```{r setup, include=FALSE}
+knitr::opts_chunk$set(echo = TRUE)
+```
+
+This R Markdown document is made interactive using Shiny. Unlike the more traditional workflow of creating static reports, you can now create documents that allow your readers to change the assumptions underlying your analysis and see the results immediately.
+
+To learn more, see [Interactive Documents](http://rmarkdown.rstudio.com/authoring_shiny.html).
+
+## Inputs and Outputs
+
+You can embed Shiny inputs and outputs in your document. Outputs are automatically updated whenever inputs change.  This demonstrates how a standard R plot can be made interactive by wrapping it in the Shiny `renderPlot` function. The `selectInput` and `sliderInput` functions create the input widgets used to drive the plot.
+
+```{r eruptions, echo=FALSE}
+inputPanel(
+  selectInput("n_breaks", label = "Number of bins:",
+              choices = c(10, 20, 35, 50), selected = 20),
+
+  sliderInput("bw_adjust", label = "Bandwidth adjustment:",
+              min = 0.2, max = 2, value = 1, step = 0.2)
+)
+
+renderPlot({
+  hist(faithful$eruptions, probability = TRUE, breaks = as.numeric(input$n_breaks),
+       xlab = "Duration (minutes)", main = "Geyser eruption duration")
+
+  dens <- density(faithful$eruptions, adjust = input$bw_adjust)
+  lines(dens, col = "blue")
+})
+```
+
+## Embedded Application
+
+It's also possible to embed an entire Shiny application within an R Markdown document using the `shinyAppDir` function. This example embeds a Shiny application located in another directory:
+
+```{r tabsets, echo=FALSE}
+shinyAppDir(
+  system.file("examples/06_tabsets", package = "shiny"),
+  options = list(
+    width = "100%", height = 550
+  )
+)
+```
+
+Note the use of the `height` parameter to determine how much vertical space the embedded application should occupy.
+
+You can also use the `shinyApp` function to define an application inline rather then in an external directory.
+
+In all of R code chunks above the `echo = FALSE` attribute is used. This is to prevent the R code within the chunk from rendering in the document alongside the Shiny components.