update commit pointer to most recent commit in shiny-test-apps

Changed script tags in reactlog from HTTP to HTTPS

.Rbuildignore

@@ -1,7 +1,7 @@
 ^\.Rproj\.user$
 ^\.git$
 ^examples$
-^shiny\.Rproj$
+^.*\.Rproj$
 ^shiny\.sh$
 ^shiny\.cmd$
 ^run\.R$
@@ -17,3 +17,6 @@
 ^cran-comments.md$
 ^.*\.o$
 ^appveyor\.yml$
+^revdep$
+^tests/testthat/apps/\.git$
+^travis_phantomjs$

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "tests/testthat/apps"]
+	path = tests/testthat/apps
+	url = git@github.com:rstudio/shiny-test-apps.git

.travis.yml

@@ -1,6 +1,39 @@
+dist: trusty
 language: r
+r:
+  - oldrel
+  - release
+  - devel
 sudo: false
-cache: packages
+
+cache:
+  packages: true
+  # Use newer version of PhantomJS than is installed by default on basic R image.
+  # Code referenced from:
+  #   https://github.com/travis-ci/travis-ci/issues/3225#issuecomment-255500144
+  directories:
+    - "travis_phantomjs"
+
+# Need to replace the git: URL with https: so that Travis can check out the
+# submodule.
+git:
+  submodules: false
+
+before_install:
+  # For updated version of PhantomJS
+  - "export PHANTOMJS_VERSION=2.1.1"
+  - "phantomjs --version"
+  - "export PATH=$PWD/travis_phantomjs/phantomjs-$PHANTOMJS_VERSION-linux-x86_64/bin:$PATH"
+  - "hash -r"
+  - "phantomjs --version"
+  - "if [ $(phantomjs --version) != $PHANTOMJS_VERSION ]; then rm -rf $PWD/travis_phantomjs; mkdir -p $PWD/travis_phantomjs; fi"
+  - "if [ $(phantomjs --version) != $PHANTOMJS_VERSION ]; then wget https://github.com/Medium/phantomjs/releases/download/v$PHANTOMJS_VERSION/phantomjs-$PHANTOMJS_VERSION-linux-x86_64.tar.bz2 -O $PWD/travis_phantomjs/phantomjs-$PHANTOMJS_VERSION-linux-x86_64.tar.bz2; fi"
+  - "if [ $(phantomjs --version) != $PHANTOMJS_VERSION ]; then tar -xvf $PWD/travis_phantomjs/phantomjs-$PHANTOMJS_VERSION-linux-x86_64.tar.bz2 -C $PWD/travis_phantomjs; fi"
+  - "if [ $(phantomjs --version) != $PHANTOMJS_VERSION ]; then hash -r; fi"
+  - "phantomjs --version"
+  # For git submodule
+  - sed -i 's/git@github.com:/https:\/\/github.com\//' .gitmodules
+  - git submodule update --init --recursive
 
 notifications:
   email:

CONTRIBUTING.md

@@ -1,10 +1,38 @@
-
 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. 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.
+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).
 
