Implement Shiny apps embedded as iframes in knitr

DESCRIPTION

@@ -26,10 +26,12 @@ Suggests:
     datasets,
     markdown,
     Cairo (>= 1.5-5),
-    testthat
+    testthat,
+    knitr
 URL: http://www.rstudio.com/shiny/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:
+    'app.R'
     'bootstrap-layout.R'
     'bootstrap.R'
     'cache.R'
@@ -43,10 +45,10 @@ Collate:
     'react.R'
     'reactives.R'
     'run-url.R'
+    'server.R'
     'sessioncontext.R'
     'utils.R'
     'shiny.R'
-    'server.R'
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'

NAMESPACE

@@ -22,6 +22,8 @@ S3method(format,shiny.tag.list)
 S3method(names,reactivevalues)
 S3method(print,html)
 S3method(print,reactive)
+S3method(print,shiny.appdir)
+S3method(print,shiny.appobj)
 S3method(print,shiny.tag)
 S3method(print,shiny.tag.list)
 export(HTML)
@@ -78,6 +80,8 @@ export(invalidateLater)
 export(is.reactive)
 export(is.reactivevalues)
 export(isolate)
+export(knit_print.shiny.appdir)
+export(knit_print.shiny.appobj)
 export(mainPanel)
 export(makeReactiveBinding)
 export(navbarMenu)
@@ -118,9 +122,12 @@ export(runApp)
 export(runExample)
 export(runGist)
 export(runGitHub)
+export(runRmdContainer)
 export(runUrl)
 export(selectInput)
 export(selectizeInput)
+export(shinyAppDir)
+export(shinyAppObj)
 export(shinyServer)
 export(shinyUI)
 export(showReactLog)

R/app.R

@@ -0,0 +1,125 @@
+#' Create a Shiny app object
+#'
+#' These functions create Shiny app objects from either an explicit UI/server
+#' pair (\code{shinyAppObj}), or by passing the path of a directory that
+#' contains a Shiny app (\code{shinyAppDir}). You generally shouldn't need to
+#' use these functions to create/run applications; they are intended for
+#' interoperability purposes, such as embedding Shiny apps inside a \pkg{knitr}
+#' document.
+#'
+#' @param ui The UI definition of the app (for example, a call to
+#'   \code{fluidPage()} with nested controls)
+#' @param server A server function
+#' @param onStart A function that will be called before the app is actually run.
+#'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
+#'   case, a \code{global.R} file can be used for this purpose.
+#' @param options Named options that should be passed to the `runApp` call. You
+#'   can also specify \code{width} and \code{height} parameters which provide a
+#'   hint to the embedding environment about the ideal height/width for the app.
+#' @return An object that represents the app. Printing the object will run the
+#'   app.
+#'
+#' @examples
+#' \dontrun{
+#' shinyAppObj(
+#'   ui = fluidPage(
+#'     numericInput("n", "n", 1),
+#'     plotOutput("plot")
+#'   ),
+#'   server = function(input, output) {
+#'     output$plot <- renderPlot( plot(head(cars, input$n)) )
+#'   },
+#'   options=list(launch.browser = rstudio::viewer)
+#' )
+#'
+#' shinyAppDir(
+#'
+#' )
+#' }
+#'
+#' @export
+shinyAppObj <- function(ui, server, onStart=NULL, options=list()) {
+  structure(
+    list(ui=ui, server=server, onStart=onStart),
+    shiny.options = options,
+    class = "shiny.appobj"
+  )
+}
+
+#' @rdname shinyAppObj
+#' @export
+shinyAppDir <- function(dir, options=list()) {
+  dir <- normalizePath(dir, mustWork = TRUE)
+  structure(
+    dir,
+    shiny.options = options,
+    class = "shiny.appdir"
+  )
+}
+
+#' Run a Shiny app object
+#'
+#' @param x A Shiny app, as returned from \code{\link{shinyAppObj}} or
+#'   \code{\link{shinyAppDir}}.
+#'
+#' @export
+print.shiny.appobj <- function(x) {
+  opts <- attr(x, "shiny.options")
+  opts <- opts[names(opts) %in%
+      c("port", "launch.browser", "host", "quiet", "display.mode")]
+
+  args <- c(list(x), opts)
+
+  do.call(runApp, args)
+}
+
+#' @rdname print.shiny.appobj
+#' @export
+print.shiny.appdir <- print.shiny.appobj
+
+#' @export
+knit_print.shiny.appobj <- function(x) {
+  path <- addSubAppObj(x)
+  opts <- attr(x, "shiny.options")
+  width <- if (is.null(opts$width)) "100%" else opts$width
+  height <- if (is.null(opts$height)) "400" else opts$height
+  iframe <- tags$iframe(src=path, width=width, height=height)
+  knitr::asis_output(format(iframe))
+}
+
+#' @export
+knit_print.shiny.appdir <- function(x) {
+  path <- addSubAppDir(x)
+  opts <- attr(x, "shiny.options")
+  width <- if (is.null(opts$width)) "100%" else opts$width
+  height <- if (is.null(opts$height)) "400" else opts$height
+  iframe <- tags$iframe(src=path, width=width, height=height)
+  knitr::asis_output(format(iframe))
+}
+
+#' @export
+runRmdContainer <- function(input, text = NULL, ..., knit.options = list()) {
+  appdir <- tempfile()
+  dir.create(appdir)
+  on.exit(unlink(appdir, recursive = TRUE), add = TRUE)
+
+  wwwdir <- file.path(appdir, "www")
+  dir.create(wwwdir)
+
+  if (missing(input))
+    input <- NULL
+  output <- file.path(wwwdir, "index.html")
+  knitArgs <- c(list(
+    input = input, text = text,
+    output = if (!is.null(text)) NULL else output
+  ), knit.options)
+
+  result <- do.call(knitr::knit2html, knitArgs)
+  if (!is.null(text))
+    writeLines(result, output)
+
+  writeLines("shinyServer(function(input, output) NULL)",
+    file.path(appdir, "server.R"))
+
+  runApp(appdir, ...)
+}

