From f8bf146b6c7e4e6c27080f39890644ea54fd8202 Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@rstudio.org>
Date: Wed, 9 Apr 2014 14:53:56 -0700
Subject: [PATCH] Render functions can be inserted directly into .Rmd

All render functions need to call markRenderFunction on their
return values for this mechanism to work.

Also:
- Remove runRmdContainer (it's moved to rmarkdown)
- Remove some bad .Rbuildignore entries
- Make height/width in shinyApp respected
---
 .Rbuildignore             |  2 --
 NAMESPACE                 |  3 ++-
 R/app.R                   | 49 +++++++++++-------------------------
 R/shinywrappers.R         | 53 +++++++++++++++++++++++++++------------
 inst/www/shared/shiny.css |  4 +++
 man/markRenderFunction.Rd | 22 ++++++++++++++++
 man/runRmdContainer.Rd    | 20 ---------------
 7 files changed, 79 insertions(+), 74 deletions(-)
 create mode 100644 man/markRenderFunction.Rd
 delete mode 100644 man/runRmdContainer.Rd

diff --git a/.Rbuildignore b/.Rbuildignore
index 0f0f13d79..9a1ee7f03 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -10,5 +10,3 @@
 ^man-roxygen$
 ^\.travis\.yml$
 ^staticdocs$
-^R/.*\.Rmd1$
-^R/.*\.html$
diff --git a/NAMESPACE b/NAMESPACE
index d984a03df..9375f9c3a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -83,10 +83,12 @@ export(is.reactive)
 export(is.reactivevalues)
 export(isolate)
 export(knit_print.shiny.appobj)
+export(knit_print.shiny.render.function)
 export(knit_print.shiny.tag)
 export(knit_print.shiny.tag.list)
 export(mainPanel)
 export(makeReactiveBinding)
+export(markRenderFunction)
 export(navbarMenu)
 export(navbarPage)
 export(navlistPanel)
@@ -126,7 +128,6 @@ export(runApp)
 export(runExample)
 export(runGist)
 export(runGitHub)
-export(runRmdContainer)
 export(runUrl)
 export(selectInput)
 export(selectizeInput)
diff --git a/R/app.R b/R/app.R
index 72597fc9f..30cbd066d 100644
--- a/R/app.R
+++ b/R/app.R
@@ -178,7 +178,7 @@ as.shiny.appobj.character <- function(x) {
 #' @param ... Additional parameters to be passed to print.
 #' @export
 print.shiny.appobj <- function(x, ...) {
-  opts <- attr(x, "shiny.options")
+  opts <- x$options %OR% list()
   opts <- opts[names(opts) %in%
       c("port", "launch.browser", "host", "quiet", "display.mode")]
 
@@ -201,10 +201,11 @@ NULL
 #' @export
 knit_print.shiny.appobj <- function(x, ...) {
   path <- addSubApp(x)
-  opts <- attr(x, "shiny.options")
+  opts <- x$options %OR% list()
   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)
+  iframe <- tags$iframe(class="shiny-frame", src=path,
+                        width=width, height=height)
   knitr::asis_output(format(iframe))
 }
 
@@ -218,37 +219,15 @@ knit_print.shiny.tag <- function(x, ...) {
 #' @export
 knit_print.shiny.tag.list <- knit_print.shiny.tag
 
-#' Run R Markdown docs with embedded Shiny apps
-#'
-#' Experimental.
-#'
-#' @param input Path to .Rmd file
-#' @param text A character vector as an alternate way to provide input
-#' @param ... Additional parameters to pass to \code{\link{runApp}}
-#' @param knit.options A list of options to pass to \code{knit2html}
+
+# Adapter functions let us use a nicer syntax in knitr chunks than
+# literally calling output$value <- renderFoo(...) and fooOutput().
+
 #' @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, ...)
+knit_print.shiny.render.function <- function(x, ...) {
+  outputFunction <- attr(x, "outputFunc")
+  id <- shiny:::createUniqueId(8)
+  o <- getDefaultReactiveDomain()$output
+  o[[id]] <- x
+  knit_print(outputFunction(id))
 }
diff --git a/R/shinywrappers.R b/R/shinywrappers.R
index c5386e822..ccb5908f7 100644
--- a/R/shinywrappers.R
+++ b/R/shinywrappers.R
@@ -1,5 +1,26 @@
 globalVariables('func')
 
+#' Mark a function as a render function
+#'
+#' Should be called by implementers of \code{renderXXX} functions in order to
+#' mark their return values as Shiny render functions, and to provide a hint to
+#' Shiny regarding what UI function is most commonly used with this type of
+#' render function. This can be used in R Markdown documents to create complete
+#' output widgets out of just the render function.
+#'
+#' @param uiFunc A function that renders Shiny UI. Must take a single argument:
+#'   an output ID.
+#' @param renderFunc A function that is suitable for assigning to a Shiny output
+#'   slot.
+#' @return The \code{renderFunc} function, with annotations.
+#'
+#' @export
+markRenderFunction <- function(uiFunc, renderFunc) {
+  class(renderFunc) <- c("shiny.render.function", "function")
+  attr(renderFunc, "outputFunc") <- uiFunc
+  renderFunc
+}
+
 #' Plot Output
 #'
 #' Renders a reactive plot that is suitable for assigning to an \code{output}
@@ -54,7 +75,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   else
     heightWrapper <- NULL
 
-  return(function(shinysession, name, ...) {
+  return(markRenderFunction(plotOutput, function(shinysession, name, ...) {
     if (!is.null(widthWrapper))
       width <- widthWrapper()
     if (!is.null(heightWrapper))
@@ -123,7 +144,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       src=shinysession$fileUrl(name, outfile, contentType='image/png'),
       width=width, height=height, coordmap=coordmap
     ))
-  })
+  }))
 }
 
 #' Image file output