-We'll try to be as responsive as possible in reviewing and accepting pull requests. We appreciate your contributions!
+We generally do not merge pull requests that update included web libraries (such as Bootstrap or jQuery) because it is difficult for us to verify that the update is done correctly; we prefer to update these libraries ourselves.
+
+
+## How to make changes
+
+Before you submit a pull request, please do the following:
+
+* Add an entry to NEWS.md concisely describing what you changed.
+
+* If appropriate, add unit tests in the tests/ directory.
+
+* If you made any changes to the JavaScript files in the srcjs/ directory, make sure you build the output JavaScript files. See tools/README.md file for information on using the build system.
+
+* Run Build->Check Package in the RStudio IDE, or `devtools::check()`, to make sure your change did not add any messages, warnings, or errors.
+
+Doing these things will make it easier for the Shiny development team to evaluate your pull request. Even so, we may still decide to modify your code or even not merge it at all. Factors that may prevent us from merging the pull request include:
+
+* breaking backward compatibility
+* adding a feature that we do not consider relevant for Shiny
+* is hard to understand
+* is hard to maintain in the future
+* is computationally expensive
+* is not intuitive for people to use
+
+We will try to be responsive and provide feedback in case we decide not to merge your pull request.
+
+
+## Filing issues
+
+If you find a bug in Shiny, you can also [file an issue](https://github.com/rstudio/shiny/issues/new). Please provide as much relevant information as you can, and include a minimal reproducible example if possible.

DESCRIPTION

@@ -1,8 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.13.2.9005
-Date: 2016-02-17
+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"),
@@ -15,7 +14,7 @@ Authors@R: c(
     person(family = "jQuery contributors", role = c("ctb", "cph"),
     comment = "jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt"),
     person(family = "jQuery UI contributors", role = c("ctb", "cph"),
-    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/1.10.4/AUTHORS.txt"),
+    comment = "jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt"),
     person("Mark", "Otto", role = "ctb",
     comment = "Bootstrap library"),
     person("Jacob", "Thornton", role = "ctb",
@@ -57,22 +56,23 @@ 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
 Imports:
     utils,
-    httpuv (>= 1.3.3),
+    httpuv (>= 1.3.5),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
     htmltools (>= 0.3.5),
     R6 (>= 2.0),
-    sourcetools
+    sourcetools,
+    tools
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -80,11 +80,16 @@ Suggests:
     knitr (>= 1.6),
     markdown,
     rmarkdown,
-    ggplot2
+    ggplot2,
+    magrittr,
+    DT,
+    shinytest
+Remotes:
+    rstudio/shinytest,
+    rstudio/DT
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-VignetteBuilder: knitr
-Collate:
+Collate: 
     'app.R'
     'bookmark-state-local.R'
     'stack.R'
@@ -99,6 +104,9 @@ Collate:
     'diagnose.R'
     'fileupload.R'
     'graph.R'
+    'reactives.R'
+    'reactive-domains.R'
+    'history.R'
     'hooks.R'
     'html-deps.R'
     'htmltools.R'
@@ -118,7 +126,9 @@ Collate:
     'input-slider.R'
     'input-submit.R'
     'input-text.R'
+    'input-textarea.R'
     'input-utils.R'
+    'insert-tab.R'
     'insert-ui.R'
     'jqueryui.R'
     'middleware-shiny.R'
@@ -129,8 +139,6 @@ Collate:
     'priorityqueue.R'
     'progress.R'
     'react.R'
-    'reactive-domains.R'
-    'reactives.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
@@ -142,7 +150,9 @@ Collate:
     'shinyui.R'
     'shinywrappers.R'
     'showcase.R'
+    'snapshot.R'
     'tar.R'
+    'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 5.0.1
+RoxygenNote: 6.0.1

LICENSE

@@ -12,7 +12,7 @@ these components are included below):
 - Respond.js, https://github.com/scottjehl/Respond
 - bootstrap-datepicker, https://github.com/eternicode/bootstrap-datepicker
 - Font Awesome, https://github.com/FortAwesome/Font-Awesome
-- selectize.js, https://github.com/brianreavis/selectize.js
+- selectize.js, https://github.com/selectize/selectize.js
 - es5-shim, https://github.com/es-shims/es5-shim
 - ion.rangeSlider, https://github.com/IonDen/ion.rangeSlider
 - strftime for Javascript, https://github.com/samsonjs/strftime

NAMESPACE

@@ -22,6 +22,8 @@ S3method(as.shiny.appobj,list)
 S3method(as.shiny.appobj,shiny.appobj)
 S3method(as.tags,shiny.appobj)
 S3method(as.tags,shiny.render.function)
+S3method(format,reactiveExpr)
+S3method(format,reactiveVal)
 S3method(names,reactivevalues)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
@@ -38,6 +40,7 @@ export(actionButton)
 export(actionLink)
 export(addResourcePath)
 export(animationOptions)
+export(appendTab)
 export(as.shiny.appobj)
 export(basicPage)
 export(bookmarkButton)
@@ -61,6 +64,7 @@ export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
+export(debounce)
 export(dialogViewer)
 export(div)
 export(downloadButton)
@@ -69,6 +73,7 @@ export(downloadLink)
 export(em)
 export(enableBookmarking)
 export(eventReactive)
+export(exportTestValues)
 export(exprToFunction)
 export(extractStackTrace)
 export(fileInput)
@@ -82,9 +87,12 @@ export(flowLayout)
 export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
+export(freezeReactiveVal)
 export(freezeReactiveValue)
 export(getDefaultReactiveDomain)
+export(getQueryString)
 export(getShinyOption)
+export(getUrlHash)
 export(h1)
 export(h2)
 export(h3)
@@ -93,6 +101,7 @@ export(h5)
 export(h6)
 export(headerPanel)
 export(helpText)
+export(hideTab)
 export(hoverOpts)
 export(hr)
 export(htmlOutput)
@@ -107,6 +116,7 @@ export(includeMarkdown)
 export(includeScript)
 export(includeText)
 export(inputPanel)
+export(insertTab)
 export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
@@ -114,6 +124,7 @@ export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
 export(is.singleton)
+export(isRunning)
 export(isTruthy)
 export(isolate)
 export(knit_print.html)
@@ -145,6 +156,7 @@ export(onReactiveDomainEnded)
 export(onRestore)
 export(onRestored)
 export(onSessionEnded)
+export(onStop)
 export(outputOptions)
 export(p)
 export(pageWithSidebar)
@@ -154,6 +166,7 @@ export(passwordInput)
 export(plotOutput)
 export(plotPNG)
 export(pre)
+export(prependTab)
 export(printError)
 export(printStackTrace)
 export(radioButtons)
@@ -166,12 +179,14 @@ export(reactiveTable)
 export(reactiveText)
 export(reactiveTimer)
 export(reactiveUI)
+export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
 export(registerInputHandler)
 export(removeInputHandler)
 export(removeModal)
 export(removeNotification)
+export(removeTab)
 export(removeUI)
 export(renderDataTable)
 export(renderImage)
@@ -195,6 +210,7 @@ export(selectizeInput)
 export(serverInfo)
 export(setBookmarkExclude)
 export(setProgress)
+export(setSerializer)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
@@ -205,10 +221,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)
@@ -225,8 +245,10 @@ export(tagAppendChildren)
 export(tagList)
 export(tagSetChildren)
 export(tags)
+export(textAreaInput)
 export(textInput)
 export(textOutput)
+export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
@@ -243,6 +265,7 @@ export(updateSelectInput)
 export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
+export(updateTextAreaInput)
 export(updateTextInput)
 export(urlModal)
 export(validate)

R/app.R

@@ -20,19 +20,29 @@
 #' @param onStart A function that will be called before the app is actually run.
 #'   This is only needed for \code{shinyAppObj}, since in the \code{shinyAppDir}
 #'   case, a \code{global.R} file can be used for this purpose.
-#' @param options Named options that should be passed to the `runApp` call. You
-#'   can also specify \code{width} and \code{height} parameters which provide a
-#'   hint to the embedding environment about the ideal height/width for the app.
+#' @param options Named options that should be passed to the \code{runApp} call
+#'   (these can be any of the following: "port", "launch.browser", "host", "quiet",
+#'   "display.mode" and "test.mode"). You can also specify \code{width} and
+#'   \code{height} parameters which provide a hint to the embedding environment
+#'   about the ideal height/width for the app.
 #' @param uiPattern A regular expression that will be applied to each \code{GET}
 #'   request to determine whether the \code{ui} should be used to handle the
 #'   request. Note that the entire request path must match the regular
 #'   expression in order for the match to be considered successful.
+#' @param enableBookmarking Can be one of \code{"url"}, \code{"server"}, or
+#'   \code{"disable"}. This is equivalent to calling the
+#'   \code{\link{enableBookmarking}()} function just before calling
+#'   \code{shinyApp()}. With the default value (\code{NULL}), the app will
+#'   respect the setting from any previous calls to \code{enableBookmarking()}.
+#'   See \code{\link{enableBookmarking}} for more information.
 #' @return An object that represents the app. Printing the object or passing it
 #'   to \code{\link{runApp}} will run the app.
 #'
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   shinyApp(
 #'     ui = fluidPage(
 #'       numericInput("n", "n", 1),
@@ -61,7 +71,7 @@
 #' }
 #' @export
 shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
-                     uiPattern="/") {
+                     uiPattern="/", enableBookmarking=NULL) {
   if (is.null(server)) {
     stop("`server` missing from shinyApp")
   }
@@ -75,6 +85,11 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
     server
   }
 
+  if (!is.null(enableBookmarking)) {
+    bookmarkStore <- match.arg(enableBookmarking, c("url", "server", "disable"))
+    enableBookmarking(bookmarkStore)
+  }
+
   # Store the appDir and bookmarking-related options, so that we can read them
   # from within the app.
   shinyOptions(appDir = getwd())
@@ -197,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
@@ -208,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"
@@ -220,13 +235,13 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 # ignored when checking extensions. If any changes are detected, all connected
 # Shiny sessions are reloaded.
 #
-# Use option(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
+# Use options(shiny.autoreload = TRUE) to enable this behavior. Since monitoring
 # for changes is expensive (we are polling for mtimes here, nothing fancy) this
 # feature is intended only for development.
 #
 # You can customize the file patterns Shiny will monitor by setting the
 # shiny.autoreload.pattern option. For example, to monitor only ui.R:
-# option(shiny.autoreload.pattern = glob2rx("ui.R"))
+# options(shiny.autoreload.pattern = glob2rx("ui.R"))
 #
 # The return value is a function that halts monitoring when called.
 initAutoReloadMonitor <- function(dir) {
@@ -302,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
@@ -314,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"
@@ -362,7 +378,8 @@ is.shiny.appobj <- function(x) {
 print.shiny.appobj <- function(x, ...) {
   opts <- x$options %OR% list()
   opts <- opts[names(opts) %in%
-      c("port", "launch.browser", "host", "quiet", "display.mode")]
+      c("port", "launch.browser", "host", "quiet",
+        "display.mode", "test.mode")]
 
   args <- c(list(x), opts)
 

R/bookmark-state.R

@@ -65,7 +65,8 @@ saveShinySaveState <- function(state) {
       isolate(state$onSave(state))
 
     # Serialize values, possibly saving some extra data to stateDir
-    inputValues <- serializeReactiveValues(state$input, state$exclude, state$dir)
+    exclude <- c(state$exclude, "._bookmark_")
+    inputValues <- serializeReactiveValues(state$input, exclude, state$dir)
     saveRDS(inputValues, file.path(stateDir, "input.rds"))
 
     # If values were added, save them also.
@@ -75,7 +76,25 @@ saveShinySaveState <- function(state) {
 
   # Pass the saveState function to the save interface function, which will
   # invoke saveState after preparing the directory.
-  saveInterface <- getShinyOption("save.interface", default = saveInterfaceLocal)
+
+  # Look for a save.interface function. This will be defined by the hosting
+  # environment if it supports bookmarking.
+  saveInterface <- getShinyOption("save.interface")
+
+  if (is.null(saveInterface)) {
+    if (inShinyServer()) {
+      # We're in a version of Shiny Server/Connect that doesn't have
+      # bookmarking support.
+      saveInterface <- function(id, callback) {
+        stop("The hosting environment does not support saved-to-server bookmarking.")
+      }
+
+    } else {
+      # We're running Shiny locally.
+      saveInterface <- saveInterfaceLocal
+    }
+  }
+
   saveInterface(id, saveState)
 
   paste0("_state_id_=", encodeURIComponent(id))
@@ -83,7 +102,8 @@ saveShinySaveState <- function(state) {
 
 # Encode the state to a URL. This does not save to disk.
 encodeShinySaveState <- function(state) {
-  inputVals <- serializeReactiveValues(state$input, state$exclude, stateDir = NULL)
+  exclude <- c(state$exclude, "._bookmark_")
+  inputVals <- serializeReactiveValues(state$input, exclude, stateDir = NULL)
 
   # Allow user-supplied onSave function to do things like add state$values.
   if (!is.null(state$onSave))
@@ -95,14 +115,19 @@ encodeShinySaveState <- function(state) {
     USE.NAMES = TRUE
   )
 
-  res <- paste0("_inputs_&",
-    paste0(
-      encodeURIComponent(names(inputVals)),
-      "=",
-      encodeURIComponent(inputVals),
-      collapse = "&"
+  res <- ""
+
+  # If any input values are present, add them.
+  if (length(inputVals) != 0) {
+    res <- paste0(res, "_inputs_&",
+      paste0(
+        encodeURIComponent(names(inputVals)),
+        "=",
+        encodeURIComponent(inputVals),
+        collapse = "&"
+      )
     )
-  )
+  }
 
   # If 'values' is present, add them as well.
   if (length(state$values) != 0) {
@@ -112,7 +137,9 @@ encodeShinySaveState <- function(state) {
       USE.NAMES = TRUE
     )
 
-    res <- paste0(res, "&_values_&",
+    res <- paste0(res,
+      if (length(inputVals != 0)) "&",  # Add separator if there were inputs
+      "_values_&",
       paste0(
         encodeURIComponent(names(values)),
         "=",
@@ -251,7 +278,24 @@ RestoreContext <- R6Class("RestoreContext",
         }
       }
 
-      loadInterface <- getShinyOption("load.interface", default = loadInterfaceLocal)
+      # Look for a load.interface function. This will be defined by the hosting
+      # environment if it supports bookmarking.
+      loadInterface <- getShinyOption("load.interface")
+
+      if (is.null(loadInterface)) {
+        if (inShinyServer()) {
+          # We're in a version of Shiny Server/Connect that doesn't have
+          # bookmarking support.
+          loadInterface <- function(id, callback) {
+            stop("The hosting environment does not support saved-to-server bookmarking.")
+          }
+
+        } else {
+          # We're running Shiny locally.
+          loadInterface <- loadInterfaceLocal
+        }
+      }
+
       loadInterface(id, loadFun)
 
       invisible()
@@ -305,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, "\"")
               }
@@ -318,7 +362,7 @@ RestoreContext <- R6Class("RestoreContext",
       self$input <- RestoreInputSet$new(inputs)
 
       values <- valuesFromJSON(values)
-      self$values <- list2env(values, self$values)
+      self$values <- list2env2(values, self$values)
     }
   )
 )
@@ -341,7 +385,7 @@ RestoreInputSet <- R6Class("RestoreInputSet",
 
   public = list(
     initialize = function(values) {
-      private$values <- list2env(values, parent = emptyenv())
+      private$values <- list2env2(values, parent = emptyenv())
     },
 
     exists = function(name) {
@@ -446,33 +490,155 @@ restoreInput <- function(id, default) {
 #' Update URL in browser's location bar
 #'
 #' This function updates the client browser's query string in the location bar.
-#' It typically is called from an observer.
+#' It typically is called from an observer. Note that this will not work in
+#' Internet Explorer 9 and below.
+#'
+#' For \code{mode = "push"}, only three updates are currently allowed:
+#' \enumerate{
+#'   \item the query string (format: \code{?param1=val1&param2=val2})
+#'   \item the hash (format: \code{#hash})
+#'   \item both the query string and the hash
+#'     (format: \code{?param1=val1&param2=val2#hash})
+#' }
+#'
+#' In other words, if \code{mode = "push"}, the \code{queryString} must start
+#' with either \code{?} or with \code{#}.
+#'
+#' A technical curiosity: under the hood, this function is calling the HTML5
+#' history API (which is where the names for the \code{mode} argument come from).
+#' When \code{mode = "replace"}, the function called is
+#' \code{window.history.replaceState(null, null, queryString)}.
+#' When \code{mode = "push"}, the function called is
+#' \code{window.history.pushState(null, null, queryString)}.
 #'
 #' @param queryString The new query string to show in the location bar.
+#' @param mode When the query string is updated, should the the current history
+#'   entry be replaced (default), or should a new history entry be pushed onto
+#'   the history stack? The former should only be used in a live bookmarking
+#'   context. The latter is useful if you want to navigate between states using
+#'   the browser's back and forward buttons. See Examples.
 #' @param session A Shiny session object.
+#' @seealso \code{\link{enableBookmarking}}, \code{\link{getQueryString}}
+#' @examples
+#' ## Only run these examples in interactive sessions
+#' if (interactive()) {
+#'
+#'   ## App 1: Doing "live" bookmarking
+#'   ## Update the browser's location bar every time an input changes.
+#'   ## This should not be used with enableBookmarking("server"),
+#'   ## because that would create a new saved state on disk every time
+#'   ## the user changes an input.
+#'   enableBookmarking("url")
+#'   shinyApp(
+#'     ui = function(req) {
+#'       fluidPage(
+#'         textInput("txt", "Text"),
+#'         checkboxInput("chk", "Checkbox")
+#'       )
+#'     },
+#'     server = function(input, output, session) {
+#'       observe({
+#'         # Trigger this observer every time an input changes
+#'         reactiveValuesToList(input)
+#'         session$doBookmark()
+#'       })
+#'       onBookmarked(function(url) {
+#'         updateQueryString(url)
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: Printing the value of the query string
+#'   ## (Use the back and forward buttons to see how the browser
+#'   ## keeps a record of each state)
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       textInput("txt", "Enter new query string"),
+#'       helpText("Format: ?param1=val1&param2=val2"),
+#'       actionButton("go", "Update"),
+#'       hr(),
+#'       verbatimTextOutput("query")
+#'     ),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         updateQueryString(input$txt, mode = "push")
+#'       })
+#'       output$query <- renderText({
+#'         query <- getQueryString()
+#'         queryText <- paste(names(query), query,
+#'                        sep = "=", collapse=", ")
+#'         paste("Your query string is:\n", queryText)
+#'       })
+#'     }
+#'   )
+#' }
 #' @export
-updateQueryString <- function(queryString, session = getDefaultReactiveDomain()) {
-  session$updateQueryString(queryString)
+updateQueryString <- function(queryString, mode = c("replace", "push"),
+                              session = getDefaultReactiveDomain()) {
+  mode <- match.arg(mode)
+  session$updateQueryString(queryString, mode)
 }
 
 #' Create a button for bookmarking/sharing
 #'
 #' A \code{bookmarkButton} is a \code{\link{actionButton}} with a default label
-#' that consists of a link icon and the text "Share...". It is meant to be used
-#' for bookmarking state.
+#' that consists of a link icon and the text "Bookmark...". It is meant to be
+#' used for bookmarking state.
 #'
+#' @inheritParams actionButton
 #' @param title A tooltip that is shown when the mouse cursor hovers over the
 #'   button.
+#' @param id An ID for the bookmark button. The only time it is necessary to set
+#'   the ID unless you have more than one bookmark button in your application.
+#'   If you specify an input ID, it should be excluded from bookmarking with
+#'   \code{\link{setBookmarkExclude}}, and you must create an observer that
+#'   does the bookmarking when the button is pressed. See the examples below.
 #'
-#' @seealso enableBookmarking
-#' @inheritParams actionButton
+#' @seealso \code{\link{enableBookmarking}} for more examples.
+#'
+#' @examples
+#' ## Only run these examples in interactive sessions
+#' if (interactive()) {
+#'
+#' # This example shows how to use multiple bookmark buttons. If you only need
+#' # a single bookmark button, see examples in ?enableBookmarking.
+#' ui <- function(request) {
+#'   fluidPage(
+#'     tabsetPanel(id = "tabs",
+#'       tabPanel("One",
+#'         checkboxInput("chk1", "Checkbox 1"),
+#'         bookmarkButton(id = "bookmark1")
+#'       ),
+#'       tabPanel("Two",
+#'         checkboxInput("chk2", "Checkbox 2"),
+#'         bookmarkButton(id = "bookmark2")
+#'       )
+#'     )
+#'   )
+#' }
+#' server <- function(input, output, session) {
+#'   # Need to exclude the buttons from themselves being bookmarked
+#'   setBookmarkExclude(c("bookmark1", "bookmark2"))
+#'
+#'   # Trigger bookmarking with either button
+#'   observeEvent(input$bookmark1, {
+#'     session$doBookmark()
+#'   })
+#'   observeEvent(input$bookmark2, {
+#'     session$doBookmark()
+#'   })
+#' }
+#' enableBookmarking(store = "url")
+#' shinyApp(ui, server)
+#' }
 #' @export
 bookmarkButton <- function(label = "Bookmark...",
   icon = shiny::icon("link", lib = "glyphicon"),
   title = "Bookmark this application's state and get a URL for sharing.",
-  ...)
+  ...,
+  id = "._bookmark_")
 {
-  actionButton("._bookmark_", label, icon, title = title, ...)
+  actionButton(id, label, icon, title = title, ...)
 }
 
 
@@ -498,7 +664,6 @@ urlModal <- function(url, title = "Bookmarked application link", subtitle = NULL
   modalDialog(
     title = title,
     easyClose = TRUE,
-    footer = NULL,
     tags$textarea(class = "form-control", rows = "1", style = "resize: none;",
       readonly = "readonly",
       url
@@ -586,8 +751,8 @@ showBookmarkUrlModal <- function(url) {
 #' \code{function(request) \{ fluidPage(....) \}}.
 #'
 #' By default, all input values will be bookmarked, except for the values of
-#' actionButtons and passwordInputs. fileInputs will be saved if the state is
-#' saved on a server, but not if the state is encoded in a URL.
+#' passwordInputs. fileInputs will be saved if the state is saved on a server,
+#' but not if the state is encoded in a URL.
 #'
 #' When bookmarking state, arbitrary values can be stored, by passing a function
 #' as the \code{onBookmark} argument. That function will be passed a
@@ -608,13 +773,22 @@ showBookmarkUrlModal <- function(url) {
 #'     the current working directory called shiny_bookmarks.
 #' }
 #'
+#' When used with \code{\link{shinyApp}()}, this function must be called before
+#' \code{shinyApp()}, or in the \code{shinyApp()}'s \code{onStart} function. An
+#' alternative to calling the \code{enableBookmarking()} function is to use the
+#' \code{enableBookmarking} \emph{argument} for \code{shinyApp()}. See examples
+#' below.
+#'
 #' @param store Either \code{"url"}, which encodes all of the relevant values in
 #'   a URL, \code{"server"}, which saves to disk on the server, or
 #'   \code{"disable"}, which disables any previously-enabled bookmarking.
 #'
-#' @seealso \code{\link{onBookmark}}, \code{\link{onRestore}}, and
-#'   \code{\link{onRestored}} for registering callback functions that are
-#'   invoked when the state is bookmarked or restored.
+#' @seealso \code{\link{onBookmark}}, \code{\link{onBookmarked}},
+#'   \code{\link{onRestore}}, and \code{\link{onRestored}} for registering
+#'   callback functions that are invoked when the state is bookmarked or
+#'   restored.
+#'
+#'   Also see \code{\link{updateQueryString}}.
 #'
 #' @export
 #' @examples
@@ -626,7 +800,7 @@ showBookmarkUrlModal <- function(url) {
 #'   fluidPage(
 #'     textInput("txt", "Text"),
 #'     checkboxInput("chk", "Checkbox"),
-#'     bookmarkButton("bookmark")
+#'     bookmarkButton()
 #'   )
 #' }
 #' server <- function(input, output, session) { }
@@ -634,15 +808,12 @@ showBookmarkUrlModal <- function(url) {
 #' shinyApp(ui, server)
 #'
 #'
-#' # Basic example with state saved to disk
-#' ui <- function(request) {
-#'   fluidPage(
-#'     textInput("txt", "Text"),
-#'     checkboxInput("chk", "Checkbox"),
-#'     bookmarkButton("bookmark")
-#'   )
-#' }
-#' server <- function(input, output, session) { }
+#' # An alternative to calling enableBookmarking(): use shinyApp's
+#' # enableBookmarking argument
+#' shinyApp(ui, server, enableBookmarking = "url")
+#'
+#'
+#' # Same basic example with state saved to disk
 #' enableBookmarking("server")
 #' shinyApp(ui, server)
 #'
@@ -686,7 +857,7 @@ showBookmarkUrlModal <- function(url) {
 #'   fluidPage(
 #'     sliderInput("slider", "Slider", 1, 100, 50),
 #'     uiOutput("ui"),
-#'     bookmarkButton("bookmark")
+#'     bookmarkButton()
 #'   )
 #' }
 #' server <- function(input, output, session) {
@@ -705,7 +876,7 @@ showBookmarkUrlModal <- function(url) {
 #'     passwordInput("pw", "Password"), # Passwords are never saved
 #'     sliderInput("slider", "Slider", 1, 100, 50), # Manually excluded below
 #'     checkboxInput("chk", "Checkbox"),
-#'     bookmarkButton("bookmark")
+#'     bookmarkButton()
 #'   )
 #' }
 #' server <- function(input, output, session) {
@@ -715,6 +886,29 @@ showBookmarkUrlModal <- function(url) {
 #' shinyApp(ui, server)
 #'
 #'
+#' # Update the browser's location bar every time an input changes. This should
+#' # not be used with enableBookmarking("server"), because that would create a
+#' # new saved state on disk every time the user changes an input.
+#' ui <- function(req) {
+#'   fluidPage(
+#'     textInput("txt", "Text"),
+#'     checkboxInput("chk", "Checkbox")
+#'   )
+#' }
+#' server <- function(input, output, session) {
+#'   observe({
+#'     # Trigger this observer every time an input changes
+#'     reactiveValuesToList(input)
+#'     session$doBookmark()
+#'   })
+#'   onBookmarked(function(url) {
+#'     updateQueryString(url)
+#'   })
+#' }
+#' enableBookmarking("url")
+#' shinyApp(ui, server)
+#'
+#'
 #' # Save/restore uploaded files
 #' ui <- function(request) {
 #'   fluidPage(
@@ -729,7 +923,7 @@ showBookmarkUrlModal <- function(url) {
 #'         ),
 #'         tags$hr(),
 #'         checkboxInput("header", "Header", TRUE),
-#'         bookmarkButton("bookmark")
+#'         bookmarkButton()
 #'       ),
 #'       mainPanel(
 #'         tableOutput("contents")
@@ -790,6 +984,8 @@ setBookmarkExclude <- function(names = character(0), session = getDefaultReactiv
 #' \itemize{
 #'   \item \code{onBookmark} registers a function that will be called just
 #'     before Shiny bookmarks state.
+#'   \item \code{onBookmarked} registers a function that will be called just
+#'     after Shiny bookmarks state.
 #'   \item \code{onRestore} registers a function that will be called when a
 #'     session is restored, after the server function executes, but before all
 #'     other reactives, observers and render functions are run.

R/bootstrap-layout.R

@@ -277,6 +277,7 @@ titlePanel <- function(title, windowTitle=title) {
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' # Define UI
 #' ui <- fluidPage(
@@ -442,6 +443,7 @@ inputPanel <- function(...) {
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' # Server code used for all examples
 #' server <- function(input, output) {

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",
@@ -335,14 +336,25 @@ navbarPage <- function(title,
   if (inverse)
     navbarClass <- paste(navbarClass, "navbar-inverse")
 
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
+
   # build the tabset
   tabs <- list(...)
   tabset <- buildTabset(tabs, "nav navbar-nav", NULL, id, selected)
 
+  # function to return plain or fluid class name
+  className <- function(name) {
+    if (fluid)
+      paste(name, "-fluid", sep="")
+    else
+      name
+  }
+
   # built the container div dynamically to support optional collapsibility
   if (collapsible) {
     navId <- paste("navbar-collapse-", p_randomInt(1000, 10000), sep="")
-    containerDiv <- div(class="container",
+    containerDiv <- div(class=className("container"),
       div(class="navbar-header",
         tags$button(type="button", class="navbar-toggle collapsed",
           `data-toggle`="collapse", `data-target`=paste0("#", navId),
@@ -356,7 +368,7 @@ navbarPage <- function(title,
       div(class="navbar-collapse collapse", id=navId, tabset$navList)
     )
   } else {
-    containerDiv <- div(class="container",
+    containerDiv <- div(class=className("container"),
       div(class="navbar-header",
         span(class="navbar-brand", pageTitle)
       ),
@@ -364,14 +376,6 @@ navbarPage <- function(title,
     )
   }
 
-  # function to return plain or fluid class name
-  className <- function(name) {
-    if (fluid)
-      paste(name, "-fluid", sep="")
-    else
-      name
-  }
-
   # build the main tab content div
   contentDiv <- div(class=className("container"))
   if (!is.null(header))
@@ -390,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")
@@ -499,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
@@ -507,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
@@ -606,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
@@ -630,9 +665,13 @@ tabsetPanel <- function(...,
                     version = "0.10.2.2")
   }
 
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
+
   # build the tabset
   tabs <- list(...)
   type <- match.arg(type)
+
   tabset <- buildTabset(tabs, paste0("nav nav-", type), NULL, id, selected)
 
   # create the content
@@ -669,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(
 #'
@@ -695,6 +736,9 @@ navlistPanel <- function(...,
       tags$li(class="navbar-brand", text)
   }
 
+  if (!is.null(id))
+    selected <- restoreInput(id = id, default = selected)
+
   # build the tabset
   tabs <- list(...)
   tabset <- buildTabset(tabs,
@@ -716,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,
+        divTag$title, tags$b(class = "caret"),
+        getIcon(iconClass = divTag$iconClass)
+      ),
+      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`,
+                 divTag$attribs$title,
+                 getIcon(iconClass = divTag$attribs$`data-icon-class`)
+               )
+    )
+    # 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))
 }
 
 
@@ -925,21 +938,34 @@ textOutput <- function(outputId, container = if (inline) span else div, inline =
 #' Render a reactive output variable as verbatim text within an
 #' application page. The text will be included within an HTML \code{pre} tag.
 #' @param outputId output variable to read the value from
+#' @param placeholder if the output is empty or \code{NULL}, should an empty
+#'   rectangle be displayed to serve as a placeholder? (does not affect
+#'   behavior when the the output in nonempty)
 #' @return A verbatim text output element that can be included in a panel
 #' @details Text is HTML-escaped prior to rendering. This element is often used
-#' with the \link{renderPrint} function to preserve fixed-width formatting
-#' of printed objects.
+#'   with the \link{renderPrint} function to preserve fixed-width formatting
+#'   of printed objects.
 #' @examples
-#' mainPanel(
-#'   h4("Summary"),
-#'   verbatimTextOutput("summary"),
-#'
-#'   h4("Observations"),
-#'   tableOutput("view")
-#' )
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'   shinyApp(
+#'     ui = basicPage(
+#'       textInput("txt", "Enter the text to display below:"),
+#'       verbatimTextOutput("default"),
+#'       verbatimTextOutput("placeholder", placeholder = TRUE)
+#'     ),
+#'     server = function(input, output) {
+#'       output$default <- renderText({ input$txt })
+#'       output$placeholder <- renderText({ input$txt })
+#'     }
+#'   )
+#' }
 #' @export
-verbatimTextOutput <- function(outputId) {
-  textOutput(outputId, container = pre)
+verbatimTextOutput <- function(outputId, placeholder = FALSE) {
+  pre(id = outputId,
+      class = paste(c("shiny-text-output", if (!placeholder) "noplaceholder"),
+                    collapse = " ")
+      )
 }
 
 
@@ -1113,7 +1139,7 @@ imageOutput <- function(outputId, width = "100%", height="400px",
 #'   same \code{id} to disappear.
 #' @inheritParams textOutput
 #' @note The arguments \code{clickId} and \code{hoverId} only work for R base
-#'   graphics (see the \pkg{\link{graphics}} package). They do not work for
+#'   graphics (see the \pkg{\link[graphics:graphics-package]{graphics}} package). They do not work for
 #'   \pkg{\link[grid:grid-package]{grid}}-based graphics, such as \pkg{ggplot2},
 #'   \pkg{lattice}, and so on.
 #'
@@ -1411,6 +1437,7 @@ uiOutput <- htmlOutput
 #'   is assigned to.
 #' @param label The label that should appear on the button.
 #' @param class Additional CSS classes to apply to the tag, if any.
+#' @param ... Other arguments to pass to the container tag function.
 #'
 #' @examples
 #' \dontrun{
@@ -1429,27 +1456,29 @@ uiOutput <- htmlOutput
 #' }
 #'
 #' @aliases downloadLink
-#' @seealso downloadHandler
+#' @seealso \code{\link{downloadHandler}}
 #' @export
 downloadButton <- function(outputId,
                            label="Download",
-                           class=NULL) {
+                           class=NULL, ...) {
   aTag <- tags$a(id=outputId,
                  class=paste('btn btn-default shiny-download-link', class),
                  href='',
                  target='_blank',
+                 download=NA,
                  icon("download"),
-                 label)
+                 label, ...)
 }
 
 #' @rdname downloadButton
 #' @export
-downloadLink <- function(outputId, label="Download", class=NULL) {
+downloadLink <- function(outputId, label="Download", class=NULL, ...) {
   tags$a(id=outputId,
          class=paste(c('shiny-download-link', class), collapse=" "),
          href='',
          target='_blank',
-         label)
+         download=NA,
+         label, ...)
 }
 
 
@@ -1517,7 +1546,7 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # font-awesome needs an additional dependency (glyphicon is in bootstrap)
   if (lib == "font-awesome") {
     htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "4.6.3", c(href="shared/font-awesome"),
+      "font-awesome", "4.7.0", c(href="shared/font-awesome"),
       stylesheet = "css/font-awesome.min.css"
     )
   }

R/conditions.R

@@ -76,7 +76,7 @@ getCallNames <- function(calls) {
 }
 
 getLocs <- function(calls) {
-  sapply(calls, function(call) {
+  vapply(calls, function(call) {
     srcref <- attr(call, "srcref", exact = TRUE)
     if (!is.null(srcref)) {
       srcfile <- attr(srcref, "srcfile", exact = TRUE)
@@ -86,7 +86,7 @@ getLocs <- function(calls) {
       }
     }
     return("")
-  })
+  }, character(1))
 }
 
 #' @details \code{captureStackTraces} runs the given \code{expr} and if any

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)
@@ -94,7 +107,7 @@ FileUploadContext <- R6Class(
     },
     createUploadOperation = function(fileInfos) {
       while (TRUE) {
-        id <- paste(as.raw(p_runif(12, min=0, max=0xFF)), collapse='')
+        id <- createUniqueId(12)
         private$ids <- c(private$ids, id)
         dir <- file.path(private$basedir, id)
         if (!dir.create(dir))

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/history.R

@@ -0,0 +1,95 @@
+
+#' @include reactive-domains.R
+NULL
+
+#' @include reactives.R
+NULL
+
+#' Get the query string / hash component from the URL
+#'
+#' Two user friendly wrappers for getting the query string and the hash
+#' component from the app's URL.
+#'
+#' These can be particularly useful if you want to display different content
+#' depending on the values in the query string / hash (e.g. instead of basing
+#' the conditional on an input or a calculated reactive, you can base it on the
+#' query string). However, note that, if you're changing the query string / hash
+#' programatically from within the server code, you must use
+#' \code{updateQueryString(_yourNewQueryString_, mode = "push")}. The default
+#' \code{mode} for \code{updateQueryString} is \code{"replace"}, which doesn't
+#' raise any events, so any observers or reactives that depend on it will
+#' \emph{not} get triggered. However, if you're changing the query string / hash
+#' directly by typing directly in the browser and hitting enter, you don't have
+#' to worry about this.
+#'
+#' @param session	A Shiny session object.
+#'
+#' @return For \code{getQueryString}, a named list. For example, the query
+#'   string \code{?param1=value1&param2=value2} becomes \code{list(param1 =
+#'   value1, param2 = value2)}. For \code{getUrlHash}, a character vector with
+#'   the hash (including the leading \code{#} symbol).
+#'
+#' @seealso \code{\link{updateQueryString}}
+#'
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#'   ## App 1: getQueryString
+#'   ## Printing the value of the query string
+#'   ## (Use the back and forward buttons to see how the browser
+#'   ## keeps a record of each state)
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       textInput("txt", "Enter new query string"),
+#'       helpText("Format: ?param1=val1&param2=val2"),
+#'       actionButton("go", "Update"),
+#'       hr(),
+#'       verbatimTextOutput("query")
+#'     ),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         updateQueryString(input$txt, mode = "push")
+#'       })
+#'       output$query <- renderText({
+#'         query <- getQueryString()
+#'         queryText <- paste(names(query), query,
+#'                        sep = "=", collapse=", ")
+#'         paste("Your query string is:\n", queryText)
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: getUrlHash
+#'   ## Printing the value of the URL hash
+#'   ## (Use the back and forward buttons to see how the browser
+#'   ## keeps a record of each state)
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       textInput("txt", "Enter new hash"),
+#'       helpText("Format: #hash"),
+#'       actionButton("go", "Update"),
+#'       hr(),
+#'       verbatimTextOutput("hash")
+#'     ),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         updateQueryString(input$txt, mode = "push")
+#'       })
+#'       output$hash <- renderText({
+#'         hash <- getUrlHash()
+#'         paste("Your hash is:\n", hash)
+#'       })
+#'     }
+#'   )
+#' }
+#' @export
+getQueryString <- function(session = getDefaultReactiveDomain()) {
+  parseQueryString(session$clientData$url_search)
+}
+
+#' @rdname getQueryString
+#' @export
+getUrlHash <- function(session = getDefaultReactiveDomain()) {
+  session$clientData$url_hash
+}

R/html-deps.R

@@ -6,13 +6,18 @@
 #' URL.
 #'
 #' @param dependency A single HTML dependency object, created using
-#'   \code{\link{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

@@ -21,7 +21,7 @@
 #' @param width Width in pixels.
 #' @param height Height in pixels.
 #' @param res Resolution in pixels per inch. This value is passed to
-#'   \code{\link{png}}. Note that this affects the resolution of PNG rendering in
+#'   \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG rendering in
 #'   R; it won't change the actual ppi of the browser.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.

R/input-action.R

@@ -39,10 +39,14 @@
 #' @seealso \code{\link{observeEvent}} and \code{\link{eventReactive}}
 #' @export
 actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
+
+  value <- restoreInput(id = inputId, default = NULL)
+
   tags$button(id=inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     type="button",
     class="btn btn-default action-button",
+    `data-val` = value,
     list(validateIcon(icon), label),
     ...
   )
@@ -51,9 +55,12 @@ actionButton <- function(inputId, label, icon = NULL, width = NULL, ...) {
 #' @rdname actionButton
 #' @export
 actionLink <- function(inputId, label, icon = NULL, ...) {
+  value <- restoreInput(id = inputId, default = NULL)
+
   tags$a(id=inputId,
     href="#",
     class="action-button",
+    `data-val` = value,
     list(validateIcon(icon), label),
     ...
   )

R/input-checkboxgroup.R

@@ -6,9 +6,22 @@
 #'
 #' @inheritParams textInput
 #' @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.
+#'   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. 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,
+#'   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.
+#'
 #' @return A list of HTML elements that can be added to a UI definition.
 #'
 #' @family input elements
@@ -26,26 +39,52 @@
 #'   tableOutput("data")
 #' )
 #'
-#' server <- function(input, output) {
+#' server <- function(input, output, session) {
 #'   output$data <- renderTable({
 #'     mtcars[, c("mpg", input$variable), drop = FALSE]
 #'   }, rownames = TRUE)
 #' }
 #'
 #' shinyApp(ui, server)
+#'
+#' ui <- fluidPage(
+#'   checkboxGroupInput("icons", "Choose icons:",
+#'     choiceNames =
+#'       list(icon("calendar"), icon("bed"),
+#'            icon("cog"), icon("bug")),
+#'     choiceValues =
+#'       list("calendar", "bed", "cog", "bug")
+#'   ),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   output$txt <- renderText({
+#'     icons <- paste(input$icons, collapse = ", ")
+#'     paste("You chose", icons)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
-checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
+
+  # keep backward compatibility with Shiny < 1.0.1 (see #1649)
+  if (is.null(choices) && is.null(choiceNames) && is.null(choiceValues)) {
+    choices <- character(0)
+  }
+
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
 
   selected <- restoreInput(id = inputId, default = selected)
 
-  # resolve names
-  choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  # default value if it's not specified
+  if (!is.null(selected)) selected <- as.character(selected)
 
-  options <- generateOptions(inputId, choices, selected, inline)
+  options <- generateOptions(inputId, selected, inline,
+    'checkbox', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-checkboxgroup shiny-input-container"
   if (inline)

R/input-date.R

@@ -10,7 +10,7 @@
 #'   \item \code{yy} Year without century (12)
 #'   \item \code{yyyy} Year with century (2012)
 #'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
 #'   \item \code{M} Abbreviated month name
 #'   \item \code{MM} Full month name
 #'   \item \code{dd} Day of month with leading zero
@@ -21,23 +21,26 @@
 #'
 #' @inheritParams textInput
 #' @param value The starting date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current
-#'   date in the client's time zone.
+#'   \code{yyyy-mm-dd} format. If NULL (the default), will use the current date
+#'   in the client's time zone.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param format The format of the date to display in the browser. Defaults to
 #'   \code{"yyyy-mm-dd"}.
-#' @param startview The date range shown when the input object is first
-#'   clicked. Can be "month" (the default), "year", or "decade".
+#' @param startview The date range shown when the input object is first clicked.
+#'   Can be "month" (the default), "year", or "decade".
 #' @param weekstart Which day is the start of the week. Should be an integer
 #'   from 0 (Sunday) to 6 (Saturday).
 #' @param language The language used for month and day names. Default is "en".
-#'   Other valid values include "bg", "ca", "cs", "da", "de", "el", "es", "fi",
-#'   "fr", "he", "hr", "hu", "id", "is", "it", "ja", "kr", "lt", "lv", "ms",
-#'   "nb", "nl", "pl", "pt", "pt-BR", "ro", "rs", "rs-latin", "ru", "sk", "sl",
-#'   "sv", "sw", "th", "tr", "uk", "zh-CN", and "zh-TW".
+#'   Other valid values include "ar", "az", "bg", "bs", "ca", "cs", "cy", "da",
+#'   "de", "el", "en-AU", "en-GB", "eo", "es", "et", "eu", "fa", "fi", "fo",
+#'   "fr-CH", "fr", "gl", "he", "hr", "hu", "hy", "id", "is", "it-CH", "it",
+#'   "ja", "ka", "kh", "kk", "ko", "kr", "lt", "lv", "me", "mk", "mn", "ms",
+#'   "nb", "nl-BE", "nl", "no", "pl", "pt-BR", "pt", "ro", "rs-latin", "rs",
+#'   "ru", "sk", "sl", "sq", "sr-latin", "sr", "sv", "sw", "th", "tr", "uk",
+#'   "vi", "zh-CN", and "zh-TW".
 #'
 #' @family input elements
 #' @seealso \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
@@ -60,7 +63,7 @@
 #'
 #'   # Use different language and different first day of week
 #'   dateInput("date5", "Date:",
-#'           language = "de",
+#'           language = "ru",
 #'           weekstart = 1),
 #'
 #'   # Start with decade view instead of default month view
@@ -83,29 +86,34 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
 
   value <- restoreInput(id = inputId, default = value)
 
-  attachDependencies(
-    tags$div(id = inputId,
-      class = "shiny-date-input form-group shiny-input-container",
-      style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
+  tags$div(id = inputId,
+    class = "shiny-date-input form-group shiny-input-container",
+    style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
-      controlLabel(inputId, label),
-      tags$input(type = "text",
-                 # datepicker class necessary for dropdown to display correctly
-                 class = "form-control datepicker",
-                 `data-date-language` = language,
-                 `data-date-weekstart` = weekstart,
-                 `data-date-format` = format,
-                 `data-date-start-view` = startview,
-                 `data-min-date` = min,
-                 `data-max-date` = max,
-                 `data-initial-date` = value
-      )
+    controlLabel(inputId, label),
+    tags$input(type = "text",
+               class = "form-control",
+               `data-date-language` = language,
+               `data-date-week-start` = weekstart,
+               `data-date-format` = format,
+               `data-date-start-view` = startview,
+               `data-min-date` = min,
+               `data-max-date` = max,
+               `data-initial-date` = value
     ),
     datePickerDependency
   )
 }
 
 datePickerDependency <- htmlDependency(
-  "bootstrap-datepicker", "1.0.2", c(href = "shared/datepicker"),
+  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
   script = "js/bootstrap-datepicker.min.js",
-  stylesheet = "css/datepicker.css")
+  stylesheet = "css/bootstrap-datepicker3.min.css",
+  # Need to enable noConflict mode. See #1346.
+  head = "<script>
+(function() {
+  var datepicker = $.fn.datepicker.noConflict();
+  $.fn.bsDatepicker = datepicker;
+})();
+</script>"
+)

R/input-daterange.R

@@ -10,7 +10,7 @@
 #'   \item \code{yy} Year without century (12)
 #'   \item \code{yyyy} Year with century (2012)
 #'   \item \code{mm} Month number, with leading zero (01-12)
-#'   \item \code{m} Month number, without leading zero (01-12)
+#'   \item \code{m} Month number, without leading zero (1-12)
 #'   \item \code{M} Abbreviated month name
 #'   \item \code{MM} Full month name
 #'   \item \code{dd} Day of month with leading zero
@@ -98,7 +98,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           class = "input-sm form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,
@@ -110,7 +110,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           class = "input-sm form-control",
           type = "text",
           `data-date-language` = language,
-          `data-date-weekstart` = weekstart,
+          `data-date-week-start` = weekstart,
           `data-date-format` = format,
           `data-date-start-view` = startview,
           `data-min-date` = min,

R/input-file.R

@@ -27,6 +27,9 @@
 #'   Internet Explorer 9 and earlier.}
 #' @param accept A character vector of MIME types; gives the browser a hint of
 #'   what kind of files the server is expecting.
+#' @param buttonLabel The label used on the button. Can be text or an HTML tag
+#'   object.
+#' @param placeholder The text to show before a file has been uploaded.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -70,7 +73,7 @@
 #' }
 #' @export
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
-  width = NULL) {
+  width = NULL, buttonLabel = "Browse...", placeholder = "No file selected") {
 
   restoredValue <- restoreInput(id = inputId, default = NULL)
 
@@ -105,12 +108,12 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
     div(class = "input-group",
       tags$label(class = "input-group-btn",
         span(class = "btn btn-default btn-file",
-          "Browse...",
+          buttonLabel,
           inputTag
         )
       ),
       tags$input(type = "text", class = "form-control",
-        placeholder = "No file selected", readonly = "readonly"
+        placeholder = placeholder, readonly = "readonly"
       )
     ),
 

R/input-radiobuttons.R

@@ -3,19 +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)
-#' @param selected The initially selected value (if not specified then
-#' defaults to the first value)
+#'   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. 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.
 #'
 #' @family input elements
 #' @seealso \code{\link{updateRadioButtons}}
@@ -47,27 +58,46 @@
 #' }
 #'
 #' shinyApp(ui, server)
+#'
+#' ui <- fluidPage(
+#'   radioButtons("rb", "Choose one:",
+#'                choiceNames = list(
+#'                  icon("calendar"),
+#'                  HTML("<p style='color:red;'>Red Text</p>"),
+#'                  "Normal text"
+#'                ),
+#'                choiceValues = list(
+#'                  "icon", "html", "text"
+#'                )),
+#'   textOutput("txt")
+#' )
+#'
+#' server <- function(input, output) {
+#'   output$txt <- renderText({
+#'     paste("You chose", input$rb)
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
 #' }
 #' @export
-radioButtons <- function(inputId, label, choices, selected = NULL,
-  inline = FALSE, width = NULL) {
+radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
+  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL) {
 
-  # resolve names
-  choices <- choicesWithNames(choices)
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues)
 
   selected <- restoreInput(id = inputId, default = selected)
 
   # default value if it's not specified
-  selected <- if (is.null(selected)) choices[[1]] else {
-    validateSelected(selected, choices, inputId)
-  }
+  selected <- if (is.null(selected)) args$choiceValues[[1]] else as.character(selected)
+
   if (length(selected) > 1) stop("The 'selected' argument must be of length 1")
 
-  options <- generateOptions(inputId, choices, selected, inline, type = 'radio')
+  options <- generateOptions(inputId, selected, inline,
+    'radio', args$choiceNames, args$choiceValues)
 
   divClass <- "form-group shiny-input-radiogroup shiny-input-container"
-  if (inline)
-    divClass <- paste(divClass, "shiny-input-container-inline")
+  if (inline) divClass <- paste(divClass, "shiny-input-container-inline")
 
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),

R/input-select.R

@@ -5,7 +5,7 @@
 #'
 #' By default, \code{selectInput()} and \code{selectizeInput()} use the
 #' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/brianreavis/selectize.js}) to instead of the basic
+#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' \code{selectInput()} with \code{selectize=FALSE}.
 #'
@@ -15,7 +15,12 @@
 #'
 #' @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.
+#'   named, then that name rather than the value is displayed to the user.
+#'   This can also be a named list whose elements are (either named or
+#'   unnamed) lists or vectors. If this is the case, the outermost names
+#'   will be used as the "optgroup" label for the elements in the respective
+#'   sublist. This allows you to group and label similar choices. See the
+#'   example section for a small demo of this feature.
 #' @param selected The initially selected value (or multiple values if
 #'   \code{multiple = TRUE}). If not specified then defaults to the first value
 #'   for single-select lists and no values for multiple select lists.
@@ -34,26 +39,43 @@
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
 #'
-#' ui <- fluidPage(
-#'   selectInput("variable", "Variable:",
-#'               c("Cylinders" = "cyl",
-#'                 "Transmission" = "am",
-#'                 "Gears" = "gear")),
-#'   tableOutput("data")
+#' # basic example
+#' shinyApp(
+#'   ui = fluidPage(
+#'     selectInput("variable", "Variable:",
+#'                 c("Cylinders" = "cyl",
+#'                   "Transmission" = "am",
+#'                   "Gears" = "gear")),
+#'     tableOutput("data")
+#'   ),
+#'   server = function(input, output) {
+#'     output$data <- renderTable({
+#'       mtcars[, c("mpg", input$variable), drop = FALSE]
+#'     }, rownames = TRUE)
+#'   }
 #' )
 #'
-#' server <- function(input, output) {
-#'   output$data <- renderTable({
-#'     mtcars[, c("mpg", input$variable), drop = FALSE]
-#'   }, rownames = TRUE)
-#' }
-#'
-#' shinyApp(ui, server)
+#' # demoing optgroup support in the `choices` arg
+#' shinyApp(
+#'   ui = fluidPage(
+#'     selectInput("state", "Choose a state:",
+#'       list(`East Coast` = c("NY", "NJ", "CT"),
+#'            `West Coast` = c("WA", "OR", "CA"),
+#'            `Midwest` = c("MN", "WI", "IA"))
+#'     ),
+#'     textOutput("result")
+#'   ),
+#'   server = function(input, output) {
+#'     output$result <- renderText({
+#'       paste("You chose", input$state)
+#'     })
+#'   }
+#' )
 #' }
 #' @export
 selectInput <- function(inputId, label, choices, selected = NULL,
-                        multiple = FALSE, selectize = TRUE, width = NULL,
-                        size = NULL) {
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL) {
 
   selected <- restoreInput(id = inputId, default = selected)
 
@@ -63,7 +85,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   # default value if it's not specified
   if (is.null(selected)) {
     if (!multiple) selected <- firstChoice(choices)
-  } else selected <- validateSelected(selected, choices, inputId)
+  } else selected <- as.character(selected)
 
   if (!is.null(size) && selectize) {
     stop("'size' argument is incompatible with 'selectize=TRUE'.")
@@ -133,7 +155,7 @@ needOptgroup <- function(choices) {
 #' @rdname selectInput
 #' @param ... Arguments passed to \code{selectInput()}.
 #' @param options A list of options. See the documentation of \pkg{selectize.js}
-#'   for possible options (character option values inside \code{\link{I}()} will
+#'   for possible options (character option values inside \code{\link[base]{I}()} will
 #'   be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
 #'   for details).
 #' @param width The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
@@ -172,7 +194,7 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   if ('drag_drop' %in% options$plugins) {
     selectizeDep <- list(selectizeDep, htmlDependency(
-      'jqueryui', '1.11.4', c(href = 'shared/jqueryui'),
+      'jqueryui', '1.12.1', c(href = 'shared/jqueryui'),
       script = 'jquery-ui.min.js'
     ))
   }

R/input-slider.R

@@ -36,7 +36,7 @@
 #'   format string, to be passed to the Javascript strftime library. See
 #'   \url{https://github.com/samsonjs/strftime} for more details. The allowed
 #'   format specifications are very similar, but not identical, to those for R's
-#'   \code{\link{strftime}} function. For Dates, the default is \code{"\%F"}
+#'   \code{\link[base]{strftime}} function. For Dates, the default is \code{"\%F"}
 #'   (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"}
 #'   (like \code{"2015-07-01 15:32:10"}).
 #' @param timezone Only used if the values are POSIXt objects. A string
@@ -51,6 +51,7 @@
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("obs", "Number of observations:",
@@ -164,11 +165,14 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-grid-num` = n_ticks,
     `data-grid-snap` = FALSE,
     `data-prettify-separator` = sep,
+    `data-prettify-enabled` = (sep != ""),
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
     `data-keyboard-step` = step / (max - min) * 100,
-    `data-drag-interval` = dragRange,
+    # 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,
     # The following are ignored by the ion.rangeSlider, but are used by Shiny.
     `data-data-type` = dataType,
     `data-time-format` = timeFormat,
@@ -214,7 +218,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
   }
 
   dep <- list(
-    htmlDependency("ionrangeslider", "2.1.2", c(href="shared/ionrangeslider"),
+    htmlDependency("ionrangeslider", "2.1.6", c(href="shared/ionrangeslider"),
       script = "js/ion.rangeSlider.min.js",
       # ion.rangeSlider also needs normalize.css, which is already included in
       # Bootstrap.

R/input-submit.R

@@ -1,8 +1,27 @@
 #' Create a submit button
 #'
-#' Create a submit button for an input form. Forms that include a submit
+#' Create a submit button for an app. Apps that include a submit
 #' button do not automatically update their outputs when inputs change,
 #' rather they wait until the user explicitly clicks the submit button.
+#' The use of \code{submitButton} is generally discouraged in favor of
+#' the more versatile \code{\link{actionButton}} (see details below).
+#'
+#' Submit buttons are unusual Shiny inputs, and we recommend using
+#' \code{\link{actionButton}} instead of \code{submitButton} when you
+#' want to delay a reaction.
+#' See \href{http://shiny.rstudio.com/articles/action-buttons.html}{this
+#' article} for more information (including a demo of how to "translate"
+#' code using a \code{submitButton} to code using an \code{actionButton}).
+#'
+#' In essence, the presence of a submit button stops all inputs from
+#' sending their values automatically to the server. This means, for
+#' instance, that if there are \emph{two} submit buttons in the same app,
+#' clicking either one will cause all inputs in the app to send their
+#' values to the server. This is probably not what you'd want, which is
+#' why submit button are unwieldy for all but the simplest apps. There
+#' are other problems with submit buttons: for example, dynamically
+#' created submit buttons (for example, with \code{\link{renderUI}}
+#' or \code{\link{insertUI}}) will not work.
 #'
 #' @param text Button caption
 #' @param icon Optional \code{\link{icon}} to appear on the button
@@ -13,8 +32,26 @@
 #' @family input elements
 #'
 #' @examples
-#' submitButton("Update View")
-#' submitButton("Update View", icon("refresh"))
+#' if (interactive()) {
+#'
+#' shinyApp(
+#'   ui = basicPage(
+#'     numericInput("num", label = "Make changes", value = 1),
+#'     submitButton("Update View", icon("refresh")),
+#'     helpText("When you click the button above, you should see",
+#'              "the output below update to reflect the value you",
+#'              "entered at the top:"),
+#'     verbatimTextOutput("value")
+#'   ),
+#'   server = function(input, output) {
+#'
+#'     # submit buttons do not have a value of their own,
+#'     # they control when the app accesses values of other widgets.
+#'     # input$num is the value of the number widget.
+#'     output$value <- renderPrint({ input$num })
+#'   }
+#' )
+#' }
 #' @export
 submitButton <- function(text = "Apply Changes", icon = NULL, width = NULL) {
   div(

R/input-textarea.R

@@ -0,0 +1,69 @@
+#' Create a textarea input control
+#'
+#' Create a textarea input control for entry of unstructured text values.
+#'
+#' @inheritParams textInput
+#' @param height The height of the input, e.g. \code{'400px'}, or
+#'   \code{'100\%'}; see \code{\link{validateCssUnit}}.
+#' @param cols Value of the visible character columns of the input, e.g.
+#'   \code{80}. If used with \code{width}, \code{width} will take precedence in
+#'   the browser's rendering.
+#' @param rows The value of the visible character rows of the input, e.g.
+#'   \code{6}. If used with \code{height}, \code{height} will take precedence in
+#'   the browser's rendering.
+#' @param resize Which directions the textarea box can be resized. Can be one of
+#'   \code{"both"}, \code{"none"}, \code{"vertical"}, and \code{"horizontal"}.
+#'   The default, \code{NULL}, will use the client browser's default setting for
+#'   resizing textareas.
+#' @return A textarea input control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateTextAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   textAreaInput("caption", "Caption", "Data Summary", width = "1000px"),
+#'   verbatimTextOutput("value")
+#' )
+#' server <- function(input, output) {
+#'   output$value <- renderText({ input$caption })
+#' }
+#' shinyApp(ui, server)
+#'
+#' }
+#' @export
+textAreaInput <- function(inputId, label, value = "", width = NULL, height = NULL,
+  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
+  if (!is.null(resize)) {
+    resize <- match.arg(resize, c("both", "none", "vertical", "horizontal"))
+  }
+
+  style <- paste(
+    if (!is.null(width))  paste0("width: ",  validateCssUnit(width),  ";"),
+    if (!is.null(height)) paste0("height: ", validateCssUnit(height), ";"),
+    if (!is.null(resize)) paste0("resize: ", resize, ";")
+  )
+
+  # Workaround for tag attribute=character(0) bug:
+  #   https://github.com/rstudio/htmltools/issues/65
+  if (length(style) == 0) style <- NULL
+
+  div(class = "form-group shiny-input-container",
+    label %AND% tags$label(label, `for` = inputId),
+    tags$textarea(
+      id = inputId,
+      class = "form-control",
+      placeholder = placeholder,
+      style = style,
+      rows = rows,
+      cols = cols,
+      value
+    )
+  )
+}

R/input-utils.R

@@ -2,42 +2,62 @@ controlLabel <- function(controlName, label) {
   label %AND% tags$label(class = "control-label", `for` = controlName, label)
 }
 
-
-# Before shiny 0.9, `selected` refers to names/labels of `choices`; now it
-# refers to values. Below is a function for backward compatibility.
-validateSelected <- function(selected, choices, inputId) {
-  # drop names, otherwise toJSON() keeps them too
-  selected <- unname(selected)
-  # if you are using optgroups, you're using shiny > 0.10.0, and you should
-  # already know that `selected` must be a value instead of a label
-  if (needOptgroup(choices)) return(selected)
-
-  if (is.list(choices)) choices <- unlist(choices)
-
-  nms <- names(choices)
-  # labels and values are identical, no need to validate
-  if (identical(nms, unname(choices))) return(selected)
-  # when selected labels instead of values
-  i <- (selected %in% nms) & !(selected %in% choices)
-  if (any(i)) {
-    warnFun <- if (all(i)) {
-      # replace names with values
-      selected <- unname(choices[selected])
-      warning
-    } else stop  # stop when it is ambiguous (some labels == values)
-    warnFun("'selected' must be the values instead of names of 'choices' ",
-            "for the input '", inputId, "'")
+# This function takes in either a list or vector for `choices` (and
+# `choiceNames` and `choiceValues` are passed in as NULL) OR it takes
+# in a list or vector for both `choiceNames` and `choiceValues` (and
+# `choices` is passed as NULL) and returns a list of two elements:
+#    - `choiceNames` is a vector or list that holds the options names
+#      (each element can be arbitrary UI, or simple text)
+#    - `choiceValues` is a vector or list that holds the options values
+#       (each element must be simple text)
+normalizeChoicesArgs <- function(choices, choiceNames, choiceValues,
+  mustExist = TRUE) {
+  # if-else to check that either choices OR (choiceNames + choiceValues)
+  # were correctly provided
+  if (is.null(choices)) {
+    if (is.null(choiceNames) || is.null(choiceValues)) {
+      if (mustExist) {
+        stop("Please specify a non-empty vector for `choices` (or, ",
+             "alternatively, for both `choiceNames` AND `choiceValues`).")
+      } else {
+        if (is.null(choiceNames) && is.null(choiceValues)) {
+          # this is useful when we call this function from `updateInputOptions()`
+          # in which case, all three `choices`, `choiceNames` and `choiceValues`
+          # may legitimately be NULL
+          return(list(choiceNames = NULL, choiceValues = NULL))
+        } else {
+          stop("One of `choiceNames` or `choiceValues` was set to ",
+               "NULL, but either both or none should be NULL.")
+        }
+      }
+    }
+    if (length(choiceNames) != length(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must have the same length.")
+    }
+    if (anyNamed(choiceNames) || anyNamed(choiceValues)) {
+      stop("`choiceNames` and `choiceValues` must not be named.")
+    }
+  } else {
+    if (!is.null(choiceNames) || !is.null(choiceValues)) {
+      warning("Using `choices` argument; ignoring `choiceNames` and `choiceValues`.")
+    }
+    choices <- choicesWithNames(choices) # resolve names if not specified
+    choiceNames <- names(choices)
+    choiceValues <- unname(choices)
   }
-  selected
-}
 
+  return(list(choiceNames = as.list(choiceNames),
+              choiceValues = as.list(as.character(choiceValues))))
+}
 
 # generate options for radio buttons and checkbox groups (type = 'checkbox' or
 # 'radio')
-generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox') {
+generateOptions <- function(inputId, selected, inline, type = 'checkbox',
+                            choiceNames, choiceValues,
+                            session = getDefaultReactiveDomain()) {
   # generate a list of <input type=? [checked] />
   options <- mapply(
-    choices, names(choices),
+    choiceValues, choiceNames,
     FUN = function(value, name) {
       inputTag <- tags$input(
         type = type, name = inputId, value = value
@@ -45,14 +65,18 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
       if (value %in% selected)
         inputTag$attribs$checked <- "checked"
 
+      # in case, the options include UI code other than text
+      # (arbitrary HTML using the tags() function or equivalent)
+      pd <- processDeps(name, session)
+
       # If inline, there's no wrapper div, and the label needs a class like
       # checkbox-inline.
       if (inline) {
-        tags$label(class = paste0(type, "-inline"), inputTag, tags$span(name))
+        tags$label(class = paste0(type, "-inline"), inputTag,
+                   tags$span(pd$html, pd$deps))
       } else {
-        tags$div(class = type,
-          tags$label(inputTag, tags$span(name))
-        )
+        tags$div(class = type, tags$label(inputTag,
+                 tags$span(pd$html, pd$deps)))
       }
     },
     SIMPLIFY = FALSE, USE.NAMES = FALSE
@@ -63,7 +87,7 @@ generateOptions <- function(inputId, choices, selected, inline, type = 'checkbox
 
 
 # Takes a vector or list, and adds names (same as the value) to any entries
-# without names.
+# without names. Coerces all leaf nodes to `character`.
 choicesWithNames <- function(choices) {
   # Take a vector or list, and convert to list. Also, if any children are
   # vectors with length > 1, convert those to list. If the list is unnamed,
@@ -79,7 +103,7 @@ choicesWithNames <- function(choices) {
       if (is.list(val))
         listify(val)
       else if (length(val) == 1 && is.null(names(val)))
-        val
+        as.character(val)
       else
         makeNamed(as.list(val))
     })

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/jqueryui.R

@@ -79,8 +79,6 @@ absolutePanel <- function(...,
   if (isTRUE(draggable)) {
     divTag <- tagAppendAttributes(divTag, class='draggable')
     return(tagList(
-      # IMPORTANT NOTE: If you update jqueryui, make sure you DON'T include the datepicker,
-      # as it collides with our bootstrap datepicker!
       singleton(tags$head(tags$script(src='shared/jqueryui/jquery-ui.min.js'))),
       divTag,
       tags$script('$(".draggable").draggable();')

R/middleware.R

@@ -191,7 +191,7 @@ staticHandler <- function(root) {
     if (!identical(req$REQUEST_METHOD, 'GET'))
       return(NULL)
 
-    path <- req$PATH_INFO
+    path <- URLdecode(req$PATH_INFO)
 
     if (is.null(path))
       return(httpResponse(400, content="<h1>Bad Request</h1>"))
@@ -360,7 +360,9 @@ HandlerManager <- R6Class("HandlerManager",
 
           response <- filter(req, response)
           if (head_request) {
-            headers$`Content-Length` <- nchar(response$content, type = "bytes")
+
+            headers$`Content-Length` <- getResponseContentLength(response, deleteOwnedContent = TRUE)
+
             return(list(
               status = response$status,
               body = "",
@@ -383,6 +385,35 @@ HandlerManager <- R6Class("HandlerManager",
   )
 )
 
+# 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/modal.R

@@ -36,11 +36,15 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' @param ... UI elements for the body of the modal dialog box.
 #' @param title An optional title for the dialog.
 #' @param footer UI for footer. Use \code{NULL} for no footer.
+#' @param size One of \code{"s"} for small, \code{"m"} (the default) for medium,
+#'   or \code{"l"} for large.
 #' @param easyClose If \code{TRUE}, the modal dialog can be dismissed by
 #'   clicking outside the dialog box, or be pressing the Escape key. If
 #'   \code{FALSE} (the default), the modal dialog can't be dismissed in those
 #'   ways; instead it must be dismissed by clicking on the dismiss button, or
 #'   from a call to \code{\link{removeModal}} on the server.
+#' @param fade If \code{FALSE}, the modal dialog will have no fade-in animation
+#'   (it will simply appear rather than fade in to view).
 #'
 #' @examples
 #' if (interactive()) {
@@ -80,7 +84,7 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' )
 #'
 #'
-# Display a modal that requires valid input before continuing.
+#' # Display a modal that requires valid input before continuing.
 #' shinyApp(
 #'   ui = basicPage(
 #'     actionButton("show", "Show modal dialog"),
@@ -120,7 +124,8 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #'     # message.
 #'     observeEvent(input$ok, {
 #'       # Check that data object exists and is data frame.
-#'       if (exists(input$dataset) && is.data.frame(get(input$dataset))) {
+#'       if (!is.null(input$dataset) && nzchar(input$dataset) &&
+#'           exists(input$dataset) && is.data.frame(get(input$dataset))) {
 #'         vals$data <- get(input$dataset)
 #'         removeModal()
 #'       } else {
@@ -140,13 +145,18 @@ removeModal <- function(session = getDefaultReactiveDomain()) {
 #' }
 #' @export
 modalDialog <- function(..., title = NULL, footer = modalButton("Dismiss"),
-                        easyClose = FALSE) {
+  size = c("m", "s", "l"), easyClose = FALSE, fade = TRUE) {
 
-  div(id = "shiny-modal", class = "modal fade", tabindex = "-1",
+  size <- match.arg(size)
+
+  cls <- if (fade) "modal fade" else "modal"
+  div(id = "shiny-modal", class = cls, tabindex = "-1",
     `data-backdrop` = if (!easyClose) "static",
     `data-keyboard` = if (!easyClose) "false",
 
-    div(class = "modal-dialog",
+    div(
+      class = "modal-dialog",
+      class = switch(size, s = "modal-sm", m = NULL, l = "modal-lg"),
       div(class = "modal-content",
         if (!is.null(title)) div(class = "modal-header",
           tags$h4(class = "modal-title", title)

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/progress.R

@@ -12,6 +12,14 @@
 #' method is called. Calling \code{close} will cause the progress panel
 #' to be removed.
 #'
+#' As of version 0.14, the progress indicators use Shiny's new notification API.
+#' If you want to use the old styling (for example, you may have used customized
+#' CSS), you can use \code{style="old"} each time you call
+#' \code{Progress$new()}. If you don't want to set the style each time
+#' \code{Progress$new} is called, you can instead call
+#' \code{\link{shinyOptions}(progress.style="old")} just once, inside the server
+#' function.
+#'
 #' \strong{Methods}
 #'   \describe{
 #'     \item{\code{initialize(session, min = 0, max = 1)}}{
@@ -47,7 +55,10 @@
 #'   de-emphasized appearance relative to \code{message}.
 #' @param value A numeric value at which to set
 #'   the progress bar, relative to \code{min} and \code{max}.
-#'   \code{NULL} hides the progress bar, if it is currently visible.
+#' @param style Progress display style. If \code{"notification"} (the default),
+#'   the progress indicator will show using Shiny's notification API. If
+#'   \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
+#'   (this is for backward-compatibility).
 #' @param amount Single-element numeric vector; the value at which to set
 #'   the progress bar, relative to \code{min} and \code{max}.
 #'   \code{NULL} hides the progress bar, if it is currently visible.
@@ -86,10 +97,12 @@
 #' @export
 Progress <- R6Class(
   'Progress',
-  portable = TRUE,
   public = list(
 
-    initialize = function(session = getDefaultReactiveDomain(), min = 0, max = 1) {
+    initialize = function(session = getDefaultReactiveDomain(),
+      min = 0, max = 1,
+      style = getShinyOption("progress.style", default = "notification"))
+    {
       if (is.null(session$progressStack))
         stop("'session' is not a ShinySession object.")
 
@@ -98,9 +111,10 @@ Progress <- R6Class(
       private$min <- min
       private$max <- max
       private$value <- NULL
+      private$style <- match.arg(style, choices = c("notification", "old"))
       private$closed <- FALSE
 
-      session$sendProgress('open', list(id = private$id))
+      session$sendProgress('open', list(id = private$id, style = private$style))
     },
 
     set = function(value = NULL, message = NULL, detail = NULL) {
@@ -109,27 +123,31 @@ Progress <- R6Class(
         return()
       }
 
-      if (is.null(value) || is.na(value)) {
+      if (is.null(value) || is.na(value))
         value <- NULL
-      } else {
+
+      if (!is.null(value)) {
+        private$value <- value
         # Normalize value to number between 0 and 1
         value <- min(1, max(0, (value - private$min) / (private$max - private$min)))
       }
 
-      private$value <- value
-
       data <- dropNulls(list(
         id = private$id,
         message = message,
         detail = detail,
-        value = value
+        value = value,
+        style = private$style
       ))
 
-       private$session$sendProgress('update', data)
+      private$session$sendProgress('update', data)
     },
 
     inc = function(amount = 0.1, message = NULL, detail = NULL) {
-      value <- min(self$getValue() + amount, private$max)
+      if (is.null(private$value))
+        private$value <- private$min
+
+      value <- min(private$value + amount, private$max)
       self$set(value, message, detail)
     },
 
@@ -137,10 +155,7 @@ Progress <- R6Class(
 
     getMax = function() private$max,
 
-    # Return value (not the normalized 0-1 value, but in the original range)
-    getValue = function() {
-      private$value * (private$max - private$min) + private$min
-    },
+    getValue = function() private$value,
 
     close = function() {
       if (private$closed) {
@@ -148,17 +163,20 @@ Progress <- R6Class(
         return()
       }
 
-      private$session$sendProgress('close', list(id = private$id))
+      private$session$sendProgress('close',
+        list(id = private$id, style = private$style)
+      )
       private$closed <- TRUE
     }
   ),
 
   private = list(
-    session = 'environment',
+    session = 'ShinySession',
     id = character(0),
     min = numeric(0),
     max = numeric(0),
-    value = NULL,
+    style = character(0),
+    value = numeric(0),
     closed = logical(0)
   )
 )
@@ -186,6 +204,14 @@ Progress <- R6Class(
 #' is not common) or otherwise cannot be encapsulated by a single scope. In that
 #' case, you can use the \code{Progress} reference class.
 #'
+#' As of version 0.14, the progress indicators use Shiny's new notification API.
+#' If you want to use the old styling (for example, you may have used customized
+#' CSS), you can use \code{style="old"} each time you call
+#' \code{withProgress()}. If you don't want to set the style each time
+#' \code{withProgress} is called, you can instead call
+#' \code{\link{shinyOptions}(progress.style="old")} just once, inside the server
+#' function.
+#'
 #' @param session The Shiny session object, as provided by \code{shinyServer} to
 #'   the server function. The default is to automatically find the session by
 #'   using the current reactive domain.
@@ -206,13 +232,17 @@ Progress <- R6Class(
 #'   displayed to the user, or \code{NULL} to hide the current detail message
 #'   (if any). The detail message will be shown with a de-emphasized appearance
 #'   relative to \code{message}.
+#' @param style Progress display style. If \code{"notification"} (the default),
+#'   the progress indicator will show using Shiny's notification API. If
+#'   \code{"old"}, use the same HTML and CSS used in Shiny 0.13.2 and below
+#'   (this is for backward-compatibility).
 #' @param value Single-element numeric vector; the value at which to set the
-#'   progress bar, relative to \code{min} and \code{max}. \code{NULL} hides the
-#'   progress bar, if it is currently visible.
+#'   progress bar, relative to \code{min} and \code{max}.
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   plotOutput("plot")
@@ -237,10 +267,12 @@ Progress <- R6Class(
 #' @rdname withProgress
 #' @export
 withProgress <- function(expr, min = 0, max = 1,
-                         value = min + (max - min) * 0.1,
-                         message = NULL, detail = NULL,
-                         session = getDefaultReactiveDomain(),
-                         env = parent.frame(), quoted = FALSE) {
+  value = min + (max - min) * 0.1,
+  message = NULL, detail = NULL,
+  style = getShinyOption("progress.style", default = "notification"),
+  session = getDefaultReactiveDomain(),
+  env = parent.frame(), quoted = FALSE)
+{
 
   if (!quoted)
     expr <- substitute(expr)
@@ -248,7 +280,9 @@ withProgress <- function(expr, min = 0, max = 1,
   if (is.null(session$progressStack))
     stop("'session' is not a ShinySession object.")
 
-  p <- Progress$new(session, min = min, max = max)
+  style <- match.arg(style, c("notification", "old"))
+
+  p <- Progress$new(session, min = min, max = max, style = style)
 
   session$progressStack$push(p)
   on.exit({

R/reactives.R

@@ -38,6 +38,229 @@ Dependents <- R6Class(
 )
 
 
+# ReactiveVal ---------------------------------------------------------------
+
+ReactiveVal <- R6Class(
+  'ReactiveVal',
+  portable = FALSE,
+  private = list(
+    value = NULL,
+    label = NULL,
+    frozen = FALSE,
+    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() {
+      private$dependents$register(depLabel = private$label)
+
+      if (private$frozen)
+        reactiveStop()
+
+      private$value
+    },
+    set = function(value) {
+      if (identical(private$value, value)) {
+        return(invisible(FALSE))
+      }
+      private$value <- value
+      .graphValueChange(private$label, value)
+      private$dependents$invalidate()
+      invisible(TRUE)
+    },
+    freeze = function(session = getDefaultReactiveDomain()) {
+      if (is.null(session)) {
+        stop("Can't freeze a reactiveVal without a reactive domain")
+      }
+      session$onFlushed(function() {
+        self$thaw()
+      })
+      private$frozen <- TRUE
+    },
+    thaw = function() {
+      private$frozen <- FALSE
+    },
+    isFrozen = function() {
+      private$frozen
+    },
+    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, ...)))
+      if (length(label) == 1) {
+        paste0("reactiveVal: ", label)
+      } else {
+        c("reactiveVal:", label)
+      }
+    }
+  )
+)
+
+#' Create a (single) reactive value
+#'
+#' The \code{reactiveVal} function is used to construct a "reactive value"
+#' object. This is an object used for reading and writing a value, like a
+#' variable, but with special capabilities for reactive programming. When you
+#' read the value out of a reactiveVal object, the calling reactive expression
+#' takes a dependency, and when you change the value, it notifies any reactives
+#' that previously depended on that value.
+#'
+#' \code{reactiveVal} is very similar to \code{\link{reactiveValues}}, except
+#' that the former is for a single reactive value (like a variable), whereas the
+#' latter lets you conveniently use multiple reactive values by name (like a
+#' named list of variables). For a one-off reactive value, it's more natural to
+#' use \code{reactiveVal}. See the Examples section for an illustration.
+#'
+#' @param value An optional initial value.
+#' @param label An optional label, for debugging purposes (see
+#'   \code{\link{showReactLog}}). If missing, a label will be automatically
+#'   created.
+#'
+#' @return A function. Call the function with no arguments to (reactively) read
+#'   the value; call the function with a single argument to set the value.
+#'
+#' @examples
+#'
+#' \dontrun{
+#'
+#' # Create the object by calling reactiveVal
+#' r <- reactiveVal()
+#'
+#' # Set the value by calling with an argument
+#' r(10)
+#'
+#' # Read the value by calling without arguments
+#' r()
+#'
+#' }
+#'
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   actionButton("minus", "-1"),
+#'   actionButton("plus", "+1"),
+#'   br(),
+#'   textOutput("value")
+#' )
+#'
+#' # The comments below show the equivalent logic using reactiveValues()
+#' server <- function(input, output, session) {
+#'   value <- reactiveVal(0)       # rv <- reactiveValues(value = 0)
+#'
+#'   observeEvent(input$minus, {
+#'     newValue <- value() - 1     # newValue <- rv$value - 1
+#'     value(newValue)             # rv$value <- newValue
+#'   })
+#'
+#'   observeEvent(input$plus, {
+#'     newValue <- value() + 1     # newValue <- rv$value + 1
+#'     value(newValue)             # rv$value <- newValue
+#'   })
+#'
+#'   output$value <- renderText({
+#'     value()                     # rv$value
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
+#'
+#' @export
+reactiveVal <- function(value = NULL, label = NULL) {
+  if (missing(label)) {
+    call <- sys.call()
+    label <- rvalSrcrefToLabel(attr(call, "srcref", exact = TRUE))
+  }
+
+  rv <- ReactiveVal$new(value, label)
+  structure(
+    function(x) {
+      if (missing(x)) {
+        rv$get()
+      } else {
+        force(x)
+        rv$set(x)
+      }
+    },
+    class = c("reactiveVal", "reactive"),
+    label = label,
+    .impl = rv
+  )
+}
+
+#' @rdname freezeReactiveValue
+#' @export
+freezeReactiveVal <- function(x) {
+  domain <- getDefaultReactiveDomain()
+  if (is.null(domain)) {
+    stop("freezeReactiveVal() must be called when a default reactive domain is active.")
+  }
+  if (!inherits(x, "reactiveVal")) {
+    stop("x must be a reactiveVal object")
+  }
+
+  attr(x, ".impl", exact = TRUE)$freeze(domain)
+  invisible()
+}
+
+#' @export
+format.reactiveVal <- function(x, ...) {
+  attr(x, ".impl", exact = TRUE)$format(...)
+}
+
+# Attempts to extract the variable name that the reactiveVal object is being
+# assigned to (e.g. for `a <- reactiveVal()`, the result should be "a"). This
+# is a fragile, error-prone operation, so we default to a random label if
+# necessary.
+rvalSrcrefToLabel <- function(srcref,
+  defaultLabel = paste0("reactiveVal", createUniqueId(4))) {
+
+  if (is.null(srcref))
+    return(defaultLabel)
+
+  srcfile <- attr(srcref, "srcfile", exact = TRUE)
+  if (is.null(srcfile))
+    return(defaultLabel)
+
+  if (is.null(srcfile$lines))
+    return(defaultLabel)
+
+  lines <- srcfile$lines
+  # When pasting at the Console, srcfile$lines is not split
+  if (length(lines) == 1) {
+    lines <- strsplit(lines, "\n")[[1]]
+  }
+
+  if (length(lines) < srcref[1]) {
+    return(defaultLabel)
+  }
+
+  firstLine <- substring(lines[srcref[1]], srcref[2] - 1)
+
+  m <- regexec("\\s*([^[:space:]]+)\\s*(<-|=)\\s*reactiveVal\\b", firstLine)
+  if (m[[1]][1] == -1) {
+    return(defaultLabel)
+  }
+
+  sym <- regmatches(firstLine, m)[[1]][2]
+  res <- try(parse(text = sym), silent = TRUE)
+  if (inherits(res, "try-error"))
+    return(defaultLabel)
+
+  if (length(res) != 1)
+    return(defaultLabel)
+
+  return(as.character(res))
+}
+
+
 # ReactiveValues ------------------------------------------------------------
 
 ReactiveValues <- R6Class(
@@ -82,7 +305,7 @@ ReactiveValues <- R6Class(
       }
 
       if (isFrozen(key))
-        stopWithCondition(c("validation", "shiny.silent.error"), "")
+        reactiveStop()
 
       if (!exists(key, envir=.values, inherits=FALSE))
         NULL
@@ -344,7 +567,7 @@ as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
 
 #' Convert a reactivevalues object to a list
 #'
-#' This function does something similar to what you might \code{\link{as.list}}
+#' This function does something similar to what you might \code{\link[base]{as.list}}
 #' to do. The difference is that the calling context will take dependencies on
 #' every object in the reactivevalues object. To avoid taking dependencies on
 #' all the objects, you can wrap the call with \code{\link{isolate}()}.
@@ -397,14 +620,17 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
 
 #' Freeze a reactive value
 #'
-#' This freezes a reactive value. If the value is accessed while frozen, a
+#' These functions freeze a \code{\link{reactiveVal}}, or an element of a
+#' \code{\link{reactiveValues}}. If the value is accessed while frozen, a
 #' "silent" exception is raised and the operation is stopped. This is the same
 #' thing that happens if \code{req(FALSE)} is called. The value is thawed
 #' (un-frozen; accessing it will no longer raise an exception) when the current
 #' reactive domain is flushed. In a Shiny application, this occurs after all of
 #' the observers are executed.
 #'
-#' @param x A \code{\link{reactiveValues}} object (like \code{input}).
+#' @param x For \code{freezeReactiveValue}, a \code{\link{reactiveValues}}
+#'   object (like \code{input}); for \code{freezeReactiveVal}, a
+#'   \code{\link{reactiveVal}} object.
 #' @param name The name of a value in the \code{\link{reactiveValues}} object.
 #'
 #' @seealso \code{\link{req}}
@@ -446,7 +672,7 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
 #' @export
 freezeReactiveValue <- function(x, name) {
   domain <- getDefaultReactiveDomain()
-  if (is.null(getDefaultReactiveDomain)) {
+  if (is.null(domain)) {
     stop("freezeReactiveValue() must be called when a default reactive domain is active.")
   }
 
@@ -461,6 +687,7 @@ Observable <- R6Class(
   'Observable',
   portable = FALSE,
   public = list(
+    .origFunc = 'function',
     .func = 'function',
     .label = character(0),
     .domain = NULL,
@@ -490,6 +717,7 @@ Observable <- R6Class(
         funcLabel <- paste0("<reactive:", label, ">")
       }
 
+      .origFunc <<- func
       .func <<- wrapFunctionLabel(func, funcLabel,
         ..stacktraceon = ..stacktraceon)
       .label <<- label
@@ -520,12 +748,17 @@ Observable <- R6Class(
       else
         invisible(.value)
     },
+    format = function() {
+      label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
+      strsplit(label, "\n")[[1]]
+    },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
                          prevId = .mostRecentCtxId)
       .mostRecentCtxId <<- ctx$id
       ctx$onInvalidate(function() {
         .invalidated <<- TRUE
+        .value <<- NULL # Value can be GC'd, it won't be read once invalidated
         .dependents$invalidate()
       })
       .execCount <<- .execCount + 1L
@@ -628,13 +861,13 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
   # Attach a label and a reference to the original user source for debugging
   srcref <- attr(substitute(x), "srcref", exact = TRUE)
   if (is.null(label)) {
-    label <- srcrefToLabel(srcref[[1]],
+    label <- rexprSrcrefToLabel(srcref[[1]],
       sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n')))
   }
   if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
   attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
   o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
-  structure(o$getValue, observable = o, class = "reactive")
+  structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive"))
 }
 
 # Given the srcref to a reactive expression, attempts to figure out what the
@@ -642,7 +875,7 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
 # scans the line of code that started the reactive block and looks for something
 # that looks like assignment. If we fail, fall back to a default value (likely
 # the block of code in the body of the reactive).
-srcrefToLabel <- function(srcref, defaultLabel) {
+rexprSrcrefToLabel <- function(srcref, defaultLabel) {
   if (is.null(srcref))
     return(defaultLabel)
 
@@ -680,19 +913,25 @@ srcrefToLabel <- function(srcref, defaultLabel) {
   return(as.character(res))
 }
 
+#' @export
+format.reactiveExpr <- function(x, ...) {
+  attr(x, "observable", exact = TRUE)$format()
+}
+
 #' @export
 print.reactive <- function(x, ...) {
-  label <- attr(x, "observable", exact = TRUE)$.label
-  cat(label, "\n")
+  cat(paste(format(x), collapse = "\n"), "\n")
 }
 
 #' @export
 #' @rdname reactive
-is.reactive <- function(x) inherits(x, "reactive")
+is.reactive <- function(x) {
+  inherits(x, "reactive")
+}
 
 # Return the number of times that a reactive expression or observer has been run
 execCount <- function(x) {
-  if (is.reactive(x))
+  if (inherits(x, "reactiveExpr"))
     return(attr(x, "observable", exact = TRUE)$.execCount)
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
@@ -922,8 +1161,8 @@ registerDebugHook("observerFunc", environment(), label)
 #' soon as their dependencies change, they schedule themselves to re-execute.
 #'
 #' Starting with Shiny 0.10.0, observers are automatically destroyed by default
-#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny session
-#' ends).
+#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny
+#' session ends).
 #'
 #' @param x An expression (quoted or unquoted). Any return value will be
 #'   ignored.
@@ -934,12 +1173,13 @@ registerDebugHook("observerFunc", environment(), label)
 #'   This is useful when you want to use an expression that is stored in a
 #'   variable; to do so, it must be quoted with \code{quote()}.
 #' @param label A label for the observer, useful for debugging.
-#' @param suspended If \code{TRUE}, start the observer in a suspended state.
-#'   If \code{FALSE} (the default), start in a non-suspended state.
+#' @param suspended If \code{TRUE}, start the observer in a suspended state. If
+#'   \code{FALSE} (the default), start in a non-suspended state.
 #' @param priority An integer or numeric that controls the priority with which
-#'   this observer should be executed. An observer with a given priority level
-#'   will always execute sooner than all observers with a lower priority level.
-#'   Positive, negative, and zero values are allowed.
+#'   this observer should be executed. A higher value means higher priority: an
+#'   observer with a higher priority value will execute before all observers
+#'   with lower priority values. Positive, negative, and zero values are
+#'   allowed.
 #' @param domain See \link{domains}.
 #' @param autoDestroy If \code{TRUE} (the default), the observer will be
 #'   automatically destroyed when its domain (if any) ends.
@@ -1108,7 +1348,7 @@ setAutoflush <- local({
 #' @return A no-parameter function that can be called from a reactive context,
 #'   in order to cause that context to be invalidated the next time the timer
 #'   interval elapses. Calling the returned function also happens to yield the
-#'   current time (as in \code{\link{Sys.time}}).
+#'   current time (as in \code{\link[base]{Sys.time}}).
 #' @seealso \code{\link{invalidateLater}}
 #'
 #' @examples
@@ -1149,6 +1389,10 @@ setAutoflush <- local({
 #' }
 #' @export
 reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain()) {
+  # Need to make sure that session is resolved at creation, not when the
+  # callback below is fired (see #1621).
+  force(session)
+
   dependents <- Map$new()
   timerCallbacks$schedule(intervalMs, function() {
     # Quit if the session is closed
@@ -1298,9 +1542,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()
 #'   })
@@ -1375,7 +1632,7 @@ reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
 #' # Cross-session reactive file reader. In this example, all sessions share
 #' # the same reader, so read.csv only gets executed once no matter how many
 #' # user sessions are connected.
-#' fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
+#' fileData <- reactiveFileReader(1000, NULL, 'data.csv', read.csv)
 #' function(input, output, session) {
 #'   output$data <- renderTable({
 #'     fileData()
@@ -1416,7 +1673,7 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
 #' The expression given to \code{isolate()} is evaluated in the calling
 #' environment. This means that if you assign a variable inside the
 #' \code{isolate()}, its value will be visible outside of the \code{isolate()}.
-#' If you want to avoid this, you can use \code{\link{local}()} inside the
+#' If you want to avoid this, you can use \code{\link[base]{local}()} inside the
 #' \code{isolate()}.
 #'
 #' This function can also be useful for calling reactive expression at the
@@ -1529,6 +1786,8 @@ maskReactiveContext <- function(expr) {
 #' invalidations that come from its reactive dependencies; it only invalidates
 #' in response to the given event.
 #'
+#' @section ignoreNULL and ignoreInit:
+#'
 #' Both \code{observeEvent} and \code{eventReactive} take an \code{ignoreNULL}
 #' parameter that affects behavior when the \code{eventExpr} evaluates to
 #' \code{NULL} (or in the special case of an \code{\link{actionButton}},
@@ -1541,6 +1800,44 @@ maskReactiveContext <- function(expr) {
 #' the action/calculation and just let the user re-initiate it (like a
 #' "Recalculate" button).
 #'
+#' Unlike what happens for \code{ignoreNULL}, only \code{observeEvent} takes in an
+#' \code{ignoreInit} argument. By default, \code{observeEvent} will run right when
+#' it is created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
+#' and \code{ignoreNULL} is \code{TRUE}). But when responding to a click of an action
+#' button, it may often be useful to set \code{ignoreInit} to \code{TRUE}. For
+#' example, if you're setting up an \code{observeEvent} for a dynamically created
+#' button, then \code{ignoreInit = TRUE} will guarantee that the action (in
+#' \code{handlerExpr}) will only be triggered when the button is actually clicked,
+#' instead of also being triggered when it is created/initialized.
+#'
+#' Even though \code{ignoreNULL} and \code{ignoreInit} can be used for similar
+#' purposes they are independent from one another. Here's the result of combining
+#' these:
+#'
+#' \describe{
+#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = FALSE}}{
+#'      This is the default. This combination means that \code{handlerExpr} will
+#'      run every time that \code{eventExpr} is not \code{NULL}. If, at the time
+#'      of the \code{observeEvent}'s creation, \code{handleExpr} happens to
+#'      \emph{not} be \code{NULL}, then the code runs.
+#'   }
+#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
+#'      This combination means that \code{handlerExpr} will run every time no
+#'      matter what.
+#'   }
+#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = TRUE}}{
+#'      This combination means that \code{handlerExpr} will \emph{not} run when
+#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}),
+#'      but it will run every other time.
+#'   }
+#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = TRUE}}{
+#'      This combination means that \code{handlerExpr} will \emph{not} run when
+#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}).
+#'      After that, \code{handlerExpr} will run every time that \code{eventExpr}
+#'      is not \code{NULL}.
+#'   }
+#' }
+#'
 #' @param eventExpr A (quoted or unquoted) expression that represents the event;
 #'   this can be a simple reactive value like \code{input$click}, a call to a
 #'   reactive expression like \code{dataset()}, or even a complex expression
@@ -1582,6 +1879,15 @@ maskReactiveContext <- function(expr) {
 #' @param ignoreNULL Whether the action should be triggered (or value
 #'   calculated, in the case of \code{eventReactive}) when the input is
 #'   \code{NULL}. See Details.
+#' @param ignoreInit If \code{TRUE}, then, when this \code{observeEvent} is
+#'   first created/initialized, ignore the \code{handlerExpr} (the second
+#'   argument), whether it is otherwise supposed to run or not. The default is
+#'   \code{FALSE}. See Details.
+#' @param once Whether this \code{observeEvent} should be immediately destroyed
+#'   after the first time that the code in \code{handlerExpr} is run. This
+#'   pattern is useful when you want to subscribe to a event that should only
+#'   happen once.
+#'
 #' @return \code{observeEvent} returns an observer reference class object (see
 #'   \code{\link{observe}}). \code{eventReactive} returns a reactive expression
 #'   object (see \code{\link{reactive}}).
@@ -1591,37 +1897,71 @@ maskReactiveContext <- function(expr) {
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
-#'   ui <- fluidPage(
-#'     column(4,
-#'       numericInput("x", "Value", 5),
-#'       br(),
-#'       actionButton("button", "Show")
+#'
+#'   ## App 1: Sample usage
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       column(4,
+#'         numericInput("x", "Value", 5),
+#'         br(),
+#'         actionButton("button", "Show")
+#'       ),
+#'       column(8, tableOutput("table"))
 #'     ),
-#'     column(8, tableOutput("table"))
+#'     server = function(input, output) {
+#'       # Take an action every time button is pressed;
+#'       # here, we just print a message to the console
+#'       observeEvent(input$button, {
+#'         cat("Showing", input$x, "rows\n")
+#'       })
+#'       # Take a reactive dependency on input$button, but
+#'       # not on any of the stuff inside the function
+#'       df <- eventReactive(input$button, {
+#'         head(cars, input$x)
+#'       })
+#'       output$table <- renderTable({
+#'         df()
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: Using `once`
+#'   shinyApp(
+#'     ui = basicPage( actionButton("go", "Go")),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         print(paste("This will only be printed once; all",
+#'               "subsequent button clicks won't do anything"))
+#'       }, once = TRUE)
+#'     }
+#'   )
+#'
+#'   ## App 3: Using `ignoreInit` and `once`
+#'   shinyApp(
+#'     ui = basicPage(actionButton("go", "Go")),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         insertUI("#go", "afterEnd",
+#'                  actionButton("dynamic", "click to remove"))
+#'
+#'         # set up an observer that depends on the dynamic
+#'         # input, so that it doesn't run when the input is
+#'         # created, and only runs once after that (since
+#'         # the side effect is remove the input from the DOM)
+#'         observeEvent(input$dynamic, {
+#'           removeUI("#dynamic")
+#'         }, ignoreInit = TRUE, once = TRUE)
+#'       })
+#'     }
 #'   )
-#'   server <- function(input, output) {
-#'     # Take an action every time button is pressed;
-#'     # here, we just print a message to the console
-#'     observeEvent(input$button, {
-#'       cat("Showing", input$x, "rows\n")
-#'     })
-#'     # Take a reactive dependency on input$button, but
-#'     # not on any of the stuff inside the function
-#'     df <- eventReactive(input$button, {
-#'       head(cars, input$x)
-#'     })
-#'     output$table <- renderTable({
-#'       df()
-#'     })
-#'   }
-#'   shinyApp(ui=ui, server=server)
 #' }
 #' @export
 observeEvent <- function(eventExpr, handlerExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   handler.env = parent.frame(), handler.quoted = FALSE,
-  label=NULL, suspended=FALSE, priority=0, domain=getDefaultReactiveDomain(),
-  autoDestroy = TRUE, ignoreNULL = TRUE) {
+  label = NULL, suspended = FALSE, priority = 0,
+  domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
+  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {
 
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
@@ -1631,16 +1971,29 @@ observeEvent <- function(eventExpr, handlerExpr,
   handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
   handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
 
-  invisible(observe({
+  initialized <- FALSE
+
+  o <- observe({
     e <- eventFunc()
 
+    if (ignoreInit && !initialized) {
+      initialized <<- TRUE
+      return()
+    }
+
     if (ignoreNULL && isNullEvent(e)) {
       return()
     }
 
+    if (once) {
+      on.exit(o$destroy())
+    }
+
     isolate(handlerFunc())
   }, label = label, suspended = suspended, priority = priority, domain = domain,
-    autoDestroy = TRUE, ..stacktraceon = FALSE))
+  autoDestroy = TRUE, ..stacktraceon = FALSE)
+
+  invisible(o)
 }
 
 #' @rdname observeEvent
@@ -1648,8 +2001,8 @@ observeEvent <- function(eventExpr, handlerExpr,
 eventReactive <- function(eventExpr, valueExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   value.env = parent.frame(), value.quoted = FALSE,
-  label=NULL, domain=getDefaultReactiveDomain(),
-  ignoreNULL = TRUE) {
+  label = NULL, domain = getDefaultReactiveDomain(),
+  ignoreNULL = TRUE, ignoreInit = FALSE) {
 
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
@@ -1659,13 +2012,17 @@ eventReactive <- function(eventExpr, valueExpr,
   handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
   handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
 
+  initialized <- FALSE
+
   invisible(reactive({
     e <- eventFunc()
 
-    validate(need(
-      !ignoreNULL || !isNullEvent(e),
-      message = FALSE
-    ))
+    if (ignoreInit && !initialized) {
+      initialized <<- TRUE
+      req(FALSE)
+    }
+
+    req(!ignoreNULL || !isNullEvent(e))
 
     isolate(handlerFunc())
   }, label = label, domain = domain, ..stacktraceon = FALSE))
@@ -1674,3 +2031,246 @@ eventReactive <- function(eventExpr, valueExpr,
 isNullEvent <- function(value) {
   is.null(value) || (inherits(value, 'shinyActionButtonValue') && value == 0)
 }
+
+#' Slow down a reactive expression with debounce/throttle
+#'
+#' Transforms a reactive expression by preventing its invalidation signals from
+#' being sent unnecessarily often. This lets you ignore a very "chatty" reactive
+#' expression until it becomes idle, which is useful when the intermediate
+#' values don't matter as much as the final value, and the downstream
+#' calculations that depend on the reactive expression take a long time.
+#' \code{debounce} and \code{throttle} use different algorithms for slowing down
+#' invalidation signals; see Details.
+#'
+#' @section Limitations:
+#'
+#'   Because R is single threaded, we can't come close to guaranteeing that the
+#'   timing of debounce/throttle (or any other timing-related functions in
+#'   Shiny) will be consistent or accurate; at the time we want to emit an
+#'   invalidation signal, R may be performing a different task and we have no
+#'   way to interrupt it (nor would we necessarily want to if we could).
+#'   Therefore, it's best to think of the time windows you pass to these
+#'   functions as minimums.
+#'
+#'   You may also see undesirable behavior if the amount of time spent doing
+#'   downstream processing for each change approaches or exceeds the time
+#'   window: in this case, debounce/throttle may not have any effect, as the
+#'   time each subsequent event is considered is already after the time window
+#'   has expired.
+#'
+#' @details
+#'
+#' This is not a true debounce/throttle in that it will not prevent \code{r}
+#' from being called many times (in fact it may be called more times than
+#' usual), but rather, the reactive invalidation signal that is produced by
+#' \code{r} is debounced/throttled instead. Therefore, these functions should be
+#' used when \code{r} is cheap but the things it will trigger (downstream
+#' outputs and reactives) are expensive.
+#'
+#' Debouncing means that every invalidation from \code{r} will be held for the
+#' specified time window. If \code{r} invalidates again within that time window,
+#' then the timer starts over again. This means that as long as invalidations
+#' continually arrive from \code{r} within the time window, the debounced
+#' reactive will not invalidate at all. Only after the invalidations stop (or
+#' slow down sufficiently) will the downstream invalidation be sent.
+#'
+#' \code{ooo-oo-oo---- => -----------o-}
+#'
+#' (In this graphical depiction, each character represents a unit of time, and
+#' the time window is 3 characters.)
+#'
+#' Throttling, on the other hand, delays invalidation if the \emph{throttled}
+#' reactive recently (within the time window) invalidated. New \code{r}
+#' invalidations do not reset the time window. This means that if invalidations
+#' continually come from \code{r} within the time window, the throttled reactive
+#' will invalidate regularly, at a rate equal to or slower than than the time
+#' window.
+#'
+#' \code{ooo-oo-oo---- => o--o--o--o---}
+#'
+#' @param r A reactive expression (that invalidates too often).
+#' @param millis The debounce/throttle time window. You may optionally pass a
+#'   no-arg function or reactive expression instead, e.g. to let the end-user
+#'   control the time window.
+#' @param priority Debounce/throttle is implemented under the hood using
+#'   \link[=observe]{observers}. Use this parameter to set the priority of
+#'   these observers. Generally, this should be higher than the priorities of
+#'   downstream observers and outputs (which default to zero).
+#' @param domain See \link{domains}.
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' library(shiny)
+#' library(magrittr)
+#'
+#' ui <- fluidPage(
+#'   plotOutput("plot", click = clickOpts("hover")),
+#'   helpText("Quickly click on the plot above, while watching the result table below:"),
+#'   tableOutput("result")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   hover <- reactive({
+#'     if (is.null(input$hover))
+#'       list(x = NA, y = NA)
+#'     else
+#'       input$hover
+#'   })
+#'   hover_d <- hover %>% debounce(1000)
+#'   hover_t <- hover %>% throttle(1000)
+#'
+#'   output$plot <- renderPlot({
+#'     plot(cars)
+#'   })
+#'
+#'   output$result <- renderTable({
+#'     data.frame(
+#'       mode = c("raw", "throttle", "debounce"),
+#'       x = c(hover()$x, hover_t()$x, hover_d()$x),
+#'       y = c(hover()$y, hover_t()$y, hover_d()$y)
+#'     )
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
+
+  # TODO: make a nice label for the observer(s)
+
+  force(r)
+  force(millis)
+
+  if (!is.function(millis)) {
+    origMillis <- millis
+    millis <- function() origMillis
+  }
+
+  v <- reactiveValues(
+    trigger = NULL,
+    when = NULL # the deadline for the timer to fire; NULL if not scheduled
+  )
+
+  # Responsible for tracking when f() changes.
+  firstRun <- TRUE
+  observe({
+    r()
+
+    if (firstRun) {
+      # During the first run we don't want to set v$when, as this will kick off
+      # the timer. We only want to do that when we see r() change.
+      firstRun <<- FALSE
+      return()
+    }
+
+    # The value (or possibly millis) changed. Start or reset the timer.
+    v$when <- Sys.time() + millis()/1000
+  }, label = "debounce tracker", domain = domain, priority = priority)
+
+  # This observer is the timer. It rests until v$when elapses, then touches
+  # v$trigger.
+  observe({
+    if (is.null(v$when))
+      return()
+
+    now <- Sys.time()
+    if (now >= v$when) {
+      # Mod by 999999999 to get predictable overflow behavior
+      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
+      v$when <- NULL
+    } else {
+      invalidateLater((v$when - now) * 1000)
+    }
+  }, label = "debounce timer", domain = domain, priority = priority)
+
+  # This is the actual reactive that is returned to the user. It returns the
+  # value of r(), but only invalidates/updates when v$trigger is touched.
+  er <- eventReactive(v$trigger, {
+    r()
+  }, label = "debounce result", ignoreNULL = FALSE, domain = domain)
+
+  # Force the value of er to be immediately cached upon creation. It's very hard
+  # to explain why this observer is needed, but if you want to understand, try
+  # commenting it out and studying the unit test failure that results.
+  primer <- observe({
+    primer$destroy()
+    er()
+  }, label = "debounce primer", domain = domain, priority = priority)
+
+  er
+}
+
+#' @rdname debounce
+#' @export
+throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
+
+  # TODO: make a nice label for the observer(s)
+
+  force(r)
+  force(millis)
+
+  if (!is.function(millis)) {
+    origMillis <- millis
+    millis <- function() origMillis
+  }
+
+  v <- reactiveValues(
+    trigger = 0,
+    lastTriggeredAt = NULL, # Last time we fired; NULL if never
+    pending = FALSE # If TRUE, trigger again when timer elapses
+  )
+
+  blackoutMillisLeft <- function() {
+    if (is.null(v$lastTriggeredAt)) {
+      0
+    } else {
+      max(0, (v$lastTriggeredAt + millis()/1000) - Sys.time()) * 1000
+    }
+  }
+
+  trigger <- function() {
+    v$lastTriggeredAt <- Sys.time()
+    # Mod by 999999999 to get predictable overflow behavior
+    v$trigger <- isolate(v$trigger) %% 999999999 + 1
+    v$pending <- FALSE
+  }
+
+  # Responsible for tracking when f() changes.
+  observeEvent(r(), {
+    if (v$pending) {
+      # In a blackout period and someone already scheduled; do nothing
+    } else if (blackoutMillisLeft() > 0) {
+      # In a blackout period but this is the first change in that period; set
+      # v$pending so that a trigger will be scheduled at the end of the period
+      v$pending <- TRUE
+    } else {
+      # Not in a blackout period. Trigger, which will start a new blackout
+      # period.
+      trigger()
+    }
+  }, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)
+
+  observe({
+    if (!v$pending) {
+      return()
+    }
+
+    timeout <- blackoutMillisLeft()
+    if (timeout > 0) {
+      invalidateLater(timeout)
+    } else {
+      trigger()
+    }
+  }, priority = priority, domain = domain)
+
+  # This is the actual reactive that is returned to the user. It returns the
+  # value of r(), but only invalidates/updates when v$trigger is touched.
+  eventReactive(v$trigger, {
+    r()
+  }, label = "throttle result", ignoreNULL = FALSE, domain = domain)
+}

R/render-plot.R

@@ -28,7 +28,7 @@
 #'   inline plot, you must provide numeric values (in pixels) to both
 #'   \code{width} and \code{height}.
 #' @param res Resolution of resulting plot, in pixels per inch. This value is
-#'   passed to \code{\link{png}}. Note that this affects the resolution of PNG
+#'   passed to \code{\link[grDevices]{png}}. Note that this affects the resolution of PNG
 #'   rendering in R; it won't change the actual ppi of the browser.
 #' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
 #'   These can be used to set the width, height, background color, etc.
@@ -165,9 +165,9 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 
   plotObj <- reactive(label = "plotObj", {
     if (execOnResize) {
-      isolate({ dims <- getDims() })
-    } else {
       dims <- getDims()
+    } else {
+      isolate({ dims <- getDims() })
     }
 
     if (is.null(dims$width) || is.null(dims$height) ||
@@ -185,6 +185,9 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       success <-FALSE
       tryCatch(
         {
+          # This is necessary to enable displaylist recording
+          grDevices::dev.control(displaylist = "enable")
+
           # Actually perform the plotting
           result <- withVisible(func())
           success <- TRUE
@@ -284,17 +287,30 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #   .. ..$ y: NULL
 #   ..$ mapping: Named list()
 #
-# For ggplot2, it might be something like:
-# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
-# str(getGgplotCoordmap(p, 1))
+# For ggplot2, first you need to define the print.ggplot function from inside
+# renderPlot, then use it to print the plot:
+# 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")
+# }
+#
+# p <- print(ggplot(mtcars, aes(wt, mpg)) + geom_point())
+# str(getGgplotCoordmap(p, 1, 72))
 # List of 1
 #  $ :List of 10
 #   ..$ panel     : int 1
 #   ..$ row       : int 1
 #   ..$ col       : int 1
 #   ..$ panel_vars: Named list()
-#   ..$ scale_x   : int 1
-#   ..$ scale_y   : int 1
 #   ..$ log       :List of 2
 #   .. ..$ x: NULL
 #   .. ..$ y: NULL
@@ -317,8 +333,8 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 # can be up to two of them.
 # mtc <- mtcars
 # mtc$am <- factor(mtc$am)
-# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() + facet_wrap(~ am)
-# str(getGgplotCoordmap(p, 1))
+# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
+# str(getGgplotCoordmap(p, 1, 72))
 # List of 2
 #  $ :List of 10
 #   ..$ panel     : int 1
@@ -326,8 +342,6 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #   ..$ col       : int 1
 #   ..$ panel_vars:List of 1
 #   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
-#   ..$ scale_x   : int 1
-#   ..$ scale_y   : int 1
 #   ..$ log       :List of 2
 #   .. ..$ x: NULL
 #   .. ..$ y: NULL
@@ -351,8 +365,6 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 #   ..$ col       : int 2
 #   ..$ panel_vars:List of 1
 #   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
-#   ..$ scale_x   : int 1
-#   ..$ scale_y   : int 1
 #   ..$ log       :List of 2
 #   .. ..$ x: NULL
 #   .. ..$ y: NULL
@@ -418,62 +430,192 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
   if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
-  # Given a built ggplot object, return x and y domains (data space coords) for
-  # each panel.
-  find_panel_info <- function(b) {
-    layout <- b$panel$layout
-    # Convert factor to numbers
-    layout$PANEL <- as.integer(as.character(layout$PANEL))
+  tryCatch({
+    # Get info from built ggplot object
+    info <- find_panel_info(p$build)
 
-    # Names of facets
-    facet <- b$plot$facet
-    facet_vars <- NULL
-    if (inherits(facet, "grid")) {
-      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
-    } else if (inherits(facet, "wrap")) {
-      facet_vars <- vapply(facet$facets, as.character, character(1))
+    # Get ranges from gtable - it's possible for this to return more elements than
+    # info, because it calculates positions even for panels that aren't present.
+    # This can happen with facet_wrap.
+    ranges <- find_panel_ranges(p$gtable, pixelratio, res)
+
+    for (i in seq_along(info)) {
+      info[[i]]$range <- ranges[[i]]
     }
 
-    # Iterate over each row in the layout data frame
-    lapply(seq_len(nrow(layout)), function(i) {
-      # Slice out one row
-      l <- layout[i, ]
+    return(info)
 
-      scale_x <- l$SCALE_X
-      scale_y <- l$SCALE_Y
+  }, error = function(e) {
+    # If there was an error extracting info from the ggplot object, just return
+    # a list with the error message.
+    return(structure(list(), error = e$message))
+  })
+}
 
-      mapping <- find_plot_mappings(b)
 
-      # For each of the faceting variables, get the value of that variable in
-      # the current panel. Default to empty _named_ list so that it's sent as a
-      # JSON object, not array.
-      panel_vars <- list(a = NULL)[0]
-      for (i in seq_along(facet_vars)) {
-        var_name <- facet_vars[[i]]
-        vname <- paste0("panelvar", i)
+find_panel_info <- function(b) {
+  # Structure of ggplot objects changed after 2.1.0. After 2.2.1, there was a
+  # an API for extracting the necessary information.
+  ggplot_ver <- utils::packageVersion("ggplot2")
 
-        mapping[[vname]] <- var_name
-        panel_vars[[vname]] <- l[[var_name]]
+  if (ggplot_ver > "2.2.1") {
+    find_panel_info_api(b)
+  } else if (ggplot_ver > "2.1.0") {
+    find_panel_info_non_api(b, ggplot_format = "new")
+  } else {
+    find_panel_info_non_api(b, ggplot_format = "old")
+  }
+}
+
+# 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 <- 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
+  # log transform.
+  get_log_bases <- function(xscale, yscale, coord) {
+    # Given a transform object, find the log base; if the transform object is
+    # NULL, or if it's not a log transform, return NA.
+    get_log_base <- function(trans) {
+      if (!is.null(trans) && grepl("^log-", trans$name)) {
+        environment(trans$transform)$base
+      } else {
+        NA_real_
       }
+    }
 
-      list(
-        panel   = l$PANEL,
-        row     = l$ROW,
-        col     = l$COL,
-        panel_vars = panel_vars,
-        scale_x = scale_x,
-        scale_y = scale_x,
-        log     = check_log_scales(b, scale_x, scale_y),
-        domain  = find_panel_domain(b, l$PANEL, scale_x, scale_y),
-        mapping = mapping
-      )
-    })
+    # First look for log base in scale, then coord; otherwise NULL.
+    list(
+      x = get_log_base(xscale$trans) %OR% coord$xlog %OR% NULL,
+      y = get_log_base(yscale$trans) %OR% coord$ylog %OR% NULL
+    )
   }
 
+  # Given x/y min/max, and the x/y scale objects, create a list that
+  # represents the domain. Note that the x/y min/max should be taken from
+  # the layout summary table, not the scale objects.
+  get_domain <- function(xmin, xmax, ymin, ymax, xscale, yscale) {
+    is_reverse <- function(scale) {
+      identical(scale$trans$name, "reverse")
+    }
+
+    domain <- list(
+      left   = xmin,
+      right  = xmax,
+      bottom = ymin,
+      top    = ymax
+    )
+
+    if (is_reverse(xscale)) {
+      domain$left  <- -domain$left
+      domain$right <- -domain$right
+    }
+    if (is_reverse(yscale)) {
+      domain$top    <- -domain$top
+      domain$bottom <- -domain$bottom
+    }
+
+    domain
+  }
+
+  # Rename the items in vars to have names like panelvar1, panelvar2.
+  rename_panel_vars <- function(vars) {
+    for (i in seq_along(vars)) {
+      names(vars)[i] <- paste0("panelvar", i)
+    }
+    vars
+  }
+
+  get_mappings <- function(layers, layout, coord) {
+    # For simplicity, we'll just use the mapping from the first layer of the
+    # ggplot object. The original uses quoted expressions; convert to
+    # character.
+    mapping <- layers$mapping[[1]]
+    # lapply'ing as.character results in unexpected behavior for expressions
+    # like `wt/2`; deparse handles it correctly.
+    mapping <- lapply(mapping, deparse)
+
+    # If either x or y is not present, give it a NULL entry.
+    mapping <- mergeVectors(list(x = NULL, y = NULL), mapping)
+
+    # The names (not values) of panel vars are the same across all panels,
+    # so just look at the first one. Also, the order of panel vars needs
+    # to be reversed.
+    vars <- rev(layout$vars[[1]])
+    for (i in seq_along(vars)) {
+      mapping[[paste0("panelvar", i)]] <- names(vars)[i]
+    }
+
+    if (isTRUE(coord$flip)) {
+      mapping[c("x", "y")] <- mapping[c("y", "x")]
+    }
+
+    mapping
+  }
+
+  # Mapping is constant across all panels, so get it here and reuse later.
+  mapping <- get_mappings(layers, layout, coord)
+
+  # If coord_flip is used, these need to be swapped
+  flip_xy <- function(layout) {
+    l <- layout
+    l$xscale <- layout$yscale
+    l$yscale <- layout$xscale
+    l$xmin <- layout$ymin
+    l$xmax <- layout$ymax
+    l$ymin <- layout$xmin
+    l$ymax <- layout$xmax
+    l
+  }
+  if (coord$flip) {
+    layout <- flip_xy(layout)
+  }
+
+  # Iterate over each row in the layout data frame
+  lapply(seq_len(nrow(layout)), function(i) {
+    # Slice out one row, use it as a list. The (former) list-cols are still
+    # in lists, so we need to unwrap them.
+    l <- as.list(layout[i, ])
+    l$vars   <- l$vars[[1]]
+    l$xscale <- l$xscale[[1]]
+    l$yscale <- l$yscale[[1]]
+
+    list(
+      panel   = as.numeric(l$panel),
+      row     = l$row,
+      col     = l$col,
+      # Rename panel vars. They must also be in reversed order.
+      panel_vars = rename_panel_vars(rev(l$vars)),
+      log     = get_log_bases(l$xscale, l$yscale, coord),
+      domain  = get_domain(l$xmin, l$xmax, l$ymin, l$ymax, l$xscale, l$yscale),
+      mapping = mapping
+    )
+  })
+}
+
+
+# This is for ggplot2<=2.2.1, before an API was introduced for extracting
+# information about the plot object. The "old" format was used before 2.1.0.
+# The "new" format was used after 2.1.0, up to 2.2.1. The reason these two
+# formats are mixed together in a single function is historical, and it's not
+# worthwhile to separate them at this point.
+find_panel_info_non_api <- function(b, ggplot_format) {
   # Given a single range object (representing the data domain) from a built
   # ggplot object, return the domain.
   find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
-    range <- b$panel$ranges[[panel_num]]
+    if (ggplot_format == "new") {
+      range <- b$layout$panel_ranges[[panel_num]]
+    } else {
+      range <- b$panel$ranges[[panel_num]]
+    }
     domain <- list(
       left   = range$x.range[1],
       right  = range$x.range[2],
@@ -482,9 +624,13 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     )
 
     # Check for reversed scales
-    xscale <- b$panel$x_scales[[scalex_num]]
-    yscale <- b$panel$y_scales[[scaley_num]]
-
+    if (ggplot_format == "new") {
+      xscale <- b$layout$panel_scales$x[[scalex_num]]
+      yscale <- b$layout$panel_scales$y[[scaley_num]]
+    } else {
+      xscale <- b$panel$x_scales[[scalex_num]]
+      yscale <- b$panel$y_scales[[scaley_num]]
+    }
     if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
       domain$left  <- -domain$left
       domain$right <- -domain$right
@@ -519,10 +665,18 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
     y_names <- character(0)
 
     # Continuous scales have a trans; discrete ones don't
-    if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
-      x_names <- b$panel$x_scales[[scalex_num]]$trans$name
-    if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
-      y_names <- b$panel$y_scales[[scaley_num]]$trans$name
+    if (ggplot_format == "new") {
+      if (!is.null(b$layout$panel_scales$x[[scalex_num]]$trans))
+        x_names <- b$layout$panel_scales$x[[scalex_num]]$trans$name
+      if (!is.null(b$layout$panel_scales$y[[scaley_num]]$trans))
+        y_names <- b$layout$panel_scales$y[[scaley_num]]$trans$name
+
+    } else {
+      if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
+        x_names <- b$panel$x_scales[[scalex_num]]$trans$name
+      if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
+        y_names <- b$panel$y_scales[[scaley_num]]$trans$name
+    }
 
     coords <- b$plot$coordinates
     if (!is.null(coords$trans)) {
@@ -576,133 +730,229 @@ getGgplotCoordmap <- function(p, pixelratio, res) {
       )
     }
 
+    # Look for CoordFlip
+    if (inherits(b$plot$coordinates, "CoordFlip")) {
+      mappings[c("x", "y")] <- mappings[c("y", "x")]
+    }
+
     mappings_cache <<- mappings
     mappings
   }
 
-  # Given a gtable object, return the x and y ranges (in pixel dimensions)
-  find_panel_ranges <- function(g, pixelratio) {
-    # Given a vector of unit objects, return logical vector indicating which ones
-    # are "null" units. These units use the remaining available width/height --
-    # that is, the space not occupied by elements that have an absolute size.
-    is_null_unit <- function(x) {
-      # A vector of units can be either a list of individual units (a unit.list
-      # object), each with their own set of attributes, or an atomic vector with
-      # one set of attributes. ggplot2 switched from the former (in version
-      # 1.0.1) to the latter. We need to make sure that we get the correct
-      # result in both cases.
-      if (inherits(x, "unit.list")) {
-        # For ggplot2 <= 1.0.1
-        vapply(x, FUN.VALUE = logical(1), function(u) {
-          isTRUE(attr(u, "unit", exact = TRUE) == "null")
-        })
-      } else {
-        # For later versions of ggplot2
-        attr(x, "unit", exact = TRUE) == "null"
-      }
+  if (ggplot_format == "new") {
+    layout <- b$layout$panel_layout
+  } else {
+    layout <- b$panel$layout
+  }
+  # Convert factor to numbers
+  layout$PANEL <- as.integer(as.character(layout$PANEL))
+
+  # Names of facets
+  facet_vars <- NULL
+  if (ggplot_format == "new") {
+    facet <- b$layout$facet
+    if (inherits(facet, "FacetGrid")) {
+      facet_vars <- vapply(c(facet$params$cols, facet$params$rows), as.character, character(1))
+    } else if (inherits(facet, "FacetWrap")) {
+      facet_vars <- vapply(facet$params$facets, as.character, character(1))
     }
-
-    # Workaround for a bug in the quartz device. If you have a 400x400 image and
-    # run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
-    # res setting of the device. If res=72, then it returns 400 (as expected),
-    # but if, e.g., res=96, it will return 300, which is incorrect.
-    devScaleFactor <- 1
-    if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
-      devScaleFactor <- res / 72
+  } else {
+    facet <- b$plot$facet
+    if (inherits(facet, "grid")) {
+      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
+    } else if (inherits(facet, "wrap")) {
+      facet_vars <- vapply(facet$facets, as.character, character(1))
     }
-
-    # Convert a unit (or vector of units) to a numeric vector of pixel sizes
-    h_px <- function(x) {
-      devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
-    }
-    w_px <- function(x) {
-      devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
-    }
-
-    # Given a vector of relative sizes (in grid units), and a function for
-    # converting grid units to numeric pixels, return a numeric vector of
-    # pixel sizes.
-    find_px_sizes <- function(rel_sizes, unit_to_px) {
-      # Total pixels (in height or width)
-      total_px <- unit_to_px(grid::unit(1, "npc"))
-      # Calculate size of all panel(s) together. Panels (and only panels) have
-      # null size.
-      null_idx <- is_null_unit(rel_sizes)
-      # All the absolute heights. At this point, null heights are 0. We need to
-      # calculate them separately and add them in later.
-      px_sizes <- unit_to_px(rel_sizes)
-      # Total size for panels is image size minus absolute (non-panel) elements
-      panel_px_total <- total_px - sum(px_sizes)
-      # Divide up the total panel size up into the panels (scaled by size)
-      panel_sizes_rel <- as.numeric(rel_sizes[null_idx])
-      panel_sizes_rel <- panel_sizes_rel / sum(panel_sizes_rel)
-      px_sizes[null_idx] <- panel_px_total * panel_sizes_rel
-      abs(px_sizes)
-    }
-
-    px_heights <- find_px_sizes(g$heights, h_px)
-    px_widths <- find_px_sizes(g$widths, w_px)
-
-    # Convert to absolute pixel positions
-    x_pos <- cumsum(px_widths)
-    y_pos <- cumsum(px_heights)
-
-    # Match up the pixel dimensions to panels
-    layout <- g$layout
-    # For panels:
-    # * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
-    # * For no facet or facet_grid, they'll just be named "panel". For
-    #   facet_grid, we need to re-order the layout table. Assume that panel
-    #   numbers go from left to right, then next row.
-    # Assign a number to each panel, corresponding to PANEl in the built ggplot
-    # object.
-    layout <- layout[grepl("^panel", layout$name), ]
-    layout <- layout[order(layout$t, layout$l), ]
-    layout$panel <- seq_len(nrow(layout))
-
-    # When using a HiDPI client on a Linux server, the pixel
-    # dimensions are doubled, so we have to divide the dimensions by
-    # `pixelratio`. When a HiDPI client is used on a Mac server (with
-    # the quartz device), the pixel dimensions _aren't_ doubled, even though
-    # the image has double size. In the latter case we don't have to scale the
-    # numbers down.
-    pix_ratio <- 1
-    if (!grepl("^quartz", names(grDevices::dev.cur()))) {
-      pix_ratio <- pixelratio
-    }
-
-    # Return list of lists, where each inner list has left, right, top, bottom
-    # values for a panel
-    lapply(seq_len(nrow(layout)), function(i) {
-      p <- layout[i, , drop = FALSE]
-      list(
-        left   = x_pos[p$l - 1] / pix_ratio,
-        right  = x_pos[p$r] / pix_ratio,
-        bottom = y_pos[p$b] / pix_ratio,
-        top    = y_pos[p$t - 1] / pix_ratio
-      )
-    })
   }
 
+  # Iterate over each row in the layout data frame
+  lapply(seq_len(nrow(layout)), function(i) {
+    # Slice out one row
+    l <- layout[i, ]
 
-  tryCatch({
-    # Get info from built ggplot object
-    info <- find_panel_info(p$build)
+    scale_x <- l$SCALE_X
+    scale_y <- l$SCALE_Y
 
-    # Get ranges from gtable - it's possible for this to return more elements than
-    # info, because it calculates positions even for panels that aren't present.
-    # This can happen with facet_wrap.
-    ranges <- find_panel_ranges(p$gtable, pixelratio)
+    mapping <- find_plot_mappings(b)
 
-    for (i in seq_along(info)) {
-      info[[i]]$range <- ranges[[i]]
+    # For each of the faceting variables, get the value of that variable in
+    # the current panel. Default to empty _named_ list so that it's sent as a
+    # JSON object, not array.
+    panel_vars <- list(a = NULL)[0]
+    for (i in seq_along(facet_vars)) {
+      var_name <- facet_vars[[i]]
+      vname <- paste0("panelvar", i)
+
+      mapping[[vname]] <- var_name
+      panel_vars[[vname]] <- l[[var_name]]
     }
 
-    return(info)
-
-  }, error = function(e) {
-    # If there was an error extracting info from the ggplot object, just return
-    # a list with the error message.
-    return(structure(list(), error = e$message))
+    list(
+      panel   = l$PANEL,
+      row     = l$ROW,
+      col     = l$COL,
+      panel_vars = panel_vars,
+      scale_x = scale_x,
+      scale_y = scale_x,
+      log     = check_log_scales(b, scale_x, scale_y),
+      domain  = find_panel_domain(b, l$PANEL, scale_x, scale_y),
+      mapping = mapping
+    )
+  })
+}
+
+
+# Given a gtable object, return the x and y ranges (in pixel dimensions)
+find_panel_ranges <- function(g, pixelratio, res) {
+  # Given a vector of unit objects, return logical vector indicating which ones
+  # are "null" units. These units use the remaining available width/height --
+  # that is, the space not occupied by elements that have an absolute size.
+  is_null_unit <- function(x) {
+    # A vector of units can be either a list of individual units (a unit.list
+    # object), each with their own set of attributes, or an atomic vector with
+    # one set of attributes. ggplot2 switched from the former (in version
+    # 1.0.1) to the latter. We need to make sure that we get the correct
+    # result in both cases.
+    if (inherits(x, "unit.list")) {
+      # For ggplot2 <= 1.0.1
+      vapply(x, FUN.VALUE = logical(1), function(u) {
+        isTRUE(attr(u, "unit", exact = TRUE) == "null")
+      })
+    } else {
+      # For later versions of ggplot2
+      attr(x, "unit", exact = TRUE) == "null"
+    }
+  }
+
+  # Workaround for a bug in the quartz device. If you have a 400x400 image and
+  # run `convertWidth(unit(1, "npc"), "native")`, the result will depend on
+  # res setting of the device. If res=72, then it returns 400 (as expected),
+  # but if, e.g., res=96, it will return 300, which is incorrect.
+  devScaleFactor <- 1
+  if (grepl("quartz", names(grDevices::dev.cur()), fixed = TRUE)) {
+    devScaleFactor <- res / 72
+  }
+
+  # Convert a unit (or vector of units) to a numeric vector of pixel sizes
+  h_px <- function(x) {
+    devScaleFactor * grid::convertHeight(x, "native", valueOnly = TRUE)
+  }
+  w_px <- function(x) {
+    devScaleFactor * grid::convertWidth(x, "native", valueOnly = TRUE)
+  }
+
+  # Given a vector of relative sizes (in grid units), and a function for
+  # converting grid units to numeric pixels, return a list with: known pixel
+  # dimensions, scalable dimensions, and the overall space for the scalable
+  # objects.
+  find_size_info <- function(rel_sizes, unit_to_px) {
+    # Total pixels (in height or width)
+    total_px <- unit_to_px(grid::unit(1, "npc"))
+    # Calculate size of all panel(s) together. Panels (and only panels) have
+    # null size.
+    null_idx <- is_null_unit(rel_sizes)
+
+    # All the absolute heights. At this point, null heights are 0. We need to
+    # calculate them separately and add them in later.
+    px_sizes <- unit_to_px(rel_sizes)
+    # Mark the null heights as NA.
+    px_sizes[null_idx] <- NA_real_
+
+    # The plotting panels all are 'null' units.
+    null_sizes <- rep(NA_real_, length(rel_sizes))
+    null_sizes[null_idx] <- as.numeric(rel_sizes[null_idx])
+
+    # Total size allocated for panels is the total image size minus absolute
+    # (non-panel) elements.
+    panel_px_total <- total_px - sum(px_sizes, na.rm = TRUE)
+
+    # Size of a 1null unit
+    null_px <- abs(panel_px_total / sum(null_sizes, na.rm = TRUE))
+
+    # This returned list contains:
+    # * px_sizes: A vector of known pixel dimensions. The values that were
+    #   null units will be assigned NA. The null units are ones that scale
+    #   when the plotting area is resized.
+    # * null_sizes: A vector of the null units. All others will be assigned
+    #   NA. The null units often are 1, but they may be any value, especially
+    #   when using coord_fixed.
+    # * null_px: The size (in pixels) of a 1null unit.
+    # * null_px_scaled: The size (in pixels) of a 1null unit when scaled to
+    #   fit a smaller dimension (used for plots with coord_fixed).
+    list(
+      px_sizes       = abs(px_sizes),
+      null_sizes     = null_sizes,
+      null_px        = null_px,
+      null_px_scaled = null_px
+    )
+  }
+
+  # Given a size_info, return absolute pixel positions
+  size_info_to_px <- function(info) {
+    px_sizes <- info$px_sizes
+
+    null_idx <- !is.na(info$null_sizes)
+    px_sizes[null_idx] <- info$null_sizes[null_idx] * info$null_px_scaled
+
+    # If this direction is scaled down because of coord_fixed, we need to add an
+    # offset so that the pixel locations are centered.
+    offset <- (info$null_px - info$null_px_scaled) *
+              sum(info$null_sizes, na.rm = TRUE) / 2
+
+    # Get absolute pixel positions
+    cumsum(px_sizes) + offset
+  }
+
+  heights_info <- find_size_info(g$heights, h_px)
+  widths_info  <- find_size_info(g$widths,  w_px)
+
+  if (g$respect) {
+    # This is a plot with coord_fixed. The grid 'respect' option means to use
+    # the same pixel value for 1null, for width and height. We want the
+    # smaller of the two values -- that's what makes the plot fit in the
+    # viewport.
+    null_px_min <- min(heights_info$null_px, widths_info$null_px)
+    heights_info$null_px_scaled <- null_px_min
+    widths_info$null_px_scaled  <- null_px_min
+  }
+
+  # Convert to absolute pixel positions
+  y_pos <- size_info_to_px(heights_info)
+  x_pos <- size_info_to_px(widths_info)
+
+  # Match up the pixel dimensions to panels
+  layout <- g$layout
+  # For panels:
+  # * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
+  # * For no facet or facet_grid, they'll just be named "panel". For
+  #   facet_grid, we need to re-order the layout table. Assume that panel
+  #   numbers go from left to right, then next row.
+  # Assign a number to each panel, corresponding to PANEl in the built ggplot
+  # object.
+  layout <- layout[grepl("^panel", layout$name), ]
+  layout <- layout[order(layout$t, layout$l), ]
+  layout$panel <- seq_len(nrow(layout))
+
+  # When using a HiDPI client on a Linux server, the pixel
+  # dimensions are doubled, so we have to divide the dimensions by
+  # `pixelratio`. When a HiDPI client is used on a Mac server (with
+  # the quartz device), the pixel dimensions _aren't_ doubled, even though
+  # the image has double size. In the latter case we don't have to scale the
+  # numbers down.
+  pix_ratio <- 1
+  if (!grepl("^quartz", names(grDevices::dev.cur()))) {
+    pix_ratio <- pixelratio
+  }
+
+  # Return list of lists, where each inner list has left, right, top, bottom
+  # values for a panel
+  lapply(seq_len(nrow(layout)), function(i) {
+    p <- layout[i, , drop = FALSE]
+    list(
+      left   = x_pos[p$l - 1] / pix_ratio,
+      right  = x_pos[p$r] / pix_ratio,
+      bottom = y_pos[p$b] / pix_ratio,
+      top    = y_pos[p$t - 1] / pix_ratio
+    )
   })
 }

R/render-table.R

@@ -176,7 +176,12 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
           else ""
         }, " ",
         "class = '", htmlEscape(classNames, TRUE), "' ",
-        "style = 'width:", validateCssUnit(width), ";'"))
+        "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))]

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

@@ -71,6 +71,63 @@ removeInputHandler <- function(type){
   inputHandlers$remove(type)
 }
 
+
+# Apply input handler to a single input value
+applyInputHandler <- function(name, val, shinysession) {
+  splitName <- strsplit(name, ':')[[1]]
+  if (length(splitName) > 1) {
+    if (!inputHandlers$containsKey(splitName[[2]])) {
+      # No input handler registered for this type
+      stop("No handler registered for type ", name)
+    }
+
+    inputName <- splitName[[1]]
+
+    # Get the function for processing this type of input
+    inputHandler <- inputHandlers$get(splitName[[2]])
+
+    return(inputHandler(val, shinysession, inputName))
+
+  } else if (is.list(val) && is.null(names(val))) {
+    return(unlist(val, recursive = TRUE))
+  } else {
+    return(val)
+  }
+}
+
+#' Apply input handlers to raw input values
+#'
+#' The purpose of this function is to make it possible for external packages to
+#' test Shiny inputs. It takes a named list of raw input values, applies input
+#' handlers to those values, and then returns a named list of the processed
+#' values.
+#'
+#' The raw input values should be in a named list. Some values may have names
+#' like \code{"x:shiny.date"}. This function would apply the \code{"shiny.date"}
+#' input handler to the value, and then rename the result to \code{"x"}, in the
+#' output.
+#'
+#' @param inputs A named list of input values.
+#' @param shinysession A Shiny session object.
+#'
+#' @seealso registerInputHandler
+#' @keywords internal
+applyInputHandlers <- function(inputs, shinysession = getDefaultReactiveDomain()) {
+  inputs <- mapply(applyInputHandler, names(inputs), inputs,
+                   MoreArgs = list(shinysession = shinysession),
+                   SIMPLIFY = FALSE)
+
+  # Convert names like "button1:shiny.action" to "button1"
+  names(inputs) <- vapply(
+    names(inputs),
+    function(name) { strsplit(name, ":")[[1]][1] },
+    FUN.VALUE = character(1)
+  )
+
+  inputs
+}
+
+
 # Takes a list-of-lists and returns a matrix. The lists
 # must all be the same length. NULL is replaced by NA.
 registerInputHandler("shiny.matrix", function(data, ...) {
@@ -91,14 +148,27 @@ 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
 })
 
 registerInputHandler("shiny.date", function(val, ...){
   # First replace NULLs with NA, then convert to Date vector
   datelist <- ifelse(lapply(val, is.null), NA, val)
-  as.Date(unlist(datelist))
+
+  res <- NULL
+  tryCatch({
+      res <- as.Date(unlist(datelist))
+    },
+    error = function(e) {
+      # It's possible for client to send a string like "99999-01-01", which
+      # as.Date can't handle.
+      warning(e$message)
+      res <<- as.Date(rep(NA, length(datelist)))
+    }
+  )
+
+  res
 })
 
 registerInputHandler("shiny.datetime", function(val, ...){
@@ -111,9 +181,6 @@ registerInputHandler("shiny.datetime", function(val, ...){
 })
 
 registerInputHandler("shiny.action", function(val, shinysession, name) {
-  # Mark as not serializable
-  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
-
   # mark up the action button value with a special class so we can recognize it later
   class(val) <- c(class(val), "shinyActionButtonValue")
   val
@@ -129,14 +196,27 @@ registerInputHandler("shiny.file", function(val, shinysession, name) {
   # The data will be a named list of lists; convert to a data frame.
   val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
 
-  # Make sure that the paths don't go up the directory tree, for security
-  # reasons.
-  if (any(grepl("..", val$datapath, fixed = TRUE))) {
-    stop("Invalid '..' found in file input path.")
+  # `val$datapath` should be a filename without a path, for security reasons.
+  if (basename(val$datapath) != val$datapath) {
+    stop("Invalid '/' found in file input path.")
   }
 
   # Prepend the persistent dir
-  val$datapath <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+  oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  # Copy the original file to a new temp dir, so that a restored session can't
+  # modify the original.
+  newdir <- file.path(tempdir(), createUniqueId(12))
+  dir.create(newdir)
+  val$datapath <- file.path(newdir, val$datapath)
+  file.copy(oldfile, val$datapath)
+
+  # 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`.
+  setSerializer(name, serializerFileInput)
+
+  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)
 
   val
 })

R/server.R

@@ -34,7 +34,7 @@ registerClient <- function(client) {
 #' JavaScript/CSS files available to their components.
 #'
 #' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+#'   A-Z, 0-9, hyphen, period, and underscore.
 #'   For example, a value of 'foo' means that any request paths that begin with
 #'   '/foo' will be mapped to the given directory.
 #' @param directoryPath The directory that contains the static resources to be
@@ -52,7 +52,7 @@ registerClient <- function(client) {
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
 
@@ -155,7 +155,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
@@ -218,14 +218,15 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
           if (is.character(msg))
             msg <- charToRaw(msg)
 
-          if (isTRUE(getOption('shiny.trace'))) {
+          traceOption <- getOption('shiny.trace', FALSE)
+          if (isTRUE(traceOption) || traceOption == "recv") {
             if (binary)
               message("RECV ", '$$binary data$$')
             else
               message("RECV ", rawToChar(msg))
           }
 
-          if (identical(charToRaw("\003\xe9"), msg))
+          if (isEmptyMessage(msg))
             return()
 
           msg <- decodeMessage(msg)
@@ -247,38 +248,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
 
           withRestoreContext(shinysession$restoreContext, {
 
-            unpackInput <- function(name, val) {
-              splitName <- strsplit(name, ':')[[1]]
-              if (length(splitName) > 1) {
-                if (!inputHandlers$containsKey(splitName[[2]])) {
-                  # No input handler registered for this type
-                  stop("No handler registered for type ", name)
-                }
-
-                inputName <- splitName[[1]]
-
-                # Get the function for processing this type of input
-                inputHandler <- inputHandlers$get(splitName[[2]])
-
-                return(inputHandler(val, shinysession, inputName))
-
-              } else if (is.list(val) && is.null(names(val))) {
-                return(unlist(val, recursive = TRUE))
-              } else {
-                return(val)
-              }
-            }
-
-            msg$data <- mapply(unpackInput, names(msg$data), msg$data,
-                               SIMPLIFY = FALSE)
-
-            # Convert names like "button1:shiny.action" to "button1"
-            names(msg$data) <- vapply(
-              names(msg$data),
-              function(name) { strsplit(name, ":")[[1]][1] },
-              FUN.VALUE = character(1)
-            )
-
+            msg$data <- applyInputHandlers(msg$data)
 
             switch(
               msg$method,
@@ -400,9 +370,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)
@@ -492,6 +462,20 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
+# 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
@@ -533,6 +517,9 @@ serviceApp <- function() {
 #'   application. If set to \code{"normal"}, displays the application normally.
 #'   Defaults to \code{"auto"}, which displays the application in the mode given
 #'   in its \code{DESCRIPTION} file, if any.
+#' @param test.mode Should the application be launched in test mode? This is
+#'   only used for recording or running automated tests. Defaults to the
+#'   \code{shiny.testmode} option, or FALSE if the option is not set.
 #'
 #' @examples
 #' \dontrun{
@@ -545,6 +532,8 @@ serviceApp <- function() {
 #'
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   # Apps can be run without a server.r and ui.r file
 #'   runApp(list(
 #'     ui = bootstrapPage(
@@ -576,28 +565,80 @@ runApp <- function(appDir=getwd(),
                                             interactive()),
                    host=getOption('shiny.host', '127.0.0.1'),
                    workerId="", quiet=FALSE,
-                   display.mode=c("auto", "normal", "showcase")) {
+                   display.mode=c("auto", "normal", "showcase"),
+                   test.mode=getOption('shiny.testmode', FALSE)) {
   on.exit({
     handlerManager$clear()
   }, add = TRUE)
 
+  if (.globals$running) {
+    stop("Can't call `runApp()` from within `runApp()`. If your ",
+         "application code contains `runApp()`, please remove it.")
+  }
+  .globals$running <- TRUE
+  on.exit({
+    .globals$running <- FALSE
+  }, add = TRUE)
+
   # Enable per-app Shiny options
   oldOptionSet <- .globals$options
   on.exit({
     .globals$options <- oldOptionSet
   },add = TRUE)
 
-  if (is.null(host) || is.na(host))
-    host <- '0.0.0.0'
-
   # 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)
+
+  # The lines below set some of the app's running options, which
+  # can be:
+  #   - left unspeficied (in which case the arguments' default
+  #     values from `runApp` kick in);
+  #   - passed through `shinyApp`
+  #   - passed through `runApp` (this function)
+  #   - passed through both `shinyApp` and `runApp` (the latter
+  #     takes precedence)
+  #
+  # Matrix of possibilities:
+  # | IN shinyApp | IN runApp | result       | check                                                                                                                                  |
+  # |-------------|-----------|--------------|----------------------------------------------------------------------------------------------------------------------------------------|
+  # | no          | no        | use defaults | exhaust all possibilities: if it's missing (runApp does not specify); THEN if it's not in shinyApp appParts$options; THEN use defaults |
+  # | yes         | no        | use shinyApp | if it's missing (runApp does not specify); THEN if it's in shinyApp appParts$options; THEN use shinyApp                                |
+  # | no          | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  # | yes         | yes       | use runApp   | if it's not missing (runApp specifies), use those                                                                                      |
+  #
+  # I tried to make this as compact and intuitive as possible,
+  # given that there are four distinct possibilities to check
+  appOps <- appParts$options
+  findVal <- function(arg, default) {
+    if (arg %in% names(appOps)) appOps[[arg]] else default
+  }
+
+  if (missing(port))
+    port <- findVal("port", port)
+  if (missing(launch.browser))
+    launch.browser <- findVal("launch.browser", launch.browser)
+  if (missing(host))
+    host <- findVal("host", host)
+  if (missing(quiet))
+    quiet <- findVal("quiet", quiet)
+  if (missing(display.mode))
+    display.mode <- findVal("display.mode", display.mode)
+  if (missing(test.mode))
+    test.mode <- findVal("test.mode", test.mode)
+
+  if (is.null(host) || is.na(host)) host <- '0.0.0.0'
+
   workerId(workerId)
 
-  if (nzchar(Sys.getenv('SHINY_PORT'))) {
+  if (inShinyServer()) {
     # If SHINY_PORT is set, we're running under Shiny Server. Check the version
     # to make sure it is compatible. Older versions of Shiny Server don't set
     # SHINY_SERVER_VERSION, those will return "" which is considered less than
@@ -614,6 +655,11 @@ runApp <- function(appDir=getwd(),
   # the display.mode parameter. The latter takes precedence.
   setShowcaseDefault(0)
 
+  .globals$testMode <- test.mode
+  if (test.mode) {
+    message("Running application in test mode.")
+  }
+
   # If appDir specifies a path, and display mode is specified in the
   # DESCRIPTION file at that path, apply it here.
   if (is.character(appDir)) {
@@ -685,7 +731,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
           }
         }
@@ -701,17 +748,22 @@ runApp <- function(appDir=getwd(),
     }
   }
 
-  appParts <- as.shiny.appobj(appDir)
+  # 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()
 
@@ -746,12 +798,16 @@ runApp <- function(appDir=getwd(),
   # Top-level ..stacktraceoff..; matches with ..stacktraceon in observe(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
-    captureStackTraces(
+    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)
       }
-    )
+    })
   )
 
   if (isTRUE(.globals$reterror)) {
@@ -983,3 +1039,15 @@ browserViewer <- function(browser = getOption("browser")) {
     utils::browseURL(url, browser = browser)
   }
 }
+
+# Returns TRUE if we're running in Shiny Server or other hosting environment,
+# otherwise returns FALSE.
+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
@@ -39,9 +39,12 @@ NULL
 #'     when an app is run. See \code{\link{runApp}} for more information.}
 #'   \item{shiny.port}{A port number that Shiny will listen on. See
 #'     \code{\link{runApp}} for more information.}
-#'   \item{shiny.trace}{If \code{TRUE}, all of the messages sent between the R
-#'     server and the web browser client will be printed on the console. This
-#'     is useful for debugging.}
+#'   \item{shiny.trace}{Print messages sent between the R server and the web
+#'     browser client to the R console. This is useful for debugging. Possible
+#'     values are \code{"send"} (only print messages sent to the client),
+#'     \code{"recv"} (only print messages received by the server), \code{TRUE}
+#'     (print all messages), or \code{FALSE} (default; don't print any of these
+#'     messages).}
 #'   \item{shiny.autoreload}{If \code{TRUE} when a Shiny app is launched, the
 #'     app directory will be continually monitored for changes to files that
 #'     have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. If any
@@ -53,10 +56,10 @@ NULL
 #'
 #'     You can customize the file patterns Shiny will monitor by setting the
 #'     shiny.autoreload.pattern option. For example, to monitor only ui.R:
-#'     \code{option(shiny.autoreload.pattern = glob2rx("ui.R"))}
+#'     \code{options(shiny.autoreload.pattern = glob2rx("ui.R"))}
 #'
 #'     The default polling interval is 500 milliseconds. You can change this
-#'     by setting e.g. \code{option(shiny.autoreload.interval = 2000)} (every
+#'     by setting e.g. \code{options(shiny.autoreload.interval = 2000)} (every
 #'     two seconds).}
 #'   \item{shiny.reactlog}{If \code{TRUE}, enable logging of reactive events,
 #'     which can be viewed later with the \code{\link{showReactLog}} function.
@@ -104,6 +107,9 @@ NULL
 #'     particular error \code{e} to get displayed to the user, then set this option
 #'     to \code{TRUE} and use \code{stop(safeError(e))} for errors you want the
 #'     user to see.}
+#'   \item{shiny.testmode}{If \code{TRUE}, then enable features for testing Shiny
+#'     applications. If \code{FALSE} (the default), do not enable those features.
+#'   }
 #' }
 #' @name shiny-options
 NULL
@@ -136,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.
 #
@@ -195,12 +210,13 @@ workerId <- local({
 #'     }
 #'     \item{\code{singletons} - for internal use}
 #'     \item{\code{url_protocol}, \code{url_hostname}, \code{url_port},
-#'       \code{url_pathname}, \code{url_search}, and \code{url_hash_initial}
-#'       can be used to get the components of the URL that was requested by the
-#'       browser to load the Shiny app page. These values are from the
-#'       browser's perspective, so neither HTTP proxies nor Shiny Server will
-#'       affect these values. The \code{url_search} value may be used with
-#'       \code{\link{parseQueryString}} to access query string parameters.
+#'       \code{url_pathname}, \code{url_search}, \code{url_hash_initial}
+#'       and \code{url_hash} can be used to get the components of the URL
+#'       that was requested by the browser to load the Shiny app page.
+#'       These values are from the browser's perspective, so neither HTTP
+#'       proxies nor Shiny Server will affect these values. The
+#'       \code{url_search} value may be used with \code{\link{parseQueryString}}
+#'       to access query string parameters.
 #'     }
 #'   }
 #'   \code{clientData} also contains information about each output.
@@ -270,6 +286,10 @@ workerId <- local({
 #'   This is the request that was used to initiate the websocket connection
 #'   (as opposed to the request that downloaded the web page for the app).
 #' }
+#' \item{userData}{
+#'   An environment for app authors and module/package authors to store whatever
+#'   session-specific data they want.
+#' }
 #' \item{resetBrush(brushId)}{
 #'   Resets/clears the brush with the given \code{brushId}, if it exists on
 #'   any \code{imageOutput} or \code{plotOutput} in the app.
@@ -286,6 +306,12 @@ workerId <- local({
 #'   \code{addCustomMessageHandler} will be invoked each time
 #'   \code{sendCustomMessage} is called on the server.
 #' }
+#' \item{sendBinaryMessage(type, message)}{
+#'   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}.
+#' }
 #' \item{sendInputMessage(inputId, message)}{
 #'   Sends a message to an input on the session's client web page; if the input
 #'   is present and bound on the page at the time the message is received, then
@@ -294,6 +320,42 @@ workerId <- local({
 #'   from Shiny apps, but through friendlier wrapper functions like
 #'   \code{\link{updateTextInput}}.
 #' }
+#' \item{setBookmarkExclude(names)}{
+#'   Set input names to be excluded from bookmarking.
+#' }
+#' \item{getBookmarkExclude()}{
+#'   Returns the set of input names to be excluded from bookmarking.
+#' }
+#' \item{onBookmark(fun)}{
+#'   Registers a function that will be called just before bookmarking state.
+#' }
+#' \item{onBookmarked(fun)}{
+#'   Registers a function that will be called just after bookmarking state.
+#' }
+#' \item{onRestore(fun)}{
+#'   Registers a function that will be called when a session is restored, before
+#'   all other reactives, observers, and render functions are run.
+#' }
+#' \item{onRestored(fun)}{
+#'   Registers a function that will be called when a session is restored, after
+#'   all other reactives, observers, and render functions are run.
+#' }
+#' \item{doBookmark()}{
+#'   Do bookmarking and invoke the onBookmark and onBookmarked callback functions.
+#' }
+#' \item{exportTestValues()}{
+#'   Registers expressions for export in test mode, available at the test
+#'   snapshot URL.
+#' }
+#' \item{getTestSnapshotUrl(input=TRUE, output=TRUE, export=TRUE,
+#'   format="json")}{
+#'   Returns a URL for the test snapshots. Only has an effect when the
+#'   \code{shiny.testmode} option is set to TRUE. For the input, output, and
+#'   export arguments, TRUE means to return all of these values. It is also
+#'   possible to specify by name which values to return by providing a
+#'   character vector, as in \code{input=c("x", "y")}. The format can be
+#'   "rds" or "json".
+#' }
 #'
 #' @name session
 NULL
@@ -322,12 +384,24 @@ NULL
 #' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
 #' @export
 NS <- function(namespace, id = NULL) {
+  if (length(namespace) == 0)
+    ns_prefix <- character(0)
+  else
+    ns_prefix <- paste(namespace, collapse = ns.sep)
+
+  f <- function(id) {
+    if (length(id) == 0)
+      return(ns_prefix)
+    if (length(ns_prefix) == 0)
+      return(id)
+
+    paste(ns_prefix, id, sep = ns.sep)
+  }
+
   if (missing(id)) {
-    function(id) {
-      paste(c(namespace, id), collapse = ns.sep)
-    }
+    f
   } else {
-    paste(c(namespace, id), collapse = ns.sep)
+    f(id)
   }
 }
 
@@ -363,6 +437,12 @@ ShinySession <- R6Class(
     restoreCallbacks = 'Callbacks',
     restoredCallbacks = 'Callbacks',
     bookmarkExclude = character(0),  # Names of inputs to exclude from bookmarking
+    getBookmarkExcludeFuns = list(),
+
+    testMode = FALSE,                # Are we running in test mode?
+    testExportExprs = list(),
+    outputValues = list(),           # Saved output values (for testing mode)
+    testSnapshotUrl = character(0),
 
     sendResponse = function(requestMsg, value) {
       if (is.null(requestMsg$tag)) {
@@ -385,7 +465,8 @@ ShinySession <- R6Class(
       if (self$closed){
         return()
       }
-      if (isTRUE(getOption('shiny.trace')))
+      traceOption <- getOption('shiny.trace', FALSE)
+      if (isTRUE(traceOption) || traceOption == "send")
         message('SEND ',
            gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE))
       private$websocket$send(json)
@@ -441,58 +522,23 @@ ShinySession <- R6Class(
       if (store == "disable")
         return()
 
-      withReactiveDomain(self, {
-        # To make code a little clearer
-        session <- self
-
-        # This observer fires when the bookmark button is clicked.
-        observeEvent(
-          label = "bookmark",
-          session$input[["._bookmark_"]],
-          {
-            tryCatch(
-              withLogErrors({
-                saveState <- ShinySaveState$new(
-                  input = session$input,
-                  exclude = session$getBookmarkExclude(),
-                  onSave = function(state) {
-                    private$bookmarkCallbacks$invoke(state)
-                  }
-                )
-
-                if (store == "server") {
-                  url <- saveShinySaveState(saveState)
-                } else if (store == "url") {
-                  url <- encodeShinySaveState(saveState)
-                } else {
-                  stop("Unknown store type: ", store)
-                }
-
-                clientData <- session$clientData
-                url <- paste0(
-                  clientData$url_protocol, "//",
-                  clientData$url_hostname,
-                  if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
-                  clientData$url_pathname,
-                  "?", url
-                )
-
-
-                # If onBookmarked callback was provided, invoke it; if not call
-                # the default.
-                if (private$bookmarkedCallbacks$count() > 0) {
-                  private$bookmarkedCallbacks$invoke(url)
-                } else {
-                  showBookmarkUrlModal(url)
-                }
-              }),
-              error = function(e) {
-                msg <- paste0("Error bookmarking state: ", e$message)
-                showNotification(msg, duration = NULL, type = "error")
-              }
-            )
-          }
+      # 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.
@@ -528,11 +574,11 @@ ShinySession <- R6Class(
               }
             )
           }
-        }, priority = -1000000)
+        }, priority = 1000000)
 
         # Run the onRestored function after the flush cycle completes and information
         # is sent to the client.
-        session$onFlushed(function() {
+        self$onFlushed(function() {
           if (private$restoredCallbacks$count() > 0) {
 
             tryCatch(
@@ -554,6 +600,159 @@ ShinySession <- R6Class(
         })
 
       }) # 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
+    # object because the return values of the functions are needed, but
+    # Callback$invoke() discards return values.
+    registerBookmarkExclude = function(fun) {
+      len <- length(private$getBookmarkExcludeFuns) + 1
+      private$getBookmarkExcludeFuns[[len]] <- fun
+    },
+
+    # Save output values and errors. This is only used for testing mode.
+    storeOutputValues = function(values = NULL) {
+      private$outputValues <- mergeVectors(private$outputValues, values)
+    },
+
+    enableTestSnapshot = function() {
+      private$testSnapshotUrl <- self$registerDataObj("shinytest", NULL,
+        function(data, req) {
+          if (!isTRUE(private$testMode)) {
+            return()
+          }
+
+          params <- parseQueryString(req$QUERY_STRING)
+          # The format of the response that will be sent back. Defaults to
+          # "json" unless requested otherwise. The only other valid value is
+          # "rds".
+          format <- params$format %OR% "json"
+
+          values <- list()
+
+          if (!is.null(params$input)) {
+
+            allInputs <- isolate(
+              reactiveValuesToList(self$input, all.names = TRUE)
+            )
+
+            # If params$input is "1", return all; otherwise return just the
+            # inputs that are named in params$input, like "x,y,z".
+            if (params$input == "1") {
+              values$input <- allInputs
+            } else {
+              items <- strsplit(params$input, ",")[[1]]
+              items <- intersect(items, names(allInputs))
+              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)
+          }
+
+          if (!is.null(params$output)) {
+
+            if (params$output == "1") {
+              values$output <- private$outputValues
+            } else {
+              items <- strsplit(params$output, ",")[[1]]
+              items <- intersect(items, names(private$outputValues))
+              values$output <- private$outputValues[items]
+            }
+
+            # Filter out those outputs that have the snapshotExclude attribute.
+            exclude_idx <- vapply(names(values$output), function(name) {
+              isTRUE(attr(private$.outputs[[name]], "snapshotExclude", TRUE))
+            }, 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)
+          }
+
+          if (!is.null(params$export)) {
+
+            if (params$export == "1") {
+              values$export <- isolate(
+                lapply(private$testExportExprs, function(item) {
+                  eval(item$expr, envir = item$env)
+                })
+              )
+            } else {
+              items <- strsplit(params$export, ",")[[1]]
+              items <- intersect(items, names(private$testExportExprs))
+              values$export <- isolate(
+                lapply(private$testExportExprs[items], function(item) {
+                  eval(item$expr, envir = item$env)
+                })
+              )
+            }
+
+            values$export <- sortByName(values$export)
+          }
+
+          # Make sure input, output, and export are all named lists (at this
+          # point, they could be unnamed if they are empty lists). This is so
+          # that the resulting object is represented as an object in JSON
+          # instead of an array, and so that the RDS data structure is of a
+          # consistent type.
+          values <- lapply(values, asNamedVector)
+
+          if (length(values) == 0) {
+            return(httpResponse(400, "text/plain",
+              "None of export, input, or output requested."
+            ))
+          }
+
+          if (identical(format, "json")) {
+            content <- toJSON(values, pretty = TRUE)
+            httpResponse(200, "application/json", content)
+
+          } else if (identical(format, "rds")) {
+            tmpfile <- tempfile("shinytest", fileext = ".rds")
+            saveRDS(values, tmpfile)
+            on.exit(unlink(tmpfile))
+
+            content <- readBin(tmpfile, "raw", n = file.info(tmpfile)$size)
+            httpResponse(200, "application/octet-stream", content)
+
+          } else {
+            httpResponse(400, "text/plain", paste("Invalid format requested:", format))
+          }
+        }
+      )
+    },
+
+    # 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
     }
   ),
   public = list(
@@ -568,6 +767,7 @@ ShinySession <- R6Class(
     closed = logical(0),
     request = 'ANY',      # Websocket request object
     singletons = character(0),  # Tracks singleton HTML fragments sent to the page
+    userData = 'environment',
     user = NULL,
     groups = NULL,
 
@@ -588,6 +788,7 @@ ShinySession <- R6Class(
       self$progressStack <- Stack$new()
       self$files <- Map$new()
       self$downloads <- Map$new()
+      self$userData <- new.env(parent = emptyenv())
 
       self$input <- .createReactiveValues(private$.input, readonly=TRUE)
       .setLabel(self$input, 'input')
@@ -606,11 +807,14 @@ ShinySession <- R6Class(
       private$restoredCallbacks <- Callbacks$new()
       private$createBookmarkObservers()
 
+      private$testMode <- .globals$testMode
+      private$enableTestSnapshot()
+
       private$registerSessionEndCallbacks()
 
       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)
@@ -624,10 +828,14 @@ ShinySession <- R6Class(
       private$sendMessage(
         config = list(
           workerId = workerId(),
-          sessionId = self$token
+          sessionId = self$token,
+          user = self$user
         )
       )
     },
+    rootScope = function() {
+      self
+    },
     makeScope = function(namespace) {
       ns <- NS(namespace)
 
@@ -678,6 +886,24 @@ ShinySession <- R6Class(
             stop("`fun` must be a function that takes one argument")
           }
           restoredCallbacks$register(fun)
+        },
+        exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) {
+          if (quoted_) {
+            dots <- list(...)
+          } else {
+            dots <- eval(substitute(alist(...)))
+          }
+
+          if (anyUnnamed(dots))
+            stop("exportTestValues: all arguments must be named.")
+
+          names(dots) <- ns(names(dots))
+
+          do.call(
+            .subset2(self, "exportTestValues"),
+            c(dots, quoted_ = TRUE, env_ = env_),
+            quote = TRUE
+          )
         }
       )
 
@@ -785,6 +1011,12 @@ ShinySession <- R6Class(
         restoredCallbacks$invoke(scopeState)
       })
 
+      # Returns the excluded names with the scope's ns prefix on them.
+      private$registerBookmarkExclude(function() {
+        excluded <- scope$getBookmarkExclude()
+        ns(excluded)
+      })
+
       scope
     },
     ns = function(id) {
@@ -868,6 +1100,10 @@ ShinySession <- R6Class(
       }
 
       if (is.function(func)) {
+        # Extract any output attributes attached to the render function. These
+        # will be attached to the observer after it's created.
+        outputAttrs <- attr(func, "outputAttrs", TRUE)
+
         funcFormals <- formals(func)
         # ..stacktraceon matches with the top-level ..stacktraceoff.., because
         # the observer we set up below has ..stacktraceon=FALSE
@@ -897,17 +1133,17 @@ ShinySession <- R6Class(
             shinyCallingHandlers(func()),
             shiny.custom.error = function(cond) {
               if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              structure(NULL, class = "try-error", condition = cond)
+              structure(list(), class = "try-error", condition = cond)
             },
             shiny.output.cancel = function(cond) {
-              structure(NULL, class = "cancel-output")
+              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(NULL, class = "try-error", condition = cond)
+              structure(list(), class = "try-error", condition = cond)
             },
             error = function(cond) {
               if (isTRUE(getOption("show.error.messages"))) printError(cond)
@@ -916,7 +1152,7 @@ ShinySession <- R6Class(
                                           "logs or contact the app author for",
                                           "clarification."))
               }
-              invisible(structure(NULL, class = "try-error", condition = cond))
+              invisible(structure(list(), class = "try-error", condition = cond))
             },
             finally = {
               private$sendMessage(recalculating = list(
@@ -945,6 +1181,12 @@ ShinySession <- R6Class(
             private$invalidatedOutputValues$set(name, value)
         }, suspended=private$shouldSuspend(name), label=label)
 
+        # If any output attributes were added to the render function attach
+        # them to observer.
+        lapply(names(outputAttrs), function(name) {
+          attr(obs, name) <- outputAttrs[[name]]
+        })
+
         obs$onInvalidate(function() {
           self$showProgress(name)
         })
@@ -991,20 +1233,31 @@ ShinySession <- R6Class(
       })
 
       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 <- private$invalidatedOutputValues
+      values <- as.list(private$invalidatedOutputValues)
       private$invalidatedOutputValues <- Map$new()
-      errors <- private$invalidatedOutputErrors
+      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 = as.list(errors),
-        values = as.list(values),
+        errors = errors,
+        values = values,
         inputMessages = inputMessages
       )
     },
@@ -1057,6 +1310,13 @@ ShinySession <- R6Class(
         private$sendResponse(msg, value)
       }
     },
+    sendBinaryMessage = function(type, message) {
+      typeBytes <- charToRaw(type)
+      if (length(typeBytes) > 255) {
+        stop("'type' argument is too long")
+      }
+      private$write(c(as.raw(length(typeBytes)), typeBytes, message))
+    },
     sendCustomMessage = function(type, message) {
       data <- list()
       data[[type]] <- message
@@ -1095,8 +1355,12 @@ ShinySession <- R6Class(
       private$bookmarkExclude <- names
     },
     getBookmarkExclude = function() {
-      private$bookmarkExclude
+      scopedExcludes <- lapply(private$getBookmarkExcludeFuns, function(f) f())
+      scopedExcludes <- unlist(scopedExcludes)
+
+      c(private$bookmarkExclude, scopedExcludes)
     },
+
     onBookmark = function(fun) {
       if (!is.function(fun) || length(fun) != 1) {
         stop("`fun` must be a function that takes one argument")
@@ -1121,10 +1385,100 @@ ShinySession <- R6Class(
       }
       private$restoredCallbacks$register(fun)
     },
+    doBookmark = function() {
+      # Get bookmarking store config
+      store <- getShinyOption("bookmarkStore", default = "disable")
+      if (store == "disable")
+        return()
+
+      tryCatch(
+        withLogErrors({
+          saveState <- ShinySaveState$new(
+            input = self$input,
+            exclude = self$getBookmarkExclude(),
+            onSave = function(state) {
+              private$bookmarkCallbacks$invoke(state)
+            }
+          )
+
+          if (store == "server") {
+            url <- saveShinySaveState(saveState)
+          } else if (store == "url") {
+            url <- encodeShinySaveState(saveState)
+          } else {
+            stop("Unknown store type: ", store)
+          }
+
+          clientData <- self$clientData
+          url <- paste0(
+            clientData$url_protocol, "//",
+            clientData$url_hostname,
+            if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
+            clientData$url_pathname,
+            "?", url
+          )
+
+
+          # If onBookmarked callback was provided, invoke it; if not call
+          # the default.
+          if (private$bookmarkedCallbacks$count() > 0) {
+            private$bookmarkedCallbacks$invoke(url)
+          } else {
+            showBookmarkUrlModal(url)
+          }
+        }),
+        error = function(e) {
+          msg <- paste0("Error bookmarking state: ", e$message)
+          showNotification(msg, duration = NULL, type = "error")
+        }
+      )
+    },
+
+    exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) {
+      # Get a named list of unevaluated expressions.
+      if (quoted_) {
+        dots <- list(...)
+      } else {
+        dots <- eval(substitute(alist(...)))
+      }
+
+      if (anyUnnamed(dots))
+        stop("exportTestValues: all arguments must be named.")
+
+      # Create a named list where each item is a list with an expression and
+      # environment in which to eval the expression.
+      items <- lapply(dots, function(expr) {
+        list(expr = expr, env = env_)
+      })
+
+      private$testExportExprs <- mergeVectors(private$testExportExprs, items)
+    },
+
+    getTestSnapshotUrl = function(input = TRUE, output = TRUE, export = TRUE,
+                                  format = "json") {
+      reqString <- function(group, value) {
+        if (isTRUE(value))
+          paste0(group, "=1")
+        else if (is.character(value))
+          paste0(group, "=", paste(value, collapse = ","))
+        else
+          ""
+      }
+      paste(
+        private$testSnapshotUrl,
+        reqString("input", input),
+        reqString("output", output),
+        reqString("export", export),
+        paste0("format=", format),
+        sep = "&"
+      )
+    },
 
     reactlog = function(logEntry) {
+      # Use sendCustomMessage instead of sendMessage, because the handler in
+      # shiny-showcase.js only has access to public API of the Shiny object.
       if (private$showcase)
-        private$sendMessage(reactlog = logEntry)
+        self$sendCustomMessage("reactlog", logEntry)
     },
     reload = function() {
       private$sendMessage(reload = TRUE)
@@ -1147,8 +1501,40 @@ ShinySession <- R6Class(
         )
       )
     },
-    updateQueryString = function(queryString) {
-      private$sendMessage(updateQueryString = list(queryString = queryString))
+    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))
     },
     resetBrush = function(brushId) {
       private$sendMessage(
@@ -1184,7 +1570,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()
     },
@@ -1227,9 +1614,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'))
       }
@@ -1297,6 +1705,10 @@ ShinySession <- R6Class(
           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),
@@ -1550,7 +1962,6 @@ outputOptions <- function(x, name, ...) {
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
 
-
 #' Add callbacks for Shiny session events
 #'
 #' These functions are for registering callbacks on Shiny session events.
@@ -1582,6 +1993,9 @@ 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)
@@ -1606,3 +2020,86 @@ 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))
+  }
+}

R/shinyui.R

@@ -14,7 +14,7 @@ NULL
 #' # now we can just write "static" content without withMathJax()
 #' div("more math here $$\\sqrt{2}$$")
 withMathJax <- function(...) {
-  path <- 'https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
+  path <- 'https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'
   tagList(
     tags$head(
       singleton(tags$script(src = path, type = 'text/javascript'))
@@ -24,7 +24,7 @@ withMathJax <- function(...) {
   )
 }
 
-renderPage <- function(ui, connection, showcase=0) {
+renderPage <- function(ui, connection, showcase=0, testMode=FALSE) {
   # If the ui is a NOT complete document (created by htmlTemplate()), then do some
   # preprocessing and make sure it's a complete document.
   if (!inherits(ui, "html_document")) {
@@ -45,11 +45,18 @@ renderPage <- function(ui, connection, showcase=0) {
   shiny_deps <- list(
     htmlDependency("json2", "2014.02.04", c(href="shared"), script = "json2-min.js"),
     htmlDependency("jquery", "1.12.4", c(href="shared"), script = "jquery.min.js"),
-    htmlDependency("babel-polyfill", "6.7.2", c(href="shared"), script = "babel-polyfill.min.js"),
     htmlDependency("shiny", utils::packageVersion("shiny"), c(href="shared"),
       script = if (getOption("shiny.minified", TRUE)) "shiny.min.js" else "shiny.js",
       stylesheet = "shiny.css")
   )
+
+  if (testMode) {
+    # Add code injection listener if in test mode
+    shiny_deps[[length(shiny_deps) + 1]] <-
+      htmlDependency("shiny-testmode", utils::packageVersion("shiny"),
+        c(href="shared"), script = "shiny-testmode.js")
+  }
+
   html <- renderDocument(ui, shiny_deps, processDep = createWebDependency)
   writeUTF8(html, con = connection)
 }
@@ -91,6 +98,8 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
 
+    testMode <- .globals$testMode %OR% FALSE
+
     # Create a restore context using query string
     bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
     if (bookmarkStore == "disable") {
@@ -121,7 +130,7 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
     if (is.null(uiValue))
       return(NULL)
 
-    renderPage(uiValue, textConn, showcaseMode)
+    renderPage(uiValue, textConn, showcaseMode, testMode)
     html <- paste(readLines(textConn, encoding = 'UTF-8'), collapse='\n')
     return(httpResponse(200, content=enc2utf8(html)))
   }

R/shinywrappers.R

@@ -88,6 +88,34 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
   useRenderFunction(x, inline = inline)
 }
 
+
+#' Mark a render function with attributes that will be used by the output
+#'
+#' @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,
+  snapshotPreprocess = NULL)
+{
+  # Add the outputAttrs attribute if necessary
+  if (is.null(attr(renderFunc, "outputAttrs", TRUE))) {
+    attr(renderFunc, "outputAttrs") <- list()
+  }
+
+  if (!is.null(snapshotExclude)) {
+    attr(renderFunc, "outputAttrs")$snapshotExclude <- snapshotExclude
+  }
+
+  if (!is.null(snapshotPreprocess)) {
+    attr(renderFunc, "outputAttrs")$snapshotPreprocess <- snapshotPreprocess
+  }
+
+  renderFunc
+}
+
 #' Image file output
 #'
 #' Renders a reactive image that is suitable for assigning to an \code{output}
@@ -127,6 +155,7 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("n", "Number of observations", 2, 1000, 500),
@@ -220,7 +249,7 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Makes a reactive version of the given function that captures any printed
 #' output, and also captures its printable result (unless
-#' \code{\link{invisible}}), into a string. The resulting function is suitable
+#' \code{\link[base]{invisible}}), into a string. The resulting function is suitable
 #' for assigning to an  \code{output} slot.
 #'
 #' The corresponding HTML output tag can be anything (though \code{pre} is
@@ -232,14 +261,14 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
 #'
 #' Note that unlike most other Shiny output functions, if the given function
 #' returns \code{NULL} then \code{NULL} will actually be visible in the output.
-#' To display nothing, make your function return \code{\link{invisible}()}.
+#' To display nothing, make your function return \code{\link[base]{invisible}()}.
 #'
 #' @param expr An expression that may print output and/or return a printable R
 #'   object.
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
 #'   is useful if you want to save an expression in a variable.
-#' @param width The value for \code{\link{options}('width')}.
+#' @param width The value for \code{\link[base]{options}('width')}.
 #' @param outputArgs A list of arguments to be passed through to the implicit
 #'   call to \code{\link{verbatimTextOutput}} when \code{renderPrint} is used
 #'   in an interactive R Markdown document.
@@ -409,7 +438,9 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
   renderFunc <- function(shinysession, name, ...) {
     shinysession$registerDownload(name, filename, contentType, content)
   }
-  markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  snapshotExclude(
+    markRenderFunction(downloadButton, renderFunc, outputArgs = outputArgs)
+  )
 }
 
 #' Table output with the JavaScript library DataTables
@@ -420,7 +451,7 @@ downloadHandler <- function(filename, content, contentType=NA, outputArgs=list()
 #' the server infrastructure.
 #'
 #' For the \code{options} argument, the character elements that have the class
-#' \code{"AsIs"} (usually returned from \code{\link{I}()}) will be evaluated in
+#' \code{"AsIs"} (usually returned from \code{\link[base]{I}()}) will be evaluated in
 #' JavaScript. This is useful when the type of the option value is not supported
 #' in JSON, e.g., a JavaScript function, which can be obtained by evaluating a
 #' character string. Note this only applies to the root-level elements of the
@@ -510,7 +541,18 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     )
   }
 
-  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/showcase.R

@@ -18,7 +18,8 @@ licenseLink <- function(licenseName) {
     "Artistic-2.0" = "http://www.r-project.org/Licenses/Artistic-2.0",
     "BSD_2_clause" = "http://www.r-project.org/Licenses/BSD_2_clause",
     "BSD_3_clause" = "http://www.r-project.org/Licenses/BSD_3_clause",
-    "MIT" = "http://www.r-project.org/Licenses/MIT")
+    "MIT" = "http://www.r-project.org/Licenses/MIT",
+    "CC-BY-SA-4.0" = "https://www.r-project.org/Licenses/CC-BY-SA-4.0")
   if (exists(licenseName, where = licenses)) {
     tags$a(href=licenses[[licenseName]], licenseName)
   } else {
@@ -31,7 +32,7 @@ licenseLink <- function(licenseName) {
 showcaseHead <- function() {
 
   deps  <- list(
-    htmlDependency("jqueryui", "1.11.4", c(href="shared/jqueryui"),
+    htmlDependency("jqueryui", "1.12.1", c(href="shared/jqueryui"),
       script = "jquery-ui.min.js"),
     htmlDependency("showdown", "0.3.1", c(href="shared/showdown/compressed"),
       script = "showdown.js"),

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/test-export.R

@@ -0,0 +1,61 @@
+#' Register expressions for export in test mode
+#'
+#' This function registers expressions that will be evaluated when a test export
+#' event occurs. These events are triggered by accessing a snapshot URL.
+#'
+#' This function only has an effect if the app is launched in test mode. This is
+#' done by calling \code{runApp()} with \code{test.mode=TRUE}, or by setting the
+#' global option \code{shiny.testmode} to \code{TRUE}.
+#'
+#' @param quoted_ Are the expression quoted? Default is \code{FALSE}.
+#' @param env_ The environment in which the expression should be evaluated.
+#' @param session_ A Shiny session object.
+#' @param ... Named arguments that are quoted or unquoted expressions that will
+#'   be captured and evaluated when snapshot URL is visited.
+#' @examples
+#' ## Only run this example in interactive R sessions
+#' if (interactive()) {
+#'
+#' options(shiny.testmode = TRUE)
+#'
+#' # This application shows the test snapshot URL; clicking on it will
+#' # fetch the input, output, and exported values in JSON format.
+#' shinyApp(
+#'   ui = basicPage(
+#'     h4("Snapshot URL: "),
+#'     uiOutput("url"),
+#'     h4("Current values:"),
+#'     verbatimTextOutput("values"),
+#'     actionButton("inc", "Increment x")
+#'   ),
+#'
+#'   server = function(input, output, session) {
+#'     vals <- reactiveValues(x = 1)
+#'     y <- reactive({ vals$x + 1 })
+#'
+#'     observeEvent(input$inc, {
+#'       vals$x <<- vals$x + 1
+#'     })
+#'
+#'     exportTestValues(
+#'       x = vals$x,
+#'       y = y()
+#'     )
+#'
+#'     output$url <- renderUI({
+#'       url <- session$getTestSnapshotUrl(format="json")
+#'       a(href = url, url)
+#'     })
+#'
+#'     output$values <- renderText({
+#'       paste0("vals$x: ", vals$x, "\ny: ", y())
+#'     })
+#'   }
+#' )
+#' }
+#' @export
+exportTestValues <- function(..., quoted_ = FALSE, env_ = parent.frame(),
+  session_ = getDefaultReactiveDomain())
+{
+  session_$exportTestValues(..., quoted_ = quoted_, env_ = env_)
+}

R/timer.R

@@ -22,6 +22,11 @@ TimerCallbacks <- R6Class(
       .times <<- data.frame()
     },
     schedule = function(millis, func) {
+      # If args could fail to evaluate, let's make them do that before
+      # we change any state
+      force(millis)
+      force(func)
+
       id <- .nextId
       .nextId <<- .nextId + 1L
 
@@ -56,7 +61,7 @@ TimerCallbacks <- R6Class(
     },
     executeElapsed = function() {
       elapsed <- takeElapsed()
-      if (length(elapsed) == 0)
+      if (nrow(elapsed) == 0)
         return(FALSE)
 
       for (id in elapsed$id) {

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,11 +35,49 @@
 #' 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
+#' @inheritParams updateTextInput
+#'
+#' @seealso \code{\link{textAreaInput}}
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' ui <- fluidPage(
+#'   sliderInput("controller", "Controller", 0, 20, 10),
+#'   textAreaInput("inText", "Input textarea"),
+#'   textAreaInput("inText2", "Input textarea 2")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observe({
+#'     # We'll use the input$controller variable multiple times, so save it as x
+#'     # for convenience.
+#'     x <- input$controller
+#'
+#'     # This will change the value of input$inText, based on x
+#'     updateTextAreaInput(session, "inText", value = paste("New text", x))
+#'
+#'     # Can also set the label, this time for input$inText2
+#'     updateTextAreaInput(session, "inText2",
+#'       label = paste("New label", x),
+#'       value = paste("New text", x))
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#' @export
+updateTextAreaInput <- updateTextInput
+
 
 #' Change the value of a checkbox input on the client
 #'
@@ -68,7 +107,10 @@ updateTextInput <- function(session, inputId, label = NULL, value = NULL) {
 #' 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
@@ -128,7 +170,7 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #'
 #' @template update-input
 #' @param value The desired date value. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supply \code{NA} to clear the date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -141,21 +183,18 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   sliderInput("n", "Day of month", 1, 30, 10),
 #'   dateInput("inDate", "Input date")
 #' )
 #'
 #' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
-#'
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'     updateDateInput(session, "inDate",
-#'       label = paste("Date label", x),
-#'       value = paste("2013-04-", x, sep=""),
-#'       min   = paste("2013-04-", x-1, sep=""),
-#'       max   = paste("2013-04-", x+1, sep="")
+#'       label = paste("Date label", input$n),
+#'       value = date,
+#'       min   = date - 3,
+#'       max   = date + 3
 #'     )
 #'   })
 #' }
@@ -166,11 +205,18 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min, "Date"))    min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max, "Date"))    max   <- format(max,   "%Y-%m-%d")
+  # Make sure values are NULL or Date objects. This is so we can ensure that
+  # they will be formatted correctly. For example, the string "2016-08-9" is not
+  # correctly formatted, but the conversion to Date and back to string will fix
+  # it.
+  formatDate <- function(x) {
+    if (is.null(x))
+      return(NULL)
+    format(as.Date(x), "%Y-%m-%d")
+  }
+  value <- formatDate(value)
+  min   <- formatDate(min)
+  max   <- formatDate(max)
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -181,9 +227,9 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #'
 #' @template update-input
 #' @param start The start date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the start date.
 #' @param end The end date. Either a Date object, or a string in
-#'   \code{yyyy-mm-dd} format.
+#'   \code{yyyy-mm-dd} format. Supplying \code{NA} clears the end date.
 #' @param min The minimum allowed date. Either a Date object, or a string in
 #'   \code{yyyy-mm-dd} format.
 #' @param max The maximum allowed date. Either a Date object, or a string in
@@ -196,20 +242,20 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 #' if (interactive()) {
 #'
 #' ui <- fluidPage(
-#'   sliderInput("controller", "Controller", 1, 30, 10),
+#'   sliderInput("n", "Day of month", 1, 30, 10),
 #'   dateRangeInput("inDateRange", "Input date range")
 #' )
 #'
 #' server <- function(input, output, session) {
 #'   observe({
-#'     # We'll use the input$controller variable multiple times, so save it as x
-#'     # for convenience.
-#'     x <- input$controller
+#'     date <- as.Date(paste0("2013-04-", input$n))
 #'
 #'     updateDateRangeInput(session, "inDateRange",
-#'       label = paste("Date range label", x),
-#'       start = paste("2013-01-", x, sep=""),
-#'       end = paste("2013-12-", x, sep="")
+#'       label = paste("Date range label", input$n),
+#'       start = date - 1,
+#'       end = date + 1,
+#'       min = date - 5,
+#'       max = date + 5
 #'     )
 #'   })
 #' }
@@ -229,7 +275,7 @@ updateDateRangeInput <- function(session, inputId, label = NULL,
 
   message <- dropNulls(list(
     label = label,
-    value = c(start, end),
+    value = dropNulls(list(start = start, end = end)),
     min = min,
     max = max
   ))
@@ -410,16 +456,18 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
 
 
 updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE,
-                               type = 'checkbox') {
-  if (!is.null(choices))
-    choices <- choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, session$ns(inputId))
+                               selected = NULL, inline = FALSE, type = NULL,
+                               choiceNames = NULL, choiceValues = NULL) {
+  if (is.null(type)) stop("Please specify the type ('checkbox' or 'radio')")
 
-  options <- if (!is.null(choices)) {
+  args <- normalizeChoicesArgs(choices, choiceNames, choiceValues, mustExist = FALSE)
+
+  if (!is.null(selected)) selected <- as.character(selected)
+
+  options <- if (!is.null(args$choiceValues)) {
     format(tagList(
-      generateOptions(session$ns(inputId), choices, selected, inline, type = type)
+      generateOptions(session$ns(inputId), selected, inline, type,
+        args$choiceNames, args$choiceValues)
     ))
   }
 
@@ -468,9 +516,10 @@ updateInputOptions <- function(session, inputId, label = NULL, choices = NULL,
 #' }
 #' @export
 updateCheckboxGroupInput <- function(session, inputId, label = NULL,
-                                     choices = NULL, selected = NULL,
-                                     inline = FALSE) {
-  updateInputOptions(session, inputId, label, choices, selected, inline)
+  choices = NULL, selected = NULL, inline = FALSE,
+  choiceNames = NULL, choiceValues = NULL) {
+  updateInputOptions(session, inputId, label, choices, selected,
+                     inline, "checkbox", choiceNames, choiceValues)
 }
 
 
@@ -510,10 +559,15 @@ updateCheckboxGroupInput <- function(session, inputId, label = NULL,
 #' }
 #' @export
 updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
-                               selected = NULL, inline = FALSE) {
+                               selected = NULL, inline = FALSE,
+                               choiceNames = NULL, choiceValues = NULL) {
   # you must select at least one radio button
-  if (is.null(selected) && !is.null(choices)) selected <- choices[[1]]
-  updateInputOptions(session, inputId, label, choices, selected, inline, type = 'radio')
+  if (is.null(selected)) {
+    if (!is.null(choices)) selected <- choices[[1]]
+    else if (!is.null(choiceValues)) selected <- choiceValues[[1]]
+  }
+  updateInputOptions(session, inputId, label, choices, selected,
+    inline, 'radio', choiceNames, choiceValues)
 }
 
 
@@ -559,8 +613,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 updateSelectInput <- function(session, inputId, label = NULL, choices = NULL,
                               selected = NULL) {
   choices <- if (!is.null(choices)) choicesWithNames(choices)
-  if (!is.null(selected))
-    selected <- validateSelected(selected, choices, inputId)
+  if (!is.null(selected)) selected <- as.character(selected)
   options <- if (!is.null(choices)) selectOptions(choices, selected)
   message <- dropNulls(list(label = label, options = options, value = selected))
   session$sendInputMessage(inputId, message)
@@ -580,7 +633,7 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     res <- checkAsIs(options)
     cfg <- tags$script(
       type = 'application/json',
-      `data-for` = inputId,
+      `data-for` = session$ns(inputId),
       `data-eval` = if (length(res$eval)) HTML(toJSON(res$eval)),
       HTML(toJSON(res$options))
     )
@@ -602,7 +655,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))
+  var <- c(safeFromJSON(query$field))
   cjn <- if (query$conju == 'and') all else any
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])

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
@@ -182,6 +172,16 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+
+# Given a vector/list, returns a named vector (the labels will be blank).
+asNamedVector <- function(x) {
+  if (!is.null(names(x)))
+    return(x)
+
+  names(x) <- rep.int("", length(x))
+  x
+}
+
 # Given two named vectors, join them together, and keep only the last element
 # with a given name in the resulting vector. If b has any elements with the same
 # name as elements in a, the element in a is dropped. Also, if there are any
@@ -196,6 +196,30 @@ mergeVectors <- function(a, b) {
   x[!drop_idx]
 }
 
+# Sort a vector by the names of items. If there are multiple items with the
+# same name, preserve the original order of those items. For empty
+# vectors/lists/NULL, return the original value.
+sortByName <- function(x) {
+  if (anyUnnamed(x))
+    stop("All items must be named")
+
+  # Special case for empty vectors/lists, and NULL
+  if (length(x) == 0)
+    return(x)
+
+  x[order(names(x))]
+}
+
+# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
+# list is passed to list2env(), it errors. But an empty named list is OK. For
+# 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)
+    attr(x, "names") <- character(0)
+
+  list2env(x, ...)
+}
 
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
@@ -638,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)
@@ -1092,15 +1119,17 @@ reactiveStop <- function(message = "", class = NULL) {
 #'   \code{shiny-output-error-} prepended to this value.
 #' @export
 #' @examples
-#' # in ui.R
-#' fluidPage(
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
 #'   selectizeInput('in2', 'Select a state', choices = state.name),
 #'   plotOutput('plot')
 #' )
 #'
-#' # in server.R
-#' function(input, output) {
+#' server <- function(input, output) {
 #'   output$plot <- renderPlot({
 #'     validate(
 #'       need(input$in1, 'Check at least one letter!'),
@@ -1109,6 +1138,10 @@ reactiveStop <- function(message = "", class = NULL) {
 #'     plot(1:10, main = paste(c(input$in1, input$in2), collapse = ', '))
 #'   })
 #' }
+#'
+#' shinyApp(ui, server)
+#'
+#' }
 validate <- function(..., errorClass = character(0)) {
   results <- sapply(list(...), function(x) {
     # Detect NULL or NA
@@ -1129,7 +1162,7 @@ validate <- function(..., errorClass = character(0)) {
   # There may be empty strings remaining; these are message-less failures that
   # started as FALSE
   results <- results[nzchar(results)]
-  reactiveStop(paste(results, collapse="\n"), errorClass)
+  reactiveStop(paste(results, collapse="\n"), c(errorClass, "validation"))
 }
 
 #' @param expr An expression to test. The condition will pass if the expression
@@ -1191,7 +1224,7 @@ need <- function(expr, message = paste(label, "must be provided"), label) {
 #' \strong{Truthy and falsy values}
 #'
 #' The terms "truthy" and "falsy" generally indicate whether a value, when
-#' coerced to a \code{\link{logical}}, is \code{TRUE} or \code{FALSE}. We use
+#' coerced to a \code{\link[base]{logical}}, is \code{TRUE} or \code{FALSE}. We use
 #' the term a little loosely here; our usage tries to match the intuitive
 #' notions of "Is this value missing or available?", or "Has the user provided
 #' an answer?", or in the case of action buttons, "Has the button been
@@ -1499,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)

README.md

@@ -14,9 +14,9 @@ For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstu
 * Shiny applications are automatically "live" in the same way that spreadsheets are live. Outputs change instantly as users modify inputs, without requiring a reload of the browser.
 * Shiny user interfaces can be built entirely using R, or can be written directly in HTML, CSS, and JavaScript for more flexibility.
 * 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/2.3.2/).
+* 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!).
@@ -43,22 +43,23 @@ To learn more we highly recommend you check out the [Shiny Tutorial](http://shin
 
 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.
-
-If you do not wish to update your code at this time, you can use the [shinybootstrap2](https://github.com/rstudio/shinybootstrap2) package for backward compatibility.
-
-If you prefer to install an older version of Shiny, you can do it using the devtools package:
-
-```R
-devtools::install_version("shiny", version = "0.10.2.2")
-```
 
 ## Development notes
 
 The Javascript code in Shiny is minified using tools that run on Node.js. See the tools/ directory for more information.
 
+A set of application-level tests reside in the [shiny-test-apps](https://github.com/rstudio/shiny-test-apps) repository, which is set up as a git submodule of this repository. To use the full-application tests, simply update the submodule:
+
+```
+git submodule update --init
+```
+
+This will clone the shiny-test-apps repository into the directory tests/testthat/apps. When you run tests for shiny, it will also test the applications.
+
+## Guidelines for contributing
+
+We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.md](CONTRIBUTING.md) file for detailed guidelines of how to contribute.
+
 ## License
 
 The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:

appveyor.yml

@@ -10,6 +10,9 @@ init:
 install:
   ps: Bootstrap
 
+cache:
+  - C:\RLibrary
+
 # Adapt as necessary starting from here
 
 build_script:

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/rsconnect/localhost/admin/01_hello.dcf

@@ -1,6 +0,0 @@
-name: 01_hello
-account: admin
-server: localhost
-bundleId: 1
-url: http://localhost:3939/admin/01_hello/
-when: 1436550957.65385

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/Readme.md

@@ -1 +1 @@
-This example demonstrates some additional widgets included in Shiny, such as `helpText` and `submitButton`. The latter is used to delay rendering output until the user explicitly requests it.
+This example demonstrates some additional widgets included in Shiny, such as `helpText` and `actionButton`. The latter is used to delay rendering output until the user explicitly requests it (a construct which also introduces two important server functions, `eventReactive` and `isolate`).

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,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/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 a submitButton 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."),
-      
-      submitButton("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

@@ -44,7 +44,9 @@ sd_section("UI Inputs",
     "sliderInput",
     "submitButton",
     "textInput",
+    "textAreaInput",
     "passwordInput",
+    "modalButton",
     "updateActionButton",
     "updateCheckboxGroupInput",
     "updateCheckboxInput",
@@ -55,7 +57,12 @@ sd_section("UI Inputs",
     "updateSelectInput",
     "updateSliderInput",
     "updateTabsetPanel",
-    "updateTextInput"
+    "insertTab",
+    "showTab",
+    "updateTextInput",
+    "updateTextAreaInput",
+    "updateQueryString",
+    "getQueryString"
   )
 )
 sd_section("UI Outputs",
@@ -69,7 +76,11 @@ sd_section("UI Outputs",
     "verbatimTextOutput",
     "downloadButton",
     "Progress",
-    "withProgress"
+    "withProgress",
+    "modalDialog",
+    "urlModal",
+    "showModal",
+    "showNotification"
   )
 )
 sd_section("Interface builder functions",
@@ -84,7 +95,9 @@ sd_section("Interface builder functions",
     "withTags",
     "htmlTemplate",
     "bootstrapLib",
-    "suppressDependencies"
+    "suppressDependencies",
+    "insertUI",
+    "removeUI"
   )
 )
 sd_section("Rendering functions",
@@ -105,23 +118,26 @@ sd_section("Rendering functions",
     "reactiveUI"
   )
 )
-sd_section("Reactive constructs",
+sd_section("Reactive programming",
   "A sub-library that provides reactive programming facilities for R.",
   c(
-    "invalidateLater",
-    "is.reactivevalues",
-    "isolate",
-    "makeReactiveBinding",
+    "reactive",
     "observe",
     "observeEvent",
-    "reactive",
+    "reactiveVal",
+    "reactiveValues",
+    "reactiveValuesToList",
+    "is.reactivevalues",
+    "isolate",
+    "invalidateLater",
+    "debounce",
+    "showReactLog",
+    "makeReactiveBinding",
     "reactiveFileReader",
     "reactivePoll",
     "reactiveTimer",
-    "reactiveValues",
-    "reactiveValuesToList",
     "domains",
-    "showReactLog"
+    "freezeReactiveValue"
   )
 )
 sd_section("Boilerplate",
@@ -140,7 +156,18 @@ sd_section("Running",
     "runGadget",
     "runUrl",
     "stopApp",
-    "viewer"
+    "viewer",
+    "isRunning"
+  )
+)
+sd_section("Bookmarking state",
+  "Functions that are used for bookmarking and restoring state.",
+  c(
+    "bookmarkButton",
+    "enableBookmarking",
+    "setBookmarkExclude",
+    "showBookmarkUrlModal",
+    "onBookmark"
   )
 )
 sd_section("Extending Shiny",
@@ -157,17 +184,28 @@ sd_section("Utility functions",
   "Miscellaneous utilities that may be useful to advanced users or when extending Shiny.",
   c(
     "req",
-    "cancelOutput",
     "validate",
     "session",
+    "shinyOptions",
+    "safeError",
+    "onFlush",
+    "restoreInput",
+    "applyInputHandlers",
     "exprToFunction",
     "installExprFunction",
     "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/datepicker/css/bootstrap-datepicker3.css

@@ -0,0 +1,678 @@
+/*!
+ * Datepicker for Bootstrap v1.6.4 (https://github.com/eternicode/bootstrap-datepicker)
+ *
+ * Copyright 2012 Stefan Petre
+ * Improvements by Andrew Rowls
+ * Licensed under the Apache License v2.0 (http://www.apache.org/licenses/LICENSE-2.0)
+ */
+.datepicker {
+  border-radius: 4px;
+  direction: ltr;
+}
+.datepicker-inline {
+  width: 220px;
+}
+.datepicker.datepicker-rtl {
+  direction: rtl;
+}
+.datepicker.datepicker-rtl table tr td span {
+  float: right;
+}
+.datepicker-dropdown {
+  top: 0;
+  left: 0;
+  padding: 4px;
+}
+.datepicker-dropdown:before {
+  content: '';
+  display: inline-block;
+  border-left: 7px solid transparent;
+  border-right: 7px solid transparent;
+  border-bottom: 7px solid rgba(0, 0, 0, 0.15);
+  border-top: 0;
+  border-bottom-color: rgba(0, 0, 0, 0.2);
+  position: absolute;
+}
+.datepicker-dropdown:after {
+  content: '';
+  display: inline-block;
+  border-left: 6px solid transparent;
+  border-right: 6px solid transparent;
+  border-bottom: 6px solid #fff;
+  border-top: 0;
+  position: absolute;
+}
+.datepicker-dropdown.datepicker-orient-left:before {
+  left: 6px;
+}
+.datepicker-dropdown.datepicker-orient-left:after {
+  left: 7px;
+}
+.datepicker-dropdown.datepicker-orient-right:before {
+  right: 6px;
+}
+.datepicker-dropdown.datepicker-orient-right:after {
+  right: 7px;
+}
+.datepicker-dropdown.datepicker-orient-bottom:before {
+  top: -7px;
+}
+.datepicker-dropdown.datepicker-orient-bottom:after {
+  top: -6px;
+}
+.datepicker-dropdown.datepicker-orient-top:before {
+  bottom: -7px;
+  border-bottom: 0;
+  border-top: 7px solid rgba(0, 0, 0, 0.15);
+}
+.datepicker-dropdown.datepicker-orient-top:after {
+  bottom: -6px;
+  border-bottom: 0;
+  border-top: 6px solid #fff;
+}
+.datepicker table {
+  margin: 0;
+  -webkit-touch-callout: none;
+  -webkit-user-select: none;
+  -khtml-user-select: none;
+  -moz-user-select: none;
+  -ms-user-select: none;
+  user-select: none;
+}
+.datepicker table tr td,
+.datepicker table tr th {
+  text-align: center;
+  width: 30px;
+  height: 30px;
+  border-radius: 4px;
+  border: none;
+}
+.table-striped .datepicker table tr td,
+.table-striped .datepicker table tr th {
+  background-color: transparent;
+}
+.datepicker table tr td.old,
+.datepicker table tr td.new {
+  color: #777777;
+}
+.datepicker table tr td.day:hover,
+.datepicker table tr td.focused {
+  background: #eeeeee;
+  cursor: pointer;
+}
+.datepicker table tr td.disabled,
+.datepicker table tr td.disabled:hover {
+  background: none;
+  color: #777777;
+  cursor: default;
+}
+.datepicker table tr td.highlighted {
+  color: #000;
+  background-color: #d9edf7;
+  border-color: #85c5e5;
+  border-radius: 0;
+}
+.datepicker table tr td.highlighted:focus,
+.datepicker table tr td.highlighted.focus {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #298fc2;
+}
+.datepicker table tr td.highlighted:hover {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #52addb;
+}
+.datepicker table tr td.highlighted:active,
+.datepicker table tr td.highlighted.active {
+  color: #000;
+  background-color: #afd9ee;
+  border-color: #52addb;
+}
+.datepicker table tr td.highlighted:active:hover,
+.datepicker table tr td.highlighted.active:hover,
+.datepicker table tr td.highlighted:active:focus,
+.datepicker table tr td.highlighted.active:focus,
+.datepicker table tr td.highlighted:active.focus,
+.datepicker table tr td.highlighted.active.focus {
+  color: #000;
+  background-color: #91cbe8;
+  border-color: #298fc2;
+}
+.datepicker table tr td.highlighted.disabled:hover,
+.datepicker table tr td.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.highlighted:hover,
+.datepicker table tr td.highlighted.disabled:focus,
+.datepicker table tr td.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.highlighted:focus,
+.datepicker table tr td.highlighted.disabled.focus,
+.datepicker table tr td.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.highlighted.focus {
+  background-color: #d9edf7;
+  border-color: #85c5e5;
+}
+.datepicker table tr td.highlighted.focused {
+  background: #afd9ee;
+}
+.datepicker table tr td.highlighted.disabled,
+.datepicker table tr td.highlighted.disabled:active {
+  background: #d9edf7;
+  color: #777777;
+}
+.datepicker table tr td.today {
+  color: #000;
+  background-color: #ffdb99;
+  border-color: #ffb733;
+}
+.datepicker table tr td.today:focus,
+.datepicker table tr td.today.focus {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #b37400;
+}
+.datepicker table tr td.today:hover {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #f59e00;
+}
+.datepicker table tr td.today:active,
+.datepicker table tr td.today.active {
+  color: #000;
+  background-color: #ffc966;
+  border-color: #f59e00;
+}
+.datepicker table tr td.today:active:hover,
+.datepicker table tr td.today.active:hover,
+.datepicker table tr td.today:active:focus,
+.datepicker table tr td.today.active:focus,
+.datepicker table tr td.today:active.focus,
+.datepicker table tr td.today.active.focus {
+  color: #000;
+  background-color: #ffbc42;
+  border-color: #b37400;
+}
+.datepicker table tr td.today.disabled:hover,
+.datepicker table tr td.today[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.today:hover,
+.datepicker table tr td.today.disabled:focus,
+.datepicker table tr td.today[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.today:focus,
+.datepicker table tr td.today.disabled.focus,
+.datepicker table tr td.today[disabled].focus,
+fieldset[disabled] .datepicker table tr td.today.focus {
+  background-color: #ffdb99;
+  border-color: #ffb733;
+}
+.datepicker table tr td.today.focused {
+  background: #ffc966;
+}
+.datepicker table tr td.today.disabled,
+.datepicker table tr td.today.disabled:active {
+  background: #ffdb99;
+  color: #777777;
+}
+.datepicker table tr td.range {
+  color: #000;
+  background-color: #eeeeee;
+  border-color: #bbbbbb;
+  border-radius: 0;
+}
+.datepicker table tr td.range:focus,
+.datepicker table tr td.range.focus {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #7c7c7c;
+}
+.datepicker table tr td.range:hover {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #9d9d9d;
+}
+.datepicker table tr td.range:active,
+.datepicker table tr td.range.active {
+  color: #000;
+  background-color: #d5d5d5;
+  border-color: #9d9d9d;
+}
+.datepicker table tr td.range:active:hover,
+.datepicker table tr td.range.active:hover,
+.datepicker table tr td.range:active:focus,
+.datepicker table tr td.range.active:focus,
+.datepicker table tr td.range:active.focus,
+.datepicker table tr td.range.active.focus {
+  color: #000;
+  background-color: #c3c3c3;
+  border-color: #7c7c7c;
+}
+.datepicker table tr td.range.disabled:hover,
+.datepicker table tr td.range[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range:hover,
+.datepicker table tr td.range.disabled:focus,
+.datepicker table tr td.range[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range:focus,
+.datepicker table tr td.range.disabled.focus,
+.datepicker table tr td.range[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.focus {
+  background-color: #eeeeee;
+  border-color: #bbbbbb;
+}
+.datepicker table tr td.range.focused {
+  background: #d5d5d5;
+}
+.datepicker table tr td.range.disabled,
+.datepicker table tr td.range.disabled:active {
+  background: #eeeeee;
+  color: #777777;
+}
+.datepicker table tr td.range.highlighted {
+  color: #000;
+  background-color: #e4eef3;
+  border-color: #9dc1d3;
+}
+.datepicker table tr td.range.highlighted:focus,
+.datepicker table tr td.range.highlighted.focus {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #4b88a6;
+}
+.datepicker table tr td.range.highlighted:hover {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #73a6c0;
+}
+.datepicker table tr td.range.highlighted:active,
+.datepicker table tr td.range.highlighted.active {
+  color: #000;
+  background-color: #c1d7e3;
+  border-color: #73a6c0;
+}
+.datepicker table tr td.range.highlighted:active:hover,
+.datepicker table tr td.range.highlighted.active:hover,
+.datepicker table tr td.range.highlighted:active:focus,
+.datepicker table tr td.range.highlighted.active:focus,
+.datepicker table tr td.range.highlighted:active.focus,
+.datepicker table tr td.range.highlighted.active.focus {
+  color: #000;
+  background-color: #a8c8d8;
+  border-color: #4b88a6;
+}
+.datepicker table tr td.range.highlighted.disabled:hover,
+.datepicker table tr td.range.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range.highlighted:hover,
+.datepicker table tr td.range.highlighted.disabled:focus,
+.datepicker table tr td.range.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range.highlighted:focus,
+.datepicker table tr td.range.highlighted.disabled.focus,
+.datepicker table tr td.range.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.highlighted.focus {
+  background-color: #e4eef3;
+  border-color: #9dc1d3;
+}
+.datepicker table tr td.range.highlighted.focused {
+  background: #c1d7e3;
+}
+.datepicker table tr td.range.highlighted.disabled,
+.datepicker table tr td.range.highlighted.disabled:active {
+  background: #e4eef3;
+  color: #777777;
+}
+.datepicker table tr td.range.today {
+  color: #000;
+  background-color: #f7ca77;
+  border-color: #f1a417;
+}
+.datepicker table tr td.range.today:focus,
+.datepicker table tr td.range.today.focus {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #815608;
+}
+.datepicker table tr td.range.today:hover {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #bf800c;
+}
+.datepicker table tr td.range.today:active,
+.datepicker table tr td.range.today.active {
+  color: #000;
+  background-color: #f4b747;
+  border-color: #bf800c;
+}
+.datepicker table tr td.range.today:active:hover,
+.datepicker table tr td.range.today.active:hover,
+.datepicker table tr td.range.today:active:focus,
+.datepicker table tr td.range.today.active:focus,
+.datepicker table tr td.range.today:active.focus,
+.datepicker table tr td.range.today.active.focus {
+  color: #000;
+  background-color: #f2aa25;
+  border-color: #815608;
+}
+.datepicker table tr td.range.today.disabled:hover,
+.datepicker table tr td.range.today[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.range.today:hover,
+.datepicker table tr td.range.today.disabled:focus,
+.datepicker table tr td.range.today[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.range.today:focus,
+.datepicker table tr td.range.today.disabled.focus,
+.datepicker table tr td.range.today[disabled].focus,
+fieldset[disabled] .datepicker table tr td.range.today.focus {
+  background-color: #f7ca77;
+  border-color: #f1a417;
+}
+.datepicker table tr td.range.today.disabled,
+.datepicker table tr td.range.today.disabled:active {
+  background: #f7ca77;
+  color: #777777;
+}
+.datepicker table tr td.selected,
+.datepicker table tr td.selected.highlighted {
+  color: #fff;
+  background-color: #777777;
+  border-color: #555555;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.selected:focus,
+.datepicker table tr td.selected.highlighted:focus,
+.datepicker table tr td.selected.focus,
+.datepicker table tr td.selected.highlighted.focus {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #161616;
+}
+.datepicker table tr td.selected:hover,
+.datepicker table tr td.selected.highlighted:hover {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #373737;
+}
+.datepicker table tr td.selected:active,
+.datepicker table tr td.selected.highlighted:active,
+.datepicker table tr td.selected.active,
+.datepicker table tr td.selected.highlighted.active {
+  color: #fff;
+  background-color: #5e5e5e;
+  border-color: #373737;
+}
+.datepicker table tr td.selected:active:hover,
+.datepicker table tr td.selected.highlighted:active:hover,
+.datepicker table tr td.selected.active:hover,
+.datepicker table tr td.selected.highlighted.active:hover,
+.datepicker table tr td.selected:active:focus,
+.datepicker table tr td.selected.highlighted:active:focus,
+.datepicker table tr td.selected.active:focus,
+.datepicker table tr td.selected.highlighted.active:focus,
+.datepicker table tr td.selected:active.focus,
+.datepicker table tr td.selected.highlighted:active.focus,
+.datepicker table tr td.selected.active.focus,
+.datepicker table tr td.selected.highlighted.active.focus {
+  color: #fff;
+  background-color: #4c4c4c;
+  border-color: #161616;
+}
+.datepicker table tr td.selected.disabled:hover,
+.datepicker table tr td.selected.highlighted.disabled:hover,
+.datepicker table tr td.selected[disabled]:hover,
+.datepicker table tr td.selected.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.selected:hover,
+fieldset[disabled] .datepicker table tr td.selected.highlighted:hover,
+.datepicker table tr td.selected.disabled:focus,
+.datepicker table tr td.selected.highlighted.disabled:focus,
+.datepicker table tr td.selected[disabled]:focus,
+.datepicker table tr td.selected.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.selected:focus,
+fieldset[disabled] .datepicker table tr td.selected.highlighted:focus,
+.datepicker table tr td.selected.disabled.focus,
+.datepicker table tr td.selected.highlighted.disabled.focus,
+.datepicker table tr td.selected[disabled].focus,
+.datepicker table tr td.selected.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.selected.focus,
+fieldset[disabled] .datepicker table tr td.selected.highlighted.focus {
+  background-color: #777777;
+  border-color: #555555;
+}
+.datepicker table tr td.active,
+.datepicker table tr td.active.highlighted {
+  color: #fff;
+  background-color: #337ab7;
+  border-color: #2e6da4;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td.active:focus,
+.datepicker table tr td.active.highlighted:focus,
+.datepicker table tr td.active.focus,
+.datepicker table tr td.active.highlighted.focus {
+  color: #fff;
+  background-color: #286090;
+  border-color: #122b40;
+}
+.datepicker table tr td.active:hover,
+.datepicker table tr td.active.highlighted:hover {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td.active:active,
+.datepicker table tr td.active.highlighted:active,
+.datepicker table tr td.active.active,
+.datepicker table tr td.active.highlighted.active {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td.active:active:hover,
+.datepicker table tr td.active.highlighted:active:hover,
+.datepicker table tr td.active.active:hover,
+.datepicker table tr td.active.highlighted.active:hover,
+.datepicker table tr td.active:active:focus,
+.datepicker table tr td.active.highlighted:active:focus,
+.datepicker table tr td.active.active:focus,
+.datepicker table tr td.active.highlighted.active:focus,
+.datepicker table tr td.active:active.focus,
+.datepicker table tr td.active.highlighted:active.focus,
+.datepicker table tr td.active.active.focus,
+.datepicker table tr td.active.highlighted.active.focus {
+  color: #fff;
+  background-color: #204d74;
+  border-color: #122b40;
+}
+.datepicker table tr td.active.disabled:hover,
+.datepicker table tr td.active.highlighted.disabled:hover,
+.datepicker table tr td.active[disabled]:hover,
+.datepicker table tr td.active.highlighted[disabled]:hover,
+fieldset[disabled] .datepicker table tr td.active:hover,
+fieldset[disabled] .datepicker table tr td.active.highlighted:hover,
+.datepicker table tr td.active.disabled:focus,
+.datepicker table tr td.active.highlighted.disabled:focus,
+.datepicker table tr td.active[disabled]:focus,
+.datepicker table tr td.active.highlighted[disabled]:focus,
+fieldset[disabled] .datepicker table tr td.active:focus,
+fieldset[disabled] .datepicker table tr td.active.highlighted:focus,
+.datepicker table tr td.active.disabled.focus,
+.datepicker table tr td.active.highlighted.disabled.focus,
+.datepicker table tr td.active[disabled].focus,
+.datepicker table tr td.active.highlighted[disabled].focus,
+fieldset[disabled] .datepicker table tr td.active.focus,
+fieldset[disabled] .datepicker table tr td.active.highlighted.focus {
+  background-color: #337ab7;
+  border-color: #2e6da4;
+}
+.datepicker table tr td span {
+  display: block;
+  width: 23%;
+  height: 54px;
+  line-height: 54px;
+  float: left;
+  margin: 1%;
+  cursor: pointer;
+  border-radius: 4px;
+}
+.datepicker table tr td span:hover,
+.datepicker table tr td span.focused {
+  background: #eeeeee;
+}
+.datepicker table tr td span.disabled,
+.datepicker table tr td span.disabled:hover {
+  background: none;
+  color: #777777;
+  cursor: default;
+}
+.datepicker table tr td span.active,
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active.disabled,
+.datepicker table tr td span.active.disabled:hover {
+  color: #fff;
+  background-color: #337ab7;
+  border-color: #2e6da4;
+  text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25);
+}
+.datepicker table tr td span.active:focus,
+.datepicker table tr td span.active:hover:focus,
+.datepicker table tr td span.active.disabled:focus,
+.datepicker table tr td span.active.disabled:hover:focus,
+.datepicker table tr td span.active.focus,
+.datepicker table tr td span.active:hover.focus,
+.datepicker table tr td span.active.disabled.focus,
+.datepicker table tr td span.active.disabled:hover.focus {
+  color: #fff;
+  background-color: #286090;
+  border-color: #122b40;
+}
+.datepicker table tr td span.active:hover,
+.datepicker table tr td span.active:hover:hover,
+.datepicker table tr td span.active.disabled:hover,
+.datepicker table tr td span.active.disabled:hover:hover {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td span.active:active,
+.datepicker table tr td span.active:hover:active,
+.datepicker table tr td span.active.disabled:active,
+.datepicker table tr td span.active.disabled:hover:active,
+.datepicker table tr td span.active.active,
+.datepicker table tr td span.active:hover.active,
+.datepicker table tr td span.active.disabled.active,
+.datepicker table tr td span.active.disabled:hover.active {
+  color: #fff;
+  background-color: #286090;
+  border-color: #204d74;
+}
+.datepicker table tr td span.active:active:hover,
+.datepicker table tr td span.active:hover:active:hover,
+.datepicker table tr td span.active.disabled:active:hover,
+.datepicker table tr td span.active.disabled:hover:active:hover,
+.datepicker table tr td span.active.active:hover,
+.datepicker table tr td span.active:hover.active:hover,
+.datepicker table tr td span.active.disabled.active:hover,
+.datepicker table tr td span.active.disabled:hover.active:hover,
+.datepicker table tr td span.active:active:focus,
+.datepicker table tr td span.active:hover:active:focus,
+.datepicker table tr td span.active.disabled:active:focus,
+.datepicker table tr td span.active.disabled:hover:active:focus,
+.datepicker table tr td span.active.active:focus,
+.datepicker table tr td span.active:hover.active:focus,
+.datepicker table tr td span.active.disabled.active:focus,
+.datepicker table tr td span.active.disabled:hover.active:focus,
+.datepicker table tr td span.active:active.focus,
+.datepicker table tr td span.active:hover:active.focus,
+.datepicker table tr td span.active.disabled:active.focus,
+.datepicker table tr td span.active.disabled:hover:active.focus,
+.datepicker table tr td span.active.active.focus,
+.datepicker table tr td span.active:hover.active.focus,
+.datepicker table tr td span.active.disabled.active.focus,
+.datepicker table tr td span.active.disabled:hover.active.focus {
+  color: #fff;
+  background-color: #204d74;
+  border-color: #122b40;
+}
+.datepicker table tr td span.active.disabled:hover,
+.datepicker table tr td span.active:hover.disabled:hover,
+.datepicker table tr td span.active.disabled.disabled:hover,
+.datepicker table tr td span.active.disabled:hover.disabled:hover,
+.datepicker table tr td span.active[disabled]:hover,
+.datepicker table tr td span.active:hover[disabled]:hover,
+.datepicker table tr td span.active.disabled[disabled]:hover,
+.datepicker table tr td span.active.disabled:hover[disabled]:hover,
+fieldset[disabled] .datepicker table tr td span.active:hover,
+fieldset[disabled] .datepicker table tr td span.active:hover:hover,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover:hover,
+.datepicker table tr td span.active.disabled:focus,
+.datepicker table tr td span.active:hover.disabled:focus,
+.datepicker table tr td span.active.disabled.disabled:focus,
+.datepicker table tr td span.active.disabled:hover.disabled:focus,
+.datepicker table tr td span.active[disabled]:focus,
+.datepicker table tr td span.active:hover[disabled]:focus,
+.datepicker table tr td span.active.disabled[disabled]:focus,
+.datepicker table tr td span.active.disabled:hover[disabled]:focus,
+fieldset[disabled] .datepicker table tr td span.active:focus,
+fieldset[disabled] .datepicker table tr td span.active:hover:focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover:focus,
+.datepicker table tr td span.active.disabled.focus,
+.datepicker table tr td span.active:hover.disabled.focus,
+.datepicker table tr td span.active.disabled.disabled.focus,
+.datepicker table tr td span.active.disabled:hover.disabled.focus,
+.datepicker table tr td span.active[disabled].focus,
+.datepicker table tr td span.active:hover[disabled].focus,
+.datepicker table tr td span.active.disabled[disabled].focus,
+.datepicker table tr td span.active.disabled:hover[disabled].focus,
+fieldset[disabled] .datepicker table tr td span.active.focus,
+fieldset[disabled] .datepicker table tr td span.active:hover.focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled.focus,
+fieldset[disabled] .datepicker table tr td span.active.disabled:hover.focus {
+  background-color: #337ab7;
+  border-color: #2e6da4;
+}
+.datepicker table tr td span.old,
+.datepicker table tr td span.new {
+  color: #777777;
+}
+.datepicker .datepicker-switch {
+  width: 145px;
+}
+.datepicker .datepicker-switch,
+.datepicker .prev,
+.datepicker .next,
+.datepicker tfoot tr th {
+  cursor: pointer;
+}
+.datepicker .datepicker-switch:hover,
+.datepicker .prev:hover,
+.datepicker .next:hover,
+.datepicker tfoot tr th:hover {
+  background: #eeeeee;
+}
+.datepicker .cw {
+  font-size: 10px;
+  width: 12px;
+  padding: 0 2px 0 5px;
+  vertical-align: middle;
+}
+.input-group.date .input-group-addon {
+  cursor: pointer;
+}
+.input-daterange {
+  width: 100%;
+}
+.input-daterange input {
+  text-align: center;
+}
+.input-daterange input:first-child {
+  border-radius: 3px 0 0 3px;
+}
+.input-daterange input:last-child {
+  border-radius: 0 3px 3px 0;
+}
+.input-daterange .input-group-addon {
+  width: auto;
+  min-width: 16px;
+  padding: 4px 5px;
+  line-height: 1.42857143;
+  text-shadow: 0 1px 0 #fff;
+  border-width: 1px 0;
+  margin-left: -5px;
+  margin-right: -5px;
+}
+/*# sourceMappingURL=bootstrap-datepicker3.css.map */