Apply lobstr::cst pruning to deep stack traces too

Fix #1964: renderPlot cache breaks when width/height throw

.Rbuildignore

@@ -18,3 +18,5 @@
 ^.*\.o$
 ^appveyor\.yml$
 ^revdep$
+^TODO-promises.md$
+^manualtests$

CONTRIBUTING.md

@@ -2,7 +2,7 @@ We welcome contributions to the **shiny** package. To submit a contribution:
 
 1. [Fork](https://github.com/rstudio/shiny/fork) the repository and make your changes.
 
-2. If the change is non-trivial, ensure that you have signed the [individual](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioIndividualContributorAgreement.pdf) or [corporate](http://www.rstudio.com/wp-content/uploads/2014/06/RStudioCorporateContributorAgreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com. For trivial changes (like typo fixes), a contributor agreement is not needed.
+2. Ensure that you have signed the [individual](https://rstudioblog.files.wordpress.com/2017/05/rstudio_individual_contributor_agreement.pdf) or [corporate](https://rstudioblog.files.wordpress.com/2017/05/rstudio_corporate_contributor_agreement.pdf) contributor agreement as appropriate. You can send the signed copy to jj@rstudio.com.
 
 3. Submit a [pull request](https://help.github.com/articles/using-pull-requests).
 

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.0.2
+Version: 1.0.5.9000
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -56,22 +56,31 @@ Authors@R: c(
     )
 Description: Makes it incredibly easy to build interactive web
     applications with R. Automatic "reactive" binding between inputs and
-    outputs and extensive pre-built widgets make it possible to build
+    outputs and extensive prebuilt widgets make it possible to build
     beautiful, responsive, and powerful applications with minimal effort.
 License: GPL-3 | file LICENSE
 Depends:
-    R (>= 3.0.0),
+    R (>= 3.0.2),
     methods
+Remotes:
+    r-lib/later,
+    rstudio/promises,
+    rstudio/httpuv
 Imports:
     utils,
-    httpuv (>= 1.3.3),
+    grDevices,
+    httpuv (>= 1.3.5),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
     htmltools (>= 0.3.5),
     R6 (>= 2.0),
-    sourcetools
+    sourcetools,
+    later (>= 0.7.1),
+    promises (>= 0.1.0.9001),
+    tools,
+    crayon
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -83,15 +92,15 @@ Suggests:
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-Collate:
+Collate: 
     'app.R'
     'bookmark-state-local.R'
     'stack.R'
     'bookmark-state.R'
     'bootstrap-layout.R'
+    'globals.R'
     'conditions.R'
     'map.R'
-    'globals.R'
     'utils.R'
     'bootstrap.R'
     'cache.R'
@@ -122,6 +131,7 @@ Collate:
     'input-text.R'
     'input-textarea.R'
     'input-utils.R'
+    'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
@@ -143,6 +153,7 @@ Collate:
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
+    'snapshot.R'
     'tar.R'
     'test-export.R'
     'timer.R'

NAMESPACE

@@ -40,6 +40,7 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
 export(bookmarkButton)
@@ -58,6 +59,7 @@ export(code)
 export(column)
 export(conditionStackTrace)
 export(conditionalPanel)
+export(createRenderFunction)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
@@ -100,6 +102,7 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
+export(hideTab)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
@@ -114,6 +117,7 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
+export(insertTab)
 export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
@@ -121,6 +125,7 @@ export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
 export(is.singleton)
+export(isRunning)
 export(isTruthy)
 export(isolate)
 export(knit_print.html)
@@ -152,6 +157,7 @@ export(onReactiveDomainEnded)
 export(onRestore)
 export(onRestored)
 export(onSessionEnded)
+export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -161,6 +167,7 @@ export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(prependTab)
 export(printError)
 export(printStackTrace)
 export(radioButtons)
@@ -180,6 +187,7 @@ export(registerInputHandler)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
+export(removeTab)
 export(removeUI)
 export(renderDataTable)
 export(renderImage)
@@ -203,6 +211,7 @@ export(selectizeInput)
 export(serverInfo)
 export(setBookmarkExclude)
 export(setProgress)
+export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
@@ -213,11 +222,14 @@ export(showBookmarkUrlModal)
 export(showModal)
 export(showNotification)
 export(showReactLog)
+export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
 export(singleton)
 export(sliderInput)
 export(snapshotExclude)
+export(snapshotPreprocessInput)
+export(snapshotPreprocessOutput)
 export(span)
 export(splitLayout)
 export(stopApp)
@@ -274,3 +286,5 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)

NEWS.md

@@ -1,3 +1,131 @@
+shiny 1.0.5.9000
+================
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+### Minor new features and improvements
+
+* Changed script tags in reactlog ([inst/www/reactive-graph.html](https://github.com/rstudio/shiny/blob/master/inst/www/reactive-graph.html)) from HTTP to HTTPS in order to avoid mixed content blocking by most browsers. (Thanks, [@jekriske-lilly](https://github.com/jekriske-lilly)! [#1844](https://github.com/rstudio/shiny/pull/1844))
+
+* The version of Shiny is now accessible from Javascript, with `Shiny.version`. There is also a new function for comparing version strings, `Shiny.compareVersion()`. ([#1826](https://github.com/rstudio/shiny/pull/1826), [#1830](https://github.com/rstudio/shiny/pull/1830))
+
+* Addressed [#1784](https://github.com/rstudio/shiny/issues/1784): `runApp()` will avoid port 6697, which is considered unsafe by Chrome.
+
+* Addressed [#1851](https://github.com/rstudio/shiny/issues/1851): Stack traces are now smaller in some places `do.call()` is used. ([#1856](https://github.com/rstudio/shiny/pull/1856))
+
+* Addressed [#1859](https://github.com/rstudio/shiny/issues/1859): Server-side selectize is now significantly faster. (Thanks to @dselivanov [#1861](https://github.com/rstudio/shiny/pull/1861))
+
+* Fixed [#1006](https://github.com/rstudio/shiny/issues/1006): Slider inputs sometimes showed too many digits. ([#1956](https://github.com/rstudio/shiny/pull/1956))
+
+* Fixed [#1958](https://github.com/rstudio/shiny/issues/1958): Slider inputs previously displayed commas after a decimal point. ([#1960](https://github.com/rstudio/shiny/pull/1960))
+
+
+### Bug fixes
+
+* The internal `URLdecode()` function previously was a copy of `httpuv::decodeURIComponent()`, assigned at build time; now it invokes the httpuv function at run time.
+
+* Fixed [#1840](https://github.com/rstudio/shiny/issues/1840): with the release of Shiny 1.0.5, we accidently changed the relative positioning of the icon and the title text in `navbarMenu`s and `tabPanel`s. This fix reverts this behavior back (i.e. the icon should be to the left of the text and/or the downward arrow in case of `navbarMenu`s). ([#1848](https://github.com/rstudio/shiny/pull/1848))
+
+* Fixed [#1600](https://github.com/rstudio/shiny/issues/1600): URL-encoded bookmarking did not work with sliders that had dates or date-times. ([#1961](https://github.com/rstudio/shiny/pull/1961))
+
+### Library updates
+
+* Updated to ion.rangeSlider 2.2.0. ([#1955](https://github.com/rstudio/shiny/pull/1955))
+
+shiny 1.0.5
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1818](https://github.com/rstudio/shiny/issues/1818): `conditionalPanel()` expressions that have a newline character in them caused the application to not work. ([#1820](https://github.com/rstudio/shiny/pull/1820))
+
+* Added a safe wrapper function for internal calls to `jsonlite::fromJSON()`. ([#1822](https://github.com/rstudio/shiny/pull/1822))
+
+* Fixed [#1824](https://github.com/rstudio/shiny/issues/1824): HTTP HEAD requests on static files caused the application to stop. ([#1825](https://github.com/rstudio/shiny/pull/1825))
+
+
+shiny 1.0.4
+===========
+
+There are three headlining features in this release of Shiny. It is now possible to add and remove tabs from a `tabPanel`; there is a new function, `onStop()`, which registers callbacks that execute when an application exits; and `fileInput`s now can have files dragged and dropped on them. In addition to these features, this release has a number of minor features and bug fixes. See the full changelog below for more details.
+
+## Full changelog
+
+### New features
+
+* Implemented [#1668](https://github.com/rstudio/shiny/issues/1668): dynamic tabs: added functions (`insertTab`, `appendTab`, `prependTab`, `removeTab`, `showTab` and `hideTab`) that allow you to do those actions for an existing `tabsetPanel`. ([#1794](https://github.com/rstudio/shiny/pull/1794))
+
+* Implemented [#1213](https://github.com/rstudio/shiny/issues/1213): Added a new function, `onStop()`, which can be used to register callback functions that are invoked when an application exits, or when a user session ends. (Multiple sessions can be connected to a single running Shiny application.) This is useful if you have finalization/clean-up code that should be run after the application exits. ([#1770](https://github.com/rstudio/shiny/pull/1770)
+
+* Implemented [#1155](https://github.com/rstudio/shiny/issues/1155): Files can now be drag-and-dropped on `fileInput` controls. The appearance of `fileInput` controls while files are being dragged can be modified by overriding the `shiny-file-input-active` and `shiny-file-input-over` classes. ([#1782](https://github.com/rstudio/shiny/pull/1782))
+
+### Minor new features and improvements
+
+* Addressed [#1688](https://github.com/rstudio/shiny/issues/1688): trigger a new `shiny:outputinvalidated` event when an output gets invalidated, at the same time that the `recalculating` CSS class is added. ([#1758](https://github.com/rstudio/shiny/pull/1758), thanks [@andrewsali](https://github.com/andrewsali)!)
+
+* Addressed [#1508](https://github.com/rstudio/shiny/issues/1508): `fileInput` now permits the same file to be uploaded multiple times. ([#1719](https://github.com/rstudio/shiny/pull/1719))
+
+* Addressed [#1501](https://github.com/rstudio/shiny/issues/1501): The `fileInput` control now retains uploaded file extensions on the server. This fixes [readxl](https://github.com/tidyverse/readxl)'s `readxl::read_excel` and other functions that must recognize a file's extension in order to work. ([#1706](https://github.com/rstudio/shiny/pull/1706))
+
+* For `conditionalPanel`s, Shiny now gives more informative messages if there are errors evaluating or parsing the JavaScript conditional expression. ([#1727](https://github.com/rstudio/shiny/pull/1727))
+
+* Addressed [#1586](https://github.com/rstudio/shiny/issues/1586): The `conditionalPanel` function now accepts an `ns` argument. The `ns` argument can be used in a [module](https://shiny.rstudio.com/articles/modules.html) UI function to scope the `condition` expression to the module's own input and output IDs. ([#1735](https://github.com/rstudio/shiny/pull/1735))
+
+* With `options(shiny.testmode=TRUE)`, the Shiny process will send a message to the client in response to a changed input, even if no outputs have changed. This helps to streamline testing using the shinytest package. ([#1747](https://github.com/rstudio/shiny/pull/1747))
+
+* Addressed [#1738](https://github.com/rstudio/shiny/issues/1738): The `updateTextInput` and `updateTextAreaInput` functions can now update the placeholder. ([#1742](https://github.com/rstudio/shiny/pull/1742))
+
+* Converted examples to single file apps, and made updates and enhancements to comments in the example app scripts. ([#1685](https://github.com/rstudio/shiny/pull/1685))
+
+* Added new `snapshotPreprocessInput()` and `snapshotPreprocessOutput()` functions, which is used for preprocessing and input and output values before taking a test snapshot. ([#1760](https://github.com/rstudio/shiny/pull/1760), [#1789](https://github.com/rstudio/shiny/pull/1789))
+
+* The HTML generated by `renderTable()` no longer includes comments with the R version, xtable version, and timestamp. ([#1771](https://github.com/rstudio/shiny/pull/1771))
+
+* Added a function `isRunning` to test whether a Shiny app is currently running. ([#1785](https://github.com/rstudio/shiny/pull/1785))
+
+* Added a function `setSerializer`, which allows authors to specify a function for serializing the value of a custom input. ([#1791](https://github.com/rstudio/shiny/pull/1791))
+
+### Bug fixes
+
+* Fixed [#1546](https://github.com/rstudio/shiny/issues/1546): make it possible (without any hacks) to write arbitrary data into a module's `session$userData` (which is exactly the same environment as the parent's `session$userData`). To be clear, it allows something like `session$userData$x <- TRUE`, but not something like `session$userData <- TRUE` (that is not allowed in any context, whether you're in the main app, or in a module) ([#1732](https://github.com/rstudio/shiny/pull/1732)).
+
+* Fixed [#1701](https://github.com/rstudio/shiny/issues/1701): There was a partial argument match in the `generateOptions` function. ([#1702](https://github.com/rstudio/shiny/pull/1702))
+
+* Fixed [#1710](https://github.com/rstudio/shiny/issues/1710): `ReactiveVal` objects did not have separate dependents. ([#1712](https://github.com/rstudio/shiny/pull/1712))
+
+* Fixed [#1438](https://github.com/rstudio/shiny/issues/1438): `unbindAll()` should not be called when inserting content with `insertUI()`. A previous fix ([#1449](https://github.com/rstudio/shiny/pull/1449)) did not work correctly. ([#1736](https://github.com/rstudio/shiny/pull/1736))
+
+* Fixed [#1755](https://github.com/rstudio/shiny/issues/1755): dynamic htmlwidgets sent the path of the package on the server to the client. ([#1756](https://github.com/rstudio/shiny/pull/1756))
+
+* Fixed [#1763](https://github.com/rstudio/shiny/issues/1763): Shiny's private random stream leaked out into the main random stream. ([#1768](https://github.com/rstudio/shiny/pull/1768))
+
+* Fixed [#1680](https://github.com/rstudio/shiny/issues/1680): `options(warn=2)` was not respected when running an app. ([#1790](https://github.com/rstudio/shiny/pull/1790))
+
+* Fixed [#1772](https://github.com/rstudio/shiny/issues/1772): ensure that `runApp()` respects the `shinyApp(onStart = function())` argument. ([#1770](https://github.com/rstudio/shiny/pull/1770))
+
+* Fixed [#1474](https://github.com/rstudio/shiny/issues/1474): A `browser()` call in an observer could cause an error in the RStudio IDE on Windows. ([#1802](https://github.com/rstudio/shiny/pull/1802))
+
+
+shiny 1.0.3
+================
+
+This is a hotfix release of Shiny. With previous versions of Shiny, when running an application on the newly-released version of R, 3.4.0, it would print a message: `Warning in body(fun) : argument is not a function`. This has no effect on the application, but because the message could be alarming to users, we are releasing a new version of Shiny that fixes this issue.
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1672](https://github.com/rstudio/shiny/issues/1672): When an error occurred while uploading a file, the progress bar did not change colors. ([#1673](https://github.com/rstudio/shiny/pull/1673))
+
+* Fixed [#1676](https://github.com/rstudio/shiny/issues/1676): On R 3.4.0, running a Shiny application gave a warning: `Warning in body(fun) : argument is not a function`. ([#1677](https://github.com/rstudio/shiny/pull/1677))
+
+
 shiny 1.0.2
 ================
 

R/app.R

@@ -71,7 +71,7 @@
 #' }
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/", enableBookmarking = NULL) {
+                     uiPattern="/", enableBookmarking=NULL) {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -212,7 +212,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
     if (file.exists(file.path.ci(appDir, "global.R")))
       sourceUTF8(file.path.ci(appDir, "global.R"))
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
     monitorHandle()
     monitorHandle <<- NULL
@@ -223,7 +223,7 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
       httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = serverFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -317,8 +317,9 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
     oldwd <<- getwd()
     setwd(appDir)
     monitorHandle <<- initAutoReloadMonitor(appDir)
+    if (!is.null(appObj()$onStart)) appObj()$onStart()
   }
-  onEnd <- function() {
+  onStop <- function() {
     setwd(oldwd)
     monitorHandle()
     monitorHandle <<- NULL
@@ -329,7 +330,7 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
       httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,
-      onEnd = onEnd,
+      onStop = onStop,
       options = options
     ),
     class = "shiny.appobj"
@@ -380,9 +381,10 @@ print.shiny.appobj <- function(x, ...) {
       c("port", "launch.browser", "host", "quiet",
         "display.mode", "test.mode")]
 
-  args <- c(list(x), opts)
+  # Quote x and put runApp in quotes so that there's a nicer stack trace (#1851)
+  args <- c(list(quote(x)), opts)
 
-  do.call(runApp, args)
+  do.call("runApp", args)
 }
 
 #' @rdname shinyApp

R/bookmark-state.R

@@ -349,7 +349,7 @@ RestoreContext <- R6Class("RestoreContext",
         mapply(names(vals), vals, SIMPLIFY = FALSE,
           FUN = function(name, value) {
             tryCatch(
-              jsonlite::fromJSON(value),
+              safeFromJSON(value),
               error = function(e) {
                 stop("Failed to parse URL parameter \"", name, "\"")
               }
@@ -451,11 +451,21 @@ hasCurrentRestoreContext <- function() {
   restoreCtxStack$size() > 0
 }
 
-# Call to access the current restore context
+# Call to access the current restore context. First look on the restore
+# context stack, and if not found, then see if there's one on the current
+# reactive domain. In practice, the only time there will be a restore context
+# on the stack is when executing the UI function; when executing server code,
+# the restore context will be attached to the domain/session.
 getCurrentRestoreContext <- function() {
   ctx <- restoreCtxStack$peek()
   if (is.null(ctx)) {
-    stop("No restore context found")
+    domain <- getDefaultReactiveDomain()
+
+    if (is.null(domain) || is.null(domain$restoreContext)) {
+      stop("No restore context found")
+    }
+
+    ctx <- domain$restoreContext
   }
   ctx
 }

R/bootstrap.R

@@ -285,7 +285,8 @@ pageWithSidebar <- function(headerPanel,
 #'   example below).
 #'
 #' @seealso \code{\link{tabPanel}}, \code{\link{tabsetPanel}},
-#'   \code{\link{updateNavbarPage}}
+#'   \code{\link{updateNavbarPage}}, \code{\link{insertTab}},
+#'   \code{\link{showTab}}
 #'
 #' @examples
 #' navbarPage("App Title",
@@ -393,10 +394,15 @@ navbarPage <- function(title,
   )
 }
 
+#' @param menuName A name that identifies this \code{navbarMenu}. This
+#'   is needed if you want to insert/remove or show/hide an entire
+#'   \code{navbarMenu}.
+#'
 #' @rdname navbarPage
 #' @export
-navbarMenu <- function(title, ..., icon = NULL) {
+navbarMenu <- function(title, ..., menuName = title, icon = NULL) {
   structure(list(title = title,
+                 menuName = menuName,
                  tabs = list(...),
                  iconClass = iconClass(icon)),
             class = "shiny.navbarmenu")
@@ -502,6 +508,8 @@ mainPanel <- function(..., width = 8) {
 #'
 #' @param condition A JavaScript expression that will be evaluated repeatedly to
 #'   determine whether the panel should be displayed.
+#' @param ns The \code{\link[=NS]{namespace}} object of the current module, if
+#'   any.
 #' @param ... Elements to include in the panel.
 #'
 #' @note You are not recommended to use special JavaScript characters such as a
@@ -510,32 +518,55 @@ mainPanel <- function(..., width = 8) {
 #'   \code{input["foo.bar"]} instead of \code{input.foo.bar} to read the input
 #'   value.
 #' @examples
-#' sidebarPanel(
-#'    selectInput(
-#'       "plotType", "Plot Type",
-#'       c(Scatter = "scatter",
-#'         Histogram = "hist")),
-#'
-#'    # Only show this panel if the plot type is a histogram
-#'    conditionalPanel(
-#'       condition = "input.plotType == 'hist'",
-#'       selectInput(
-#'          "breaks", "Breaks",
-#'          c("Sturges",
-#'            "Scott",
-#'            "Freedman-Diaconis",
-#'            "[Custom]" = "custom")),
-#'
-#'       # Only show this panel if Custom is selected
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   ui <- fluidPage(
+#'     sidebarPanel(
+#'       selectInput("plotType", "Plot Type",
+#'         c(Scatter = "scatter", Histogram = "hist")
+#'       ),
+#'       # Only show this panel if the plot type is a histogram
 #'       conditionalPanel(
-#'          condition = "input.breaks == 'custom'",
-#'          sliderInput("breakCount", "Break Count", min=1, max=1000, value=10)
+#'         condition = "input.plotType == 'hist'",
+#'         selectInput(
+#'           "breaks", "Breaks",
+#'           c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
+#'         ),
+#'         # Only show this panel if Custom is selected
+#'         conditionalPanel(
+#'           condition = "input.breaks == 'custom'",
+#'           sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
+#'         )
 #'       )
-#'    )
-#' )
+#'     ),
+#'     mainPanel(
+#'       plotOutput("plot")
+#'     )
+#'   )
+#'
+#'   server <- function(input, output) {
+#'     x <- rnorm(100)
+#'     y <- rnorm(100)
+#'
+#'     output$plot <- renderPlot({
+#'       if (input$plotType == "scatter") {
+#'         plot(x, y)
+#'       } else {
+#'         breaks <- input$breaks
+#'         if (breaks == "custom") {
+#'           breaks <- input$breakCount
+#'         }
+#'
+#'         hist(x, breaks = breaks)
+#'       }
+#'     })
+#'   }
+#'
+#'   shinyApp(ui, server)
+#' }
 #' @export
-conditionalPanel <- function(condition, ...) {
-  div('data-display-if'=condition, ...)
+conditionalPanel <- function(condition, ..., ns = NS(NULL)) {
+  div(`data-display-if`=condition, `data-ns-prefix`=ns(""), ...)
 }
 
 #' Create a help text element
@@ -609,7 +640,8 @@ tabPanel <- function(title, ..., value = title, icon = NULL) {
 #'   Bootstrap 3.
 #' @return A tabset that can be passed to \code{\link{mainPanel}}
 #'
-#' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}}
+#' @seealso \code{\link{tabPanel}}, \code{\link{updateTabsetPanel}},
+#'   \code{\link{insertTab}}, \code{\link{showTab}}
 #'
 #' @examples
 #' # Show a tabset that includes a plot, summary, and
@@ -676,7 +708,9 @@ tabsetPanel <- function(...,
 #'   supported. This is because version 0.11 switched to Bootstrap 3, which
 #'   doesn't support separators.
 #'
-#' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
+#' @seealso \code{\link{tabPanel}}, \code{\link{updateNavlistPanel}},
+#'    \code{\link{insertTab}}, \code{\link{showTab}}
+#'
 #' @examples
 #' fluidPage(
 #'
@@ -726,189 +760,158 @@ navlistPanel <- function(...,
     fixedRow(columns)
 }
 
+# Helpers to build tabsetPanels (& Co.) and their elements
+markTabAsSelected <- function(x) {
+  attr(x, "selected") <- TRUE
+  x
+}
 
-buildTabset <- function(tabs, ulClass, textFilter = NULL,
-                        id = NULL, selected = NULL) {
+isTabSelected <- function(x) {
+  isTRUE(attr(x, "selected", exact = TRUE))
+}
 
-  # This function proceeds in two phases. First, it scans over all the items
-  # to find and mark which tab should start selected. Then it actually builds
-  # the tab nav and tab content lists.
+containsSelectedTab <- function(tabs) {
+  any(vapply(tabs, isTabSelected, logical(1)))
+}
 
-  # Mark an item as selected
-  markSelected <- function(x) {
-    attr(x, "selected") <- TRUE
-    x
-  }
+findAndMarkSelectedTab <- function(tabs, selected, foundSelected) {
+  tabs <- lapply(tabs, function(div) {
+    if (foundSelected || is.character(div)) {
+      # Strings are not selectable items
 
-  # Returns TRUE if an item is selected
-  isSelected <- function(x) {
-    isTRUE(attr(x, "selected", exact = TRUE))
-  }
-
-  # Returns TRUE if a list of tab items contains a selected tab, FALSE
-  # otherwise.
-  containsSelected <- function(tabs) {
-    any(vapply(tabs, isSelected, logical(1)))
-  }
-
-  # Take a pass over all tabs, and mark the selected tab.
-  foundSelectedItem <- FALSE
-  findAndMarkSelected <- function(tabs, selected) {
-    lapply(tabs, function(divTag) {
-      if (foundSelectedItem) {
-        # If we already found the selected tab, no need to keep looking
-
-      } else if (is.character(divTag)) {
-        # Strings don't represent selectable items
-
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
-        # Navbar menu
-        divTag$tabs <- findAndMarkSelected(divTag$tabs, selected)
+    } else if (inherits(div, "shiny.navbarmenu")) {
+      # Recur for navbarMenus
+      res <- findAndMarkSelectedTab(div$tabs, selected, foundSelected)
+      div$tabs <- res$tabs
+      foundSelected <<- res$foundSelected
 
+    } else {
+      # Base case: regular tab item. If the `selected` argument is
+      # provided, check for a match in the existing tabs; else,
+      # mark first available item as selected
+      if (is.null(selected)) {
+        foundSelected <<- TRUE
+        div <- markTabAsSelected(div)
       } else {
-        # Regular tab item
-        if (is.null(selected)) {
-          # If selected tab isn't specified, mark first available item
-          # as selected.
-          foundSelectedItem <<- TRUE
-          divTag <- markSelected(divTag)
-
-        } else {
-          # If selected tab is specified, check for a match
-          tabValue <- divTag$attribs$`data-value` %OR% divTag$attribs$title
-          if (identical(selected, tabValue)) {
-            foundSelectedItem <<- TRUE
-            divTag <- markSelected(divTag)
-          }
+        tabValue <- div$attribs$`data-value` %OR% div$attribs$title
+        if (identical(selected, tabValue)) {
+          foundSelected <<- TRUE
+          div <- markTabAsSelected(div)
         }
       }
+    }
+    return(div)
+  })
+  return(list(tabs = tabs, foundSelected = foundSelected))
+}
 
-      return(divTag)
-    })
-  }
-
-
-  # Append an optional icon to an aTag
-  appendIcon <- function(aTag, iconClass) {
-    if (!is.null(iconClass)) {
+# Returns the icon object (or NULL if none), provided either a
+# tabPanel, OR the icon class
+getIcon <- function(tab = NULL, iconClass = NULL) {
+  if (!is.null(tab)) iconClass <- tab$attribs$`data-icon-class`
+  if (!is.null(iconClass)) {
+    if (grepl("fa-", iconClass, fixed = TRUE)) {
       # for font-awesome we specify fixed-width
-      if (grepl("fa-", iconClass, fixed = TRUE))
-        iconClass <- paste(iconClass, "fa-fw")
-      aTag <- tagAppendChild(aTag, icon(name = NULL, class = iconClass))
+      iconClass <- paste(iconClass, "fa-fw")
     }
-    aTag
+    icon(name = NULL, class = iconClass)
+  } else NULL
+}
+
+# Text filter for navbarMenu's (plain text) separators
+navbarMenuTextFilter <- function(text) {
+  if (grepl("^\\-+$", text)) tags$li(class = "divider")
+  else tags$li(class = "dropdown-header", text)
+}
+
+# This function is called internally by navbarPage, tabsetPanel
+# and navlistPanel
+buildTabset <- function(tabs, ulClass, textFilter = NULL, id = NULL,
+                        selected = NULL, foundSelected = FALSE) {
+
+  res <- findAndMarkSelectedTab(tabs, selected, foundSelected)
+  tabs <- res$tabs
+  foundSelected <- res$foundSelected
+
+  # add input class if we have an id
+  if (!is.null(id)) ulClass <- paste(ulClass, "shiny-tab-input")
+
+  if (anyNamed(tabs)) {
+    nms <- names(tabs)
+    nms <- nms[nzchar(nms)]
+    stop("Tabs should all be unnamed arguments, but some are named: ",
+      paste(nms, collapse = ", "))
   }
 
-  # Build the tabset
-  build <- function(tabs, ulClass, textFilter = NULL, id = NULL) {
-    # add tab input sentinel class if we have an id
-    if (!is.null(id))
-      ulClass <- paste(ulClass, "shiny-tab-input")
+  tabsetId <- p_randomInt(1000, 10000)
+  tabs <- lapply(seq_len(length(tabs)), buildTabItem,
+            tabsetId = tabsetId, foundSelected = foundSelected,
+            tabs = tabs, textFilter = textFilter)
 
-    if (anyNamed(tabs)) {
-      nms <- names(tabs)
-      nms <- nms[nzchar(nms)]
-      stop("Tabs should all be unnamed arguments, but some are named: ",
-           paste(nms, collapse = ", "))
+  tabNavList <- tags$ul(class = ulClass, id = id,
+                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 1))
+
+  tabContent <- tags$div(class = "tab-content",
+                  `data-tabsetid` = tabsetId, lapply(tabs, "[[", 2))
+
+  list(navList = tabNavList, content = tabContent)
+}
+
+# Builds tabPanel/navbarMenu items (this function used to be
+# declared inside the buildTabset() function and it's been
+# refactored for clarity and reusability). Called internally
+# by buildTabset.
+buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
+                         divTag = NULL, textFilter = NULL) {
+
+  divTag <- if (!is.null(divTag)) divTag else tabs[[index]]
+
+  if (is.character(divTag) && !is.null(textFilter)) {
+    # text item: pass it to the textFilter if it exists
+    liTag <- textFilter(divTag)
+    divTag <- NULL
+
+  } else if (inherits(divTag, "shiny.navbarmenu")) {
+    # navbarMenu item: build the child tabset
+    tabset <- buildTabset(divTag$tabs, "dropdown-menu",
+      navbarMenuTextFilter, foundSelected = foundSelected)
+
+    # if this navbarMenu contains a selected item, mark it active
+    containsSelected <- containsSelectedTab(divTag$tabs)
+    liTag <- tags$li(
+      class = paste0("dropdown", if (containsSelected) " active"),
+      tags$a(href = "#",
+        class = "dropdown-toggle", `data-toggle` = "dropdown",
+        `data-value` = divTag$menuName,
+        getIcon(iconClass = divTag$iconClass),
+        divTag$title, tags$b(class = "caret")
+      ),
+      tabset$navList   # inner tabPanels items
+    )
+    # list of tab content divs from the child tabset
+    divTag <- tabset$content$children
+
+  } else {
+    # tabPanel item: create the tab's liTag and divTag
+    tabId <- paste("tab", tabsetId, index, sep = "-")
+    liTag <- tags$li(
+               tags$a(
+                 href = paste("#", tabId, sep = ""),
+                 `data-toggle` = "tab",
+                 `data-value` = divTag$attribs$`data-value`,
+                 getIcon(iconClass = divTag$attribs$`data-icon-class`),
+                 divTag$attribs$title
+               )
+    )
+    # if this tabPanel is selected item, mark it active
+    if (isTabSelected(divTag)) {
+      liTag$attribs$class <- "active"
+      divTag$attribs$class <- "tab-pane active"
     }
-
-    tabNavList <- tags$ul(class = ulClass, id = id)
-    tabContent <- tags$div(class = "tab-content")
-    tabsetId <- p_randomInt(1000, 10000)
-    tabId <- 1
-
-    buildItem <- function(divTag) {
-      # check for text; pass it to the textFilter or skip it if there is none
-      if (is.character(divTag)) {
-        if (!is.null(textFilter)) {
-          tabNavList <<- tagAppendChild(tabNavList, textFilter(divTag))
-        }
-
-      } else if (inherits(divTag, "shiny.navbarmenu")) {
-
-        # create the a tag
-        aTag <- tags$a(href="#",
-                       class="dropdown-toggle",
-                       `data-toggle`="dropdown")
-
-        # add optional icon
-        aTag <- appendIcon(aTag, divTag$iconClass)
-
-        # add the title and caret
-        aTag <- tagAppendChild(aTag, divTag$title)
-        aTag <- tagAppendChild(aTag, tags$b(class="caret"))
-
-        # build the dropdown list element
-        liTag <- tags$li(class = "dropdown", aTag)
-
-        # text filter for separators
-        textFilter <- function(text) {
-          if (grepl("^\\-+$", text))
-            tags$li(class="divider")
-          else
-            tags$li(class="dropdown-header", text)
-        }
-
-        # build the child tabset
-        tabset <- build(divTag$tabs, "dropdown-menu", textFilter)
-        liTag <- tagAppendChild(liTag, tabset$navList)
-
-        # If this navbar menu contains a selected item, mark it as active
-        if (containsSelected(divTag$tabs)) {
-          liTag$attribs$class <- paste(liTag$attribs$class, "active")
-        }
-
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        # don't add a standard tab content div, rather add the list of tab
-        # content divs that are contained within the tabset
-        tabContent <<- tagAppendChildren(tabContent,
-                                        list = tabset$content$children)
-
-      } else {
-        # Standard navbar item
-        # compute id and assign it to the div
-        thisId <- paste("tab", tabsetId, tabId, sep="-")
-        divTag$attribs$id <- thisId
-        tabId <<- tabId + 1
-
-        tabValue <- divTag$attribs$`data-value`
-
-        # create the a tag
-        aTag <- tags$a(href=paste("#", thisId, sep=""),
-                       `data-toggle` = "tab",
-                       `data-value` = tabValue)
-
-        # append optional icon
-        aTag <- appendIcon(aTag, divTag$attribs$`data-icon-class`)
-
-        # add the title
-        aTag <- tagAppendChild(aTag, divTag$attribs$title)
-
-        # create the li tag
-        liTag <- tags$li(aTag)
-
-        # If selected, set appropriate classes on li tag and div tag.
-        if (isSelected(divTag)) {
-          liTag$attribs$class <- "active"
-          divTag$attribs$class <- "tab-pane active"
-        }
-
-        divTag$attribs$title <- NULL
-
-        # append the elements to our lists
-        tabNavList <<- tagAppendChild(tabNavList, liTag)
-        tabContent <<- tagAppendChild(tabContent, divTag)
-      }
-    }
-
-    lapply(tabs, buildItem)
-    list(navList = tabNavList, content = tabContent)
+    divTag$attribs$id <- tabId
+    divTag$attribs$title <- NULL
   }
-
-
-  # Finally, actually invoke the functions to do the processing.
-  tabs <- findAndMarkSelected(tabs, selected)
-  build(tabs, ulClass, textFilter, id)
+  return(list(liTag = liTag, divTag = divTag))
 }
 
 

R/conditions.R

@@ -89,6 +89,23 @@ getLocs <- function(calls) {
   }, character(1))
 }
 
+getCallCategories <- function(calls) {
+  vapply(calls, function(call) {
+    srcref <- attr(call, "srcref", exact = TRUE)
+    if (!is.null(srcref)) {
+      srcfile <- attr(srcref, "srcfile", exact = TRUE)
+      if (!is.null(srcfile)) {
+        if (!is.null(srcfile$original)) {
+          return("pkg")
+        } else {
+          return("user")
+        }
+      }
+    }
+    return("")
+  }, character(1))
+}
+
 #' @details \code{captureStackTraces} runs the given \code{expr} and if any
 #'   \emph{uncaught} errors occur, annotates them with stack trace info for use
 #'   by \code{printError} and \code{printStackTrace}. It is not necessary to use
@@ -105,17 +122,92 @@ getLocs <- function(calls) {
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  withCallingHandlers(expr,
-    error = function(e) {
-      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
-        calls <- sys.calls()
-        attr(e, "stack.trace") <- calls
-        stop(e)
-      }
-    }
+  promises::with_promise_domain(createStackTracePromiseDomain(),
+    expr
   )
 }
 
+#' @include globals.R
+.globals$deepStack <- NULL
+
+createStackTracePromiseDomain <- function() {
+  d <- promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        calls <- sys.calls()
+        parents <- sys.parents()
+        attr(calls, "parents") <- parents
+        currentStack <- formatStackTrace(calls)
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onFulfilled(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        calls <- sys.calls()
+        parents <- sys.parents()
+        attr(calls, "parents") <- parents
+        currentStack <- formatStackTrace(calls)
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onRejected(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapSync = function(expr) {
+      withCallingHandlers(expr,
+        error = doCaptureStack
+      )
+    },
+    onError = doCaptureStack
+  )
+}
+
+deepStacksEnabled <- function() {
+  getOption("shiny.deepstacktrace", FALSE)
+}
+
+doCaptureStack <- function(e) {
+  if (is.null(attr(e, "stack.trace", exact = TRUE))) {
+    calls <- sys.calls()
+    parents <- sys.parents()
+    attr(calls, "parents") <- parents
+    attr(e, "stack.trace") <- calls
+  }
+  if (deepStacksEnabled()) {
+    if (is.null(attr(e, "deep.stack.trace", exact = TRUE)) && !is.null(.globals$deepStack)) {
+      attr(e, "deep.stack.trace") <- .globals$deepStack
+    }
+  }
+  stop(e)
+}
+
 #' @details \code{withLogErrors} captures stack traces and logs errors that
 #'   occur in \code{expr}, but does allow errors to propagate beyond this point
 #'   (i.e. it doesn't catch the error). The same caveats that apply to
@@ -128,7 +220,22 @@ withLogErrors <- function(expr,
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
-    captureStackTraces(expr),
+    {
+      result <- captureStackTraces(expr)
+
+      # Handle expr being an async operation
+      if (promises::is.promise(result)) {
+        result <- promises::catch(result, function(cond) {
+          # Don't print shiny.silent.error (i.e. validation errors)
+          if (inherits(cond, "shiny.silent.error")) return()
+          if (isTRUE(getOption("show.error.messages"))) {
+            printError(cond, full = full, offset = offset)
+          }
+        })
+      }
+
+      result
+    },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
       if (inherits(cond, "shiny.silent.error")) return()
@@ -162,6 +269,15 @@ printError <- function(cond,
   warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
   printStackTrace(cond, full = full, offset = offset)
+  lapply(rev(attr(cond, "deep.stack.trace", exact = TRUE)), function(st) {
+    message(
+      paste0(
+        "From earlier call:\n",
+        paste0(st, collapse = "\n"),
+        "\n"
+      )
+    )
+  })
   invisible()
 }
 
@@ -179,7 +295,8 @@ printStackTrace <- function(cond,
         paste0(collapse = "\n",
           formatStackTrace(stackTrace, full = full, offset = offset,
             indent = "    ")
-        )
+        ),
+        "\n"
       ))
     } else {
       message("No stack trace available")
@@ -192,6 +309,37 @@ printStackTrace <- function(cond,
   invisible()
 }
 
+# Given sys.parents() (which corresponds to sys.calls()), return a logical index
+# that prunes each subtree so that only the final branch remains. The result,
+# when applied to sys.calls(), is a linear list of calls without any "wrapper"
+# functions like tryCatch, try, with, hybrid_chain, etc. While these are often
+# part of the active call stack, they rarely are helpful when trying to identify
+# a broken bit of code.
+prune <- function(parents) {
+  # Detect nodes that are not the last child. This is necessary, but not
+  # sufficient; we also need to drop nodes that are the last child, but one of
+  # their ancestors is not.
+  is_dupe <- duplicated(parents, fromLast = TRUE)
+
+  # The index of the most recently seen node that was actually kept instead of
+  # dropped.
+  current_node <- 0
+
+  # Loop over the parent indices. Anything that is not parented by current_node
+  # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
+  # is kept becomes the new current_node.
+  include <- vapply(seq_along(parents), function(i) {
+    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+      current_node <<- i
+      TRUE
+    } else {
+      FALSE
+    }
+  }, FUN.VALUE = logical(1))
+
+  include
+}
+
 #' @details \code{extractStackTrace} takes a list of calls (e.g. as returned
 #'   from \code{conditionStackTrace(cond)}) and returns a data frame with one
 #'   row for each stack frame and the columns \code{num} (stack frame number),
@@ -203,6 +351,7 @@ extractStackTrace <- function(calls,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
+  parents <- attr(calls, "parents", exact = TRUE)
   srcrefs <- getSrcRefs(calls)
   if (offset) {
     # Offset calls vs. srcrefs by 1 to make them more intuitive.
@@ -231,6 +380,7 @@ extractStackTrace <- function(calls,
     if (toRemove > 0 && toRemove < 5) {
       calls <- utils::head(calls, -toRemove)
       callnames <- utils::head(callnames, -toRemove)
+      parents <- utils::head(parents, -toRemove)
     }
 
     # This uses a ref-counting scheme. It might make sense to switch this
@@ -242,6 +392,8 @@ extractStackTrace <- function(calls,
     score[callnames == "..stacktraceoff.."] <- -1
     score[callnames == "..stacktraceon.."] <- 1
     toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff.."))
+
+    toShow <- toShow & prune(parents)
   }
   calls <- calls[toShow]
 
@@ -253,6 +405,7 @@ extractStackTrace <- function(calls,
     num = index,
     call = getCallNames(calls),
     loc = getLocs(calls),
+    category = getCallCategories(calls),
     stringsAsFactors = FALSE
   )
 }
@@ -276,8 +429,14 @@ formatStackTrace <- function(calls, indent = "    ",
     indent,
     formatC(st$num, width = width),
     ": ",
-    st$call,
-    st$loc
+    mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+      if (category == "pkg")
+        crayon::silver(name)
+      else if (category == "user")
+        crayon::blue$bold(name)
+      else
+        crayon::white(name)
+    })
   )
 }
 

R/fileupload.R

@@ -20,6 +20,18 @@
 # form upload, i.e. traditional HTTP POST-based file upload) doesn't work with
 # the websockets package's HTTP server at the moment.
 
+# @description Returns a file's extension, with a leading dot, if one can be
+#   found. A valid extension contains only alphanumeric characters. If there is
+#   no extension, or if it contains non-alphanumeric characters, an empty
+#   string is returned.
+# @param x character vector giving file paths.
+# @return The extension of \code{x}, with a leading dot, if one was found.
+#   Otherwise, an empty character vector.
+maybeGetExtension <- function(x) {
+  ext <- tools::file_ext(x)
+  ifelse(ext == "", ext, paste0(".", ext))
+}
+
 FileUploadOperation <- R6Class(
   'FileUploadOperation',
   portable = FALSE,
@@ -52,8 +64,9 @@ FileUploadOperation <- R6Class(
       .currentFileInfo <<- file
       .pendingFileInfos <<- tail(.pendingFileInfos, -1)
 
-      filename <- file.path(.dir, as.character(length(.files$name)))
-      row <- data.frame(name=file$name, size=file$size, type=file$type,
+      fileBasename <- basename(.currentFileInfo$name)
+      filename <- file.path(.dir, paste0(as.character(length(.files$name)), maybeGetExtension(fileBasename)))
+      row <- data.frame(name=fileBasename, size=file$size, type=file$type,
                         datapath=filename, stringsAsFactors=FALSE)
 
       if (length(.files$name) == 0)

R/globals.R

@@ -5,7 +5,7 @@
   # R's lazy-loading package scheme causes the private seed to be cached in the
   # package itself, making our PRNG completely deterministic. This line resets
   # the private seed during load.
-  withPrivateSeed(reinitializeSeed())
+  withPrivateSeed(set.seed(NULL))
 }
 
 .onAttach <- function(libname, pkgname) {

R/html-deps.R

@@ -6,13 +6,18 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
-#'   \code{href} and/or \code{file} names must be present.
+#'   \code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named,
+#'   then \code{href} and/or \code{file} names must be present.
+#' @param scrubFile If TRUE (the default), remove \code{src$file} for the
+#'   dependency. This prevents the local file path from being sent to the client
+#'   when dynamic web dependencies are used. If FALSE, don't remove
+#'   \code{src$file}. Setting it to FALSE should be needed only in very unusual
+#'   cases.
 #'
 #' @return A single HTML dependency object that has an \code{href}-named element
 #'   in its \code{src}.
 #' @export
-createWebDependency <- function(dependency) {
+createWebDependency <- function(dependency, scrubFile = TRUE) {
   if (is.null(dependency))
     return(NULL)
 
@@ -25,6 +30,10 @@ createWebDependency <- function(dependency) {
     dependency$src$href <- prefix
   }
 
+  # Don't leak local file path to client
+  if (scrubFile)
+    dependency$src$file <- NULL
+
   return(dependency)
 }
 

R/imageutils.R

@@ -1,3 +1,33 @@
+startPNG <- function(filename, width, height, res, ...) {
+  # If quartz is available, use png() (which will default to quartz).
+  # Otherwise, if the Cairo package is installed, use CairoPNG().
+  # Finally, if neither quartz nor Cairo, use png().
+  if (capabilities("aqua")) {
+    pngfun <- grDevices::png
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
+      nchar(system.file(package = "Cairo"))) {
+    pngfun <- Cairo::CairoPNG
+  } else {
+    pngfun <- grDevices::png
+  }
+
+  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  # Call plot.new() so that even if no plotting operations are performed at
+  # least we have a blank background. N.B. we need to set the margin to 0
+  # temporarily before plot.new() because when the plot size is small (e.g.
+  # 200x50), we will get an error "figure margin too large", which is triggered
+  # by plot.new() with the default (large) margin. However, this does not
+  # guarantee user's code in func() will not trigger the error -- they may have
+  # to set par(mar = smaller_value) before they draw base graphics.
+  op <- graphics::par(mar = rep(0, 4))
+  tryCatch(
+    graphics::plot.new(),
+    finally = graphics::par(op)
+  )
+
+  grDevices::dev.cur()
+}
+
 #' Run a plotting function and save the output as a PNG
 #'
 #' This function returns the name of the PNG file that it generates. In
@@ -28,35 +58,44 @@
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
-  # If quartz is available, use png() (which will default to quartz).
-  # Otherwise, if the Cairo package is installed, use CairoPNG().
-  # Finally, if neither quartz nor Cairo, use png().
-  if (capabilities("aqua")) {
-    pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-             nchar(system.file(package = "Cairo"))) {
-    pngfun <- Cairo::CairoPNG
-  } else {
-    pngfun <- grDevices::png
-  }
-
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
-  # Call plot.new() so that even if no plotting operations are performed at
-  # least we have a blank background. N.B. we need to set the margin to 0
-  # temporarily before plot.new() because when the plot size is small (e.g.
-  # 200x50), we will get an error "figure margin too large", which is triggered
-  # by plot.new() with the default (large) margin. However, this does not
-  # guarantee user's code in func() will not trigger the error -- they may have
-  # to set par(mar = smaller_value) before they draw base graphics.
-  op <- graphics::par(mar = rep(0, 4))
-  tryCatch(
-    graphics::plot.new(),
-    finally = graphics::par(op)
-  )
-
-  dv <- grDevices::dev.cur()
+  dv <- startPNG(filename, width, height, res, ...)
   on.exit(grDevices::dev.off(dv), add = TRUE)
   func()
 
   filename
 }
+
+#' @importFrom grDevices dev.set dev.cur
+createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
+  force(which)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      old <- dev.cur()
+      dev.set(which)
+      on.exit(dev.set(old))
+
+      force(expr)
+    }
+  )
+}

R/input-checkboxgroup.R

@@ -8,7 +8,8 @@
 #' @param choices List of values to show checkboxes for. If elements of the list
 #'   are named then that name rather than the value is displayed to the user. If
 #'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
-#'   must not be provided, and vice-versa.
+#'   must not be provided, and vice-versa. The values should be strings; other
+#'   types (such as logicals and numbers) will be coerced to strings.
 #' @param selected The values that should be initially selected, if any.
 #' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
 #' @param choiceNames,choiceValues List of names and values, respectively,

R/input-radiobuttons.R

@@ -3,30 +3,30 @@
 #' Create a set of radio buttons used to select an item from a list.
 #'
 #' If you need to represent a "None selected" state, it's possible to default
-#' the radio buttons to have no options selected by using
-#' \code{selected = character(0)}. However, this is not recommended, as it gives
-#' the user no way to return to that state once they've made a selection.
-#' Instead, consider having the first of your choices be \code{c("None selected"
-#' = "")}.
+#' the radio buttons to have no options selected by using \code{selected =
+#' character(0)}. However, this is not recommended, as it gives the user no way
+#' to return to that state once they've made a selection. Instead, consider
+#' having the first of your choices be \code{c("None selected" = "")}.
 #'
 #' @inheritParams textInput
 #' @param choices List of values to select from (if elements of the list are
 #'   named then that name rather than the value is displayed to the user). If
 #'   this argument is provided, then \code{choiceNames} and \code{choiceValues}
-#'   must not be provided, and vice-versa.
-#' @param selected The initially selected value (if not specified then
-#'   defaults to the first value)
+#'   must not be provided, and vice-versa. The values should be strings; other
+#'   types (such as logicals and numbers) will be coerced to strings.
+#' @param selected The initially selected value (if not specified then defaults
+#'   to the first value)
 #' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally)
 #' @return A set of radio buttons that can be added to a UI definition.
-#' @param choiceNames,choiceValues List of names and values, respectively,
-#'   that are displayed to the user in the app and correspond to the each
-#'   choice (for this reason, \code{choiceNames} and \code{choiceValues}
-#'   must have the same length). If either of these arguments is
-#'   provided, then the other \emph{must} be provided and \code{choices}
-#'   \emph{must not} be provided. The advantage of using both of these over
-#'   a named list for \code{choices} is that \code{choiceNames} allows any
-#'   type of UI object to be passed through (tag objects, icons, HTML code,
-#'   ...), instead of just simple text. See Examples.
+#' @param choiceNames,choiceValues List of names and values, respectively, that
+#'   are displayed to the user in the app and correspond to the each choice (for
+#'   this reason, \code{choiceNames} and \code{choiceValues} must have the same
+#'   length). If either of these arguments is provided, then the other
+#'   \emph{must} be provided and \code{choices} \emph{must not} be provided. The
+#'   advantage of using both of these over a named list for \code{choices} is
+#'   that \code{choiceNames} allows any type of UI object to be passed through
+#'   (tag objects, icons, HTML code, ...), instead of just simple text. See
+#'   Examples.
 #'
 #' @family input elements
 #' @seealso \code{\link{updateRadioButtons}}

R/input-slider.R

@@ -86,22 +86,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  value <- restoreInput(id = inputId, default = value)
-
-  # If step is NULL, use heuristic to set the step size.
-  findStepSize <- function(min, max, step) {
-    if (!is.null(step)) return(step)
-
-    range <- max - min
-    # If short range or decimals, use continuous decimal with ~100 points
-    if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
-      step <- pretty(c(min, max), n = 100)
-      step[2] - step[1]
-    } else {
-      1
-    }
-  }
-
   if (inherits(min, "Date")) {
     if (!inherits(max, "Date") || !inherits(value, "Date"))
       stop("`min`, `max`, and `value must all be Date or non-Date objects")
@@ -122,6 +106,21 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     dataType <- "number"
   }
 
+  # Restore bookmarked values here, after doing the type checking, because the
+  # restored value will be a character vector instead of Date or POSIXct, and we can do
+  # the conversion to correct type next.
+  value <- restoreInput(id = inputId, default = value)
+
+  if (is.character(value)) {
+    # If we got here, the value was restored from a URL-encoded bookmark.
+    if (dataType == "date") {
+      value <- as.Date(value, format = "%Y-%m-%d")
+    } else if (dataType == "datetime") {
+      # Date-times will have a format like "2018-02-28T03:46:26Z"
+      value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
+    }
+  }
+
   step <- findStepSize(min, max, step)
 
   if (dataType %in% c("date", "datetime")) {
@@ -169,7 +168,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
-    `data-keyboard-step` = step / (max - min) * 100,
     # This value is only relevant for range sliders; for non-range sliders it
     # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
     `data-drag-interval` = if (length(value) > 1) dragRange,
@@ -238,6 +236,28 @@ hasDecimals <- function(value) {
   return (!identical(value, truncatedValue))
 }
 
+
+# If step is NULL, use heuristic to set the step size.
+findStepSize <- function(min, max, step) {
+  if (!is.null(step)) return(step)
+
+  range <- max - min
+  # If short range or decimals, use continuous decimal with ~100 points
+  if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
+    # Workaround for rounding errors (#1006): the intervals between the items
+    # returned by pretty() can have rounding errors. To avoid this, we'll use
+    # pretty() to find the min, max, and number of steps, and then use those
+    # values to calculate the step size.
+    pretty_steps <- pretty(c(min, max), n = 100)
+    n_steps <- length(pretty_steps) - 1
+    (max(pretty_steps) - min(pretty_steps)) / n_steps
+
+  } else {
+    1
+  }
+}
+
+
 #' @rdname sliderInput
 #'
 #' @param interval The interval, in milliseconds, between each animation step.

R/input-utils.R

@@ -73,10 +73,10 @@ generateOptions <- function(inputId, selected, inline, type = 'checkbox',
       # checkbox-inline.
       if (inline) {
         tags$label(class = paste0(type, "-inline"), inputTag,
-                   tags$span(pd$html, pd$dep))
+                   tags$span(pd$html, pd$deps))
       } else {
         tags$div(class = type, tags$label(inputTag,
-                 tags$span(pd$html, pd$dep)))
+                 tags$span(pd$html, pd$deps)))
       }
     },
     SIMPLIFY = FALSE, USE.NAMES = FALSE

R/insert-tab.R

@@ -0,0 +1,325 @@
+#' Dynamically insert/remove a tabPanel
+#'
+#' Dynamically insert or remove a \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}}) from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' When you want to insert a new tab before or after an existing tab, you
+#' should use \code{insertTab}. When you want to prepend a tab (i.e. add a
+#' tab to the beginning of the \code{tabsetPanel}), use \code{prependTab}.
+#' When you want to append a tab (i.e. add a tab to the end of the
+#' \code{tabsetPanel}), use \code{appendTab}.
+#'
+#' For \code{navbarPage}, you can insert/remove conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) into which \code{tab} will
+#'   be inserted/removed.
+#'
+#' @param tab The item to be added (must be created with \code{tabPanel},
+#'   or with \code{navbarMenu}).
+#'
+#' @param target If inserting: the \code{value} of an existing
+#'   \code{tabPanel}, next to which \code{tab} will be added.
+#'   If removing: the \code{value} of the \code{tabPanel} that
+#'   you want to remove. See Details if you want to insert next to/remove
+#'   an entire \code{navbarMenu} instead.
+#'
+#' @param position Should \code{tab} be added before or after the
+#'   \code{target} tab?
+#'
+#' @param select Should \code{tab} be selected upon being inserted?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{showTab}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' # example app for inserting/removing a tab
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       actionButton("add", "Add 'Dynamic' tab"),
+#'       actionButton("remove", "Remove 'Foo' tab")
+#'     ),
+#'     mainPanel(
+#'       tabsetPanel(id = "tabs",
+#'         tabPanel("Hello", "This is the hello tab"),
+#'         tabPanel("Foo", "This is the foo tab"),
+#'         tabPanel("Bar", "This is the bar tab")
+#'       )
+#'     )
+#'   )
+#' )
+#' server <- function(input, output, session) {
+#'   observeEvent(input$add, {
+#'     insertTab(inputId = "tabs",
+#'       tabPanel("Dynamic", "This a dynamically-added tab"),
+#'       target = "Bar"
+#'     )
+#'   })
+#'   observeEvent(input$remove, {
+#'     removeTab(inputId = "tabs", target = "Foo")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#' # example app for prepending/appending a navbarMenu
+#' ui <- navbarPage("Navbar page", id = "tabs",
+#'   tabPanel("Home",
+#'     actionButton("prepend", "Prepend a navbarMenu"),
+#'     actionButton("append", "Append a navbarMenu")
+#'   )
+#' )
+#' server <- function(input, output, session) {
+#'   observeEvent(input$prepend, {
+#'     id <- paste0("Dropdown", input$prepend, "p")
+#'     prependTab(inputId = "tabs",
+#'       navbarMenu(id,
+#'         tabPanel("Drop1", paste("Drop1 page from", id)),
+#'         tabPanel("Drop2", paste("Drop2 page from", id)),
+#'         "------",
+#'         "Header",
+#'         tabPanel("Drop3", paste("Drop3 page from", id))
+#'       )
+#'     )
+#'   })
+#'   observeEvent(input$append, {
+#'     id <- paste0("Dropdown", input$append, "a")
+#'     appendTab(inputId = "tabs",
+#'       navbarMenu(id,
+#'         tabPanel("Drop1", paste("Drop1 page from", id)),
+#'         tabPanel("Drop2", paste("Drop2 page from", id)),
+#'         "------",
+#'         "Header",
+#'         tabPanel("Drop3", paste("Drop3 page from", id))
+#'       )
+#'     )
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+insertTab <- function(inputId, tab, target,
+                      position = c("before", "after"), select = FALSE,
+                      session = getDefaultReactiveDomain()) {
+  force(target)
+  force(select)
+  position <- match.arg(position)
+  inputId <- session$ns(inputId)
+
+  # Barbara -- August 2017
+  # Note: until now, the number of tabs in a tabsetPanel (or navbarPage
+  # or navlistPanel) was always fixed. So, an easy way to give an id to
+  # a tab was simply incrementing a counter. (Just like it was easy to
+  # give a random 4-digit number to identify the tabsetPanel). Since we
+  # can only know this in the client side, we'll just pass `id` and
+  # `tsid` (TabSetID) as dummy values that will be fixed in the JS code.
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = NULL,
+      target = target,
+      position = position,
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @param menuName This argument should only be used when you want to
+#'   prepend (or append) \code{tab} to the beginning (or end) of an
+#'   existing \code{\link{navbarMenu}} (which must itself be part of
+#'   an existing \code{\link{navbarPage}}). In this case, this argument
+#'   should be the \code{menuName} that you gave your \code{navbarMenu}
+#'   when you first created it (by default, this is equal to the value
+#'   of the \code{title} argument). Note that you still need to set the
+#'   \code{inputId} argument to whatever the \code{id} of the parent
+#'   \code{navbarPage} is. If \code{menuName} is left as \code{NULL},
+#'   \code{tab} will be prepended (or appended) to whatever
+#'   \code{inputId} is.
+#'
+#' @rdname insertTab
+#' @export
+prependTab <- function(inputId, tab, select = FALSE, menuName = NULL,
+                       session = getDefaultReactiveDomain()) {
+  force(select)
+  force(menuName)
+  inputId <- session$ns(inputId)
+
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = menuName,
+      target = NULL,
+      position = "after",
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname insertTab
+#' @export
+appendTab <- function(inputId, tab, select = FALSE, menuName = NULL,
+                      session = getDefaultReactiveDomain()) {
+  force(select)
+  force(menuName)
+  inputId <- session$ns(inputId)
+
+  item <- buildTabItem("id", "tsid", TRUE, divTag = tab,
+    textFilter = if (is.character(tab)) navbarMenuTextFilter else NULL)
+
+  callback <- function() {
+    session$sendInsertTab(
+      inputId = inputId,
+      liTag = processDeps(item$liTag, session),
+      divTag = processDeps(item$divTag, session),
+      menuName = menuName,
+      target = NULL,
+      position = "before",
+      select = select)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname insertTab
+#' @export
+removeTab <- function(inputId, target,
+                      session = getDefaultReactiveDomain()) {
+  force(target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendRemoveTab(
+      inputId = inputId,
+      target = target)
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+
+#' Dynamically hide/show a tabPanel
+#'
+#' Dynamically hide or show a \code{\link{tabPanel}} (or a
+#' \code{\link{navbarMenu}})from an existing \code{\link{tabsetPanel}},
+#' \code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+#'
+#' For \code{navbarPage}, you can hide/show conventional
+#' \code{tabPanel}s (whether at the top level or nested inside a
+#' \code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+#' For the latter case, \code{target} should be the \code{menuName} that
+#' you gave your \code{navbarMenu} when you first created it (by default,
+#' this is equal to the value of the \code{title} argument).
+#'
+#' @param inputId The \code{id} of the \code{tabsetPanel} (or
+#'   \code{navlistPanel} or \code{navbarPage}) in which to find
+#'   \code{target}.
+#'
+#' @param target The \code{value} of the \code{tabPanel} to be
+#'   hidden/shown. See Details if you want to hide/show an entire
+#'   \code{navbarMenu} instead.
+#'
+#' @param select Should \code{target} be selected upon being shown?
+#'
+#' @param session The shiny session within which to call this function.
+#'
+#' @seealso \code{\link{insertTab}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- navbarPage("Navbar page", id = "tabs",
+#'   tabPanel("Home",
+#'     actionButton("hideTab", "Hide 'Foo' tab"),
+#'     actionButton("showTab", "Show 'Foo' tab"),
+#'     actionButton("hideMenu", "Hide 'More' navbarMenu"),
+#'     actionButton("showMenu", "Show 'More' navbarMenu")
+#'   ),
+#'   tabPanel("Foo", "This is the foo tab"),
+#'   tabPanel("Bar", "This is the bar tab"),
+#'   navbarMenu("More",
+#'     tabPanel("Table", "Table page"),
+#'     tabPanel("About", "About page"),
+#'     "------",
+#'     "Even more!",
+#'     tabPanel("Email", "Email page")
+#'   )
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observeEvent(input$hideTab, {
+#'     hideTab(inputId = "tabs", target = "Foo")
+#'   })
+#'
+#'   observeEvent(input$showTab, {
+#'     showTab(inputId = "tabs", target = "Foo")
+#'   })
+#'
+#'   observeEvent(input$hideMenu, {
+#'     hideTab(inputId = "tabs", target = "More")
+#'   })
+#'
+#'   observeEvent(input$showMenu, {
+#'     showTab(inputId = "tabs", target = "More")
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+showTab <- function(inputId, target, select = FALSE,
+                    session = getDefaultReactiveDomain()) {
+  force(target)
+
+  if (select) updateTabsetPanel(session, inputId, selected = target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendChangeTabVisibility(
+      inputId = inputId,
+      target = target,
+      type = "show"
+    )
+  }
+  session$onFlush(callback, once = TRUE)
+}
+
+#' @rdname showTab
+#' @export
+hideTab <- function(inputId, target,
+                    session = getDefaultReactiveDomain()) {
+  force(target)
+  inputId <- session$ns(inputId)
+
+  callback <- function() {
+    session$sendChangeTabVisibility(
+      inputId = inputId,
+      target = target,
+      type = "hide"
+    )
+  }
+  session$onFlush(callback, once = TRUE)
+}

R/middleware.R

@@ -351,38 +351,72 @@ HandlerManager <- R6Class("HandlerManager",
         }
 
         response <- handler(req)
-        if (is.null(response))
-          response <- httpResponse(404, content="<h1>Not Found</h1>")
 
-        if (inherits(response, "httpResponse")) {
-          headers <- as.list(response$headers)
-          headers$'Content-Type' <- response$content_type
+        res <- hybrid_chain(response, function(response) {
+          if (is.null(response))
+            response <- httpResponse(404, content="<h1>Not Found</h1>")
+
+          if (inherits(response, "httpResponse")) {
+            headers <- as.list(response$headers)
+            headers$'Content-Type' <- response$content_type
+
+            response <- filter(req, response)
+            if (head_request) {
+
+              headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
+
+              return(list(
+                status = response$status,
+                body = "",
+                headers = headers
+              ))
+            } else {
+              return(list(
+                status = response$status,
+                body = response$content,
+                headers = headers
+              ))
+            }
 
-          response <- filter(req, response)
-          if (head_request) {
-            headers$`Content-Length` <- nchar(response$content, type = "bytes")
-            return(list(
-              status = response$status,
-              body = "",
-              headers = headers
-            ))
           } else {
-            return(list(
-              status = response$status,
-              body = response$content,
-              headers = headers
-            ))
+            # Assume it's a Rook-compatible response
+            return(response)
           }
-
-        } else {
-          # Assume it's a Rook-compatible response
-          return(response)
-        }
+        })
       }
     }
   )
 )
 
+# Safely get the Content-Length of a Rook response, or NULL if the length cannot
+# be determined for whatever reason (probably malformed response$content).
+# If deleteOwnedContent is TRUE, then the function should delete response
+# content that is of the form list(file=..., owned=TRUE).
+getResponseContentLength <- function(response, deleteOwnedContent) {
+  force(deleteOwnedContent)
+
+  result <- if (is.character(response$content) && length(response$content) == 1) {
+    nchar(response$content, type = "bytes")
+  } else if (is.raw(response$content)) {
+    length(response$content)
+  } else if (is.list(response$content) && !is.null(response$content$file)) {
+    if (deleteOwnedContent && isTRUE(response$content$owned)) {
+      on.exit(unlink(response$content$file, recursive = FALSE, force = FALSE), add = TRUE)
+    }
+    file.info(response$content$file)$size
+  } else {
+    warning("HEAD request for unexpected content class ", class(response$content)[[1]])
+    NULL
+  }
+
+  if (is.na(result)) {
+    # Mostly for missing file case
+    return(NULL)
+  } else {
+    return(result)
+  }
+}
+
 #
 # ## Next steps
 #

R/modules.R

@@ -26,6 +26,11 @@ createSessionProxy <- function(parentSession, ...) {
 
 #' @export
 `$<-.session_proxy` <- function(x, name, value) {
+  # this line allows users to write into session$userData
+  # (e.g. it allows something like `session$userData$x <- TRUE`,
+  # but not `session$userData <- TRUE`) from within a module
+  # without any hacks (see PR #1732)
+  if (identical(x[[name]], value)) return(x)
   stop("Attempted to assign value on session proxy.")
 }
 

R/react.R

@@ -1,3 +1,21 @@
+processId <- local({
+  # pid is not sufficient to uniquely identify a process, because
+  # distributed futures span machines which could introduce pid
+  # collisions.
+  cached <- NULL
+  function() {
+    if (is.null(cached)) {
+      cached <<- digest::digest(list(
+        Sys.info(),
+        Sys.time()
+      ))
+    }
+    # Sys.getpid() cannot be cached because forked children will
+    # then have the same processId as their parents.
+    paste(cached, Sys.getpid())
+  }
+})
+
 Context <- R6Class(
   'Context',
   portable = FALSE,
@@ -9,25 +27,35 @@ Context <- R6Class(
     .invalidateCallbacks = list(),
     .flushCallbacks = list(),
     .domain = NULL,
+    .pid = NULL,
 
     initialize = function(domain, label='', type='other', prevId='') {
       id <<- .getReactiveEnvironment()$nextId()
       .label <<- label
       .domain <<- domain
+      .pid <<- processId()
       .graphCreateContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
-      withReactiveDomain(.domain, {
-        env <- .getReactiveEnvironment()
-        .graphEnterContext(id)
-        on.exit(.graphExitContext(id), add = TRUE)
-        env$runWith(self, func)
+
+      promises::with_promise_domain(reactivePromiseDomain(), {
+        withReactiveDomain(.domain, {
+          env <- .getReactiveEnvironment()
+          .graphEnterContext(id)
+          on.exit(.graphExitContext(id), add = TRUE)
+          env$runWith(self, func)
+        })
       })
     },
     invalidate = function() {
       "Invalidate this context. It will immediately call the callbacks
         that have been registered with onInvalidate()."
+
+      if (!identical(.pid, processId())) {
+        stop("Reactive context was created in one process and invalidated from another")
+      }
+
       if (.invalidated)
         return()
       .invalidated <<- TRUE
@@ -43,6 +71,11 @@ Context <- R6Class(
       "Register a function to be called when this context is invalidated.
         If this context is already invalidated, the function is called
         immediately."
+
+      if (!identical(.pid, processId())) {
+        stop("Reactive context was created in one process and accessed from another")
+      }
+
       if (.invalidated)
         func()
       else
@@ -52,9 +85,6 @@ Context <- R6Class(
     addPendingFlush = function(priority) {
       "Tell the reactive environment that this context should be flushed the
         next time flushReact() called."
-      if (!is.null(.domain)) {
-        .domain$incrementBusyCount()
-      }
       .getReactiveEnvironment()$addPendingFlush(self, priority)
     },
     onFlush = function(func) {
@@ -64,12 +94,6 @@ Context <- R6Class(
     executeFlushCallbacks = function() {
       "For internal use only."
 
-      on.exit({
-        if (!is.null(.domain)) {
-          .domain$decrementBusyCount()
-        }
-      }, add = TRUE)
-
       lapply(.flushCallbacks, function(flushCallback) {
         flushCallback()
       })
@@ -118,9 +142,12 @@ ReactiveEnvironment <- R6Class(
     hasPendingFlush = function() {
       return(!.pendingFlush$isEmpty())
     },
+    # Returns TRUE if anything was actually called
     flush = function() {
+      # If nothing to flush, exit early
+      if (!hasPendingFlush()) return(invisible(FALSE))
       # If already in a flush, don't start another one
-      if (.inFlush) return()
+      if (.inFlush) return(invisible(FALSE))
       .inFlush <<- TRUE
       on.exit(.inFlush <<- FALSE)
 
@@ -128,6 +155,8 @@ ReactiveEnvironment <- R6Class(
         ctx <- .pendingFlush$dequeue()
         ctx$executeFlushCallbacks()
       }
+
+      invisible(TRUE)
     }
   )
 )
@@ -141,9 +170,10 @@ ReactiveEnvironment <- R6Class(
   }
 })
 
-# Causes any pending invalidations to run.
+# Causes any pending invalidations to run. Returns TRUE if any invalidations
+# were pending (i.e. if work was actually done).
 flushReact <- function() {
-  .getReactiveEnvironment()$flush()
+  return(.getReactiveEnvironment()$flush())
 }
 
 # Retrieves the current reactive context, or errors if there is no reactive
@@ -163,3 +193,31 @@ local({
     return(dummyContext)
   }
 })
+
+wrapForContext <- function(func, ctx) {
+  force(func)
+  force(ctx)
+
+  function(...) {
+    ctx$run(function() {
+      captureStackTraces(
+        func(...)
+      )
+    })
+  }
+}
+
+reactivePromiseDomain <- function() {
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      ctx <- getCurrentContext()
+      wrapForContext(onFulfilled, ctx)
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      ctx <- getCurrentContext()
+      wrapForContext(onRejected, ctx)
+    }
+  )
+}

R/reactives.R

@@ -47,12 +47,13 @@ ReactiveVal <- R6Class(
     value = NULL,
     label = NULL,
     frozen = FALSE,
-    dependents = Dependents$new()
+    dependents = NULL
   ),
   public = list(
     initialize = function(value, label = NULL) {
       private$value <- value
       private$label <- label
+      private$dependents <- Dependents$new()
       .graphValueChange(private$label, value)
     },
     get = function() {
@@ -90,7 +91,7 @@ ReactiveVal <- R6Class(
     format = function(...) {
       # capture.output(print()) is necessary because format() doesn't
       # necessarily return a character vector, e.g. data.frame.
-      label <- capture.output(print(base::format(private$value, ...)))
+      label <- utils::capture.output(print(base::format(private$value, ...)))
       if (length(label) == 1) {
         paste0("reactiveVal: ", label)
       } else {
@@ -1025,6 +1026,9 @@ registerDebugHook("observerFunc", environment(), label)
 
         continue <- function() {
           ctx$addPendingFlush(.priority)
+          if (!is.null(.domain)) {
+            .domain$incrementBusyCount()
+          }
         }
 
         if (.suspended == FALSE)
@@ -1034,16 +1038,21 @@ registerDebugHook("observerFunc", environment(), label)
       })
 
       ctx$onFlush(function() {
-        tryCatch({
-          if (!.destroyed)
-            shinyCallingHandlers(run())
 
-        }, error = function(e) {
-          printError(e)
-          if (!is.null(.domain)) {
-            .domain$unhandledError(e)
-          }
-        })
+        hybrid_chain(
+          {
+            if (!.destroyed) {
+              shinyCallingHandlers(run())
+            }
+          },
+          catch = function(e) {
+            printError(e)
+            if (!is.null(.domain)) {
+              .domain$unhandledError(e)
+            }
+          },
+          finally = .domain$decrementBusyCount
+        )
       })
 
       return(ctx)
@@ -1474,13 +1483,21 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
+  force(session)
   ctx <- .getReactiveEnvironment()$currentContext()
   timerCallbacks$schedule(millis, function() {
-    # Quit if the session is closed
-    if (!is.null(session) && session$isClosed()) {
+    if (is.null(session)) {
+      ctx$invalidate()
       return(invisible())
     }
-    ctx$invalidate()
+
+    if (!session$isClosed()) {
+      session$cycleStartAction(function() {
+        ctx$invalidate()
+      })
+    }
+
+    invisible()
   })
   invisible()
 }
@@ -1541,9 +1558,22 @@ coerceToFunc <- function(x) {
 #' @seealso \code{\link{reactiveFileReader}}
 #'
 #' @examples
-#' # Assume the existence of readTimestamp and readValue functions
 #' function(input, output, session) {
-#'   data <- reactivePoll(1000, session, readTimestamp, readValue)
+#'
+#'   data <- reactivePoll(1000, session,
+#'     # This function returns the time that log_file was last modified
+#'     checkFunc = function() {
+#'       if (file.exists(log_file))
+#'         file.info(log_file)$mtime[1]
+#'       else
+#'         ""
+#'     },
+#'     # This function returns the content of log_file
+#'     valueFunc = function() {
+#'       read.csv(log_file)
+#'     }
+#'   )
+#'
 #'   output$dataTable <- renderTable({
 #'     data()
 #'   })

R/render-plot.R

@@ -55,37 +55,20 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 
   args <- list(...)
 
-  if (is.function(width))
+  if (is.reactive(width))
+    widthWrapper <- width
+  else if (is.function(width))
     widthWrapper <- reactive({ width() })
   else
     widthWrapper <- function() { width }
 
-  if (is.function(height))
+  if (is.reactive(height))
+    heightWrapper <- height
+  else if (is.function(height))
     heightWrapper <- reactive({ height() })
   else
     heightWrapper <- function() { height }
 
-  # A modified version of print.ggplot which returns the built ggplot object
-  # as well as the gtable grob. This overrides the ggplot::print.ggplot
-  # method, but only within the context of renderPlot. The reason this needs
-  # to be a (pseudo) S3 method is so that, if an object has a class in
-  # addition to ggplot, and there's a print method for that class, that we
-  # won't override that method. https://github.com/rstudio/shiny/issues/841
-  print.ggplot <- function(x) {
-    grid::grid.newpage()
-
-    build <- ggplot2::ggplot_build(x)
-
-    gtable <- ggplot2::ggplot_gtable(build)
-    grid::grid.draw(gtable)
-
-    structure(list(
-      build = build,
-      gtable = gtable
-    ), class = "ggplot_build_gtable")
-  }
-
-
   getDims <- function() {
     width <- widthWrapper()
     height <- heightWrapper()
@@ -106,155 +89,45 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   session <- NULL
   outputName <- NULL
 
-  # This function is the one that's returned from renderPlot(), and gets
-  # wrapped in an observer when the output value is assigned. The expression
-  # passed to renderPlot() is actually run in plotObj(); this function can only
-  # replay a plot if the width/height changes.
-  renderFunc <- function(shinysession, name, ...) {
-    session <<- shinysession
-    outputName <<- name
+  # Calls drawPlot, invoking the user-provided `func` (which may or may not
+  # return a promise). The idea is that the (cached) return value from this
+  # reactive can be used for varying width/heights, as it includes the
+  # displaylist, which is resolution independent.
+  drawReactive <- reactive(label = "plotObj", ..stacktraceon = FALSE, {
+    hybrid_chain(
+      {
+        # If !execOnResize, don't invalidate when width/height changes.
+        dims <- if (execOnResize) getDims() else isolate(getDims())
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        drawPlot(outputName, session, func, dims$width, dims$height, pixelratio, res)
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        getDims()
 
-    dims <- getDims()
-
-    if (is.null(dims$width) || is.null(dims$height) ||
-        dims$width <= 0 || dims$height <= 0) {
-      return(NULL)
-    }
-
-    # The reactive that runs the expr in renderPlot()
-    plotData <- plotObj()
-
-    img <- plotData$img
-
-    # If only the width/height have changed, simply replay the plot and make a
-    # new img.
-    if (dims$width != img$width || dims$height != img$height) {
-      pixelratio <- session$clientData$pixelratio %OR% 1
-
-      coordmap <- NULL
-      plotFunc <- function() {
-        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
-
-        # Coordmap must be recalculated after replaying plot, because pixel
-        # dimensions will have changed.
-        if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
-          coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
-        } else {
-          coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
-        }
+        # Propagate the error
+        stop(reason)
       }
-      outfile <- ..stacktraceoff..(
-        plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
-                res = res*pixelratio)
-      )
-      on.exit(unlink(outfile))
-
-      img <- dropNulls(list(
-        src = session$fileUrl(name, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present
-        error = attr(coordmap, "error", exact = TRUE)
-      ))
-    }
-
-    img
-  }
-
-
-  plotObj <- reactive(label = "plotObj", {
-    if (execOnResize) {
-      dims <- getDims()
-    } else {
-      isolate({ dims <- getDims() })
-    }
-
-    if (is.null(dims$width) || is.null(dims$height) ||
-        dims$width <= 0 || dims$height <= 0) {
-      return(NULL)
-    }
-
-    # Resolution multiplier
-    pixelratio <- session$clientData$pixelratio %OR% 1
-
-    plotResult <- NULL
-    recordedPlot <- NULL
-    coordmap <- NULL
-    plotFunc <- function() {
-      success <-FALSE
-      tryCatch(
-        {
-          # This is necessary to enable displaylist recording
-          grDevices::dev.control(displaylist = "enable")
-
-          # Actually perform the plotting
-          result <- withVisible(func())
-          success <- TRUE
-        },
-        finally = {
-          if (!success) {
-            # If there was an error in making the plot, there's a good chance
-            # it's "Error in plot.new: figure margins too large". We need to
-            # take a reactive dependency on the width and height, so that the
-            # user's plotting code will re-execute when the plot is resized,
-            # instead of just replaying the previous plot (which errored).
-            getDims()
-          }
-        }
-      )
-
-      if (result$visible) {
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-        utils::capture.output({
-          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
-          # the call to plotFunc. The value needs to be printed just in case
-          # it's an object that requires printing to generate plot output,
-          # similar to ggplot2. But for base graphics, it would already have
-          # been rendered when func was called above, and the print should
-          # have no effect.
-          plotResult <<- ..stacktraceon..(print(result$value))
-        })
-      }
-
-      recordedPlot <<- grDevices::recordPlot()
-
-      if (inherits(plotResult, "ggplot_build_gtable")) {
-        coordmap <<- getGgplotCoordmap(plotResult, pixelratio, res)
-      } else {
-        coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
-      }
-    }
-
-    # This ..stacktraceoff.. is matched by the `func` function's
-    # wrapFunctionLabel(..stacktraceon=TRUE) call near the beginning of
-    # renderPlot, and by the ..stacktraceon.. in plotFunc where ggplot objects
-    # are printed
-    outfile <- ..stacktraceoff..(
-      do.call(plotPNG, c(plotFunc, width=dims$width*pixelratio,
-        height=dims$height*pixelratio, res=res*pixelratio, args))
-    )
-    on.exit(unlink(outfile))
-
-    list(
-      # img is the content that gets sent to the client.
-      img = dropNulls(list(
-        src = session$fileUrl(outputName, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present.
-        error = attr(coordmap, "error", exact = TRUE)
-      )),
-      # Returned value from expression in renderPlot() -- may be a printable
-      # object like ggplot2. Needed just in case we replayPlot and need to get
-      # a coordmap again.
-      plotResult = plotResult,
-      recordedPlot = recordedPlot
     )
   })
 
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+
+    hybrid_chain(
+      drawReactive(),
+      function(result) {
+        dims <- getDims()
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        resizeSavedPlot(name, shinysession, result, dims$width, dims$height, pixelratio, res)
+      }
+    )
+  }
 
   # If renderPlot isn't going to adapt to the height of the div, then the
   # div needs to adapt to the height of renderPlot. By default, plotOutput
@@ -266,6 +139,130 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
   markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
 }
 
+resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res) {
+  if (result$img$width == width && result$img$height == height &&
+      result$pixelratio == pixelratio && result$res == res) {
+    return(result$img)
+  }
+
+  coordmap <- NULL
+  outfile <- plotPNG(function() {
+    grDevices::replayPlot(result$recordedPlot)
+    coordmap <<- getCoordmap(result$plotResult, width, height, pixelratio, res)
+  }, width = width*pixelratio, height = height*pixelratio, res = res*pixelratio)
+  on.exit(unlink(outfile), add = TRUE)
+
+  img <- list(
+    src = session$fileUrl(name, outfile, contentType = "image/png"),
+    width = width,
+    height = height,
+    coordmap = coordmap,
+    error = attr(coordmap, "error", exact = TRUE)
+  )
+}
+
+drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
+  #  1. Start PNG
+  #  2. Enable displaylist recording
+  #  3. Call user-defined func
+  #  4. Print/save result, if visible
+  #  5. Snapshot displaylist
+  #  6. Form coordmap
+  #  7. End PNG (in finally)
+  #  8. Form img tag
+  #  9. Return img, value, displaylist, coordmap
+  # 10. On error, take width and height dependency
+
+  outfile <- tempfile(fileext='.png') # If startPNG throws, this could leak. Shrug.
+  device <- startPNG(outfile, width*pixelratio, height*pixelratio, res = res*pixelratio, ...)
+  domain <- createGraphicsDevicePromiseDomain(device)
+  grDevices::dev.control(displaylist = "enable")
+
+  hybrid_chain(
+    hybrid_chain(
+      promises::with_promise_domain(domain, {
+        hybrid_chain(
+          func(),
+          function(value, .visible) {
+            if (.visible) {
+              # A modified version of print.ggplot which returns the built ggplot object
+              # as well as the gtable grob. This overrides the ggplot::print.ggplot
+              # method, but only within the context of renderPlot. The reason this needs
+              # to be a (pseudo) S3 method is so that, if an object has a class in
+              # addition to ggplot, and there's a print method for that class, that we
+              # won't override that method. https://github.com/rstudio/shiny/issues/841
+              print.ggplot <- custom_print.ggplot
+
+              # Use capture.output to squelch printing to the actual console; we
+              # are only interested in plot output
+              utils::capture.output({
+                # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
+                # the call to plotFunc. The value needs to be printed just in case
+                # it's an object that requires printing to generate plot output,
+                # similar to ggplot2. But for base graphics, it would already have
+                # been rendered when func was called above, and the print should
+                # have no effect.
+                result <- ..stacktraceon..(print(value))
+                # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
+              })
+              result
+            } else {
+              # Not necessary, but I wanted to make it explicit
+              NULL
+            }
+          },
+          function(value) {
+            list(
+              plotResult = value,
+              recordedPlot = grDevices::recordPlot(),
+              coordmap = getCoordmap(value, width, height, pixelratio, res),
+              pixelratio = pixelratio,
+              res = res
+            )
+          }
+        )
+      }),
+      finally = function() {
+        grDevices::dev.off(device)
+      }
+    ),
+    function(result) {
+      result$img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = width,
+        height = height,
+        coordmap = result$coordmap,
+        # Get coordmap error message if present
+        error = attr(result$coordmap, "error", exact = TRUE)
+      ))
+      result
+    },
+    finally = function() {
+      unlink(outfile)
+    }
+  )
+}
+
+# A modified version of print.ggplot which returns the built ggplot object
+# as well as the gtable grob. This overrides the ggplot::print.ggplot
+# method, but only within the context of renderPlot. The reason this needs
+# to be a (pseudo) S3 method is so that, if an object has a class in
+# addition to ggplot, and there's a print method for that class, that we
+# won't override that method. https://github.com/rstudio/shiny/issues/841
+custom_print.ggplot <- function(x) {
+  grid::grid.newpage()
+
+  build <- ggplot2::ggplot_build(x)
+
+  gtable <- ggplot2::ggplot_gtable(build)
+  grid::grid.draw(gtable)
+
+  structure(list(
+    build = build,
+    gtable = gtable
+  ), class = "ggplot_build_gtable")
+}
+
 # The coordmap extraction functions below return something like the examples
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
@@ -384,6 +381,14 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #   .. ..$ top   : num 35.7
 
 
+getCoordmap <- function(x, width, height, pixelratio, res) {
+  if (inherits(x, "ggplot_build_gtable")) {
+    getGgplotCoordmap(x, pixelratio, res)
+  } else {
+    getPrevPlotCoordmap(width, height)
+  }
+}
+
 # Get a coordmap for the previous plot made with base graphics.
 # Requires width and height of output image, in pixels.
 # Must be called before the graphics device is closed.
@@ -424,7 +429,6 @@ getPrevPlotCoordmap <- function(width, height) {
   ))
 }
 
-
 # Given a ggplot_build_gtable object, return a coordmap for it.
 getGgplotCoordmap <- function(p, pixelratio, res) {
   if (!inherits(p, "ggplot_build_gtable"))
@@ -470,11 +474,13 @@ find_panel_info <- function(b) {
 # This is for ggplot2>2.2.1, after an API was introduced for extracting
 # information about the plot object.
 find_panel_info_api <- function(b) {
+  # Workaround for check NOTE, until ggplot2 >2.2.1 is released
+  colon_colon <- `::`
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
-  layout <- ggplot2::summarise_layout(b)
-  coord  <- ggplot2::summarise_coord(b)
-  layers <- ggplot2::summarise_layers(b)
+  layout <- colon_colon("ggplot2", "summarise_layout")(b)
+  coord  <- colon_colon("ggplot2", "summarise_coord")(b)
+  layers <- colon_colon("ggplot2", "summarise_layers")(b)
 
   # Given x and y scale objects and a coord object, return a list that has
   # the bases of log transformations for x and y, or NULL if it's not a

R/render-table.R

@@ -81,143 +81,148 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
 
   dots <- list(...)  ## used later (but defined here because of scoping)
 
-  renderFunc <- function(shinysession, name, ...) {
-    striped <- stripedWrapper()
-    hover <- hoverWrapper()
-    bordered <- borderedWrapper()
-    format <- c(striped = striped, hover = hover, bordered = bordered)
-    spacing <- spacingWrapper()
-    width <- widthWrapper()
-    align <- alignWrapper()
-    rownames <- rownamesWrapper()
-    colnames <- colnamesWrapper()
-    digits <- digitsWrapper()
-    na <- naWrapper()
+  createRenderFunction(
+    func,
+    function(data, session, name, ...) {
+      striped <- stripedWrapper()
+      hover <- hoverWrapper()
+      bordered <- borderedWrapper()
+      format <- c(striped = striped, hover = hover, bordered = bordered)
+      spacing <- spacingWrapper()
+      width <- widthWrapper()
+      align <- alignWrapper()
+      rownames <- rownamesWrapper()
+      colnames <- colnamesWrapper()
+      digits <- digitsWrapper()
+      na <- naWrapper()
 
-    spacing_choices <- c("s", "xs", "m", "l")
-    if (!(spacing %in% spacing_choices)) {
-      stop(paste("`spacing` must be one of",
-                 paste0("'", spacing_choices, "'", collapse=", ")))
-    }
+      spacing_choices <- c("s", "xs", "m", "l")
+      if (!(spacing %in% spacing_choices)) {
+        stop(paste("`spacing` must be one of",
+          paste0("'", spacing_choices, "'", collapse=", ")))
+      }
 
-    # For css styling
-    classNames <- paste0("table shiny-table",
-                         paste0(" table-", names(format)[format], collapse = "" ),
-                         paste0(" spacing-", spacing))
+      # For css styling
+      classNames <- paste0("table shiny-table",
+        paste0(" table-", names(format)[format], collapse = "" ),
+        paste0(" spacing-", spacing))
 
-    data <- func()
-    data <- as.data.frame(data)
+      data <- as.data.frame(data)
 
-    # Return NULL if no data is provided
-    if (is.null(data) ||
-        (is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
-      return(NULL)
+      # Return NULL if no data is provided
+      if (is.null(data) ||
+          (is.data.frame(data) && nrow(data) == 0 && ncol(data) == 0))
+        return(NULL)
 
-    # Separate the ... args to pass to xtable() vs print.xtable()
-    xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
-    xtable_args <- dots[intersect(names(dots), xtable_argnames)]
-    non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
+      # Separate the ... args to pass to xtable() vs print.xtable()
+      xtable_argnames <- setdiff(names(formals(xtable)), c("x", "..."))
+      xtable_args <- dots[intersect(names(dots), xtable_argnames)]
+      non_xtable_args <- dots[setdiff(names(dots), xtable_argnames)]
 
-    # By default, numbers are right-aligned and everything else is left-aligned.
-    defaultAlignment <- function(col) {
-      if (is.numeric(col)) "r" else "l"
-    }
+      # By default, numbers are right-aligned and everything else is left-aligned.
+      defaultAlignment <- function(col) {
+        if (is.numeric(col)) "r" else "l"
+      }
 
-    # Figure out column alignment
-    ## Case 1: default alignment
-    if (is.null(align) || align == "?") {
-      names <- defaultAlignment(attr(data, "row.names"))
-      cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
-      cols <- paste0(names, cols)
-    } else {
-      ## Case 2: user-specified alignment
-      num_cols <- if (rownames) nchar(align) else nchar(align)+1
-      valid <- !grepl("[^lcr\\?]", align)
-      if (num_cols == ncol(data)+1 && valid) {
-        cols <- if (rownames) align else paste0("r", align)
-        defaults <- grep("\\?", strsplit(cols,"")[[1]])
-        if (length(defaults) != 0) {
-          vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
-          for (i in seq_len(length(defaults))) {
-            substr(cols, defaults[i], defaults[i]) <- vals[i]
-          }
-        }
-      } else if (nchar(align) == 1 && valid) {
-        cols <- paste0(rep(align, ncol(data)+1), collapse="")
+      # Figure out column alignment
+      ## Case 1: default alignment
+      if (is.null(align) || align == "?") {
+        names <- defaultAlignment(attr(data, "row.names"))
+        cols <- paste(vapply(data, defaultAlignment, character(1)), collapse = "")
+        cols <- paste0(names, cols)
       } else {
-        stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
-             "have length either equal to 1 or to the total number of columns")
+        ## Case 2: user-specified alignment
+        num_cols <- if (rownames) nchar(align) else nchar(align)+1
+        valid <- !grepl("[^lcr\\?]", align)
+        if (num_cols == ncol(data)+1 && valid) {
+          cols <- if (rownames) align else paste0("r", align)
+          defaults <- grep("\\?", strsplit(cols,"")[[1]])
+          if (length(defaults) != 0) {
+            vals <- vapply(data[,defaults-1], defaultAlignment, character(1))
+            for (i in seq_len(length(defaults))) {
+              substr(cols, defaults[i], defaults[i]) <- vals[i]
+            }
+          }
+        } else if (nchar(align) == 1 && valid) {
+          cols <- paste0(rep(align, ncol(data)+1), collapse="")
+        } else {
+          stop("`align` must contain only the characters `l`, `c`, `r` and/or `?` and",
+            "have length either equal to 1 or to the total number of columns")
+        }
       }
-    }
 
-    # Call xtable with its (updated) args
-    xtable_args <- c(xtable_args, align = cols, digits = digits)
-    xtable_res <- do.call(xtable, c(list(data), xtable_args))
+      # Call xtable with its (updated) args
+      xtable_args <- c(xtable_args, align = cols, digits = digits)
+      xtable_res <- do.call(xtable, c(list(data), xtable_args))
 
-    # Set up print args
-    print_args <- list(
-      x = xtable_res,
-      type = 'html',
-      include.rownames = {
-        if ("include.rownames" %in% names(dots)) dots$include.rownames
-        else rownames
-      },
-      include.colnames = {
-        if ("include.colnames" %in% names(dots)) dots$include.colnames
-        else colnames
-      },
-      NA.string = {
-        if ("NA.string" %in% names(dots)) dots$NA.string
-        else na
-      },
-      html.table.attributes =
-        paste0({
-          if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
-          else ""
-        }, " ",
-        "class = '", htmlEscape(classNames, TRUE), "' ",
-        "style = 'width:", validateCssUnit(width), ";'"))
+      # Set up print args
+      print_args <- list(
+        x = xtable_res,
+        type = 'html',
+        include.rownames = {
+          if ("include.rownames" %in% names(dots)) dots$include.rownames
+          else rownames
+        },
+        include.colnames = {
+          if ("include.colnames" %in% names(dots)) dots$include.colnames
+          else colnames
+        },
+        NA.string = {
+          if ("NA.string" %in% names(dots)) dots$NA.string
+          else na
+        },
+        html.table.attributes =
+          paste0({
+            if ("html.table.attributes" %in% names(dots)) dots$html.table.attributes
+            else ""
+          }, " ",
+            "class = '", htmlEscape(classNames, TRUE), "' ",
+            "style = 'width:", validateCssUnit(width), ";'"),
+        comment = {
+          if ("comment" %in% names(dots)) dots$comment
+          else FALSE
+        }
+      )
 
-    print_args <- c(print_args, non_xtable_args)
-    print_args <- print_args[unique(names(print_args))]
+      print_args <- c(print_args, non_xtable_args)
+      print_args <- print_args[unique(names(print_args))]
 
-    # Capture the raw html table returned by print.xtable(), and store it in
-    # a variable for further processing
-    tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
+      # Capture the raw html table returned by print.xtable(), and store it in
+      # a variable for further processing
+      tab <- paste(utils::capture.output(do.call(print, print_args)),collapse = "\n")
 
-    # Add extra class to cells with NA value, to be able to style them separately
-    tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
+      # Add extra class to cells with NA value, to be able to style them separately
+      tab <- gsub(paste(">", na, "<"), paste(" class='NA'>", na, "<"), tab)
 
-    # All further processing concerns the table headers, so we don't need to run
-    # any of this if colnames=FALSE
-    if (colnames) {
-      # Make sure that the final html table has a proper header (not included
-      # in the print.xtable() default)
-      tab <- sub("<tr>", "<thead> <tr>", tab)
-      tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
-      tab <- sub("</table>$", "</tbody> </table>", tab)
+      # All further processing concerns the table headers, so we don't need to run
+      # any of this if colnames=FALSE
+      if (colnames) {
+        # Make sure that the final html table has a proper header (not included
+        # in the print.xtable() default)
+        tab <- sub("<tr>", "<thead> <tr>", tab)
+        tab <- sub("</tr>", "</tr> </thead> <tbody>", tab)
+        tab <- sub("</table>$", "</tbody> </table>", tab)
 
-      # Update the `cols` string (which stores the alignment of each column) so
-      # that it only includes the alignment for the table variables (and not
-      # for the row.names)
-      cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
+        # Update the `cols` string (which stores the alignment of each column) so
+        # that it only includes the alignment for the table variables (and not
+        # for the row.names)
+        cols <- if (rownames) cols else substr(cols, 2, nchar(cols))
 
-      # Create a vector whose i-th entry corresponds to the i-th table variable
-      # alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
-      cols <- strsplit(cols, "")[[1]]
-      cols[cols == "l"] <- "left"
-      cols[cols == "r"] <- "right"
-      cols[cols == "c"] <- "center"
+        # Create a vector whose i-th entry corresponds to the i-th table variable
+        # alignment (substituting "l" by "left", "c" by "center" and "r" by "right")
+        cols <- strsplit(cols, "")[[1]]
+        cols[cols == "l"] <- "left"
+        cols[cols == "r"] <- "right"
+        cols[cols == "c"] <- "center"
 
-      # Align each header accordingly (this guarantees that each header and its
-      # corresponding column have the same alignment)
-      for (i in seq_len(length(cols))) {
-        tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
+        # Align each header accordingly (this guarantees that each header and its
+        # corresponding column have the same alignment)
+        for (i in seq_len(length(cols))) {
+          tab <- sub("<th>", paste0("<th style='text-align: ", cols[i], ";'>"), tab)
+        }
       }
-    }
-    return(tab)
-  }
-
-  # Main render function
-  markRenderFunction(tableOutput, renderFunc, outputArgs = outputArgs)
+      return(tab)
+    },
+    tableOutput, outputArgs
+  )
 }

R/serializers.R

@@ -1,3 +1,22 @@
+#' Add a function for serializing an input before bookmarking application state
+#'
+#' @param inputId Name of the input value.
+#' @param fun A function that takes the input value and returns a modified
+#'   value. The returned value will be used for the test snapshot.
+#' @param session A Shiny session object.
+#'
+#' @keywords internal
+#' @export
+setSerializer <- function(inputId, fun, session = getDefaultReactiveDomain()) {
+  if (is.null(session)) {
+    stop("setSerializer() needs a session object.")
+  }
+
+  input_impl <- .subset2(session$input, "impl")
+  input_impl$setMeta(inputId, "shiny.serializer", fun)
+}
+
+
 # For most types of values, simply return the value unchanged.
 serializerDefault <- function(value, stateDir) {
   value
@@ -58,12 +77,12 @@ serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
 
     # Get the serializer function for this input value. If none specified, use
     # the default.
-    serializer <- impl$getMeta(name, "shiny.serializer")
-    if (is.null(serializer))
-      serializer <- serializerDefault
+    serializer_fun <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer_fun))
+      serializer_fun <- serializerDefault
 
     # Apply serializer function.
-    serializer(val, stateDir)
+    serializer_fun(val, stateDir)
   })
 
   # Filter out any values that were marked as unserializable.

R/server-input-handlers.R

@@ -148,7 +148,7 @@ registerInputHandler("shiny.number", function(val, ...){
 
 registerInputHandler("shiny.password", function(val, shinysession, name) {
   # Mark passwords as not serializable
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+  setSerializer(name, serializerUnserializable)
   val
 })
 
@@ -214,7 +214,9 @@ registerInputHandler("shiny.file", function(val, shinysession, name) {
   # Need to mark this input value with the correct serializer. When a file is
   # uploaded the usual way (instead of being restored), this occurs in
   # session$`@uploadEnd`.
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerFileInput)
+  setSerializer(name, serializerFileInput)
+
+  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
 
   val
 })

R/server.R

@@ -1,6 +1,7 @@
 #' @include server-input-handlers.R
 
 appsByToken <- Map$new()
+appsNeedingFlush <- Map$new()
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -155,7 +156,7 @@ decodeMessage <- function(data) {
     # Treat message as UTF-8
     charData <- rawToChar(data)
     Encoding(charData) <- 'UTF-8'
-    return(jsonlite::fromJSON(charData, simplifyVector=FALSE))
+    return(safeFromJSON(charData, simplifyVector=FALSE))
   }
 
   i <- 5
@@ -226,7 +227,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
               message("RECV ", rawToChar(msg))
           }
 
-          if (identical(charToRaw("\003\xe9"), msg))
+          if (isEmptyMessage(msg))
             return()
 
           msg <- decodeMessage(msg)
@@ -243,94 +244,75 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
             } else {
               # If there's bookmarked state, save it on the session object
               shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+              shinysession$createBookmarkObservers()
             }
           }
 
-          withRestoreContext(shinysession$restoreContext, {
 
-            msg$data <- applyInputHandlers(msg$data)
+          msg$data <- applyInputHandlers(msg$data)
 
-            switch(
-              msg$method,
-              init = {
+          switch(
+            msg$method,
+            init = {
 
-                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                  appvars$server <- serverFunc
-                  if (!is.null(appvars$server))
-                  {
-                    # Tag this function as the Shiny server function. A debugger may use this
-                    # tag to give this function special treatment.
-                    # It's very important that it's appvars$server itself and NOT a copy that
-                    # is invoked, otherwise new breakpoints won't be picked up.
-                    attr(appvars$server, "shinyServerFunction") <- TRUE
-                    registerDebugHook("server", appvars, "Server Function")
-                  }
+              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                appvars$server <- serverFunc
+                if (!is.null(appvars$server))
+                {
+                  # Tag this function as the Shiny server function. A debugger may use this
+                  # tag to give this function special treatment.
+                  # It's very important that it's appvars$server itself and NOT a copy that
+                  # is invoked, otherwise new breakpoints won't be picked up.
+                  attr(appvars$server, "shinyServerFunction") <- TRUE
+                  registerDebugHook("server", appvars, "Server Function")
                 }
+              }
 
-                # Check for switching into/out of showcase mode
-                if (.globals$showcaseOverride &&
-                    exists(".clientdata_url_search", where = msg$data)) {
-                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                  if (!is.null(mode))
-                    shinysession$setShowcase(mode)
-                }
+              # Check for switching into/out of showcase mode
+              if (.globals$showcaseOverride &&
+                  exists(".clientdata_url_search", where = msg$data)) {
+                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                if (!is.null(mode))
+                  shinysession$setShowcase(mode)
+              }
 
-                shinysession$manageInputs(msg$data)
+              shinysession$manageInputs(msg$data)
 
-                # The client tells us what singletons were rendered into
-                # the initial page
-                if (!is.null(msg$data$.clientdata_singletons)) {
-                  shinysession$singletons <- strsplit(
-                    msg$data$.clientdata_singletons, ',')[[1]]
-                }
+              # The client tells us what singletons were rendered into
+              # the initial page
+              if (!is.null(msg$data$.clientdata_singletons)) {
+                shinysession$singletons <- strsplit(
+                  msg$data$.clientdata_singletons, ',')[[1]]
+              }
 
-                local({
-                  args <- argsForServerFunc(serverFunc, shinysession)
+              local({
+                args <- argsForServerFunc(serverFunc, shinysession)
 
-                  withReactiveDomain(shinysession, {
-                    do.call(
-                      # No corresponding ..stacktraceoff; the server func is pure
-                      # user code
-                      wrapFunctionLabel(appvars$server, "server",
-                        ..stacktraceon = TRUE
-                      ),
-                      args
-                    )
-                  })
+                withReactiveDomain(shinysession, {
+                  do.call(
+                    # No corresponding ..stacktraceoff; the server func is pure
+                    # user code
+                    wrapFunctionLabel(appvars$server, "server",
+                      ..stacktraceon = TRUE
+                    ),
+                    args
+                  )
                 })
-              },
-              update = {
-                shinysession$manageInputs(msg$data)
-              },
-              shinysession$dispatch(msg)
-            )
-            shinysession$manageHiddenOutputs()
+              })
+            },
+            update = {
+              shinysession$manageInputs(msg$data)
+            },
+            shinysession$dispatch(msg)
+          )
+          # The HTTP_GUID, if it exists, is for Shiny Server reporting purposes
+          shinysession$startTiming(ws$request$HTTP_GUID)
+          shinysession$requestFlush()
 
-            if (exists(".shiny__stdout", globalenv()) &&
-                exists("HTTP_GUID", ws$request)) {
-              # safe to assume we're in shiny-server
-              shiny_stdout <- get(".shiny__stdout", globalenv())
-
-              # eNter a flushReact
-              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-
-              flushReact()
-
-              # eXit a flushReact
-              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-            } else {
-              flushReact()
-            }
-
-            flushAllSessions()
-          })
+          # Make httpuv return control to Shiny quickly, instead of waiting
+          # for the usual timeout
+          httpuv::interrupt()
         })
       }
       ws$onMessage(function(binary, msg) {
@@ -341,6 +323,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       ws$onClose(function() {
         shinysession$wsClosed()
         appsByToken$remove(shinysession$token)
+        appsNeedingFlush$remove(shinysession$token)
       })
 
       return(TRUE)
@@ -370,9 +353,9 @@ argsForServerFunc <- function(serverFunc, session) {
 }
 
 getEffectiveBody <- function(func) {
-  # Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
-  # returns NULL.
-  if (isS4(func) && class(func) == "functionWithTrace")
+  if (is.null(func))
+    NULL
+  else if (isS4(func) && class(func) == "functionWithTrace")
     body(func@original)
   else
     body(func)
@@ -443,21 +426,20 @@ startApp <- function(appObj, port, host, quiet) {
 # Run an application that was created by \code{\link{startApp}}. This
 # function should normally be called in a \code{while(TRUE)} loop.
 serviceApp <- function() {
-  if (timerCallbacks$executeElapsed()) {
-    for (shinysession in appsByToken$values()) {
-      shinysession$manageHiddenOutputs()
-    }
+  timerCallbacks$executeElapsed()
 
-    flushReact()
-    flushAllSessions()
-  }
+  flushReact()
+  flushPendingSessions()
 
   # If this R session is interactive, then call service() with a short timeout
   # to keep the session responsive to user input
   maxTimeout <- ifelse(interactive(), 100, 1000)
 
-  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
+  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
   service(timeout)
+
+  flushReact()
+  flushPendingSessions()
 }
 
 .shinyServerMinVersion <- '0.3.4'
@@ -465,6 +447,17 @@ serviceApp <- function() {
 # Global flag that's TRUE whenever we're inside of the scope of a call to runApp
 .globals$running <- FALSE
 
+#' Check whether a Shiny application is running
+#'
+#' This function tests whether a Shiny application is currently running.
+#'
+#' @return \code{TRUE} if a Shiny application is currently running. Otherwise,
+#'   \code{FALSE}.
+#' @export
+isRunning <- function() {
+  .globals$running
+}
+
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
@@ -577,7 +570,11 @@ runApp <- function(appDir=getwd(),
 
   # Make warnings print immediately
   # Set pool.scheduler to support pool package
-  ops <- options(warn = 1, pool.scheduler = scheduleTask)
+  ops <- options(
+    # Raise warn level to 1, but don't lower it
+    warn = max(1, getOption("warn", default = 1)),
+    pool.scheduler = scheduleTask
+  )
   on.exit(options(ops), add = TRUE)
 
   appParts <- as.shiny.appobj(appDir)
@@ -716,7 +713,8 @@ runApp <- function(appDir=getwd(),
           port <- p_randomInt(3000, 8000)
           # Reject ports in this range that are considered unsafe by Chrome
           # http://superuser.com/questions/188058/which-ports-are-considered-unsafe-on-chrome
-          if (!port %in% c(3659, 4045, 6000, 6665:6669)) {
+          # https://github.com/rstudio/shiny/issues/1784
+          if (!port %in% c(3659, 4045, 6000, 6665:6669, 6697)) {
             break
           }
         }
@@ -732,15 +730,22 @@ runApp <- function(appDir=getwd(),
     }
   }
 
+  # Invoke user-defined onStop callbacks, before the application's internal
+  # onStop callbacks.
+  on.exit({
+    .globals$onStopCallbacks$invoke()
+    .globals$onStopCallbacks <- Callbacks$new()
+  }, add = TRUE)
+
   # Extract appOptions (which is a list) and store them as shinyOptions, for
   # this app. (This is the only place we have to store settings that are
   # accessible both the UI and server portion of the app.)
   unconsumeAppOptions(appParts$appOptions)
 
-  # Set up the onEnd before we call onStart, so that it gets called even if an
+  # Set up the onStop before we call onStart, so that it gets called even if an
   # error happens in onStart.
-  if (!is.null(appParts$onEnd))
-    on.exit(appParts$onEnd(), add = TRUE)
+  if (!is.null(appParts$onStop))
+    on.exit(appParts$onStop(), add = TRUE)
   if (!is.null(appParts$onStart))
     appParts$onStart()
 
@@ -776,10 +781,6 @@ runApp <- function(appDir=getwd(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
     captureStackTraces({
-      # If any observers were created before runApp was called, this will make
-      # sure they run once the app starts. (Issue #1013)
-      scheduleFlush()
-
       while (!.globals$stopped) {
         serviceApp()
         Sys.sleep(0.001)
@@ -1022,3 +1023,9 @@ browserViewer <- function(browser = getOption("browser")) {
 inShinyServer <- function() {
   nzchar(Sys.getenv('SHINY_PORT'))
 }
+
+# This check was moved out of the main function body because of an issue with
+# the RStudio debugger. (#1474)
+isEmptyMessage <- function(msg) {
+  identical(charToRaw("\003\xe9"), msg)
+}

R/shiny.R

@@ -5,7 +5,7 @@ NULL
 #'
 #' Shiny makes it incredibly easy to build interactive web applications with R.
 #' Automatic "reactive" binding between inputs and outputs and extensive
-#' pre-built widgets make it possible to build beautiful, responsive, and
+#' prebuilt widgets make it possible to build beautiful, responsive, and
 #' powerful applications with minimal effort.
 #'
 #' The Shiny tutorial at \url{http://shiny.rstudio.com/tutorial/} explains
@@ -142,6 +142,15 @@ toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
 }
 
+# If the input to jsonlite::fromJSON is not valid JSON, it will try to fetch a
+# URL or read a file from disk. We don't want to allow that.
+safeFromJSON <- function(txt, ...) {
+  if (!jsonlite::validate(txt)) {
+    stop("Argument 'txt' is not a valid JSON string.")
+  }
+  jsonlite::fromJSON(txt, ...)
+}
+
 # Call the workerId func with no args to get the worker id, and with an arg to
 # set it.
 #
@@ -301,7 +310,8 @@ workerId <- local({
 #'   Similar to \code{sendCustomMessage}, but the message must be a raw vector
 #'   and the registration method on the client is
 #'   \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
-#'   message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
+#'   message argument on the client will be a
+#'   \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
 #' }
 #' \item{sendInputMessage(inputId, message)}{
 #'   Sends a message to an input on the session's client web page; if the input
@@ -411,6 +421,7 @@ ShinySession <- R6Class(
     invalidatedOutputValues = 'Map',
     invalidatedOutputErrors = 'Map',
     inputMessageQueue = list(), # A list of inputMessages to send when flushed
+    cycleStartActionQueue = list(), # A list of actions to perform to start a cycle
     .outputs = list(),          # Keeps track of all the output observer objects
     .outputOptions = list(),     # Options for each of the output observer objects
     progressKeys = 'character',
@@ -429,6 +440,7 @@ ShinySession <- R6Class(
     restoredCallbacks = 'Callbacks',
     bookmarkExclude = character(0),  # Names of inputs to exclude from bookmarking
     getBookmarkExcludeFuns = list(),
+    timingRecorder = 'ShinyServerTimingRecorder',
 
     testMode = FALSE,                # Are we running in test mode?
     testExportExprs = list(),
@@ -504,95 +516,6 @@ ShinySession <- R6Class(
       self$onSessionEnded(private$fileUploadContext$rmUploadDirs)
     },
 
-    createBookmarkObservers = function() {
-      # This is to be called from the initialization. It registers observers
-      # for bookmarking to work.
-
-      # Get bookmarking config
-      store <- getShinyOption("bookmarkStore", default = "disable")
-      if (store == "disable")
-        return()
-
-      # Warn if trying to enable save-to-server bookmarking on a version of SS,
-      # SSP, or Connect that doesn't support it.
-      if (store == "server" && inShinyServer() &&
-          is.null(getShinyOption("save.interface")))
-      {
-        showNotification(
-          "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
-          duration = NULL, type = "warning", session = self
-        )
-        return()
-      }
-
-      withReactiveDomain(self, {
-        # This observer fires when the bookmark button is clicked.
-        observeEvent(self$input[["._bookmark_"]], {
-          self$doBookmark()
-        })
-
-        # If there was an error initializing the current restore context, show
-        # notification in the client.
-        observe({
-          rc <- getCurrentRestoreContext()
-          if (!is.null(rc$initErrorMessage)) {
-            showNotification(
-              paste("Error in RestoreContext initialization:", rc$initErrorMessage),
-              duration = NULL, type = "error"
-            )
-          }
-        })
-
-        # Run the onRestore function at the beginning of the flush cycle, but after
-        # the server function has been executed.
-        observe({
-          if (private$restoreCallbacks$count() > 0) {
-            tryCatch(
-              withLogErrors(
-                isolate({
-                  rc <- getCurrentRestoreContext()
-                  if (rc$active) {
-                    restoreState <- getCurrentRestoreContext()$asList()
-                    private$restoreCallbacks$invoke(restoreState)
-                  }
-                })
-              ),
-              error = function(e) {
-                showNotification(
-                  paste0("Error calling onRestore callback: ", e$message),
-                  duration = NULL, type = "error"
-                )
-              }
-            )
-          }
-        }, priority = 1000000)
-
-        # Run the onRestored function after the flush cycle completes and information
-        # is sent to the client.
-        self$onFlushed(function() {
-          if (private$restoredCallbacks$count() > 0) {
-
-            tryCatch(
-              withLogErrors(
-                isolate({
-                  rc <- getCurrentRestoreContext()
-                  if (rc$active) {
-                    restoreState <- getCurrentRestoreContext()$asList()
-                    private$restoredCallbacks$invoke(restoreState)
-                  }
-                })
-              ),
-              error = function(e) {
-                msg <- paste0("Error calling onRestored callback: ", e$message)
-                showNotification(msg, duration = NULL, type = "error")
-              }
-            )
-          }
-        })
-
-      }) # withReactiveDomain
-    },
-
     # Modules (scopes) call this to register a function that returns a vector
     # of names to exclude from bookmarking. The function should return
     # something like c("scope1-x", "scope1-y"). This doesn't use a Callback
@@ -639,6 +562,15 @@ ShinySession <- R6Class(
               values$input <- allInputs[items]
             }
 
+            # Apply preprocessor functions for inputs that have them.
+            values$input <- lapply(
+              setNames(names(values$input), names(values$input)),
+              function(name) {
+                preprocess <- private$getSnapshotPreprocessInput(name)
+                preprocess(values$input[[name]])
+              }
+            )
+
             values$input <- sortByName(values$input)
           }
 
@@ -658,6 +590,15 @@ ShinySession <- R6Class(
             }, logical(1))
             values$output <- values$output[!exclude_idx]
 
+            # Apply snapshotPreprocess functions for outputs that have them.
+            values$output <- lapply(
+              setNames(names(values$output), names(values$output)),
+              function(name) {
+                preprocess <- private$getSnapshotPreprocessOutput(name)
+                preprocess(values$output[[name]])
+              }
+            )
+
             values$output <- sortByName(values$output)
           }
 
@@ -702,7 +643,7 @@ ShinySession <- R6Class(
           } else if (identical(format, "rds")) {
             tmpfile <- tempfile("shinytest", fileext = ".rds")
             saveRDS(values, tmpfile)
-            on.exit(unlink(tmpfile))
+            on.exit(unlink(tmpfile), add = TRUE)
 
             content <- readBin(tmpfile, "raw", n = file.info(tmpfile)$size)
             httpResponse(200, "application/octet-stream", content)
@@ -712,6 +653,29 @@ ShinySession <- R6Class(
           }
         }
       )
+    },
+
+    # Get the snapshotPreprocessOutput function for an output name. If no preprocess
+    # function has been set, return the identity function.
+    getSnapshotPreprocessOutput = function(name) {
+      fun <- attr(private$.outputs[[name]], "snapshotPreprocess", exact = TRUE)
+      fun %OR% identity
+    },
+
+    # Get the snapshotPreprocessInput function for an input name. If no preprocess
+    # function has been set, return the identity function.
+    getSnapshotPreprocessInput = function(name) {
+      fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess")
+      fun %OR% identity
+    },
+
+    # See cycleStartAction
+    startCycle = function() {
+      if (length(private$cycleStartActionQueue) > 0) {
+        head <- private$cycleStartActionQueue[[1L]]
+        private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
+        head()
+      }
     }
   ),
   public = list(
@@ -744,6 +708,7 @@ ShinySession <- R6Class(
       private$inputReceivedCallbacks <- Callbacks$new()
       private$.input      <- ReactiveValues$new()
       private$.clientData <- ReactiveValues$new()
+      private$timingRecorder <- ShinyServerTimingRecorder$new()
       self$progressStack <- Stack$new()
       self$files <- Map$new()
       self$downloads <- Map$new()
@@ -764,7 +729,6 @@ ShinySession <- R6Class(
       private$bookmarkedCallbacks <- Callbacks$new()
       private$restoreCallbacks <- Callbacks$new()
       private$restoredCallbacks <- Callbacks$new()
-      private$createBookmarkObservers()
 
       private$testMode <- .globals$testMode
       private$enableTestSnapshot()
@@ -773,7 +737,7 @@ ShinySession <- R6Class(
 
       if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
         try({
-          creds <- jsonlite::fromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
+          creds <- safeFromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
           self$user <- creds$user
           self$groups <- creds$groups
         }, silent=FALSE)
@@ -792,6 +756,15 @@ ShinySession <- R6Class(
         )
       )
     },
+    startTiming = function(guid) {
+      if (!is.null(guid)) {
+        private$timingRecorder$start(guid)
+        self$onFlush(private$timingRecorder$stop)
+      }
+    },
+    requestFlush = function() {
+      appsNeedingFlush$set(self$token, self)
+    },
     rootScope = function() {
       self
     },
@@ -1023,8 +996,6 @@ ShinySession <- R6Class(
       }
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
-      flushReact()
-      flushAllSessions()
     },
     isClosed = function() {
       return(self$closed)
@@ -1088,56 +1059,64 @@ ShinySession <- R6Class(
             name = name, status = 'recalculating'
           ))
 
-          value <- tryCatch(
-            shinyCallingHandlers(func()),
-            shiny.custom.error = function(cond) {
-              if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              structure(list(), class = "try-error", condition = cond)
-            },
-            shiny.output.cancel = function(cond) {
-              structure(list(), class = "cancel-output")
-            },
-            shiny.silent.error = function(cond) {
-              # Don't let shiny.silent.error go through the normal stop
-              # path of try, because we don't want it to print. But we
-              # do want to try to return the same looking result so that
-              # the code below can send the error to the browser.
-              structure(list(), class = "try-error", condition = cond)
-            },
-            error = function(cond) {
-              if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              if (getOption("shiny.sanitize.errors", FALSE)) {
-                cond <- simpleError(paste("An error has occurred. Check your",
-                                          "logs or contact the app author for",
-                                          "clarification."))
+          # This shinyCallingHandlers should maybe be at a higher level,
+          # to include the $then/$catch calls below?
+          hybrid_chain(
+            hybrid_chain(
+              shinyCallingHandlers(func()),
+              catch = function(cond) {
+                if (inherits(cond, "shiny.custom.error")) {
+                  if (isTRUE(getOption("show.error.messages"))) printError(cond)
+                  structure(list(), class = "try-error", condition = cond)
+                } else if (inherits(cond, "shiny.output.cancel")) {
+                  structure(list(), class = "cancel-output")
+                } else if (inherits(cond, "shiny.silent.error")) {
+                  # Don't let shiny.silent.error go through the normal stop
+                  # path of try, because we don't want it to print. But we
+                  # do want to try to return the same looking result so that
+                  # the code below can send the error to the browser.
+                  structure(list(), class = "try-error", condition = cond)
+                } else {
+                  if (isTRUE(getOption("show.error.messages"))) printError(cond)
+                  if (getOption("shiny.sanitize.errors", FALSE)) {
+                    cond <- simpleError(paste("An error has occurred. Check your",
+                      "logs or contact the app author for",
+                      "clarification."))
+                  }
+                  invisible(structure(list(), class = "try-error", condition = cond))
+                }
               }
-              invisible(structure(list(), class = "try-error", condition = cond))
-            },
-            finally = {
+            ),
+            function(value) {
+              # Needed so that Shiny knows to flush the outputs. Even if no
+              # outputs/errors are queued, it's necessary to flush so that the
+              # client knows that progress is over.
+              self$requestFlush()
+
               private$sendMessage(recalculating = list(
                 name = name, status = 'recalculated'
               ))
+
+              if (inherits(value, "cancel-output")) {
+                return()
+              }
+
+              private$invalidatedOutputErrors$remove(name)
+              private$invalidatedOutputValues$remove(name)
+
+              if (inherits(value, 'try-error')) {
+                cond <- attr(value, 'condition')
+                type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
+                private$invalidatedOutputErrors$set(
+                  name,
+                  list(message = cond$message,
+                    call = utils::capture.output(print(cond$call)),
+                    type = if (length(type)) type))
+              }
+              else
+                private$invalidatedOutputValues$set(name, value)
             }
           )
-
-          if (inherits(value, "cancel-output")) {
-            return()
-          }
-
-          private$invalidatedOutputErrors$remove(name)
-          private$invalidatedOutputValues$remove(name)
-
-          if (inherits(value, 'try-error')) {
-            cond <- attr(value, 'condition')
-            type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
-            private$invalidatedOutputErrors$set(
-              name,
-              list(message = cond$message,
-                   call = utils::capture.output(print(cond$call)),
-                   type = if (length(type)) type))
-          }
-          else
-            private$invalidatedOutputValues$set(name, value)
         }, suspended=private$shouldSuspend(name), label=label)
 
         # If any output attributes were added to the render function attach
@@ -1159,6 +1138,11 @@ ShinySession <- R6Class(
       }
     },
     flushOutput = function() {
+      if (private$busyCount > 0)
+        return()
+
+      appsNeedingFlush$remove(self$token)
+
       if (self$isClosed())
         return()
 
@@ -1176,42 +1160,57 @@ ShinySession <- R6Class(
         )
       }
 
-      # ..stacktraceon matches with the top-level ..stacktraceoff..
-      private$flushCallbacks$invoke(..stacktraceon = TRUE)
-
-      # Schedule execution of onFlushed callbacks
-      on.exit({
+      withReactiveDomain(self, {
         # ..stacktraceon matches with the top-level ..stacktraceoff..
-        private$flushedCallbacks$invoke(..stacktraceon = TRUE)
+        private$flushCallbacks$invoke(..stacktraceon = TRUE)
 
-        # If one of the flushedCallbacks added anything to send to the client,
-        # or invalidated any observers, set up another flush cycle.
-        if (hasPendingUpdates() || .getReactiveEnvironment()$hasPendingFlush()) {
-          scheduleFlush()
+        # Schedule execution of onFlushed callbacks
+        on.exit({
+          # ..stacktraceon matches with the top-level ..stacktraceoff..
+          private$flushedCallbacks$invoke(..stacktraceon = TRUE)
+        }, add = TRUE)
+
+        if (!hasPendingUpdates()) {
+          # Normally, if there are no updates, simply return without sending
+          # anything to the client. But if we are in test mode, we still want to
+          # send a message with blank `values`, so that the client knows that
+          # any changed inputs have been received by the server and processed.
+          if (isTRUE(private$testMode)) {
+            private$sendMessage( values = list() )
+          }
+          return(invisible())
         }
+
+        private$progressKeys <- character(0)
+        values <- as.list(private$invalidatedOutputValues)
+        private$invalidatedOutputValues <- Map$new()
+        errors <- as.list(private$invalidatedOutputErrors)
+        private$invalidatedOutputErrors <- Map$new()
+        inputMessages <- private$inputMessageQueue
+        private$inputMessageQueue <- list()
+
+        if (isTRUE(private$testMode)) {
+          private$storeOutputValues(mergeVectors(values, errors))
+        }
+
+        private$sendMessage(
+          errors = errors,
+          values = values,
+          inputMessages = inputMessages
+        )
       })
-
-      if (!hasPendingUpdates()) {
-        return(invisible())
+    },
+    # Schedule an action to execute not (necessarily) now, but when no observers
+    # that belong to this session are busy executing. This helps prevent (but
+    # does not guarantee) inputs and reactive values from changing underneath
+    # async observers as they run.
+    cycleStartAction = function(callback) {
+      private$cycleStartActionQueue <- c(private$cycleStartActionQueue, list(callback))
+      # If no observers are running in this session, we're safe to proceed.
+      # Otherwise, startCycle() will be called later, via decrementBusyCount().
+      if (private$busyCount == 0L) {
+        private$startCycle()
       }
-
-      private$progressKeys <- character(0)
-      values <- as.list(private$invalidatedOutputValues)
-      private$invalidatedOutputValues <- Map$new()
-      errors <- as.list(private$invalidatedOutputErrors)
-      private$invalidatedOutputErrors <- Map$new()
-      inputMessages <- private$inputMessageQueue
-      private$inputMessageQueue <- list()
-
-      if (isTRUE(private$testMode)) {
-        private$storeOutputValues(mergeVectors(values, errors))
-      }
-
-      private$sendMessage(
-        errors = errors,
-        values = values,
-        inputMessages = inputMessages
-      )
     },
     showProgress = function(id) {
       'Send a message to the client that recalculation of the output identified
@@ -1279,6 +1278,8 @@ ShinySession <- R6Class(
 
       # Add to input message queue
       private$inputMessageQueue[[length(private$inputMessageQueue) + 1]] <- data
+      # Needed so that Shiny knows to actually flush the input message queue
+      self$requestFlush()
     },
     onFlush = function(flushCallback, once = TRUE) {
       if (!isTRUE(once)) {
@@ -1303,6 +1304,94 @@ ShinySession <- R6Class(
       }
     },
 
+    createBookmarkObservers = function() {
+      # This registers observers for bookmarking to work.
+
+      # Get bookmarking config
+      store <- getShinyOption("bookmarkStore", default = "disable")
+      if (store == "disable")
+        return()
+
+      # Warn if trying to enable save-to-server bookmarking on a version of SS,
+      # SSP, or Connect that doesn't support it.
+      if (store == "server" && inShinyServer() &&
+          is.null(getShinyOption("save.interface")))
+      {
+        showNotification(
+          "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
+          duration = NULL, type = "warning", session = self
+        )
+        return()
+      }
+
+      withReactiveDomain(self, {
+        # This observer fires when the bookmark button is clicked.
+        observeEvent(self$input[["._bookmark_"]], {
+          self$doBookmark()
+        })
+
+        # If there was an error initializing the current restore context, show
+        # notification in the client.
+        observe({
+          rc <- getCurrentRestoreContext()
+          if (!is.null(rc$initErrorMessage)) {
+            showNotification(
+              paste("Error in RestoreContext initialization:", rc$initErrorMessage),
+              duration = NULL, type = "error"
+            )
+          }
+        })
+
+        # Run the onRestore function at the beginning of the flush cycle, but after
+        # the server function has been executed.
+        observe({
+          if (private$restoreCallbacks$count() > 0) {
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoreCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                showNotification(
+                  paste0("Error calling onRestore callback: ", e$message),
+                  duration = NULL, type = "error"
+                )
+              }
+            )
+          }
+        }, priority = 1000000)
+
+        # Run the onRestored function after the flush cycle completes and information
+        # is sent to the client.
+        self$onFlushed(function() {
+          if (private$restoredCallbacks$count() > 0) {
+
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoredCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                msg <- paste0("Error calling onRestored callback: ", e$message)
+                showNotification(msg, duration = NULL, type = "error")
+              }
+            )
+          }
+        })
+
+      }) # withReactiveDomain
+    },
+
     setBookmarkExclude = function(names) {
       private$bookmarkExclude <- names
     },
@@ -1453,6 +1542,37 @@ ShinySession <- R6Class(
         )
       )
     },
+    sendInsertTab = function(inputId, liTag, divTag, menuName,
+                             target, position, select) {
+      private$sendMessage(
+        `shiny-insert-tab` = list(
+          inputId = inputId,
+          liTag = liTag,
+          divTag = divTag,
+          menuName = menuName,
+          target = target,
+          position = position,
+          select = select
+        )
+      )
+    },
+    sendRemoveTab = function(inputId, target) {
+      private$sendMessage(
+        `shiny-remove-tab` = list(
+          inputId = inputId,
+          target = target
+        )
+      )
+    },
+    sendChangeTabVisibility = function(inputId, target, type) {
+      private$sendMessage(
+        `shiny-change-tab-visibility` = list(
+          inputId = inputId,
+          target = target,
+          type = type
+        )
+      )
+    },
     updateQueryString = function(queryString, mode) {
       private$sendMessage(updateQueryString = list(
         queryString = queryString, mode = mode))
@@ -1491,7 +1611,8 @@ ShinySession <- R6Class(
       fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
       private$.input$set(inputId, fileData)
 
-      private$.input$setMeta(inputId, "shiny.serializer", serializerFileInput)
+      setSerializer(inputId, serializerFileInput)
+      snapshotPreprocessInput(inputId, snapshotPreprocessorFileInput)
 
       invisible()
     },
@@ -1534,9 +1655,30 @@ ShinySession <- R6Class(
         }
       }
 
+      # @description Only applicable to files uploaded via IE. When possible,
+      #   adds the appropriate extension to temporary files created by
+      #   \code{mime::parse_multipart}.
+      # @param multipart A named list as returned by
+      #   \code{mime::parse_multipart}
+      # @return A named list with datapath updated to point to the new location
+      #   of the file, if an extension was added.
+      maybeMoveIEUpload <- function(multipart) {
+        if (is.null(multipart)) return(NULL)
+
+        lapply(multipart, function(input) {
+          oldPath <- input$datapath
+          newPath <- paste0(oldPath, maybeGetExtension(input$name))
+          if (oldPath != newPath) {
+            file.rename(oldPath, newPath)
+            input$datapath <- newPath
+          }
+          input
+        })
+      }
+
       if (matches[2] == 'uploadie' && identical(req$REQUEST_METHOD, "POST")) {
         id <- URLdecode(matches[3])
-        res <- mime::parse_multipart(req)
+        res <- maybeMoveIEUpload(mime::parse_multipart(req))
         private$.input$set(id, res[[id]])
         return(httpResponse(200, 'text/plain', 'OK'))
       }
@@ -1596,32 +1738,44 @@ ShinySession <- R6Class(
         if (nzchar(ext))
           ext <- paste(".", ext, sep = "")
         tmpdata <- tempfile(fileext = ext)
-        # ..stacktraceon matches with the top-level ..stacktraceoff..
-        result <- try(shinyCallingHandlers(Context$new(getDefaultReactiveDomain(), '[download]')$run(
-          function() { ..stacktraceon..(download$func(tmpdata)) }
-        )), silent = TRUE)
-        if (inherits(result, 'try-error')) {
-          unlink(tmpdata)
-          stop(attr(result, "condition", exact = TRUE))
-        }
-        if (!file.exists(tmpdata)) {
-          # If no file was created, return a 404
-          return(httpResponse(404, content = "404 Not found"))
-        }
-        return(httpResponse(
-          200,
-          download$contentType %OR% getContentType(filename),
-          # owned=TRUE means tmpdata will be deleted after response completes
-          list(file=tmpdata, owned=TRUE),
-          c(
-            'Content-Disposition' = ifelse(
-              dlmatches[3] == '',
-              'attachment; filename="' %.%
-                gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
-                '"',
-              'attachment'
-            ),
-            'Cache-Control'='no-cache')))
+        return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
+          promises::with_promise_domain(reactivePromiseDomain(), {
+            promises::with_promise_domain(createStackTracePromiseDomain(), {
+              self$incrementBusyCount()
+              hybrid_chain(
+                # ..stacktraceon matches with the top-level ..stacktraceoff..
+                try(..stacktraceon..(download$func(tmpdata)), silent = TRUE),
+                function(result) {
+                  if (inherits(result, 'try-error')) {
+                    unlink(tmpdata)
+                    stop(attr(result, "condition", exact = TRUE))
+                  }
+                  if (!file.exists(tmpdata)) {
+                    # If no file was created, return a 404
+                    return(httpResponse(404, content = "404 Not found"))
+                  }
+                  return(httpResponse(
+                    200,
+                    download$contentType %OR% getContentType(filename),
+                    # owned=TRUE means tmpdata will be deleted after response completes
+                    list(file=tmpdata, owned=TRUE),
+                    c(
+                      'Content-Disposition' = ifelse(
+                        dlmatches[3] == '',
+                        'attachment; filename="' %.%
+                          gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
+                          '"',
+                        'attachment'
+                      ),
+                      'Cache-Control'='no-cache')))
+                },
+                finally = function() {
+                  self$decrementBusyCount()
+                }
+              )
+            })
+          })
+        }))
       }
 
       if (matches[2] == 'dataobj') {
@@ -1686,9 +1840,13 @@ ShinySession <- R6Class(
     },
     # This function suspends observers for hidden outputs and resumes observers
     # for un-hidden outputs.
-    manageHiddenOutputs = function() {
+    manageHiddenOutputs = function(outputsToCheck = NULL) {
+      if (is.null(outputsToCheck)) {
+        outputsToCheck <- names(private$.outputs)
+      }
+
       # Find hidden state for each output, and suspend/resume accordingly
-      for (outputName in names(private$.outputs)) {
+      for (outputName in outputsToCheck) {
         if (private$shouldSuspend(outputName)) {
           private$.outputs[[outputName]]$suspend()
         } else {
@@ -1698,22 +1856,26 @@ ShinySession <- R6Class(
     },
     # Set the normal and client data input variables
     manageInputs = function(data) {
+      force(data)
+      self$cycleStartAction(function() {
+        private$inputReceivedCallbacks$invoke(data)
 
-      private$inputReceivedCallbacks$invoke(data)
+        data_names <- names(data)
 
-      data_names <- names(data)
+        # Separate normal input variables from client data input variables
+        clientdata_idx <- grepl("^.clientdata_", data_names)
 
-      # Separate normal input variables from client data input variables
-      clientdata_idx <- grepl("^.clientdata_", data_names)
+        # Set normal (non-clientData) input values
+        private$.input$mset(data[data_names[!clientdata_idx]])
 
-      # Set normal (non-clientData) input values
-      private$.input$mset(data[data_names[!clientdata_idx]])
+        # Strip off .clientdata_ from clientdata input names, and set values
+        input_clientdata <- data[data_names[clientdata_idx]]
+        names(input_clientdata) <- sub("^.clientdata_", "",
+          names(input_clientdata))
+        private$.clientData$mset(input_clientdata)
 
-      # Strip off .clientdata_ from clientdata input names, and set values
-      input_clientdata <- data[data_names[clientdata_idx]]
-      names(input_clientdata) <- sub("^.clientdata_", "",
-                                     names(input_clientdata))
-      private$.clientData$mset(input_clientdata)
+        self$manageHiddenOutputs()
+      })
     },
     outputOptions = function(name, ...) {
       # If no name supplied, return the list of options for all outputs
@@ -1738,7 +1900,7 @@ ShinySession <- R6Class(
 
       # If any changes to suspendWhenHidden, need to re-run manageHiddenOutputs
       if ("suspendWhenHidden" %in% names(opts)) {
-        self$manageHiddenOutputs()
+        self$manageHiddenOutputs(name)
       }
 
       if ("priority" %in% names(opts)) {
@@ -1757,6 +1919,19 @@ ShinySession <- R6Class(
       private$busyCount <- private$busyCount - 1L
       if (private$busyCount == 0L) {
         private$sendMessage(busy = "idle")
+        self$requestFlush()
+        # We defer the call to startCycle() using later(), to defend against
+        # cycles where we continually call startCycle which causes an observer
+        # to fire which calls startCycle which causes an observer to fire...
+        #
+        # It's OK for these cycles to occur, but we must return control to the
+        # event loop between iterations (or at least sometimes) in order to not
+        # make the whole Shiny app go unresponsive.
+        later::later(function() {
+          if (private$busyCount == 0L) {
+            private$startCycle()
+          }
+        })
       }
     }
   ),
@@ -1861,17 +2036,6 @@ outputOptions <- function(x, name, ...) {
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
 
-
-#' Mark an output to be excluded from test snapshots
-#'
-#' @param x A reactive which will be assigned to an output.
-#'
-#' @export
-snapshotExclude <- function(x) {
-  markOutputAttrs(x, snapshotExclude = TRUE)
-}
-
-
 #' Add callbacks for Shiny session events
 #'
 #' These functions are for registering callbacks on Shiny session events.
@@ -1903,18 +2067,17 @@ onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
 }
 
 #' @rdname onFlush
+#'
+#' @seealso \code{\link{onStop}()} for registering callbacks that will be
+#'   invoked when the application exits, or when a session ends.
 #' @export
 onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
   session$onSessionEnded(fun)
 }
 
 
-scheduleFlush <- function() {
-  timerCallbacks$schedule(0, function() {})
-}
-
-flushAllSessions <- function() {
-  lapply(appsByToken$values(), function(shinysession) {
+flushPendingSessions <- function() {
+  lapply(appsNeedingFlush$values(), function(shinysession) {
     tryCatch(
       shinysession$flushOutput(),
 
@@ -1927,3 +2090,129 @@ flushAllSessions <- function() {
     NULL
   })
 }
+
+.globals$onStopCallbacks <- Callbacks$new()
+
+#' Run code after an application or session ends
+#'
+#' This function registers callback functions that are invoked when the
+#' application exits (when \code{\link{runApp}} exits), or after each user
+#' session ends (when a client disconnects).
+#'
+#' @param fun A function that will be called after the app has finished running.
+#' @param session A scope for when the callback will run. If \code{onStop} is
+#'   called from within the server function, this will default to the current
+#'   session, and the callback will be invoked when the current session ends. If
+#'   \code{onStop} is called outside a server function, then the callback will
+#'   be invoked with the application exits.
+#'
+#'
+#' @seealso \code{\link{onSessionEnded}()} for the same functionality, but at
+#'   the session level only.
+#'
+#' @return A function which, if invoked, will cancel the callback.
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   # Open this application in multiple browsers, then close the browsers.
+#'   shinyApp(
+#'     ui = basicPage("onStop demo"),
+#'
+#'     server = function(input, output, session) {
+#'       onStop(function() cat("Session stopped\n"))
+#'     },
+#'
+#'     onStart = function() {
+#'       cat("Doing application setup\n")
+#'
+#'       onStop(function() {
+#'         cat("Doing application cleanup\n")
+#'       })
+#'     }
+#'   )
+#' }
+#' # In the example above, onStop() is called inside of onStart(). This is
+#' # the pattern that should be used when creating a shinyApp() object from
+#' # a function, or at the console. If instead you are writing an app.R which
+#' # will be invoked with runApp(), you can do it that way, or put the onStop()
+#' # before the shinyApp() call, as shown below.
+#'
+#' \dontrun{
+#' # ==== app.R ====
+#' cat("Doing application setup\n")
+#' onStop(function() {
+#'   cat("Doing application cleanup\n")
+#' })
+#'
+#' shinyApp(
+#'   ui = basicPage("onStop demo"),
+#'
+#'   server = function(input, output, session) {
+#'     onStop(function() cat("Session stopped\n"))
+#'   }
+#' )
+#' # ==== end app.R ====
+#'
+#'
+#' # Similarly, if you have a global.R, you can call onStop() from there.
+#' # ==== global.R ====
+#' cat("Doing application setup\n")
+#' onStop(function() {
+#'   cat("Doing application cleanup\n")
+#' })
+#' # ==== end global.R ====
+#' }
+#' @export
+onStop <- function(fun, session = getDefaultReactiveDomain()) {
+  if (is.null(getDefaultReactiveDomain())) {
+    return(.globals$onStopCallbacks$register(fun))
+  } else {
+    # Note: In the future if we allow scoping the onStop() callback to modules
+    # and allow modules to be stopped, then session_proxy objects will need
+    # its own implementation of $onSessionEnded.
+    return(session$onSessionEnded(fun))
+  }
+}
+
+# Helper class for emitting log messages to stdout that will be interpreted by
+# a Shiny Server parent process. The duration it's trying to record is the time
+# between a websocket message being received, and the next flush to the client.
+ShinyServerTimingRecorder <- R6Class("ShinyServerTimingRecorder",
+  cloneable = FALSE,
+  public = list(
+    initialize = function() {
+      private$shiny_stdout <- if (exists(".shiny__stdout", globalenv()))
+        get(".shiny__stdout", globalenv())
+      else
+        NULL
+      private$guid <- NULL
+    },
+    start = function(guid) {
+      if (is.null(private$shiny_stdout)) return()
+
+      private$guid <- guid
+      if (!is.null(guid)) {
+        private$write("n")
+      }
+    },
+    stop = function() {
+      if (is.null(private$shiny_stdout)) return()
+
+      if (!is.null(private$guid)) {
+        private$write("x")
+        private$guid <- NULL
+      }
+    }
+  ),
+  private = list(
+    shiny_stdout = NULL,
+    guid = character(),
+    write = function(code) {
+      # eNter or eXit a flushReact
+      writeLines(paste("_", code, "_flushReact ", private$guid,
+        " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+        sep=""), con=private$shiny_stdout)
+      flush(private$shiny_stdout)
+    }
+  )
+)

R/shinywrappers.R

@@ -52,6 +52,49 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
             hasExecuted = hasExecuted)
 }
 
+#' Implement render functions
+#'
+#' @param func A function without parameters, that returns user data. If the
+#'   returned value is a promise, then the render function will proceed in async
+#'   mode.
+#' @param transform A function that takes four arguments: \code{value},
+#'   \code{session}, \code{name}, and \code{...} (for future-proofing). This
+#'   function will be invoked each time a value is returned from \code{func},
+#'   and is responsible for changing the value into a JSON-ready value to be
+#'   JSON-encoded and sent to the browser.
+#' @param outputFunc The UI function that is used (or most commonly used) with
+#'   this render function. This can be used in R Markdown documents to create
+#'   complete output widgets out of just the render function.
+#' @param outputArgs A list of arguments to pass to the \code{outputFunc}.
+#'   Render functions should include \code{outputArgs = list()} in their own
+#'   parameter list, and pass through the value as this argument, to allow app
+#'   authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
+#' @return An annotated render function, ready to be assigned to an
+#'   \code{output} slot.
+#'
+#' @export
+createRenderFunction <- function(
+  func, transform = function(value, session, name, ...) value,
+  outputFunc = NULL, outputArgs = NULL
+) {
+
+  renderFunc <- function(shinysession, name, ...) {
+    hybrid_chain(
+      func(),
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
+      }
+    )
+  }
+
+  if (!is.null(outputFunc))
+    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  else
+    renderFunc
+}
+
 useRenderFunction <- function(renderFunc, inline = FALSE) {
   outputFunction <- attr(renderFunc, "outputFunc")
   outputArgs <- attr(renderFunc, "outputArgs")
@@ -93,9 +136,13 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #'
 #' @inheritParams markRenderFunction
 #' @param snapshotExclude If TRUE, exclude the output from test snapshots.
+#' @param snapshotPreprocess A function for preprocessing the value before
+#'   taking a test snapshot.
 #'
 #' @keywords internal
-markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
+markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
+  snapshotPreprocess = NULL)
+{
   # Add the outputAttrs attribute if necessary
   if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
     attr(renderFunc, "outputAttrs") <- list()
@@ -105,6 +152,10 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL) {
     attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
   }
 
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
+
   renderFunc
 }
 
@@ -214,26 +265,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- 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.
-    if (deleteFile) {
-      on.exit(unlink(imageinfo$src))
-    }
+  createRenderFunction(func,
+    transform = function(imageinfo, session, name, ...) {
+      # Should the file be deleted after being sent? If .deleteFile not set or if
+      # TRUE, then delete; otherwise don't delete.
+      if (deleteFile) {
+        on.exit(unlink(imageinfo$src))
+      }
 
-    # If contentType not specified, autodetect based on extension
-    contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
+      # If contentType not specified, autodetect based on extension
+      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
 
-    # Extra values are everything in imageinfo except 'src' and 'contentType'
-    extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
+      # Extra values are everything in imageinfo except 'src' and 'contentType'
+      extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
 
-    # Return a list with src, and other img attributes
-    c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
-      extra_attr)
-  }
-
-  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
+      # Return a list with src, and other img attributes
+      c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
+        extra_attr)
+    },
+    imageOutput, outputArgs)
 }
 
 
@@ -273,15 +323,74 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
                         width = getOption('width'), outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
+  # Set a promise domain that sets the console width
+  #   and captures output
+  # op <- options(width = width)
+  # on.exit(options(op), add = TRUE)
+
   renderFunc <- function(shinysession, name, ...) {
-    op <- options(width = width)
-    on.exit(options(op), add = TRUE)
-    paste(utils::capture.output(func()), collapse = "\n")
+    domain <- createRenderPrintPromiseDomain(width)
+    hybrid_chain(
+      {
+        promises::with_promise_domain(domain, func())
+      },
+      function(value, .visible) {
+        if (.visible) {
+          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
+        }
+        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res
+      },
+      finally = function() {
+        close(domain$conn)
+      }
+    )
   }
 
   markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
+createRenderPrintPromiseDomain <- function(width) {
+  f <- file()
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      op <- options(width = width)
+      on.exit(options(op), add = TRUE)
+
+      sink(f, append = TRUE)
+      on.exit(sink(NULL), add = TRUE)
+
+      force(expr)
+    },
+    conn = f
+  )
+}
+
 #' Text Output
 #'
 #' Makes a reactive version of the given function that also uses
@@ -313,12 +422,13 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
                        outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    value <- func()
-    return(paste(utils::capture.output(cat(value)), collapse="\n"))
-  }
-
-  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
+  createRenderFunction(
+    func,
+    function(value, session, name, ...) {
+      paste(utils::capture.output(cat(value)), collapse="\n")
+    },
+    textOutput, outputArgs
+  )
 }
 
 #' UI Output
@@ -363,15 +473,16 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
                      outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    result <- func()
-    if (is.null(result) || length(result) == 0)
-      return(NULL)
+  createRenderFunction(
+    func,
+    function(result, shinysession, name, ...) {
+      if (is.null(result) || length(result) == 0)
+        return(NULL)
 
-    processDeps(result, shinysession)
-  }
-
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads
@@ -509,31 +620,46 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
-    data <- func()
-    if (length(dim(data)) != 2) return() # expects a rectangular data object
-    if (is.data.frame(data)) data <- as.data.frame(data)
-    action <- shinysession$registerDataObj(name, data, dataTablesJSON)
-    colnames <- colnames(data)
-    # if escape is column names, turn names to numeric indices
-    if (is.character(escape)) {
-      escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
-      if (any(is.na(escape)))
-        stop("Some column names in the 'escape' argument not found in data")
-    }
-    colnames[escape] <- htmlEscape(colnames[escape])
-    if (!is.logical(escape)) {
-      if (!is.numeric(escape))
-        stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
-      escape <- paste(escape, collapse = ',')
-    }
-    list(
-      colnames = colnames, action = action, options = res$options,
-      evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
-      callback = paste(callback, collapse = '\n'), escape = escape
+    hybrid_chain(
+      func(),
+      function(data) {
+        if (length(dim(data)) != 2) return() # expects a rectangular data object
+        if (is.data.frame(data)) data <- as.data.frame(data)
+        action <- shinysession$registerDataObj(name, data, dataTablesJSON)
+        colnames <- colnames(data)
+        # if escape is column names, turn names to numeric indices
+        if (is.character(escape)) {
+          escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
+          if (any(is.na(escape)))
+            stop("Some column names in the 'escape' argument not found in data")
+        }
+        colnames[escape] <- htmlEscape(colnames[escape])
+        if (!is.logical(escape)) {
+          if (!is.numeric(escape))
+            stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
+          escape <- paste(escape, collapse = ',')
+        }
+        list(
+          colnames = colnames, action = action, options = res$options,
+          evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
+          callback = paste(callback, collapse = '\n'), escape = escape
+        )
+      }
     )
   }
 
-  markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+  renderFunc <- markRenderFunction(dataTableOutput, renderFunc, outputArgs = outputArgs)
+
+  renderFunc <- snapshotPreprocessOutput(renderFunc, function(value) {
+    # Remove the action field so that it's not saved in test snapshots. It
+    # contains a value that changes every time an app is run, and shouldn't be
+    # stored for test snapshots. It will be something like:
+    # "session/e0d14d3fe97f672f9655a127f2a1e079/dataobj/table?w=&nonce=7f5d6d54e22450a3"
+    value$action <- NULL
+    value
+  })
+
+  renderFunc
 }
 
 # a data frame containing the DataTables 1.9 and 1.10 names

R/snapshot.R

@@ -0,0 +1,44 @@
+#' Mark an output to be excluded from test snapshots
+#'
+#' @param x A reactive which will be assigned to an output.
+#'
+#' @export
+snapshotExclude <- function(x) {
+  markOutputAttrs(x, snapshotExclude = TRUE)
+}
+
+#' Add a function for preprocessing an output before taking a test snapshot
+#'
+#' @param x A reactive which will be assigned to an output.
+#' @param fun A function that takes the output value as an input and returns a
+#'   modified value. The returned value will be used for the test snapshot.
+#'
+#' @export
+snapshotPreprocessOutput <- function(x, fun) {
+  markOutputAttrs(x, snapshotPreprocess = fun)
+}
+
+
+#' Add a function for preprocessing an input before taking a test snapshot
+#'
+#' @param inputId Name of the input value.
+#' @param fun A function that takes the input value and returns a modified
+#'   value. The returned value will be used for the test snapshot.
+#' @param session A Shiny session object.
+#'
+#' @export
+snapshotPreprocessInput <- function(inputId, fun, session = getDefaultReactiveDomain()) {
+  if (is.null(session)) {
+    stop("snapshotPreprocessInput() needs a session object.")
+  }
+
+  input_impl <- .subset2(session$input, "impl")
+  input_impl$setMeta(inputId, "shiny.snapshot.preprocess", fun)
+}
+
+
+# Strip out file path from fileInput value
+snapshotPreprocessorFileInput <- function(value) {
+  value$datapath <- basename(value$datapath)
+  value
+}

R/update-input.R

@@ -2,6 +2,7 @@
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
+#' @param placeholder The placeholder to set for the input object.
 #'
 #' @seealso \code{\link{textInput}}
 #'
@@ -34,15 +35,15 @@
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
-  message <- dropNulls(list(label=label, value=value))
+updateTextInput <- function(session, inputId, label = NULL, value = NULL, placeholder = NULL) {
+  message <- dropNulls(list(label=label, value=value, placeholder=placeholder))
   session$sendInputMessage(inputId, message)
 }
 
 #' Change the value of a textarea input on the client
 #'
 #' @template update-input
-#' @param value The value to set for the input object.
+#' @inheritParams updateTextInput
 #'
 #' @seealso \code{\link{textAreaInput}}
 #'
@@ -106,7 +107,10 @@ updateTextAreaInput <- updateTextInput
 #' shinyApp(ui, server)
 #' }
 #' @export
-updateCheckboxInput <- updateTextInput
+updateCheckboxInput <- function(session, inputId, label = NULL, value = NULL) {
+  message <- dropNulls(list(label=label, value=value))
+  session$sendInputMessage(inputId, message)
+}
 
 
 #' Change the label or icon of an action button on the client
@@ -638,8 +642,33 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
+
+  # server side updateSelectizeInput
   value <- unname(selected)
   attr(choices, 'selected_value') <- value
+
+  # convert a single vector to a data frame so it returns {label: , value: }
+  # other objects return arbitrary JSON {x: , y: , foo: , ...}
+  choices <- if (is.atomic(choices)) {
+    # fast path
+    if(is.null(names(choices))) {
+      lab <- as.character(choices)
+    } else {
+      lab <- names(choices)
+      # replace empty names like: choices = c(a = 1, 2)
+      # int this case: names(choices) = c("a", "")
+      # with replacement below choices will be: lab = c("a", "2")
+      empty_names_indices <- lab == ""
+      lab[empty_names_indices] <- as.character(choices[empty_names_indices])
+    }
+    # lab shold be lower-case for faster case-insensitive matching - grepl(... , fixed = TRUE)
+    lab <- tolower(lab)
+    data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
+  } else {
+    # slow path
+    as.data.frame(choices, stringsAsFactors = FALSE)
+  }
+
   message <- dropNulls(list(
     label = label,
     value = value,
@@ -651,8 +680,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)
   # extract the query variables, conjunction (and/or), search string, maximum options
-  var <- c(jsonlite::fromJSON(query$field))
-  cjn <- if (query$conju == 'and') all else any
+  var <- c(safeFromJSON(query$field))
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
   if (identical(key, '')) key <- character(0)
@@ -660,25 +688,30 @@ selectizeJSON <- function(data, req) {
   vfd <- query$value  # the value field name
   sel <- attr(data, 'selected_value', exact = TRUE)
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
-  data <- if (is.atomic(data)) {
-    data.frame(label = names(choicesWithNames(data)), value = data,
-               stringsAsFactors = FALSE)
-  } else as.data.frame(data, stringsAsFactors = FALSE)
-
   # start searching for keywords in all specified columns
   idx <- logical(nrow(data))
-  if (length(key)) for (v in var) {
-    matches <- do.call(
-      cbind,
-      lapply(key, function(k) {
-        grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
-      })
-    )
-    # merge column matches using OR, and match multiple keywords in one column
-    # using the conjunction setting (AND or OR)
-    idx <- idx | apply(matches, 1, cjn)
+  if (length(key)) {
+    for (v in var) {
+      matches <- do.call(
+        cbind,
+        lapply(key, function(k) {
+          if(is.character(data[[v]])) {
+            # according to updateSelectizeInput() we know that
+            # `data[[v]]` already in lower case
+            grepl(k, data[[v]], fixed = TRUE)
+          } else {
+            grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
+          }
+        })
+      )
+      # merge column matches using OR, and match multiple keywords in one column
+      # using the conjunction setting (AND or OR)
+      matches <- rowSums(matches)
+      if(query$conju == 'and')
+        idx <- idx | (matches == length(key))
+      else
+        idx <- idx | matches
+    }
   }
   # only return the first n rows (n = maximum options in configuration)
   idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)

R/utils.R

@@ -43,53 +43,43 @@ repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max))
   }
 }
 
-# Temporarily set x in env to value, evaluate expr, and
-# then restore x to its original state
-withTemporary <- function(env, x, value, expr, unset = FALSE) {
-
-  if (exists(x, envir = env, inherits = FALSE)) {
-    oldValue <- get(x, envir = env, inherits = FALSE)
-    on.exit(
-      assign(x, oldValue, envir = env, inherits = FALSE),
-      add = TRUE)
-  } else {
-    on.exit(
-      rm(list = x, envir = env, inherits = FALSE),
-      add = TRUE
-    )
-  }
-
-  if (!missing(value) && !isTRUE(unset))
-    assign(x, value, envir = env, inherits = FALSE)
-  else {
-    if (exists(x, envir = env, inherits = FALSE))
-      rm(list = x, envir = env, inherits = FALSE)
-  }
-  force(expr)
-}
-
 .globals$ownSeed <- NULL
 # Evaluate an expression using Shiny's own private stream of
 # randomness (not affected by set.seed).
 withPrivateSeed <- function(expr) {
-  withTemporary(.GlobalEnv, ".Random.seed",
-    .globals$ownSeed, unset=is.null(.globals$ownSeed), {
-      tryCatch({
-        expr
-      }, finally = {
-        .globals$ownSeed <- getExists('.Random.seed', 'numeric', globalenv())
-      })
-    }
-  )
-}
+  # Save the old seed if present.
+  if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
+    hasOrigSeed <- TRUE
+    origSeed <- .GlobalEnv$.Random.seed
+  } else {
+    hasOrigSeed <- FALSE
+  }
 
-# a homemade version of set.seed(NULL) for backward compatibility with R 2.15.x
-reinitializeSeed <- if (getRversion() >= '3.0.0') {
-  function() set.seed(NULL)
-} else function() {
-  if (exists('.Random.seed', globalenv()))
-    rm(list = '.Random.seed', pos = globalenv())
-  stats::runif(1)  # generate any random numbers so R can reinitialize the seed
+  # Swap in the private seed.
+  if (is.null(.globals$ownSeed)) {
+    if (hasOrigSeed) {
+      # Move old seed out of the way if present.
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+  } else {
+    .GlobalEnv$.Random.seed <- .globals$ownSeed
+  }
+
+  # On exit, save the modified private seed, and put the old seed back.
+  on.exit({
+    .globals$ownSeed <- .GlobalEnv$.Random.seed
+
+    if (hasOrigSeed) {
+      .GlobalEnv$.Random.seed <- origSeed
+    } else {
+      rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
+    }
+    # Need to call this to make sure that the value of .Random.seed gets put
+    # into R's internal RNG state. (Issue #1763)
+    httpuv::getRNGState()
+  })
+
+  expr
 }
 
 # Version of runif that runs with private seed
@@ -225,7 +215,7 @@ sortByName <- function(x) {
 # R >=3.2.0, this wrapper is not necessary.
 list2env2 <- function(x, ...) {
   # Ensure that zero-length lists have a name attribute
-   if (length(x) == 0)
+  if (length(x) == 0)
     attr(x, "names") <- character(0)
 
   list2env(x, ...)
@@ -672,6 +662,9 @@ Callbacks <- R6Class(
       .callbacks <<- Map$new()
     },
     register = function(callback) {
+      if (!is.function(callback)) {
+        stop("callback must be a function")
+      }
       id <- as.character(.nextId)
       .nextId <<- .nextId - 1L
       .callbacks$set(id, callback)
@@ -1539,7 +1532,10 @@ writeUTF8 <- function(text, ...) {
   writeLines(text, ..., useBytes = TRUE)
 }
 
-URLdecode <- decodeURIComponent
+URLdecode <- function(value) {
+  decodeURIComponent(value)
+}
+
 URLencode <- function(value, reserved = FALSE) {
   value <- enc2utf8(value)
   if (reserved) encodeURIComponent(value) else encodeURI(value)
@@ -1585,3 +1581,96 @@ Mutable <- R6Class("Mutable",
     get = function() { private$value }
   )
 )
+
+# More convenient way of chaining together promises than then/catch/finally,
+# without the performance impact of %...>%.
+promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    p <- Reduce(function(memo, func) {
+      promises::then(memo, func)
+    }, list(...), promise)
+
+    if (!is.null(catch)) {
+      p <- promises::catch(p, catch)
+    }
+
+    if (!is.null(finally)) {
+      p <- promises::finally(p, finally)
+    }
+
+    p
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`,
+# and `finally` are all executed synchronously
+hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    runFinally <- TRUE
+    tryCatch(
+      {
+        captureStackTraces({
+          result <- withVisible(force(expr))
+          if (promises::is.promising(result$value)) {
+            # Purposefully NOT including domain (nor replace), as we're already in
+            # the domain at this point
+            p <- promise_chain(setVisible(result), ..., catch = catch, finally = finally)
+            runFinally <- FALSE
+            p
+          } else {
+            result <- Reduce(function(v, func) {
+              if (".visible" %in% names(formals(func))) {
+                withVisible(func(v$value, .visible = v$visible))
+              } else {
+                withVisible(func(v$value))
+              }
+            }, list(...), result)
+
+            setVisible(result)
+          }
+        })
+      },
+      error = function(e) {
+        if (!is.null(catch))
+          catch(e)
+        else
+          stop(e)
+      },
+      finally = if (runFinally && !is.null(finally)) finally()
+    )
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Returns `value` with either `invisible()` applied or not, depending on the
+# value of `visible`.
+#
+# If the `visible` is missing, then `value` should be a list as returned from
+# `withVisible()`, and that visibility will be applied.
+setVisible <- function(value, visible) {
+  if (missing(visible)) {
+    visible <- value$visible
+    value <- value$value
+  }
+
+  if (!visible) {
+    invisible(value)
+  } else {
+    (value)
+  }
+}

README.md

@@ -8,6 +8,8 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 
 For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstudio.com/).
 
+If you have general questions about using Shiny, please use the [RStudio Community website](https://community.rstudio.com). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.
@@ -16,7 +18,7 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
 * Works in any R environment (Console R, Rgui for Windows or Mac, ESS, StatET, RStudio, etc.).
 * Attractive default UI theme based on [Bootstrap](http://getbootstrap.com/).
 * A highly customizable slider widget with built-in support for animation.
-* Pre-built output widgets for displaying plots, tables, and printed output of R objects.
+* Prebuilt output widgets for displaying plots, tables, and printed output of R objects.
 * Fast bidirectional communication between the web browser and R using the [httpuv](https://github.com/rstudio/httpuv) package.
 * Uses a [reactive](http://en.wikipedia.org/wiki/Reactive_programming) programming model that eliminates messy event handling code, so you can focus on the code that really matters.
 * Develop and redistribute your own Shiny widgets that other developers can easily drop into their own applications (coming soon!).
@@ -41,8 +43,6 @@ devtools::install_github("rstudio/shiny")
 
 To learn more we highly recommend you check out the [Shiny Tutorial](http://shiny.rstudio.com/tutorial/). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
 
-We hope you enjoy using Shiny. If you have general questions about using Shiny, please use the Shiny [mailing list](https://groups.google.com/forum/#!forum/shiny-discuss). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
-
 ## Bootstrap 3 migration
 
 Shiny versions 0.10.2.2 and below used the Bootstrap 2 web framework. After 0.10.2.2, Shiny switched to Bootstrap 3. For most users, the upgrade should be seamless. However, if you have have customized your HTML-generating code to use features specific to Bootstrap 2, you may need to update your code to work with Bootstrap 3.

TODO-promises.md

@@ -0,0 +1,54 @@
+# Promises TODO
+
+## Documentation
+
+- [x] Motivation -- why should I care about async? Why shouldn't I (what are the limitations)?
+- [x] High level technical overview
+- [ ] Cookbook-style examples
+- [ ] Top-down porting of a sync app to async
+
+## Core API
+- [x] Should as.promise() convert regular values to promises? Or throw?
+  - [x] If as.promise() doesn't convert regular values to promises, add promise_resolved(value) and promise_rejected(err) functions?
+
+## later
+- [ ] Add support for multiple event loops
+- [x] Add timeout to run_now
+
+## Error handling/debugging
+- [ ] ..stacktraceon../..stacktraceoff.. and stack traces in general
+- [x] long stack traces
+  - [x] require opt-in
+- [ ] options(shiny.error) should work in promise handlers
+- [x] Detect when reactives are used across process boundaries, and error
+
+## Render functions
+- [x] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
+- [x] Promise domains should maybe have an onExecute, for the "sync" part that kicks off async operations to also have wrapping behavior (like capturing output). Right now, I have to start off renderPrint with promise(~resolve(TRUE)) and then execute the user code in a then(), just to get the promise behavior. Same will be true when we tackle error handling (stack trace capture).
+- [x] invisible() doesn't seem to be working correctly with renderPrint. .visible doesn't survive promise chaining, e.g. promise(~resolve(promise(~resolve(invisible("Hi"))))) %>% then(function(x, .visible) { cat(.visible) }) will print TRUE, not FALSE.
+- [x] renderDataTable should support async
+- [x] Support downloadHandler
+  - [ ] Support async filename?
+  - [x] Should prevent session from continuing until download completes (ref count)
+
+## Flush lifecycle
+- [x] While async operations are running in a session, hold off on any further processing of inputs and scheduled task items until all operations are complete.
+- [x] Hold all outputs/errors until async operations are complete.
+- [ ] Allow both sync and async outputs to be displayed before all outputs are done. (opt-in)
+
+## Testing
+- [x] App that tests that all built-in render functions support async
+- [x] Apps that test flush lifecycle, including onFlushed(once = FALSE)
+- [x] Apps that test invisible() behavior for renderPrint, both sync and async
+- [x] Apps that ensure all render functions execute synchronous code before tick is over
+- [x] App that tests async downloadHandler
+- [x] App that verifies inputs/timers don't fire for a session while it has async operations pending
+- [x] App that verifies req(FALSE), req(FALSE, cancelOutput = TRUE), validate/need, etc. all work in async
+
+## External packages
+- [x] DT
+- [x] htmlwidgets: Don't require async-aware version of Shiny if not using async
+- [x] Plotly
+
+## Bugs
+- [x] req(FALSE, cancelOutput = TRUE) shows grey (even without async)

appveyor.yml

@@ -43,3 +43,7 @@ artifacts:
 
   - path: '\*_*.zip'
     name: Bits
+
+environment:
+  global:
+    USE_RTOOLS: true

inst/examples/01_hello/Readme.md

@@ -1,4 +1,3 @@
-This small Shiny application demonstrates Shiny's automatic UI updates. Move
-the *Number of bins* slider and notice how the `renderPlot` expression is
-automatically re-evaluated when its dependant, `input$bins`, changes,
-causing a histogram with a new number of bins to be rendered.
+This small Shiny application demonstrates Shiny's automatic UI updates. 
+
+Move the *Number of bins* slider and notice how the `renderPlot` expression is automatically re-evaluated when its dependant, `input$bins`, changes, causing a histogram with a new number of bins to be rendered.

inst/examples/01_hello/app.R

@@ -0,0 +1,59 @@
+library(shiny)
+
+# Define UI for app that draws a histogram ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Hello Shiny!"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Slider for the number of bins ----
+      sliderInput(inputId = "bins",
+                  label = "Number of bins:",
+                  min = 1,
+                  max = 50,
+                  value = 30)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Histogram ----
+      plotOutput(outputId = "distPlot")
+
+    )
+  )
+)
+
+# Define server logic required to draw a histogram ----
+server <- function(input, output) {
+
+  # Histogram of the Old Faithful Geyser Data ----
+  # with requested number of bins
+  # This expression that generates a histogram is wrapped in a call
+  # to renderPlot to indicate that:
+  #
+  # 1. It is "reactive" and therefore should be automatically
+  #    re-executed when inputs (input$bins) change
+  # 2. Its output type is a plot
+  output$distPlot <- renderPlot({
+
+    x    <- faithful$waiting
+    bins <- seq(min(x), max(x), length.out = input$bins + 1)
+
+    hist(x, breaks = bins, col = "#75AADB", border = "white",
+         xlab = "Waiting time to next eruption (in mins)",
+         main = "Histogram of waiting times")
+
+    })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/01_hello/server.R

@@ -1,21 +0,0 @@
-library(shiny)
-
-# Define server logic required to draw a histogram
-function(input, output) {
-
-  # Expression that generates a histogram. The expression is
-  # wrapped in a call to renderPlot to indicate that:
-  #
-  #  1) It is "reactive" and therefore should be automatically
-  #     re-executed when inputs change
-  #  2) Its output type is a plot
-
-  output$distPlot <- renderPlot({
-    x    <- faithful[, 2]  # Old Faithful Geyser data
-    bins <- seq(min(x), max(x), length.out = input$bins + 1)
-
-    # draw the histogram with the specified number of bins
-    hist(x, breaks = bins, col = 'darkgray', border = 'white')
-  })
-
-}

inst/examples/01_hello/ui.R

@@ -1,24 +0,0 @@
-library(shiny)
-
-# Define UI for application that draws a histogram
-fluidPage(
-
-  # Application title
-  titlePanel("Hello Shiny!"),
-
-  # Sidebar with a slider input for the number of bins
-  sidebarLayout(
-    sidebarPanel(
-      sliderInput("bins",
-                  "Number of bins:",
-                  min = 1,
-                  max = 50,
-                  value = 30)
-    ),
-
-    # Show a plot of the generated distribution
-    mainPanel(
-      plotOutput("distPlot")
-    )
-  )
-)

inst/examples/02_text/Readme.md

@@ -1 +1 @@
-This example demonstrates output of raw text from R using the `renderPrint` function in `server.R` and the `verbatimTextOutput` function in `ui.R`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 
+This example demonstrates output of raw text from R using the `renderPrint` function in `server` and the `verbatimTextOutput` function in `ui`. In this case, a textual summary of the data is shown using R's built-in `summary` function. 

inst/examples/02_text/app.R

@@ -0,0 +1,64 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Shiny Text"),
+
+  # Sidebar layout with a input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Generate a summary of the dataset ----
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = ui, server = server)

inst/examples/02_text/server.R

@@ -1,26 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-function(input, output) {
-  
-  # Return the requested dataset
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # Generate a summary of the dataset
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # Show the first "n" observations
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-}

inst/examples/02_text/ui.R

@@ -1,27 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-  
-  # Application title
-  titlePanel("Shiny Text"),
-  
-  # Sidebar with controls to select a dataset and specify the
-  # number of observations to view
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    # Show a summary of the dataset and an HTML table with the 
-    # requested number of observations
-    mainPanel(
-      verbatimTextOutput("summary"),
-      
-      tableOutput("view")
-    )
-  )
-)

inst/examples/03_reactivity/Readme.md

@@ -1,5 +1,5 @@
-This example demonstrates a core feature of Shiny: **reactivity**. In `server.R`, a reactive called `datasetInput` is declared. 
+This example demonstrates a core feature of Shiny: **reactivity**. In the `server` function, a reactive called `datasetInput` is declared. 
 
-Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by both the output expression `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
+Notice that the reactive expression depends on the input expression `input$dataset`, and that it's used by two output expressions: `output$summary` and `output$view`. Try changing the dataset (using *Choose a dataset*) while looking at the reactive and then at the outputs; you will see first the reactive and then its dependencies flash. 
 
 Notice also that the reactive expression doesn't just update whenever anything changes--only the inputs it depends on will trigger an update. Change the "Caption" field and notice how only the `output$caption` expression is re-evaluated; the reactive and its dependents are left alone.

inst/examples/03_reactivity/app.R

@@ -0,0 +1,102 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Reactivity"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Text for providing a caption ----
+      # Note: Changes made to the caption in the textInput control
+      # are updated in the output area immediately as you type
+      textInput(inputId = "caption",
+                label = "Caption:",
+                value = "Data Summary"),
+
+      # Input: Selector for choosing dataset ----
+      selectInput(inputId = "dataset",
+                  label = "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Numeric entry for number of obs to view ----
+      numericInput(inputId = "obs",
+                   label = "Number of observations to view:",
+                   value = 10)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption", container = span)),
+
+      # Output: Verbatim text for data summary ----
+      verbatimTextOutput("summary"),
+
+      # Output: HTML table with requested number of observations ----
+      tableOutput("view")
+
+    )
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  # By declaring datasetInput as a reactive expression we ensure
+  # that:
+  #
+  # 1. It is only called when the inputs it depends on changes
+  # 2. The computation and result are shared by all the callers,
+  #    i.e. it only executes a single time
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Create caption ----
+  # The output$caption is computed based on a reactive expression
+  # that returns input$caption. When the user changes the
+  # "caption" field:
+  #
+  # 1. This function is automatically called to recompute the output
+  # 2. New caption is pushed back to the browser for re-display
+  #
+  # Note that because the data-oriented reactive expressions
+  # below don't depend on input$caption, those expressions are
+  # NOT called when input$caption changes
+  output$caption <- renderText({
+    input$caption
+  })
+
+  # Generate a summary of the dataset ----
+  # The output$summary depends on the datasetInput reactive
+  # expression, so will be re-executed whenever datasetInput is
+  # invalidated, i.e. whenever the input$dataset changes
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  # The output$view depends on both the databaseInput reactive
+  # expression and input$obs, so it will be re-executed whenever
+  # input$dataset or input$obs is changed
+  output$view <- renderTable({
+    head(datasetInput(), n = input$obs)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/03_reactivity/server.R

@@ -1,53 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the selected
-# dataset
-function(input, output) {
-
-  # By declaring datasetInput as a reactive expression we ensure 
-  # that:
-  #
-  #  1) It is only called when the inputs it depends on changes
-  #  2) The computation and result are shared by all the callers 
-  #     (it only executes a single time)
-  #
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  # The output$caption is computed based on a reactive expression
-  # that returns input$caption. When the user changes the
-  # "caption" field:
-  #
-  #  1) This function is automatically called to recompute the 
-  #     output 
-  #  2) The new caption is pushed back to the browser for 
-  #     re-display
-  # 
-  # Note that because the data-oriented reactive expressions
-  # below don't depend on input$caption, those expressions are
-  # NOT called when input$caption changes.
-  output$caption <- renderText({
-    input$caption
-  })
-  
-  # The output$summary depends on the datasetInput reactive
-  # expression, so will be re-executed whenever datasetInput is
-  # invalidated
-  # (i.e. whenever the input$dataset changes)
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-  
-  # The output$view depends on both the databaseInput reactive
-  # expression and input$obs, so will be re-executed whenever
-  # input$dataset or input$obs is changed. 
-  output$view <- renderTable({
-    head(datasetInput(), n = input$obs)
-  })
-}

inst/examples/03_reactivity/ui.R

@@ -1,34 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-  
-  # Application title
-  titlePanel("Reactivity"),
-  
-  # Sidebar with controls to provide a caption, select a dataset,
-  # and specify the number of observations to view. Note that
-  # changes made to the caption in the textInput control are
-  # updated in the output area immediately as you type
-  sidebarLayout(
-    sidebarPanel(
-      textInput("caption", "Caption:", "Data Summary"),
-      
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      
-      numericInput("obs", "Number of observations to view:", 10)
-    ),
-    
-    
-    # Show the caption, a summary of the dataset and an HTML 
-    # table with the requested number of observations
-    mainPanel(
-      h3(textOutput("caption", container = span)),
-      
-      verbatimTextOutput("summary"), 
-      
-      tableOutput("view")
-    )
-  )
-)

inst/examples/04_mpg/Readme.md

@@ -1,4 +1,4 @@
 This example demonstrates the following concepts:
 
-* **Global variables**: The `mpgData` variable is declared outside the `shinyServer` function. This makes it available anywhere inside `shinyServer`. The code in `server.R` outside `shinyServer` is only run once when the app starts up, so it can't contain user input.
-* **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is ticked. 
+- **Global variables**: The `mpgData` variable is declared outside of the `ui` and `server` function definitions. This makes it available anywhere inside `app.R`. The code in `app.R` outside of `ui` and `server` function definitions is only run once when the app starts up, so it can't contain user input.
+- **Reactive expressions**: `formulaText` is a reactive expression. Note how it re-evaluates when the Variable field is changed, but not when the Show Outliers box is unchecked. 

inst/examples/04_mpg/app.R

@@ -0,0 +1,75 @@
+library(shiny)
+library(datasets)
+
+# Data pre-processing ----
+# Tweak the "am" variable to have nicer factor labels -- since this
+# doesn't rely on any user inputs, we can do this once at startup
+# and then use the value throughout the lifetime of the app
+mpgData <- mtcars
+mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
+
+
+# Define UI for miles per gallon app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Miles Per Gallon"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Selector for variable to plot against mpg ----
+      selectInput("variable", "Variable:",
+                  c("Cylinders" = "cyl",
+                    "Transmission" = "am",
+                    "Gears" = "gear")),
+
+      # Input: Checkbox for whether outliers should be included ----
+      checkboxInput("outliers", "Show outliers", TRUE)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Formatted text for caption ----
+      h3(textOutput("caption")),
+
+      # Output: Plot of the requested variable against mpg ----
+      plotOutput("mpgPlot")
+
+    )
+  )
+)
+
+# Define server logic to plot various variables against mpg ----
+server <- function(input, output) {
+
+  # Compute the formula text ----
+  # This is in a reactive expression since it is shared by the
+  # output$caption and output$mpgPlot functions
+  formulaText <- reactive({
+    paste("mpg ~", input$variable)
+  })
+
+  # Return the formula text for printing as a caption ----
+  output$caption <- renderText({
+    formulaText()
+  })
+
+  # Generate a plot of the requested variable against mpg ----
+  # and only exclude outliers if requested
+  output$mpgPlot <- renderPlot({
+    boxplot(as.formula(formulaText()),
+            data = mpgData,
+            outline = input$outliers,
+            col = "#75AADB", pch = 19)
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/04_mpg/server.R

@@ -1,34 +0,0 @@
-library(shiny)
-library(datasets)
-
-# We tweak the "am" field to have nicer factor labels. Since
-# this doesn't rely on any user inputs we can do this once at
-# startup and then use the value throughout the lifetime of the
-# application
-mpgData <- mtcars
-mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
-
-
-# Define server logic required to plot various variables against
-# mpg
-function(input, output) {
-
-  # Compute the formula text in a reactive expression since it is
-  # shared by the output$caption and output$mpgPlot functions
-  formulaText <- reactive({
-    paste("mpg ~", input$variable)
-  })
-
-  # Return the formula text for printing as a caption
-  output$caption <- renderText({
-    formulaText()
-  })
-
-  # Generate a plot of the requested variable against mpg and
-  # only include outliers if requested
-  output$mpgPlot <- renderPlot({
-    boxplot(as.formula(formulaText()),
-            data = mpgData,
-            outline = input$outliers)
-  })
-}

inst/examples/04_mpg/ui.R

@@ -1,29 +0,0 @@
-library(shiny)
-
-# Define UI for miles per gallon application
-fluidPage(
-  
-  # Application title
-  titlePanel("Miles Per Gallon"),
-  
-  # Sidebar with controls to select the variable to plot against
-  # mpg and to specify whether outliers should be included
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("variable", "Variable:",
-                  c("Cylinders" = "cyl",
-                    "Transmission" = "am",
-                    "Gears" = "gear")),
-  
-      checkboxInput("outliers", "Show outliers", FALSE)
-    ),
-    
-    # Show the caption and plot of the requested variable against
-    # mpg
-    mainPanel(
-      h3(textOutput("caption")),
-      
-      plotOutput("mpgPlot")
-    )
-  )
-)

inst/examples/05_sliders/app.R

@@ -0,0 +1,86 @@
+library(shiny)
+
+# Define UI for slider demo app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Sliders"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar to demonstrate various slider options ----
+    sidebarPanel(
+
+      # Input: Simple integer interval ----
+      sliderInput("integer", "Integer:",
+                  min = 0, max = 1000,
+                  value = 500),
+
+      # Input: Decimal interval with step value ----
+      sliderInput("decimal", "Decimal:",
+                  min = 0, max = 1,
+                  value = 0.5, step = 0.1),
+
+      # Input: Specification of range within an interval ----
+      sliderInput("range", "Range:",
+                  min = 1, max = 1000,
+                  value = c(200,500)),
+
+      # Input: Custom currency format for with basic animation ----
+      sliderInput("format", "Custom Format:",
+                  min = 0, max = 10000,
+                  value = 0, step = 2500,
+                  pre = "$", sep = ",",
+                  animate = TRUE),
+
+      # Input: Animation with custom interval (in ms) ----
+      # to control speed, plus looping
+      sliderInput("animation", "Looping Animation:",
+                  min = 1, max = 2000,
+                  value = 1, step = 10,
+                  animate =
+                    animationOptions(interval = 300, loop = TRUE))
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Table summarizing the values entered ----
+      tableOutput("values")
+
+    )
+  )
+)
+
+# Define server logic for slider examples ----
+server <- function(input, output) {
+
+  # Reactive expression to create data frame of all input values ----
+  sliderValues <- reactive({
+
+    data.frame(
+      Name = c("Integer",
+               "Decimal",
+               "Range",
+               "Custom Format",
+               "Animation"),
+      Value = as.character(c(input$integer,
+                             input$decimal,
+                             paste(input$range, collapse = " "),
+                             input$format,
+                             input$animation)),
+      stringsAsFactors = FALSE)
+
+  })
+
+  # Show the values in an HTML table ----
+  output$values <- renderTable({
+    sliderValues()
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/05_sliders/server.R

@@ -1,29 +0,0 @@
-library(shiny)
-
-# Define server logic for slider examples
-function(input, output) {
-  
-  # Reactive expression to compose a data frame containing all of
-  # the values
-  sliderValues <- reactive({
-    
-    # Compose data frame
-    data.frame(
-      Name = c("Integer", 
-               "Decimal",
-               "Range",
-               "Custom Format",
-               "Animation"),
-      Value = as.character(c(input$integer, 
-                             input$decimal,
-                             paste(input$range, collapse=' '),
-                             input$format,
-                             input$animation)), 
-      stringsAsFactors=FALSE)
-  }) 
-  
-  # Show the values using an HTML table
-  output$values <- renderTable({
-    sliderValues()
-  })
-}

inst/examples/05_sliders/ui.R

@@ -1,43 +0,0 @@
-library(shiny)
-
-# Define UI for slider demo application
-fluidPage(
-
-  #  Application title
-  titlePanel("Sliders"),
-
-  # Sidebar with sliders that demonstrate various available
-  # options
-  sidebarLayout(
-    sidebarPanel(
-      # Simple integer interval
-      sliderInput("integer", "Integer:",
-                  min=0, max=1000, value=500),
-
-      # Decimal interval with step value
-      sliderInput("decimal", "Decimal:",
-                  min = 0, max = 1, value = 0.5, step= 0.1),
-
-      # Specification of range within an interval
-      sliderInput("range", "Range:",
-                  min = 1, max = 1000, value = c(200,500)),
-
-      # Provide a custom currency format for value display,
-    # with basic animation
-      sliderInput("format", "Custom Format:",
-                  min = 0, max = 10000, value = 0, step = 2500,
-                  pre = "$", sep = ",", animate=TRUE),
-
-      # Animation with custom interval (in ms) to control speed,
-    # plus looping
-      sliderInput("animation", "Looping Animation:", 1, 2000, 1,
-                  step = 10, animate =
-                  animationOptions(interval=300, loop=TRUE))
-    ),
-
-    # Show a table summarizing the values entered
-    mainPanel(
-      tableOutput("values")
-    )
-  )
-)

inst/examples/06_tabsets/Readme.md

@@ -2,7 +2,7 @@ This example demonstrates the `tabsetPanel` and `tabPanel` widgets.
 
 Notice that outputs that are not visible are not re-evaluated until they become visible. Try this: 
 
-1. Scroll to the bottom of `server.R`
+1. Scroll to the bottom of the `server` function. You might need to use the *show with app* option so you can easily view the code and interact with the app at the same time.
 2. Change the number of observations, and observe that only `output$plot` is evaluated.
 3. Click the Summary tab, and observe that `output$summary` is evaluated.
 4. Change the number of observations again, and observe that now only `output$summary` is evaluated.

inst/examples/06_tabsets/app.R

@@ -0,0 +1,92 @@
+library(shiny)
+
+# Define UI for random distribution app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Tabsets"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select the random distribution type ----
+      radioButtons("dist", "Distribution type:",
+                   c("Normal" = "norm",
+                     "Uniform" = "unif",
+                     "Log-normal" = "lnorm",
+                     "Exponential" = "exp")),
+
+      # br() element to introduce extra vertical spacing ----
+      br(),
+
+      # Input: Slider for the number of observations to generate ----
+      sliderInput("n",
+                  "Number of observations:",
+                  value = 500,
+                  min = 1,
+                  max = 1000)
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Tabset w/ plot, summary, and table ----
+      tabsetPanel(type = "tabs",
+                  tabPanel("Plot", plotOutput("plot")),
+                  tabPanel("Summary", verbatimTextOutput("summary")),
+                  tabPanel("Table", tableOutput("table"))
+      )
+
+    )
+  )
+)
+
+# Define server logic for random distribution app ----
+server <- function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the data ----
+  output$table <- renderTable({
+    d()
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/06_tabsets/server.R

@@ -1,44 +0,0 @@
-library(shiny)
-
-# Define server logic for random distribution application
-function(input, output) {
-  
-  # Reactive expression to generate the requested distribution.
-  # This is called whenever the inputs change. The output
-  # functions defined below then all use the value computed from
-  # this expression
-  data <- reactive({
-    dist <- switch(input$dist,
-                   norm = rnorm,
-                   unif = runif,
-                   lnorm = rlnorm,
-                   exp = rexp,
-                   rnorm)
-    
-    dist(input$n)
-  })
-  
-  # Generate a plot of the data. Also uses the inputs to build
-  # the plot label. Note that the dependencies on both the inputs
-  # and the data reactive expression are both tracked, and
-  # all expressions are called in the sequence implied by the
-  # dependency graph
-  output$plot <- renderPlot({
-    dist <- input$dist
-    n <- input$n
-    
-    hist(data(), 
-         main=paste('r', dist, '(', n, ')', sep=''))
-  })
-  
-  # Generate a summary of the data
-  output$summary <- renderPrint({
-    summary(data())
-  })
-  
-  # Generate an HTML table view of the data
-  output$table <- renderTable({
-    data.frame(x=data())
-  })
-  
-}

inst/examples/06_tabsets/ui.R

@@ -1,38 +0,0 @@
-library(shiny)
-
-# Define UI for random distribution application 
-fluidPage(
-    
-  # Application title
-  titlePanel("Tabsets"),
-  
-  # Sidebar with controls to select the random distribution type
-  # and number of observations to generate. Note the use of the
-  # br() element to introduce extra vertical spacing
-  sidebarLayout(
-    sidebarPanel(
-      radioButtons("dist", "Distribution type:",
-                   c("Normal" = "norm",
-                     "Uniform" = "unif",
-                     "Log-normal" = "lnorm",
-                     "Exponential" = "exp")),
-      br(),
-      
-      sliderInput("n", 
-                  "Number of observations:", 
-                   value = 500,
-                   min = 1, 
-                   max = 1000)
-    ),
-    
-    # Show a tabset that includes a plot, summary, and table view
-    # of the generated distribution
-    mainPanel(
-      tabsetPanel(type = "tabs", 
-        tabPanel("Plot", plotOutput("plot")), 
-        tabPanel("Summary", verbatimTextOutput("summary")), 
-        tabPanel("Table", tableOutput("table"))
-      )
-    )
-  )
-)

inst/examples/07_widgets/app.R

@@ -0,0 +1,82 @@
+library(shiny)
+
+# Define UI for dataset viewer app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("More Widgets"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select a dataset ----
+      selectInput("dataset", "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Input: Specify the number of observations to view ----
+      numericInput("obs", "Number of observations to view:", 10),
+
+      # Include clarifying text ----
+      helpText("Note: while the data view will show only the specified",
+               "number of observations, the summary will still be based",
+               "on the full dataset."),
+
+      # Input: actionButton() to defer the rendering of output ----
+      # until the user explicitly clicks the button (rather than
+      # doing it immediately when inputs change). This is useful if
+      # the computations required to render output are inordinately
+      # time-consuming.
+      actionButton("update", "Update View")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Header + summary of distribution ----
+      h4("Summary"),
+      verbatimTextOutput("summary"),
+
+      # Output: Header + table of distribution ----
+      h4("Observations"),
+      tableOutput("view")
+    )
+
+  )
+)
+
+# Define server logic to summarize and view selected dataset ----
+server <- function(input, output) {
+
+  # Return the requested dataset ----
+  # Note that we use eventReactive() here, which depends on
+  # input$update (the action button), so that the output is only
+  # updated when the user clicks the button
+  datasetInput <- eventReactive(input$update, {
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  }, ignoreNULL = FALSE)
+
+  # Generate a summary of the dataset ----
+  output$summary <- renderPrint({
+    dataset <- datasetInput()
+    summary(dataset)
+  })
+
+  # Show the first "n" observations ----
+  # The use of isolate() is necessary because we don't want the table
+  # to update whenever input$obs changes (only when the user clicks
+  # the action button)
+  output$view <- renderTable({
+    head(datasetInput(), n = isolate(input$obs))
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/07_widgets/server.R

@@ -1,32 +0,0 @@
-library(shiny)
-library(datasets)
-
-# Define server logic required to summarize and view the
-# selected dataset
-function(input, output) {
-
-  # Return the requested dataset. Note that we use `eventReactive()`
-  # here, which takes a dependency on input$update (the action
-  # button), so that the output is only updated when the user
-  # clicks the button.
-  datasetInput <- eventReactive(input$update, {
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  }, ignoreNULL = FALSE)
-
-  # Generate a summary of the dataset
-  output$summary <- renderPrint({
-    dataset <- datasetInput()
-    summary(dataset)
-  })
-
-  # Show the first "n" observations. The use of `isolate()` here
-  # is necessary because we don't want the table to update
-  # whenever input$obs changes (only when the user clicks the
-  # action button).
-  output$view <- renderTable({
-    head(datasetInput(), n = isolate(input$obs))
-  })
-}

inst/examples/07_widgets/ui.R

@@ -1,43 +0,0 @@
-library(shiny)
-
-# Define UI for dataset viewer application
-fluidPage(
-
-  # Application title.
-  titlePanel("More Widgets"),
-
-  # Sidebar with controls to select a dataset and specify the
-  # number of observations to view. The helpText function is
-  # also used to include clarifying text. Most notably, the
-  # inclusion of an actionButton defers the rendering of output
-  # until the user explicitly clicks the button (rather than
-  # doing it immediately when inputs change). This is useful if
-  # the computations required to render output are inordinately
-  # time-consuming.
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:",
-                  choices = c("rock", "pressure", "cars")),
-
-      numericInput("obs", "Number of observations to view:", 10),
-
-      helpText("Note: while the data view will show only the specified",
-               "number of observations, the summary will still be based",
-               "on the full dataset."),
-
-      actionButton("update", "Update View")
-    ),
-
-    # Show a summary of the dataset and an HTML table with the
-    # requested number of observations. Note the use of the h4
-    # function to provide an additional header above each output
-    # section.
-    mainPanel(
-      h4("Summary"),
-      verbatimTextOutput("summary"),
-
-      h4("Observations"),
-      tableOutput("view")
-    )
-  )
-)

inst/examples/08_html/Readme.md

@@ -1,4 +1 @@
-Normally we use the built-in functions, such as `textInput()`, to generate
-the HTML UI in the R script `ui.R`. Actually **shiny** also works with a
-custom HTML page `www/index.html`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#html-ui) for more details.
+Normally we use the built-in functions, such as `textInput()`, to generate the HTML UI in the R script `ui.R`. Actually **shiny** also works with a custom HTML page `www/index.html`. See [the tutorial](http://shiny.rstudio.com/tutorial/) for more details.

inst/examples/08_html/app.R

@@ -0,0 +1,47 @@
+library(shiny)
+
+# Define server logic for random distribution app ----
+server <- function(input, output) {
+
+  # Reactive expression to generate the requested distribution ----
+  # This is called whenever the inputs change. The output functions
+  # defined below then use the value computed from this expression
+  d <- reactive({
+    dist <- switch(input$dist,
+                   norm = rnorm,
+                   unif = runif,
+                   lnorm = rlnorm,
+                   exp = rexp,
+                   rnorm)
+
+    dist(input$n)
+  })
+
+  # Generate a plot of the data ----
+  # Also uses the inputs to build the plot label. Note that the
+  # dependencies on the inputs and the data reactive expression are
+  # both tracked, and all expressions are called in the sequence
+  # implied by the dependency graph.
+  output$plot <- renderPlot({
+    dist <- input$dist
+    n <- input$n
+
+    hist(d(),
+         main = paste("r", dist, "(", n, ")", sep = ""),
+         col = "#75AADB", border = "white")
+  })
+
+  # Generate a summary of the data ----
+  output$summary <- renderPrint({
+    summary(d())
+  })
+
+  # Generate an HTML table view of the head of the data ----
+  output$table <- renderTable({
+    head(data.frame(x = d()))
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui = htmlTemplate("www/index.html"), server)

inst/examples/08_html/server.R

@@ -1,42 +0,0 @@
-library(shiny)
-
-# Define server logic for random distribution application
-function(input, output) {
-  
-  # Reactive expression to generate the requested distribution. This is 
-  # called whenever the inputs change. The output expressions defined 
-  # below then all used the value computed from this expression
-  data <- reactive({
-    dist <- switch(input$dist,
-                   norm = rnorm,
-                   unif = runif,
-                   lnorm = rlnorm,
-                   exp = rexp,
-                   rnorm)
-    
-    dist(input$n)
-  })
-  
-  # Generate a plot of the data. Also uses the inputs to build the 
-  # plot label. Note that the dependencies on both the inputs and
-  # the data reactive expression are both tracked, and all expressions 
-  # are called in the sequence implied by the dependency graph
-  output$plot <- renderPlot({
-    dist <- input$dist
-    n <- input$n
-    
-    hist(data(), 
-         main=paste('r', dist, '(', n, ')', sep=''))
-  })
-  
-  # Generate a summary of the data
-  output$summary <- renderPrint({
-    summary(data())
-  })
-  
-  # Generate an HTML table view of the data
-  output$table <- renderTable({
-    data.frame(x=data())
-  })
-  
-}

inst/examples/08_html/www/index.html

@@ -3,13 +3,13 @@
 <head>
   <script src="shared/jquery.js" type="text/javascript"></script>
   <script src="shared/shiny.js" type="text/javascript"></script>
-  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/> 
+  <link rel="stylesheet" type="text/css" href="shared/shiny.css"/>
 </head>
- 
+
 <body>
 
   <h1>HTML UI</h1>
- 
+
   <p>
     <label>Distribution type:</label><br />
     <select name="dist">
@@ -17,22 +17,25 @@
       <option value="unif">Uniform</option>
       <option value="lnorm">Log-normal</option>
       <option value="exp">Exponential</option>
-    </select> 
+    </select>
   </p>
- 
+
   <p>
- 
-    <label>Number of observations:</label><br /> 
+
+    <label>Number of observations:</label><br />
     <input type="number" name="n" value="500" min="1" max="1000" />
 
   </p>
- 
-  <pre id="summary" class="shiny-text-output"></pre> 
-  
-  <div id="plot" class="shiny-plot-output" 
-       style="width: 100%; height: 400px"></div> 
-  
+
+  <h3>Summary of data:</h3>
+  <pre id="summary" class="shiny-text-output"></pre>
+
+  <h3>Plot of data:</h3>
+  <div id="plot" class="shiny-plot-output"
+       style="width: 100%; height: 300px"></div>
+
+  <h3>Head of data:</h3>
   <div id="table" class="shiny-html-output"></div>
- 
+
 </body>
-</html>
+</html>

inst/examples/09_upload/Readme.md

@@ -1,4 +1,3 @@
 We can add a file upload input in the UI using the function `fileInput()`,
-e.g. `fileInput('foo')`. In `server.R`, we can access the uploaded files via
-`input$foo`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#uploads) for more details.
+e.g. `fileInput('foo')`. In the `server` function, we can access the 
+uploaded files via `input$foo`.

inst/examples/09_upload/app.R

@@ -0,0 +1,92 @@
+library(shiny)
+
+# Define UI for data upload app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Uploading Files"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Select a file ----
+      fileInput("file1", "Choose CSV File",
+                multiple = TRUE,
+                accept = c("text/csv",
+                         "text/comma-separated-values,text/plain",
+                         ".csv")),
+
+      # Horizontal line ----
+      tags$hr(),
+
+      # Input: Checkbox if file has header ----
+      checkboxInput("header", "Header", TRUE),
+
+      # Input: Select separator ----
+      radioButtons("sep", "Separator",
+                   choices = c(Comma = ",",
+                               Semicolon = ";",
+                               Tab = "\t"),
+                   selected = ","),
+
+      # Input: Select quotes ----
+      radioButtons("quote", "Quote",
+                   choices = c(None = "",
+                               "Double Quote" = '"',
+                               "Single Quote" = "'"),
+                   selected = '"'),
+
+      # Horizontal line ----
+      tags$hr(),
+
+      # Input: Select number of rows to display ----
+      radioButtons("disp", "Display",
+                   choices = c(Head = "head",
+                               All = "all"),
+                   selected = "head")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      # Output: Data file ----
+      tableOutput("contents")
+
+    )
+
+  )
+)
+
+# Define server logic to read selected file ----
+server <- function(input, output) {
+
+  output$contents <- renderTable({
+
+    # input$file1 will be NULL initially. After the user selects
+    # and uploads a file, head of that data file by default,
+    # or all rows if selected, will be shown.
+
+    req(input$file1)
+
+    df <- read.csv(input$file1$datapath,
+             header = input$header,
+             sep = input$sep,
+             quote = input$quote)
+
+    if(input$disp == "head") {
+      return(head(df))
+    }
+    else {
+      return(df)
+    }
+
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/09_upload/server.R

@@ -1,20 +0,0 @@
-library(shiny)
-
-function(input, output) {
-  output$contents <- renderTable({
-    
-    # input$file1 will be NULL initially. After the user selects
-    # and uploads a file, it will be a data frame with 'name',
-    # 'size', 'type', and 'datapath' columns. The 'datapath'
-    # column will contain the local filenames where the data can
-    # be found.
-
-    inFile <- input$file1
-
-    if (is.null(inFile))
-      return(NULL)
-    
-    read.csv(inFile$datapath, header=input$header, sep=input$sep,
-             quote=input$quote)
-  })
-}

inst/examples/09_upload/ui.R

@@ -1,28 +0,0 @@
-library(shiny)
-
-fluidPage(
-  titlePanel("Uploading Files"),
-  sidebarLayout(
-    sidebarPanel(
-      fileInput('file1', 'Choose CSV File',
-                accept=c('text/csv', 
-                'text/comma-separated-values,text/plain',
-                '.csv')),
-      tags$hr(),
-      checkboxInput('header', 'Header', TRUE),
-      radioButtons('sep', 'Separator',
-                   c(Comma=',',
-                     Semicolon=';',
-                     Tab='\t'),
-                   ','),
-      radioButtons('quote', 'Quote',
-                   c(None='',
-                     'Double Quote'='"',
-                     'Single Quote'="'"),
-                   '"')
-    ),
-    mainPanel(
-      tableOutput('contents')
-    )
-  )
-)

inst/examples/10_download/Readme.md

@@ -1,4 +1,2 @@
 We can add a download button to the UI using `downloadButton()`, and write
-the content of the file in `downloadHandler()` in `server.R`. See [the
-tutorial](http://rstudio.github.io/shiny/tutorial/#downloads) for more
-details.
+the content of the file in `downloadHandler()` in the `server` function.

inst/examples/10_download/app.R

@@ -0,0 +1,63 @@
+library(shiny)
+
+# Define UI for data download app ----
+ui <- fluidPage(
+
+  # App title ----
+  titlePanel("Downloading Data"),
+
+  # Sidebar layout with input and output definitions ----
+  sidebarLayout(
+
+    # Sidebar panel for inputs ----
+    sidebarPanel(
+
+      # Input: Choose dataset ----
+      selectInput("dataset", "Choose a dataset:",
+                  choices = c("rock", "pressure", "cars")),
+
+      # Button
+      downloadButton("downloadData", "Download")
+
+    ),
+
+    # Main panel for displaying outputs ----
+    mainPanel(
+
+      tableOutput("table")
+
+    )
+
+  )
+)
+
+# Define server logic to display and download selected file ----
+server <- function(input, output) {
+
+  # Reactive value for selected dataset ----
+  datasetInput <- reactive({
+    switch(input$dataset,
+           "rock" = rock,
+           "pressure" = pressure,
+           "cars" = cars)
+  })
+
+  # Table of selected dataset ----
+  output$table <- renderTable({
+    datasetInput()
+  })
+
+  # Downloadable csv of selected dataset ----
+  output$downloadData <- downloadHandler(
+    filename = function() {
+      paste(input$dataset, ".csv", sep = "")
+    },
+    content = function(file) {
+      write.csv(datasetInput(), file, row.names = FALSE)
+    }
+  )
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/10_download/server.R

@@ -1,21 +0,0 @@
-function(input, output) {
-  datasetInput <- reactive({
-    switch(input$dataset,
-           "rock" = rock,
-           "pressure" = pressure,
-           "cars" = cars)
-  })
-  
-  output$table <- renderTable({
-    datasetInput()
-  })
-  
-  output$downloadData <- downloadHandler(
-    filename = function() { 
-      paste(input$dataset, '.csv', sep='')
-    },
-    content = function(file) {
-      write.csv(datasetInput(), file)
-    }
-  )
-}

inst/examples/10_download/ui.R

@@ -1,13 +0,0 @@
-fluidPage(
-  titlePanel('Downloading Data'),
-  sidebarLayout(
-    sidebarPanel(
-      selectInput("dataset", "Choose a dataset:", 
-                  choices = c("rock", "pressure", "cars")),
-      downloadButton('downloadData', 'Download')
-    ),
-    mainPanel(
-      tableOutput('table')
-    )
-  )
-)

inst/examples/11_timer/app.R

@@ -0,0 +1,21 @@
+library(shiny)
+
+# Define UI for displaying current time ----
+ui <- fluidPage(
+
+  h2(textOutput("currentTime"))
+
+)
+
+# Define server logic to show current time, update every second ----
+server <- function(input, output, session) {
+
+  output$currentTime <- renderText({
+    invalidateLater(1000, session)
+    paste("The current time is", Sys.time())
+  })
+
+}
+
+# Create Shiny app ----
+shinyApp(ui, server)

inst/examples/11_timer/server.R

@@ -1,6 +0,0 @@
-function(input, output, session) {
-  output$currentTime <- renderText({
-    invalidateLater(1000, session)
-    paste("The current time is", Sys.time())
-  })
-}

inst/examples/11_timer/ui.R

@@ -1,3 +0,0 @@
-fluidPage(
-  textOutput("currentTime")
-)

inst/staticdocs/index.r

@@ -57,6 +57,8 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
+    "insertTab",
+    "showTab",
     "updateTextInput",
     "updateTextAreaInput",
     "updateQueryString",
@@ -113,7 +115,8 @@ sd_section("Rendering functions",
     "reactivePrint",
     "reactiveTable",
     "reactiveText",
-    "reactiveUI"
+    "reactiveUI",
+    "createRenderFunction"
   )
 )
 sd_section("Reactive programming",
@@ -154,7 +157,8 @@ sd_section("Running",
     "runGadget",
     "runUrl",
     "stopApp",
-    "viewer"
+    "viewer",
+    "isRunning"
   )
 )
 sd_section("Bookmarking state",
@@ -193,12 +197,16 @@ sd_section("Utility functions",
     "parseQueryString",
     "plotPNG",
     "exportTestValues",
+    "setSerializer",
     "snapshotExclude",
+    "snapshotPreprocessInput",
+    "snapshotPreprocessOutput",
     "markOutputAttrs",
     "repeatable",
     "shinyDeprecated",
     "serverInfo",
-    "shiny-options"
+    "shiny-options",
+    "onStop"
   )
 )
 sd_section("Plot interaction",

inst/www/reactive-graph.html

@@ -1,8 +1,8 @@
 <!DOCTYPE html>
 <html>
-<script src="http://ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
-<script src="http://d3js.org/d3.v3.min.js" charset="utf-8"></script>
-<link href='http://fonts.googleapis.com/css?family=Source+Sans+Pro:200,400,600' rel='stylesheet' type='text/css'>
+<script src="https://ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
+<script src="https://d3js.org/d3.v3.min.js" charset="utf-8"></script>
+<link href='https://fonts.googleapis.com/css?family=Source+Sans+Pro:200,400,600' rel='stylesheet' type='text/css'>
 <style type="text/css">
 html, body {
   font-family: 'Source Sans Pro', sans-serif;

inst/www/shared/ionrangeslider/css/ion.rangeSlider.skinRound.css

@@ -0,0 +1,108 @@
+/* Ion.RangeSlider, Round Skin
+// css version 2.2.0
+// © Denis Ineshin, 2014           https://github.com/IonDen
+// © Veaceslav Grimalschi, 2018    https://github.com/grimalschi
+// ===================================================================================================================*/
+
+/* =====================================================================================================================
+// Skin details */
+
+.irs {
+    height: 50px;
+    font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
+}
+
+.irs-with-grid {
+    height: 67px;
+}
+
+.irs-line {
+    top: 36px;
+    height: 4px;
+    background: #DEE4EC;
+    border-radius: 16px;
+}
+
+.irs-bar, .irs-bar-edge {
+    top: 36px;
+    height: 4px;
+    background: #006CFA;
+}
+.irs-bar-edge {
+    width: 12px;
+}
+
+.irs-shadow {
+    height: 4px;
+    top: 40px;
+    background: #DEE4EC;
+    opacity: 0.5;
+}
+
+.lt-ie9 .irs-shadow {
+    filter: alpha(opacity=25);
+}
+
+.irs-slider {
+    top: 35px;
+    width: 16px;
+    height: 16px;
+    margin-top: -10px;
+    border: 4px solid #006CFA;
+    background: white;
+    border-radius: 27px;
+    box-shadow: 0 1px 3px rgba(0,0,255,0.3);
+    cursor: pointer;
+    box-sizing: content-box;
+}
+
+.irs-slider.state_hover, .irs-slider:hover {
+    background: #f0f6ff;
+}
+
+.irs-min, .irs-max {
+    color: #333;
+    font-size: 14px;
+    top: 0;
+    padding: 3px 5px;
+    background: rgba(0,0,0,0.1);
+    border-radius: 3px;
+    line-height: 1;
+}
+
+.irs-from, .irs-to, .irs-single {
+    color: #fff;
+    font-size: 14px;
+    text-shadow: none;
+    padding: 3px 5px;
+    background: #006CFA;
+    border-radius: 3px;
+    line-height: 1;
+}
+.irs-from:after, .irs-to:after, .irs-single:after {
+    position: absolute;
+    display: block;
+    content: "";
+    bottom: -6px;
+    left: 50%;
+    width: 0;
+    height: 0;
+    margin-left: -3px;
+    overflow: hidden;
+    border: 3px solid transparent;
+    border-top-color: #006CFA;
+}
+
+.irs-grid {
+    height: 27px;
+}
+.irs-grid-pol {
+    background: #DEE4EC;
+}
+
+.irs-grid-text {
+    bottom: 4px;
+    color: silver;
+    font-size: 12px;
+}
+

inst/www/shared/ionrangeslider/css/ion.rangeSlider.skinSquare.css

@@ -0,0 +1,87 @@
+/* Ion.RangeSlider, Square Skin
+// css version 2.2.0
+// © Denis Ineshin, 2014           https://github.com/IonDen
+// © Veaceslav Grimalschi, 2018    https://github.com/grimalschi
+// ===================================================================================================================*/
+
+/* =====================================================================================================================
+// Skin details */
+
+.irs {
+    height: 45px;
+    font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
+}
+
+.irs-with-grid {
+    height: 62px;
+}
+
+.irs-line {
+    top: 31px;
+    height: 4px;
+    background: #DEDEDE;
+}
+
+.irs-bar, .irs-bar-edge {
+    top: 31px;
+    height: 4px;
+    background: black;
+}
+.irs-bar-edge {
+    width: 8px;
+}
+
+.irs-shadow {
+    height: 2px;
+    top: 37px;
+    background: #DEDEDE;
+}
+
+.irs-slider {
+    top: 30px;
+    width: 10px;
+    height: 10px;
+    margin-top: -5px;
+    border: 3px solid black;
+    background: white;
+    cursor: pointer;
+    box-sizing: content-box;
+    -webkit-transform: rotate(45deg);
+    -ms-transform: rotate(45deg);
+    transform: rotate(45deg);
+}
+
+.irs-slider.state_hover, .irs-slider:hover {
+    background: #f0f0f0;
+}
+
+.irs-min, .irs-max {
+    color: #333;
+    font-size: 13px;
+    top: 0;
+    padding: 3px 4px;
+    background: rgba(0,0,0,0.1);
+    line-height: 1;
+}
+
+.irs-from, .irs-to, .irs-single {
+    color: #fff;
+    font-size: 13px;
+    text-shadow: none;
+    padding: 3px 4px;
+    background: black;
+    line-height: 1;
+}
+
+.irs-grid {
+    height: 27px;
+}
+.irs-grid-pol {
+    background: #DEDEDE;
+}
+
+.irs-grid-text {
+    bottom: 4px;
+    color: silver;
+    font-size: 11px;
+}

inst/www/shared/ionrangeslider/js/ion.rangeSlider.js

@@ -1,6 +1,6 @@
 // Ion.RangeSlider
-// version 2.1.6 Build: 369
-// © Denis Ineshin, 2016
+// version 2.2.0 Build: 380
+// © Denis Ineshin, 2017
 // https://github.com/IonDen
 //
 // Project page:    http://ionden.com/a/plugins/ion.rangeSlider/en.html
@@ -121,7 +121,7 @@
 
     var base_html =
         '<span class="irs">' +
-        '<span class="irs-line" tabindex="-1"><span class="irs-line-left"></span><span class="irs-line-mid"></span><span class="irs-line-right"></span></span>' +
+        '<span class="irs-line" tabindex="0"><span class="irs-line-left"></span><span class="irs-line-mid"></span><span class="irs-line-right"></span></span>' +
         '<span class="irs-min">0</span><span class="irs-max">1</span>' +
         '<span class="irs-from">0</span><span class="irs-to">0</span><span class="irs-single">0</span>' +
         '</span>' +
@@ -156,7 +156,7 @@
      * @constructor
      */
     var IonRangeSlider = function (input, options, plugin_count) {
-        this.VERSION = "2.1.6";
+        this.VERSION = "2.2.0";
         this.input = input;
         this.plugin_count = plugin_count;
         this.current_plugin = 0;
@@ -169,9 +169,9 @@
         this.dragging = false;
         this.force_redraw = false;
         this.no_diapason = false;
+        this.has_tab_index = true;
         this.is_key = false;
         this.is_update = false;
-        this.is_first_update = true;
         this.is_start = true;
         this.is_finish = false;
         this.is_active = false;
@@ -303,8 +303,7 @@
 
             force_edges: false,
 
-            keyboard: false,
-            keyboard_step: 5,
+            keyboard: true,
 
             grid: false,
             grid_margin: true,
@@ -323,7 +322,11 @@
             input_values_separator: ";",
 
             disable: false,
+            block: false,
 
+            extra_classes: "",
+
+            scope: null,
             onStart: null,
             onChange: null,
             onFinish: null,
@@ -369,7 +372,6 @@
             force_edges: $inp.data("forceEdges"),
 
             keyboard: $inp.data("keyboard"),
-            keyboard_step: $inp.data("keyboardStep"),
 
             grid: $inp.data("grid"),
             grid_margin: $inp.data("gridMargin"),
@@ -387,7 +389,10 @@
 
             input_values_separator: $inp.data("inputValuesSeparator"),
 
-            disable: $inp.data("disable")
+            disable: $inp.data("disable"),
+            block: $inp.data("block"),
+
+            extra_classes: $inp.data("extraClasses"),
         };
         config_from_data.values = config_from_data.values && config_from_data.values.split(",");
 
@@ -498,7 +503,7 @@
          * Appends slider template to a DOM
          */
         append: function () {
-            var container_html = '<span class="irs js-irs-' + this.plugin_count + '"></span>';
+            var container_html = '<span class="irs js-irs-' + this.plugin_count + ' ' + this.options.extra_classes + '"></span>';
             this.$cache.input.before(container_html);
             this.$cache.input.prop("readonly", true);
             this.$cache.cont = this.$cache.input.prev();
@@ -544,11 +549,20 @@
                 this.appendDisableMask();
                 this.$cache.input[0].disabled = true;
             } else {
-                this.$cache.cont.removeClass("irs-disabled");
                 this.$cache.input[0].disabled = false;
+                this.removeDisableMask();
                 this.bindEvents();
             }
 
+            // block only if not disabled
+            if (!this.options.disable) {
+                if (this.options.block) {
+                    this.appendDisableMask();
+                } else {
+                    this.removeDisableMask();
+                }
+            }
+
             if (this.options.drag_interval) {
                 this.$cache.bar[0].style.cursor = "ew-resize";
             }
@@ -581,6 +595,7 @@
             switch (target) {
                 case "single":
                     this.coords.p_gap = this.toFixed(this.coords.p_pointer - this.coords.p_single_fake);
+                    this.$cache.s_single.addClass("state_hover");
                     break;
                 case "from":
                     this.coords.p_gap = this.toFixed(this.coords.p_pointer - this.coords.p_from_fake);
@@ -612,9 +627,18 @@
             this.$cache.cont.addClass("irs-disabled");
         },
 
+        /**
+         * Then slider is not disabled
+         * remove disable mask
+         */
+        removeDisableMask: function () {
+            this.$cache.cont.remove(".irs-disable-mask");
+            this.$cache.cont.removeClass("irs-disabled");
+        },
+
         /**
          * Remove slider instance
-         * and ubind all events
+         * and unbind all events
          */
         remove: function () {
             this.$cache.cont.remove();
@@ -659,6 +683,8 @@
             this.$cache.line.on("touchstart.irs_" + this.plugin_count, this.pointerClick.bind(this, "click"));
             this.$cache.line.on("mousedown.irs_" + this.plugin_count, this.pointerClick.bind(this, "click"));
 
+            this.$cache.line.on("focus.irs_" + this.plugin_count, this.pointerFocus.bind(this));
+
             if (this.options.drag_interval && this.options.type === "double") {
                 this.$cache.bar.on("touchstart.irs_" + this.plugin_count, this.pointerDown.bind(this, "both"));
                 this.$cache.bar.on("mousedown.irs_" + this.plugin_count, this.pointerDown.bind(this, "both"));
@@ -705,6 +731,29 @@
             }
         },
 
+        /**
+         * Focus with tabIndex
+         *
+         * @param e {Object} event object
+         */
+        pointerFocus: function (e) {
+            if (!this.target) {
+                var x;
+                var $handle;
+
+                if (this.options.type === "single") {
+                    $handle = this.$cache.single;
+                } else {
+                    $handle = this.$cache.from;
+                }
+
+                x = $handle.offset().left;
+                x += ($handle.width() / 2) - 1;
+
+                this.pointerClick("single", {preventDefault: function () {}, pageX: x});
+            }
+        },
+
         /**
          * Mousemove or touchmove
          * only for handlers
@@ -864,18 +913,19 @@
         },
 
         /**
-         * Move by key. Beta
-         * @todo refactor than have plenty of time
+         * Move by key
          *
          * @param right {boolean} direction to move
          */
         moveByKey: function (right) {
             var p = this.coords.p_pointer;
+            var p_step = (this.options.max - this.options.min) / 100;
+            p_step = this.options.step / p_step;
 
             if (right) {
-                p += this.options.keyboard_step;
+                p += p_step;
             } else {
-                p -= this.options.keyboard_step;
+                p -= p_step;
             }
 
             this.coords.x_pointer = this.toFixed(this.coords.w_rs / 100 * p);
@@ -902,8 +952,14 @@
                 this.$cache.min.html(this.decorate(this.options.p_values[this.options.min]));
                 this.$cache.max.html(this.decorate(this.options.p_values[this.options.max]));
             } else {
-                this.$cache.min.html(this.decorate(this._prettify(this.options.min), this.options.min));
-                this.$cache.max.html(this.decorate(this._prettify(this.options.max), this.options.max));
+                var min_pretty = this._prettify(this.options.min);
+                var max_pretty = this._prettify(this.options.max);
+
+                this.result.min_pretty = min_pretty;
+                this.result.max_pretty = max_pretty;
+
+                this.$cache.min.html(this.decorate(min_pretty, this.options.min));
+                this.$cache.max.html(this.decorate(max_pretty, this.options.max));
             }
 
             this.labels.w_min = this.$cache.min.outerWidth(false);
@@ -1114,6 +1170,7 @@
 
                 this.result.from_percent = this.coords.p_single_real;
                 this.result.from = this.convertToValue(this.coords.p_single_real);
+                this.result.from_pretty = this._prettify(this.result.from);
 
                 if (this.options.values.length) {
                     this.result.from_value = this.options.values[this.result.from];
@@ -1124,8 +1181,10 @@
 
                 this.result.from_percent = this.coords.p_from_real;
                 this.result.from = this.convertToValue(this.coords.p_from_real);
+                this.result.from_pretty = this._prettify(this.result.from);
                 this.result.to_percent = this.coords.p_to_real;
                 this.result.to = this.convertToValue(this.coords.p_to_real);
+                this.result.to_pretty = this._prettify(this.result.to);
 
                 if (this.options.values.length) {
                     this.result.from_value = this.options.values[this.result.from];
@@ -1364,10 +1423,9 @@
                 if (!this.is_resize && !this.is_update && !this.is_start && !this.is_finish) {
                     this.callOnChange();
                 }
-                if (this.is_key || this.is_click || this.is_first_update) {
+                if (this.is_key || this.is_click) {
                     this.is_key = false;
                     this.is_click = false;
-                    this.is_first_update = false;
                     this.callOnFinish();
                 }
 
@@ -1392,11 +1450,13 @@
                 return;
             }
 
-            var values_num = this.options.values.length,
-                p_values = this.options.p_values,
-                text_single,
-                text_from,
-                text_to;
+            var values_num = this.options.values.length;
+            var p_values = this.options.p_values;
+            var text_single;
+            var text_from;
+            var text_to;
+            var from_pretty;
+            var to_pretty;
 
             if (this.options.hide_from_to) {
                 return;
@@ -1408,7 +1468,9 @@
                     text_single = this.decorate(p_values[this.result.from]);
                     this.$cache.single.html(text_single);
                 } else {
-                    text_single = this.decorate(this._prettify(this.result.from), this.result.from);
+                    from_pretty = this._prettify(this.result.from);
+
+                    text_single = this.decorate(from_pretty, this.result.from);
                     this.$cache.single.html(text_single);
                 }
 
@@ -1445,16 +1507,18 @@
                     this.$cache.to.html(text_to);
 
                 } else {
+                    from_pretty = this._prettify(this.result.from);
+                    to_pretty = this._prettify(this.result.to);
 
                     if (this.options.decorate_both) {
-                        text_single = this.decorate(this._prettify(this.result.from), this.result.from);
+                        text_single = this.decorate(from_pretty, this.result.from);
                         text_single += this.options.values_separator;
-                        text_single += this.decorate(this._prettify(this.result.to), this.result.to);
+                        text_single += this.decorate(to_pretty, this.result.to);
                     } else {
-                        text_single = this.decorate(this._prettify(this.result.from) + this.options.values_separator + this._prettify(this.result.to), this.result.to);
+                        text_single = this.decorate(from_pretty + this.options.values_separator + to_pretty, this.result.to);
                     }
-                    text_from = this.decorate(this._prettify(this.result.from), this.result.from);
-                    text_to = this.decorate(this._prettify(this.result.to), this.result.to);
+                    text_from = this.decorate(from_pretty, this.result.from);
+                    text_to = this.decorate(to_pretty, this.result.to);
 
                     this.$cache.single.html(text_single);
                     this.$cache.from.html(text_from);
@@ -1606,28 +1670,44 @@
             this.writeToInput();
 
             if (this.options.onStart && typeof this.options.onStart === "function") {
-                this.options.onStart(this.result);
+                if (this.options.scope) {
+                    this.options.onStart.call(this.options.scope, this.result);
+                } else {
+                    this.options.onStart(this.result);
+                }
             }
         },
         callOnChange: function () {
             this.writeToInput();
 
             if (this.options.onChange && typeof this.options.onChange === "function") {
-                this.options.onChange(this.result);
+                if (this.options.scope) {
+                    this.options.onChange.call(this.options.scope, this.result);
+                } else {
+                    this.options.onChange(this.result);
+                }
             }
         },
         callOnFinish: function () {
             this.writeToInput();
 
             if (this.options.onFinish && typeof this.options.onFinish === "function") {
-                this.options.onFinish(this.result);
+                if (this.options.scope) {
+                    this.options.onFinish.call(this.options.scope, this.result);
+                } else {
+                    this.options.onFinish(this.result);
+                }
             }
         },
         callOnUpdate: function () {
             this.writeToInput();
 
             if (this.options.onUpdate && typeof this.options.onUpdate === "function") {
-                this.options.onUpdate(this.result);
+                if (this.options.scope) {
+                    this.options.onUpdate.call(this.options.scope, this.result);
+                } else {
+                    this.options.onUpdate(this.result);
+                }
             }
         },
 
@@ -1639,6 +1719,14 @@
 
         toggleInput: function () {
             this.$cache.input.toggleClass("irs-hidden-input");
+
+            if (this.has_tab_index) {
+                this.$cache.input.prop("tabindex", -1);
+            } else {
+                this.$cache.input.removeProp("tabindex");
+            }
+
+            this.has_tab_index = !this.has_tab_index;
         },
 
         /**
@@ -1897,7 +1985,6 @@
             if (typeof o.to_min === "string") o.to_min = +o.to_min;
             if (typeof o.to_max === "string") o.to_max = +o.to_max;
 
-            if (typeof o.keyboard_step === "string") o.keyboard_step = +o.keyboard_step;
             if (typeof o.grid_num === "string") o.grid_num = +o.grid_num;
 
             if (o.max < o.min) {
@@ -1912,7 +1999,6 @@
                 o.grid_num = o.max;
                 o.grid_snap = true;
 
-
                 for (i = 0; i < vl; i++) {
                     value = +v[i];
 
@@ -1968,10 +2054,6 @@
                 o.step = 1;
             }
 
-            if (typeof o.keyboard_step !== "number" || isNaN(o.keyboard_step) || !o.keyboard_step || o.keyboard_step < 0) {
-                o.keyboard_step = 5;
-            }
-
             if (typeof o.from_min === "number" && o.from < o.from_min) {
                 o.from = o.from_min;
             }
@@ -2057,6 +2139,7 @@
         updateFrom: function () {
             this.result.from = this.options.from;
             this.result.from_percent = this.convertToPercent(this.result.from);
+            this.result.from_pretty = this._prettify(this.result.from);
             if (this.options.values) {
                 this.result.from_value = this.options.values[this.result.from];
             }
@@ -2065,6 +2148,7 @@
         updateTo: function () {
             this.result.to = this.options.to;
             this.result.to_percent = this.convertToPercent(this.result.to);
+            this.result.to_pretty = this._prettify(this.result.to);
             if (this.options.values) {
                 this.result.to_value = this.options.values[this.result.to];
             }
@@ -2107,8 +2191,15 @@
             this.calcGridMargin();
 
             if (o.grid_snap) {
-                big_num = total / o.step;
-                big_p = this.toFixed(o.step / (total / 100));
+
+                if (total > 50) {
+                    big_num = 50 / o.step;
+                    big_p = this.toFixed(o.step / 0.5);
+                } else {
+                    big_num = total / o.step;
+                    big_p = this.toFixed(o.step / (total / 100));
+                }
+
             } else {
                 big_p = this.toFixed(100 / big_num);
             }
@@ -2133,11 +2224,6 @@
 
                 if (big_w > 100) {
                     big_w = 100;
-
-                    local_small_max -= 2;
-                    if (local_small_max < 0) {
-                        local_small_max = 0;
-                    }
                 }
                 this.coords.big[i] = big_w;
 

inst/www/shared/shiny.css

@@ -373,3 +373,11 @@ pre.shiny-text-output.noplaceholder:empty {
   text-decoration: underline;
   font-weight: bold;
 }
+
+.shiny-file-input-active {
+  box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(102, 175, 233, .6);
+}
+
+.shiny-file-input-over {
+  box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(76, 174, 76, .6);
+}

man/checkboxGroupInput.Rd

@@ -15,7 +15,8 @@ checkboxGroupInput(inputId, label, choices = NULL, selected = NULL,
 \item{choices}{List of values to show checkboxes for. If elements of the list
 are named then that name rather than the value is displayed to the user. If
 this argument is provided, then \code{choiceNames} and \code{choiceValues}
-must not be provided, and vice-versa.}
+must not be provided, and vice-versa. The values should be strings; other
+types (such as logicals and numbers) will be coerced to strings.}
 
 \item{selected}{The values that should be initially selected, if any.}
 

man/conditionalPanel.Rd

@@ -4,13 +4,16 @@
 \alias{conditionalPanel}
 \title{Conditional Panel}
 \usage{
-conditionalPanel(condition, ...)
+conditionalPanel(condition, ..., ns = NS(NULL))
 }
 \arguments{
 \item{condition}{A JavaScript expression that will be evaluated repeatedly to
 determine whether the panel should be displayed.}
 
 \item{...}{Elements to include in the panel.}
+
+\item{ns}{The \code{\link[=NS]{namespace}} object of the current module, if
+any.}
 }
 \description{
 Creates a panel that is visible or not, depending on the value of a
@@ -32,27 +35,50 @@ You are not recommended to use special JavaScript characters such as a
   value.
 }
 \examples{
-sidebarPanel(
-   selectInput(
-      "plotType", "Plot Type",
-      c(Scatter = "scatter",
-        Histogram = "hist")),
-
-   # Only show this panel if the plot type is a histogram
-   conditionalPanel(
-      condition = "input.plotType == 'hist'",
-      selectInput(
-         "breaks", "Breaks",
-         c("Sturges",
-           "Scott",
-           "Freedman-Diaconis",
-           "[Custom]" = "custom")),
-
-      # Only show this panel if Custom is selected
+## Only run this example in interactive R sessions
+if (interactive()) {
+  ui <- fluidPage(
+    sidebarPanel(
+      selectInput("plotType", "Plot Type",
+        c(Scatter = "scatter", Histogram = "hist")
+      ),
+      # Only show this panel if the plot type is a histogram
       conditionalPanel(
-         condition = "input.breaks == 'custom'",
-         sliderInput("breakCount", "Break Count", min=1, max=1000, value=10)
+        condition = "input.plotType == 'hist'",
+        selectInput(
+          "breaks", "Breaks",
+          c("Sturges", "Scott", "Freedman-Diaconis", "[Custom]" = "custom")
+        ),
+        # Only show this panel if Custom is selected
+        conditionalPanel(
+          condition = "input.breaks == 'custom'",
+          sliderInput("breakCount", "Break Count", min = 1, max = 50, value = 10)
+        )
       )
-   )
-)
+    ),
+    mainPanel(
+      plotOutput("plot")
+    )
+  )
+
+  server <- function(input, output) {
+    x <- rnorm(100)
+    y <- rnorm(100)
+
+    output$plot <- renderPlot({
+      if (input$plotType == "scatter") {
+        plot(x, y)
+      } else {
+        breaks <- input$breaks
+        if (breaks == "custom") {
+          breaks <- input$breakCount
+        }
+
+        hist(x, breaks = breaks)
+      }
+    })
+  }
+
+  shinyApp(ui, server)
+}
 }

man/createRenderFunction.Rd

@@ -0,0 +1,38 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shinywrappers.R
+\name{createRenderFunction}
+\alias{createRenderFunction}
+\title{Implement render functions}
+\usage{
+createRenderFunction(func, transform = function(value, session, name, ...)
+  value, outputFunc = NULL, outputArgs = NULL)
+}
+\arguments{
+\item{func}{A function without parameters, that returns user data. If the
+returned value is a promise, then the render function will proceed in async
+mode.}
+
+\item{transform}{A function that takes four arguments: \code{value},
+\code{session}, \code{name}, and \code{...} (for future-proofing). This
+function will be invoked each time a value is returned from \code{func},
+and is responsible for changing the value into a JSON-ready value to be
+JSON-encoded and sent to the browser.}
+
+\item{outputFunc}{The UI function that is used (or most commonly used) with
+this render function. This can be used in R Markdown documents to create
+complete output widgets out of just the render function.}
+
+\item{outputArgs}{A list of arguments to pass to the \code{outputFunc}.
+Render functions should include \code{outputArgs = list()} in their own
+parameter list, and pass through the value as this argument, to allow app
+authors to customize outputs. (Currently, this is only supported for
+dynamically generated UIs, such as those created by Shiny code snippets
+embedded in R Markdown documents).}
+}
+\value{
+An annotated render function, ready to be assigned to an
+  \code{output} slot.
+}
+\description{
+Implement render functions
+}

man/createWebDependency.Rd

@@ -4,12 +4,18 @@
 \alias{createWebDependency}
 \title{Create a web dependency}
 \usage{
-createWebDependency(dependency)
+createWebDependency(dependency, scrubFile = TRUE)
 }
 \arguments{
 \item{dependency}{A single HTML dependency object, created using
-\code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named, then
-\code{href} and/or \code{file} names must be present.}
+\code{\link[htmltools]{htmlDependency}}. If the \code{src} value is named,
+then \code{href} and/or \code{file} names must be present.}
+
+\item{scrubFile}{If TRUE (the default), remove \code{src$file} for the
+dependency. This prevents the local file path from being sent to the client
+when dynamic web dependencies are used. If FALSE, don't remove
+\code{src$file}. Setting it to FALSE should be needed only in very unusual
+cases.}
 }
 \value{
 A single HTML dependency object that has an \code{href}-named element

man/insertTab.Rd

@@ -0,0 +1,148 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/insert-tab.R
+\name{insertTab}
+\alias{insertTab}
+\alias{prependTab}
+\alias{appendTab}
+\alias{removeTab}
+\title{Dynamically insert/remove a tabPanel}
+\usage{
+insertTab(inputId, tab, target, position = c("before", "after"),
+  select = FALSE, session = getDefaultReactiveDomain())
+
+prependTab(inputId, tab, select = FALSE, menuName = NULL,
+  session = getDefaultReactiveDomain())
+
+appendTab(inputId, tab, select = FALSE, menuName = NULL,
+  session = getDefaultReactiveDomain())
+
+removeTab(inputId, target, session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{inputId}{The \code{id} of the \code{tabsetPanel} (or
+\code{navlistPanel} or \code{navbarPage}) into which \code{tab} will
+be inserted/removed.}
+
+\item{tab}{The item to be added (must be created with \code{tabPanel},
+or with \code{navbarMenu}).}
+
+\item{target}{If inserting: the \code{value} of an existing
+\code{tabPanel}, next to which \code{tab} will be added.
+If removing: the \code{value} of the \code{tabPanel} that
+you want to remove. See Details if you want to insert next to/remove
+an entire \code{navbarMenu} instead.}
+
+\item{position}{Should \code{tab} be added before or after the
+\code{target} tab?}
+
+\item{select}{Should \code{tab} be selected upon being inserted?}
+
+\item{session}{The shiny session within which to call this function.}
+
+\item{menuName}{This argument should only be used when you want to
+prepend (or append) \code{tab} to the beginning (or end) of an
+existing \code{\link{navbarMenu}} (which must itself be part of
+an existing \code{\link{navbarPage}}). In this case, this argument
+should be the \code{menuName} that you gave your \code{navbarMenu}
+when you first created it (by default, this is equal to the value
+of the \code{title} argument). Note that you still need to set the
+\code{inputId} argument to whatever the \code{id} of the parent
+\code{navbarPage} is. If \code{menuName} is left as \code{NULL},
+\code{tab} will be prepended (or appended) to whatever
+\code{inputId} is.}
+}
+\description{
+Dynamically insert or remove a \code{\link{tabPanel}} (or a
+\code{\link{navbarMenu}}) from an existing \code{\link{tabsetPanel}},
+\code{\link{navlistPanel}} or \code{\link{navbarPage}}.
+}
+\details{
+When you want to insert a new tab before or after an existing tab, you
+should use \code{insertTab}. When you want to prepend a tab (i.e. add a
+tab to the beginning of the \code{tabsetPanel}), use \code{prependTab}.
+When you want to append a tab (i.e. add a tab to the end of the
+\code{tabsetPanel}), use \code{appendTab}.
+
+For \code{navbarPage}, you can insert/remove conventional
+\code{tabPanel}s (whether at the top level or nested inside a
+\code{navbarMenu}), as well as an entire \code{\link{navbarMenu}}.
+For the latter case, \code{target} should be the \code{menuName} that
+you gave your \code{navbarMenu} when you first created it (by default,
+this is equal to the value of the \code{title} argument).
+}
+\examples{
+## Only run this example in interactive R sessions
+if (interactive()) {
+
+# example app for inserting/removing a tab
+ui <- fluidPage(
+  sidebarLayout(
+    sidebarPanel(
+      actionButton("add", "Add 'Dynamic' tab"),
+      actionButton("remove", "Remove 'Foo' tab")
+    ),
+    mainPanel(
+      tabsetPanel(id = "tabs",
+        tabPanel("Hello", "This is the hello tab"),
+        tabPanel("Foo", "This is the foo tab"),
+        tabPanel("Bar", "This is the bar tab")
+      )
+    )
+  )
+)
+server <- function(input, output, session) {
+  observeEvent(input$add, {
+    insertTab(inputId = "tabs",
+      tabPanel("Dynamic", "This a dynamically-added tab"),
+      target = "Bar"
+    )
+  })
+  observeEvent(input$remove, {
+    removeTab(inputId = "tabs", target = "Foo")
+  })
+}
+
+shinyApp(ui, server)
+
+
+# example app for prepending/appending a navbarMenu
+ui <- navbarPage("Navbar page", id = "tabs",
+  tabPanel("Home",
+    actionButton("prepend", "Prepend a navbarMenu"),
+    actionButton("append", "Append a navbarMenu")
+  )
+)
+server <- function(input, output, session) {
+  observeEvent(input$prepend, {
+    id <- paste0("Dropdown", input$prepend, "p")
+    prependTab(inputId = "tabs",
+      navbarMenu(id,
+        tabPanel("Drop1", paste("Drop1 page from", id)),
+        tabPanel("Drop2", paste("Drop2 page from", id)),
+        "------",
+        "Header",
+        tabPanel("Drop3", paste("Drop3 page from", id))
+      )
+    )
+  })
+  observeEvent(input$append, {
+    id <- paste0("Dropdown", input$append, "a")
+    appendTab(inputId = "tabs",
+      navbarMenu(id,
+        tabPanel("Drop1", paste("Drop1 page from", id)),
+        tabPanel("Drop2", paste("Drop2 page from", id)),
+        "------",
+        "Header",
+        tabPanel("Drop3", paste("Drop3 page from", id))
+      )
+    )
+  })
+}
+
+shinyApp(ui, server)
+
+}
+}
+\seealso{
+\code{\link{showTab}}
+}

man/isRunning.Rd

@@ -0,0 +1,15 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/server.R
+\name{isRunning}
+\alias{isRunning}
+\title{Check whether a Shiny application is running}
+\usage{
+isRunning()
+}
+\value{
+\code{TRUE} if a Shiny application is currently running. Otherwise,
+  \code{FALSE}.
+}
+\description{
+This function tests whether a Shiny application is currently running.
+}

man/markOutputAttrs.Rd

@@ -4,13 +4,17 @@
 \alias{markOutputAttrs}
 \title{Mark a render function with attributes that will be used by the output}
 \usage{
-markOutputAttrs(renderFunc, snapshotExclude = NULL)
+markOutputAttrs(renderFunc, snapshotExclude = NULL,
+  snapshotPreprocess = NULL)
 }
 \arguments{
 \item{renderFunc}{A function that is suitable for assigning to a Shiny output
 slot.}
 
 \item{snapshotExclude}{If TRUE, exclude the output from test snapshots.}
+
+\item{snapshotPreprocess}{A function for preprocessing the value before
+taking a test snapshot.}
 }
 \description{
 Mark a render function with attributes that will be used by the output

man/navbarPage.Rd

@@ -10,7 +10,7 @@ navbarPage(title, ..., id = NULL, selected = NULL,
   footer = NULL, inverse = FALSE, collapsible = FALSE, collapsable,
   fluid = TRUE, responsive = NULL, theme = NULL, windowTitle = title)
 
-navbarMenu(title, ..., icon = NULL)
+navbarMenu(title, ..., menuName = title, icon = NULL)
 }
 \arguments{
 \item{title}{The title to display in the navbar}
@@ -65,6 +65,10 @@ www directory). For example, to use the theme located at
 \item{windowTitle}{The title that should be displayed by the browser window.
 Useful if \code{title} is not a string.}
 
+\item{menuName}{A name that identifies this \code{navbarMenu}. This
+is needed if you want to insert/remove or show/hide an entire
+\code{navbarMenu}.}
+
 \item{icon}{Optional icon to appear on a \code{navbarMenu} tab.}
 }
 \value{
@@ -98,5 +102,6 @@ navbarPage("App Title",
 }
 \seealso{
 \code{\link{tabPanel}}, \code{\link{tabsetPanel}},
-  \code{\link{updateNavbarPage}}
+  \code{\link{updateNavbarPage}}, \code{\link{insertTab}},
+  \code{\link{showTab}}
 }

man/navlistPanel.Rd

@@ -53,5 +53,6 @@ fluidPage(
 )
 }
 \seealso{
-\code{\link{tabPanel}}, \code{\link{updateNavlistPanel}}
+\code{\link{tabPanel}}, \code{\link{updateNavlistPanel}},
+   \code{\link{insertTab}}, \code{\link{showTab}}
 }

man/onFlush.Rd

@@ -34,3 +34,7 @@ These functions should be called within the application's server function.
 All of these functions return a function which can be called with no
 arguments to cancel the registration.
 }
+\seealso{
+\code{\link{onStop}()} for registering callbacks that will be
+  invoked when the application exits, or when a session ends.
+}

man/onStop.Rd

@@ -0,0 +1,81 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny.R
+\name{onStop}
+\alias{onStop}
+\title{Run code after an application or session ends}
+\usage{
+onStop(fun, session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{fun}{A function that will be called after the app has finished running.}
+
+\item{session}{A scope for when the callback will run. If \code{onStop} is
+called from within the server function, this will default to the current
+session, and the callback will be invoked when the current session ends. If
+\code{onStop} is called outside a server function, then the callback will
+be invoked with the application exits.}
+}
+\value{
+A function which, if invoked, will cancel the callback.
+}
+\description{
+This function registers callback functions that are invoked when the
+application exits (when \code{\link{runApp}} exits), or after each user
+session ends (when a client disconnects).
+}
+\examples{
+## Only run this example in interactive R sessions
+if (interactive()) {
+  # Open this application in multiple browsers, then close the browsers.
+  shinyApp(
+    ui = basicPage("onStop demo"),
+
+    server = function(input, output, session) {
+      onStop(function() cat("Session stopped\\n"))
+    },
+
+    onStart = function() {
+      cat("Doing application setup\\n")
+
+      onStop(function() {
+        cat("Doing application cleanup\\n")
+      })
+    }
+  )
+}
+# In the example above, onStop() is called inside of onStart(). This is
+# the pattern that should be used when creating a shinyApp() object from
+# a function, or at the console. If instead you are writing an app.R which
+# will be invoked with runApp(), you can do it that way, or put the onStop()
+# before the shinyApp() call, as shown below.
+
+\dontrun{
+# ==== app.R ====
+cat("Doing application setup\\n")
+onStop(function() {
+  cat("Doing application cleanup\\n")
+})
+
+shinyApp(
+  ui = basicPage("onStop demo"),
+
+  server = function(input, output, session) {
+    onStop(function() cat("Session stopped\\n"))
+  }
+)
+# ==== end app.R ====
+
+
+# Similarly, if you have a global.R, you can call onStop() from there.
+# ==== global.R ====
+cat("Doing application setup\\n")
+onStop(function() {
+  cat("Doing application cleanup\\n")
+})
+# ==== end global.R ====
+}
+}
+\seealso{
+\code{\link{onSessionEnded}()} for the same functionality, but at
+  the session level only.
+}

man/radioButtons.Rd

@@ -15,25 +15,26 @@ radioButtons(inputId, label, choices = NULL, selected = NULL,
 \item{choices}{List of values to select from (if elements of the list are
 named then that name rather than the value is displayed to the user). If
 this argument is provided, then \code{choiceNames} and \code{choiceValues}
-must not be provided, and vice-versa.}
+must not be provided, and vice-versa. The values should be strings; other
+types (such as logicals and numbers) will be coerced to strings.}
 
-\item{selected}{The initially selected value (if not specified then
-defaults to the first value)}
+\item{selected}{The initially selected value (if not specified then defaults
+to the first value)}
 
 \item{inline}{If \code{TRUE}, render the choices inline (i.e. horizontally)}
 
 \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
 see \code{\link{validateCssUnit}}.}
 
-\item{choiceNames, choiceValues}{List of names and values, respectively,
-that are displayed to the user in the app and correspond to the each
-choice (for this reason, \code{choiceNames} and \code{choiceValues}
-must have the same length). If either of these arguments is
-provided, then the other \emph{must} be provided and \code{choices}
-\emph{must not} be provided. The advantage of using both of these over
-a named list for \code{choices} is that \code{choiceNames} allows any
-type of UI object to be passed through (tag objects, icons, HTML code,
-...), instead of just simple text. See Examples.}
+\item{choiceNames, choiceValues}{List of names and values, respectively, that
+are displayed to the user in the app and correspond to the each choice (for
+this reason, \code{choiceNames} and \code{choiceValues} must have the same
+length). If either of these arguments is provided, then the other
+\emph{must} be provided and \code{choices} \emph{must not} be provided. The
+advantage of using both of these over a named list for \code{choices} is
+that \code{choiceNames} allows any type of UI object to be passed through
+(tag objects, icons, HTML code, ...), instead of just simple text. See
+Examples.}
 }
 \value{
 A set of radio buttons that can be added to a UI definition.
@@ -43,11 +44,10 @@ Create a set of radio buttons used to select an item from a list.
 }
 \details{
 If you need to represent a "None selected" state, it's possible to default
-the radio buttons to have no options selected by using
-\code{selected = character(0)}. However, this is not recommended, as it gives
-the user no way to return to that state once they've made a selection.
-Instead, consider having the first of your choices be \code{c("None selected"
-= "")}.
+the radio buttons to have no options selected by using \code{selected =
+character(0)}. However, this is not recommended, as it gives the user no way
+to return to that state once they've made a selection. Instead, consider
+having the first of your choices be \code{c("None selected" = "")}.
 }
 \examples{
 ## Only run examples in interactive R sessions

man/reactivePoll.Rd

@@ -57,9 +57,22 @@ will be executed in a reactive context; therefore, they may read reactive
 values and reactive expressions.
 }
 \examples{
-# Assume the existence of readTimestamp and readValue functions
 function(input, output, session) {
-  data <- reactivePoll(1000, session, readTimestamp, readValue)
+
+  data <- reactivePoll(1000, session,
+    # This function returns the time that log_file was last modified
+    checkFunc = function() {
+      if (file.exists(log_file))
+        file.info(log_file)$mtime[1]
+      else
+        ""
+    },
+    # This function returns the content of log_file
+    valueFunc = function() {
+      read.csv(log_file)
+    }
+  )
+
   output$dataTable <- renderTable({
     data()
   })