@@ -218,7 +239,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE) {
   installExprFunction(expr, "func", env, quoted)
 
-  return(function(shinysession, name, ...) {
+  return(markRenderFunction(imageOutput, function(shinysession, name, ...) {
     imageinfo <- func()
     # Should the file be deleted after being sent? If .deleteFile not set or if
     # TRUE, then delete; otherwise don't delete.
@@ -239,7 +260,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
     # Return a list with src, and other img attributes
     c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
       extra_attr)
-  })
+  }))
 }
 
 
@@ -269,7 +290,7 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
+  markRenderFunction(tableOutput, function() {
     classNames <- getOption('shiny.table.class', 'data table table-bordered table-condensed')
     data <- func()
 
@@ -285,7 +306,7 @@ renderTable <- function(expr, ..., env=parent.frame(), quoted=FALSE, func=NULL)
                                           '"',
                                           sep=''), ...)),
       collapse="\n"))
-  }
+  })
 }
 
 #' Printable Output
@@ -326,13 +347,13 @@ renderPrint <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
+  markRenderFunction(verbatimTextOutput, function() {
     return(paste(capture.output({
       result <- withVisible(func())
       if (result$visible)
         print(result$value)
     }), collapse="\n"))
-  }
+  })
 }
 
 #' Text Output
@@ -369,10 +390,10 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function() {
+  markRenderFunction(textOutput, function() {
     value <- func()
     return(paste(capture.output(cat(value)), collapse="\n"))
-  }
+  })
 }
 
 #' UI Output
@@ -409,7 +430,7 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     installExprFunction(expr, "func", env, quoted)
   }
 
-  function(shinysession, name, ...) {
+  markRenderFunction(uiOutput, function(shinysession, name, ...) {
     result <- func()
     if (is.null(result) || length(result) == 0)
       return(NULL)
@@ -421,7 +442,7 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
     output <- doRenderTags(result)
 
     return(output)
-  }
+  })
 }
 
 #' File Downloads
@@ -466,9 +487,9 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE, func=NULL) {
 #'
 #' @export
 downloadHandler <- function(filename, content, contentType=NA) {
-  return(function(shinysession, name, ...) {
+  return(markRenderFunction(downloadButton, function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
-  })
+  }))
 }
 
 #' Table output with the JavaScript library DataTables
@@ -506,7 +527,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
                             env = parent.frame(), quoted = FALSE) {
   installExprFunction(expr, "func", env, quoted)
 
-  function(shinysession, name, ...) {
+  markRenderFunction(dataTableOutput, function(shinysession, name, ...) {
     res <- checkAsIs(if (is.function(options)) options() else options)
     data <- func()
     if (length(dim(data)) != 2) return() # expects a rectangular data object
@@ -516,7 +537,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
       evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
       callback = paste(callback, collapse = '\n')
     )
-  }
+  })
 }
 
 
diff --git a/inst/www/shared/shiny.css b/inst/www/shared/shiny.css
index 432c180a2..74dce72f0 100644
--- a/inst/www/shared/shiny.css
+++ b/inst/www/shared/shiny.css
@@ -102,3 +102,7 @@ span.jslider {
 .selectize-control {
   margin-bottom: 10px;
 }
+
+.shiny-frame {
+  border: none;
+}
diff --git a/man/markRenderFunction.Rd b/man/markRenderFunction.Rd
new file mode 100644
index 000000000..3a14eab32
--- /dev/null
+++ b/man/markRenderFunction.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2 (4.0.0): do not edit by hand
+\name{markRenderFunction}
+\alias{markRenderFunction}
+\title{Mark a function as a render function}
+\usage{
+markRenderFunction(uiFunc, renderFunc)
+}
+\arguments{
+\item{uiFunc}{A function that renders Shiny UI. Must take a single argument:
+an output ID.}
+
+\item{renderFunc}{A function that is suitable for assigning to a Shiny output
+  slot.}
+}
+\description{
+Should be called by implementers of \code{renderXXX} functions in order to
+mark their return values as Shiny render functions, and to provide a hint to
+Shiny regarding what UI function is most commonly used with this type of
+render function. This can be used in R Markdown documents to create complete
+output widgets out of just the render function.
+}
+
diff --git a/man/runRmdContainer.Rd b/man/runRmdContainer.Rd
deleted file mode 100644
index aef9dc318..000000000
--- a/man/runRmdContainer.Rd
+++ /dev/null
@@ -1,20 +0,0 @@
-% Generated by roxygen2 (4.0.0): do not edit by hand
-\name{runRmdContainer}
-\alias{runRmdContainer}
-\title{Run R Markdown docs with embedded Shiny apps}
-\usage{
-runRmdContainer(input, text = NULL, ..., knit.options = list())
-}
-\arguments{
-\item{input}{Path to .Rmd file}
-
-\item{text}{A character vector as an alternate way to provide input}
-
-\item{...}{Additional parameters to pass to \code{\link{runApp}}}
-
-\item{knit.options}{A list of options to pass to \code{knit2html}}
-}
-\description{
-Experimental.
-}
-