R/server.R

@@ -549,7 +549,6 @@ proxyCallbacks <- function(prefix, targetCallbacks) {
   pathPattern <- paste("^\\Q", prefix, "\\E/", sep = "")
   matchReq <- function(req) {
     if (isTRUE(grepl(pathPattern, req$PATH_INFO))) {
-      message("Matched with ", prefix)
       req <- as.environment(as.list(req))
       pathInfo <- substr(req$PATH_INFO, nchar(prefix)+1, nchar(req$PATH_INFO))
       req$SCRIPT_NAME <- paste(req$SCRIPT_NAME, prefix, sep = "")
@@ -562,6 +561,20 @@ proxyCallbacks <- function(prefix, targetCallbacks) {
 
   list(
     onHeaders = function(req) {
+      if (identical(req$PATH_INFO, prefix)) {
+        # We could return a 302 response here, but doing so seems to cause
+        # httpuv to report "ERROR: [on_request_read] parse error" for some
+        # reason. Instead, let the request proceed as normal and handle it
+        # in call().
+        return(NULL)
+      }
+      req <- matchReq(req)
+      if (is.null(req))
+        return(FALSE)
+      else
+        return(targetCallbacks$onHeaders(req))
+    },
+    call = function(req) {
       if (identical(req$PATH_INFO, prefix)) {
         return(list(
           status = 302L,
@@ -572,15 +585,7 @@ proxyCallbacks <- function(prefix, targetCallbacks) {
           body = ""
         ))
       }
-      cat("onHeaders: ", req$PATH_INFO, "\n")
-      req <- matchReq(req)
-      if (is.null(req))
-        return(FALSE)
-      else
-        return(targetCallbacks$onHeaders(req))
-    },
-    call = function(req) {
-      cat("call: ", req$PATH_INFO, "\n")
+
       req <- matchReq(req)
       if (is.null(req))
         return(FALSE)
@@ -794,7 +799,6 @@ httpuvCallbackSet <- local({
         callbacks <<- list(cb)
       else
         callbacks <<- c(callbacks, list(cb))
-      message("Callback length: ", length(callbacks))
     },
     clear = function() {
       callbacks <<- list()
@@ -832,7 +836,6 @@ httpuvCallbackSet <- local({
 addSubAppObj <- function(appObj, workerId="") {
   appParts <- createAppObj(appObj$ui, appObj$server)
   path <- registerSubApp(appParts$httpHandlers, appParts$serverFuncSource, workerId)
-  message(path)
   invisible(path)
 }
 
@@ -845,7 +848,6 @@ addSubAppDir <- function(appDir, workerId="") {
     finally = setwd(oldwd)
   )
   path <- registerSubApp(appParts$httpHandlers, appParts$serverFuncSource, workerId)
-  message(path)
   invisible(path)
 }
 
@@ -853,7 +855,6 @@ registerSubApp <- function(httpHandlers, serverFuncSource, workerId) {
   path <- sprintf("/%s", createUniqueId(8))
   httpuvCallbacks <- proxyCallbacks(path,
     createAppCallbacks(httpHandlers, serverFuncSource, workerId))
-  message("GOT HERE 1")
   httpuvCallbackSet$add(httpuvCallbacks)
   return(path)
 }
@@ -861,7 +862,6 @@ registerSubApp <- function(httpHandlers, serverFuncSource, workerId) {
 startApp <- function(httpHandlers, serverFuncSource, port, host, workerId, quiet) {
   httpuvCallbacks <- proxyCallbacks("",
     createAppCallbacks(httpHandlers, serverFuncSource, workerId))
-  message("GOT HERE 2")
   httpuvCallbackSet$add(httpuvCallbacks)
 
   if (is.numeric(port) || is.integer(port)) {

inst/rmd-examples/subapps.Rmd

@@ -0,0 +1,23 @@
+# Subapp test
+
+This is an R Markdown document that contains several embedded Shiny apps.
+
+```{r}
+library(shiny)
+shinyAppDir(
+  system.file("examples/01_hello", package="shiny"),
+  options=list(
+    width="100%", height=250
+  )
+)
+shinyAppObj(
+  ui = fluidPage(
+    numericInput("n", "n", 1),
+    plotOutput("plot")
+  ),
+  server = function(input, output) {
+    output$plot <- renderPlot( plot(head(cars, input$n)) )
+  },
+  options=list(width=450)
+)
+```

man/print.shiny.appobj.Rd

@@ -0,0 +1,18 @@
+% Generated by roxygen2 (4.0.0): do not edit by hand
+\name{print.shiny.appobj}
+\alias{print.shiny.appdir}
+\alias{print.shiny.appobj}
+\title{Run a Shiny app object}
+\usage{
+\method{print}{shiny.appobj}(x)
+
+\method{print}{shiny.appdir}(x)
+}
+\arguments{
+\item{x}{A Shiny app, as returned from \code{\link{shinyAppObj}} or
+  \code{\link{shinyAppDir}}.}
+}
+\description{
+Run a Shiny app object
+}
+

man/shinyAppObj.Rd

@@ -0,0 +1,37 @@
+% Generated by roxygen2 (4.0.0): do not edit by hand
+\name{shinyAppObj}
+\alias{shinyAppDir}
+\alias{shinyAppObj}
+\title{Create a Shiny app object}
+\usage{
+shinyAppObj(ui, server, onStart = NULL, options = list())
+
+shinyAppDir(dir, options = list())
+}
+\arguments{
+\item{ui}{The UI definition of the app (for example, a call to
+\code{fluidPage()} with nested controls)}
+
+\item{server}{A server function}
+
+\item{onStart}{A function that will be called before the app is actually run.
+This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
+case, a \code{global.R} file can be used for this purpose.}
+
+\item{options}{Named options that should be passed to the `runApp` call. You
+can also specify \code{width} and \code{height} parameters which provide a
+hint to the embedding environment about the ideal height/width for the app.}
+}
+\value{
+An object that represents the app. Printing the object will run the
+  app.
+}
+\description{
+These functions create Shiny app objects from either an explicit UI/server
+pair (\code{shinyAppObj}), or by passing the path of a directory that
+contains a Shiny app (\code{shinyAppDir}). You generally shouldn't need to
+use these functions to create/run applications; they are intended for
+interoperability purposes, such as embedding Shiny apps inside a \pkg{knitr}
+document.
+}
+

staticdocs/index.r

@@ -80,8 +80,8 @@ list(
     sd_section("Rendering functions",
       "Functions that you use in your application's server side code, assigning them to outputs that appear in your user interface.",
       c(
-        "renderPlot", 
-        "renderText", 
+        "renderPlot",
+        "renderText",
         "renderPrint",
         "renderDataTable",
         "renderImage",
@@ -148,6 +148,13 @@ list(
         "repeatable",
         "shinyDeprecated"
       )
+    ),
+    sd_section("Embedding",
+      "Functions that are intended for third-party packages that embed Shiny applications.",
+      c(
+        "shinyAppObj",
+        "print.shiny.appobj"
+      )
     )
   )
 )