Add NEWS item for renderUI bookmarking fix

Fixes #2138.

.Rbuildignore

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

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.0.4
+Version: 1.1.0.9000
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -64,7 +64,8 @@ Depends:
     methods
 Imports:
     utils,
-    httpuv (>= 1.3.5),
+    grDevices,
+    httpuv (>= 1.4.3.9001),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
@@ -72,7 +73,11 @@ Imports:
     htmltools (>= 0.3.5),
     R6 (>= 2.0),
     sourcetools,
-    tools
+    later (>= 0.7.2),
+    promises (>= 1.0.1),
+    tools,
+    crayon,
+    rlang
 Suggests:
     datasets,
     Cairo (>= 1.5-5),
@@ -84,15 +89,18 @@ Suggests:
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-Collate: 
+Remotes:
+    tidyverse/ggplot2,
+    rstudio/httpuv
+Collate:
     'app.R'
     'bookmark-state-local.R'
     'stack.R'
     'bookmark-state.R'
     'bootstrap-layout.R'
+    'globals.R'
     'conditions.R'
     'map.R'
-    'globals.R'
     'utils.R'
     'bootstrap.R'
     'cache.R'
@@ -150,4 +158,4 @@ Collate:
     'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 6.0.1
+RoxygenNote: 6.0.1.9000

NAMESPACE

@@ -59,6 +59,7 @@ export(code)
 export(column)
 export(conditionStackTrace)
 export(conditionalPanel)
+export(createRenderFunction)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
@@ -267,9 +268,13 @@ export(updateSliderInput)
 export(updateTabsetPanel)
 export(updateTextAreaInput)
 export(updateTextInput)
+export(updateVarSelectInput)
+export(updateVarSelectizeInput)
 export(urlModal)
 export(validate)
 export(validateCssUnit)
+export(varSelectInput)
+export(varSelectizeInput)
 export(verbatimTextOutput)
 export(verticalLayout)
 export(wellPanel)
@@ -285,3 +290,5 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(grDevices,dev.cur)
+importFrom(grDevices,dev.set)

NEWS.md

@@ -1,3 +1,116 @@
+shiny 1.1.0.9000
+===========
+
+## Full changelog
+
+### Minor new features and improvements
+
+* Support for selecting variables of a data frame with the output values to be used within tidy evaluation.  Added functions: `varSelectInput`, `varSelectizeInput`, `updateVarSelectInput`, `updateVarSelectizeInput`. ([#2091](https://github.com/rstudio/shiny/pull/2091))
+
+* Addressed [#2042](https://github.com/rstudio/shiny/issues/2042): dates outside of `min`/`max` date range are now a lighter shade of grey to highlight the allowed range. ([#2087](https://github.com/rstudio/shiny/pull/2087))
+
+* Fixed [#1933](https://github.com/rstudio/shiny/issues/1933): extended server-side selectize to lists and optgroups. ([#2102](https://github.com/rstudio/shiny/pull/2102))
+
+* Fixed [#1935](https://github.com/rstudio/shiny/issues/1935): correctly returns plot coordinates when using outer margins. ([#2108](https://github.com/rstudio/shiny/pull/2108))
+
+* Resolved [#2019](https://github.com/rstudio/shiny/issues/2019): `updateSliderInput` now changes the slider formatting if the input type changes. ([#2099](https://github.com/rstudio/shiny/pull/2099))
+
+* Added namespace support when freezing reactiveValue keys. [#2080](https://github.com/rstudio/shiny/pull/2080)
+
+* Fixed [#2138](https://github.com/rstudio/shiny/issues/2138): Inputs that are part of a `renderUI` were no longer restoring correctly from bookmarked state. [#2139](https://github.com/rstudio/shiny/pull/2139)
+
+### Documentation Updates
+
+* Addressed [#1864](https://github.com/rstudio/shiny/issues/1864) by changing `optgroup` documentation to use `list` instead of `c`. ([#2084](https://github.com/rstudio/shiny/pull/2084))
+
+
+shiny 1.1.0
+===========
+
+This is a significant release for Shiny, with a major new feature that was nearly a year in the making: support for asynchronous operations! Until now, R's single-threaded nature meant that performing long-running calculations or tasks from Shiny would bring your app to a halt for other users of that process. This release of Shiny deeply integrates the [promises](https://rstudio.github.io/promises/) package to allow you to execute some tasks asynchronously, including as part of reactive expressions and outputs. See the [promises](https://rstudio.github.io/promises/) documentation to learn more.
+
+## Full changelog
+
+### Breaking changes
+
+* `extractStackTrace` and `formatStackTrace` are deprecated and will be removed in a future version of Shiny. As far as we can tell, nobody has been using these functions, and a refactor has made them vestigial; if you need this functionality, please file an issue.
+
+### New features
+
+* Support for asynchronous operations! Built-in render functions that expected a certain kind of object to be yielded from their `expr`, now generally can handle a promise for that kind of object. Reactive expressions and observers are now promise-aware as well. ([#1932](https://github.com/rstudio/shiny/pull/1932))
+
+* Introduced two changes to the (undocumented but widely used) JavaScript function `Shiny.onInputChange(name, value)`. First, we changed the function name to `Shiny.setInputValue` (but don't worry--the old function name will continue to work). Second, until now, all calls to `Shiny.onInputChange(inputId, value)` have been "deduplicated"; that is, anytime an input is set to the same value it already has, the set is ignored. With Shiny v1.1, you can now add an options object as the third parameter: `Shiny.setInputValue("name", value, {priority: "event"})`. When the priority option is set to `"event"`, Shiny will always send the value and trigger reactivity, whether it is a duplicate or not. This closes [#928](https://github.com/rstudio/shiny/issues/928), which was the most upvoted open issue by far! Thanks, @daattali. ([#2018](https://github.com/rstudio/shiny/pull/2018))
+
+### Minor new features and improvements
+
+* Addressed [#1978](https://github.com/rstudio/shiny/issues/1978): `shiny:value` is now triggered when duplicate output data is received from the server. (Thanks, @andrewsali! [#1999](https://github.com/rstudio/shiny/pull/1999))
+
+* If a shiny output contains a css class of `shiny-report-size`, its container height and width are now reported in `session$clientData`. So, for an output with an id with `"myID"`, the height/width can be accessed via `session$clientData[['output_myID_height']]`/`session$clientData[['output_myID_width']]`. Addresses [#1980](https://github.com/rstudio/shiny/issues/1980). (Thanks, @cpsievert! [#1981](https://github.com/rstudio/shiny/pull/1981))
+
+* Added a new `autoclose = TRUE` parameter to `dateInput()` and `dateRangeInput()`. This closed [#1969](https://github.com/rstudio/shiny/issues/1969) which was a duplicate of much older issue, [#173](https://github.com/rstudio/shiny/issues/173). The default value is `TRUE` since that seems to be the common use case. However, this will cause existing apps with date inputs (that update to this version of Shiny) to have the datepicker be immediately closed once a date is selected. For most apps, this is actually desired behavior; if you wish to keep the datepicker open until the user clicks out of it use `autoclose = FALSE`. ([#1987](https://github.com/rstudio/shiny/pull/1987))
+
+* The version of Shiny is now accessible from Javascript, with `Shiny.version`. There is also a new function for comparing version strings, `Shiny.compareVersion()`. ([#1826](https://github.com/rstudio/shiny/pull/1826), [#1830](https://github.com/rstudio/shiny/pull/1830))
+
+* Addressed [#1851](https://github.com/rstudio/shiny/issues/1851): Stack traces are now smaller in some places `do.call()` is used. ([#1856](https://github.com/rstudio/shiny/pull/1856))
+
+* Stack traces have been improved, with more aggressive de-noising and support for deep stack traces (stitching together multiple stack traces that are conceptually part of the same async operation).
+
+* Addressed [#1859](https://github.com/rstudio/shiny/issues/1859): Server-side selectize is now significantly faster. (Thanks to @dselivanov [#1861](https://github.com/rstudio/shiny/pull/1861))
+
+* [#1989](https://github.com/rstudio/shiny/issues/1989): The server side of outputs can now be removed (e.g. `output$plot <- NULL`). This is not usually necessary but it does allow some objects to be garbage collected, which might matter if you are dynamically creating and destroying many outputs. (Thanks, @mmuurr! [#2011](https://github.com/rstudio/shiny/pull/2011))
+
+* Removed the (ridiculously outdated) "experimental feature" tag from the reference documentation for `renderUI`. ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+* Addressed [#1907](https://github.com/rstudio/shiny/issues/1907): the `ignoreInit` argument was first added only to `observeEvent`. Later, we also added it to `eventReactive`, but forgot to update the documentation. Now done, thanks [@flo12392](https://github.com/flo12392)! ([#2036](https://github.com/rstudio/shiny/pull/2036))
+
+### Bug fixes
+
+* Fixed [#1006](https://github.com/rstudio/shiny/issues/1006): Slider inputs sometimes showed too many digits. ([#1956](https://github.com/rstudio/shiny/pull/1956))
+
+* Fixed [#1958](https://github.com/rstudio/shiny/issues/1958): Slider inputs previously displayed commas after a decimal point. ([#1960](https://github.com/rstudio/shiny/pull/1960))
+
+* The internal `URLdecode()` function previously was a copy of `httpuv::decodeURIComponent()`, assigned at build time; now it invokes the httpuv function at run time.
+
+* Fixed [#1840](https://github.com/rstudio/shiny/issues/1840): with the release of Shiny 1.0.5, we accidently changed the relative positioning of the icon and the title text in `navbarMenu`s and `tabPanel`s. This fix reverts this behavior back (i.e. the icon should be to the left of the text and/or the downward arrow in case of `navbarMenu`s). ([#1848](https://github.com/rstudio/shiny/pull/1848))
+
+* Fixed [#1600](https://github.com/rstudio/shiny/issues/1600): URL-encoded bookmarking did not work with sliders that had dates or date-times. ([#1961](https://github.com/rstudio/shiny/pull/1961))
+
+* Fixed [#1962](https://github.com/rstudio/shiny/issues/1962): [File dragging and dropping](https://blog.rstudio.com/2017/08/15/shiny-1-0-4/) broke in the presence of jQuery version 3.0 as introduced by the [rhandsontable](https://jrowen.github.io/rhandsontable/) [htmlwidget](https://www.htmlwidgets.org/). ([#2005](https://github.com/rstudio/shiny/pull/2005))
+
+* Improved the error handling inside the `addResourcePath()` function, to give end users more informative error messages when the `directoryPath` argument cannot be normalized. This is especially useful for `runtime: shiny_prerendered` Rmd documents, like `learnr` tutorials. ([#1968](https://github.com/rstudio/shiny/pull/1968))
+
+* Changed script tags in reactlog ([inst/www/reactive-graph.html](https://github.com/rstudio/shiny/blob/master/inst/www/reactive-graph.html)) from HTTP to HTTPS in order to avoid mixed content blocking by most browsers. (Thanks, @jekriske-lilly! [#1844](https://github.com/rstudio/shiny/pull/1844))
+
+* Addressed [#1784](https://github.com/rstudio/shiny/issues/1784): `runApp()` will avoid port 6697, which is considered unsafe by Chrome.
+
+* Fixed [#2000](https://github.com/rstudio/shiny/issues/2000): Implicit calls to `xxxOutput` not working inside modules. (Thanks, @GregorDeCillia! [#2010](https://github.com/rstudio/shiny/pull/2010))
+
+* Fixed [#2021](https://github.com/rstudio/shiny/issues/2021): Memory leak with `reactiveTimer` and `invalidateLater`. ([#2022](https://github.com/rstudio/shiny/pull/2022))
+
+### Library updates
+
+* Updated to ion.rangeSlider 2.2.0. ([#1955](https://github.com/rstudio/shiny/pull/1955))
+
+
+## Known issues
+
+In some rare cases, interrupting an application (by pressing Ctrl-C or Esc) may result in the message `Error in execCallbacks(timeoutSecs) : c++ exception (unknown reason)`. Although this message sounds alarming, it is harmless, and will go away in a future version of the later package (more information [here](https://github.com/r-lib/later/issues/55)).
+
+
+shiny 1.0.5
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed [#1818](https://github.com/rstudio/shiny/issues/1818): `conditionalPanel()` expressions that have a newline character in them caused the application to not work. ([#1820](https://github.com/rstudio/shiny/pull/1820))
+
+* Added a safe wrapper function for internal calls to `jsonlite::fromJSON()`. ([#1822](https://github.com/rstudio/shiny/pull/1822))
+
+* Fixed [#1824](https://github.com/rstudio/shiny/issues/1824): HTTP HEAD requests on static files caused the application to stop. ([#1825](https://github.com/rstudio/shiny/pull/1825))
+
+
 shiny 1.0.4
 ===========
 
@@ -195,7 +308,7 @@ Now there's an official way to slow down reactive values and expressions that in
 ### Minor new features and improvements
 
 * Addressed [#1486](https://github.com/rstudio/shiny/issues/1486) by adding a new argument to `observeEvent` and `eventReactive`, called `ignoreInit` (defaults to `FALSE` for backwards compatibility). When set to `TRUE`, the action (i.e. the second argument: `handlerExpr` and `valueExpr`, respectively) will not be triggered when the observer/reactive is first created/initialized. In other words, `ignoreInit = TRUE` ensures that the `observeEvent` (or `eventReactive`) is *never* run right away. For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
-    
+
 * Added a new argument to `observeEvent` called `once`. When set to `TRUE`, it results in the observer being destroyed (stop observing) after the first time that `handlerExpr` is run (i.e. `once = TRUE` guarantees that the observer only runs, at most, once). For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
 
 * Addressed [#1358](https://github.com/rstudio/shiny/issues/1358): more informative error message when calling `runApp()` inside of an app's app.R (or inside ui.R or server.R). ([#1482](https://github.com/rstudio/shiny/pull/1482))
@@ -594,7 +707,7 @@ shiny 0.12.1
 shiny 0.12.0
 ============
 
-In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps. 
+In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps.
 
 ### JSON serialization
 
@@ -685,13 +798,13 @@ Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version,
 ### Known issues for migration
 
 *    In Bootstrap 3, images in `<img>` tags are no longer automatically scaled to the width of their container. If you use `img()` in your UI code, or `<img>` tags in your raw HTML source, it's possible that they will be too large in the new version of Shiny. To address this you can add the `img-responsive` class:
-    
+
     ```r
     img(src = "picture.png", class = "img-responsive")
     ```
-    
+
     The R code above will generate the following HTML:
-    
+
     ```html
     <img src="picture.png" class="img-responsive">
     ```

R/app.R

@@ -381,9 +381,10 @@ print.shiny.appobj <- function(x, ...) {
       c("port", "launch.browser", "host", "quiet",
         "display.mode", "test.mode")]
 
-  args <- c(list(x), opts)
+  # Quote x and put runApp in quotes so that there's a nicer stack trace (#1851)
+  args <- c(list(quote(x)), opts)
 
-  do.call(runApp, args)
+  do.call("runApp", args)
 }
 
 #' @rdname shinyApp

R/bookmark-state.R

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

R/bootstrap-layout.R

@@ -588,7 +588,7 @@ flexfill <- function(..., direction, flex, width = width, height = height) {
   }
 
   if (length(flex) > length(children)) {
-    flex <- flex[1:length(children)]
+    flex <- flex[seq_along(children)]
   }
 
   # The dimension along the main axis

R/bootstrap.R

@@ -883,8 +883,8 @@ buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
       tags$a(href = "#",
         class = "dropdown-toggle", `data-toggle` = "dropdown",
         `data-value` = divTag$menuName,
-        divTag$title, tags$b(class = "caret"),
-        getIcon(iconClass = divTag$iconClass)
+        getIcon(iconClass = divTag$iconClass),
+        divTag$title, tags$b(class = "caret")
       ),
       tabset$navList   # inner tabPanels items
     )
@@ -899,8 +899,8 @@ buildTabItem <- function(index, tabsetId, foundSelected, tabs = NULL,
                  href = paste("#", tabId, sep = ""),
                  `data-toggle` = "tab",
                  `data-value` = divTag$attribs$`data-value`,
-                 divTag$attribs$title,
-                 getIcon(iconClass = divTag$attribs$`data-icon-class`)
+                 getIcon(iconClass = divTag$attribs$`data-icon-class`),
+                 divTag$attribs$title
                )
     )
     # if this tabPanel is selected item, mark it active

R/conditions.R

@@ -89,6 +89,23 @@ getLocs <- function(calls) {
   }, character(1))
 }
 
+getCallCategories <- function(calls) {
+  vapply(calls, function(call) {
+    srcref <- attr(call, "srcref", exact = TRUE)
+    if (!is.null(srcref)) {
+      srcfile <- attr(srcref, "srcfile", exact = TRUE)
+      if (!is.null(srcfile)) {
+        if (!is.null(srcfile$original)) {
+          return("pkg")
+        } else {
+          return("user")
+        }
+      }
+    }
+    return("")
+  }, character(1))
+}
+
 #' @details \code{captureStackTraces} runs the given \code{expr} and if any
 #'   \emph{uncaught} errors occur, annotates them with stack trace info for use
 #'   by \code{printError} and \code{printStackTrace}. It is not necessary to use
@@ -105,17 +122,93 @@ getLocs <- function(calls) {
 #' @rdname stacktrace
 #' @export
 captureStackTraces <- function(expr) {
-  withCallingHandlers(expr,
-    error = function(e) {
-      if (is.null(attr(e, "stack.trace", exact = TRUE))) {
-        calls <- sys.calls()
-        attr(e, "stack.trace") <- calls
-        stop(e)
-      }
-    }
+  promises::with_promise_domain(createStackTracePromiseDomain(),
+    expr
   )
 }
 
+#' @include globals.R
+.globals$deepStack <- NULL
+
+createStackTracePromiseDomain <- function() {
+  # These are actually stateless, we wouldn't have to create a new one each time
+  # if we didn't want to. They're pretty cheap though.
+  
+  d <- promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        currentStack <- sys.calls()
+        currentParents <- sys.parents()
+        attr(currentStack, "parents") <- currentParents
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onFulfilled(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      # Subscription time
+      if (deepStacksEnabled()) {
+        currentStack <- sys.calls()
+        currentParents <- sys.parents()
+        attr(currentStack, "parents") <- currentParents
+        currentDeepStack <- .globals$deepStack
+      }
+      function(...) {
+        # Fulfill time
+        if (deepStacksEnabled()) {
+          origDeepStack <- .globals$deepStack
+          .globals$deepStack <- c(currentDeepStack, list(currentStack))
+          on.exit(.globals$deepStack <- origDeepStack, add = TRUE)
+        }
+
+        withCallingHandlers(
+          onRejected(...),
+          error = doCaptureStack
+        )
+      }
+    },
+    wrapSync = function(expr) {
+      withCallingHandlers(expr,
+        error = doCaptureStack
+      )
+    },
+    onError = doCaptureStack
+  )
+}
+
+deepStacksEnabled <- function() {
+  getOption("shiny.deepstacktrace", TRUE)
+}
+
+doCaptureStack <- function(e) {
+  if (is.null(attr(e, "stack.trace", exact = TRUE))) {
+    calls <- sys.calls()
+    parents <- sys.parents()
+    attr(calls, "parents") <- parents
+    attr(e, "stack.trace") <- calls
+  }
+  if (deepStacksEnabled()) {
+    if (is.null(attr(e, "deep.stack.trace", exact = TRUE)) && !is.null(.globals$deepStack)) {
+      attr(e, "deep.stack.trace") <- .globals$deepStack
+    }
+  }
+  stop(e)
+}
+
 #' @details \code{withLogErrors} captures stack traces and logs errors that
 #'   occur in \code{expr}, but does allow errors to propagate beyond this point
 #'   (i.e. it doesn't catch the error). The same caveats that apply to
@@ -128,7 +221,22 @@ withLogErrors <- function(expr,
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
   withCallingHandlers(
-    captureStackTraces(expr),
+    {
+      result <- captureStackTraces(expr)
+
+      # Handle expr being an async operation
+      if (promises::is.promise(result)) {
+        result <- promises::catch(result, function(cond) {
+          # Don't print shiny.silent.error (i.e. validation errors)
+          if (inherits(cond, "shiny.silent.error")) return()
+          if (isTRUE(getOption("show.error.messages"))) {
+            printError(cond, full = full, offset = offset)
+          }
+        })
+      }
+
+      result
+    },
     error = function(cond) {
       # Don't print shiny.silent.error (i.e. validation errors)
       if (inherits(cond, "shiny.silent.error")) return()
@@ -158,11 +266,11 @@ withLogErrors <- function(expr,
 printError <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
-
-  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s",
+  
+  warning(call. = FALSE, immediate. = TRUE, sprintf("Error in %s: %s", 
     getCallNames(list(conditionCall(cond))), conditionMessage(cond)))
+  
   printStackTrace(cond, full = full, offset = offset)
-  invisible()
 }
 
 #' @rdname stacktrace
@@ -171,24 +279,85 @@ printStackTrace <- function(cond,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
-  stackTrace <- attr(cond, "stack.trace", exact = TRUE)
-  tryCatch(
-    if (!is.null(stackTrace)) {
-      message(paste0(
-        "Stack trace (innermost first):\n",
-        paste0(collapse = "\n",
-          formatStackTrace(stackTrace, full = full, offset = offset,
-            indent = "    ")
-        )
-      ))
-    } else {
-      message("No stack trace available")
-    },
-
-    error = function(cond) {
-      warning("Failed to write stack trace: ", cond)
-    }
+  should_drop <- !full
+  should_strip <- !full
+  should_prune <- !full
+  
+  stackTraceCalls <- c(
+    attr(cond, "deep.stack.trace", exact = TRUE),
+    list(attr(cond, "stack.trace", exact = TRUE))
   )
+  
+  stackTraceParents <- lapply(stackTraceCalls, attr, which = "parents", exact = TRUE)
+  stackTraceCallNames <- lapply(stackTraceCalls, getCallNames)
+  stackTraceCalls <- lapply(stackTraceCalls, offsetSrcrefs, offset = offset)
+  
+  # Use dropTrivialFrames logic to remove trailing bits (.handleSimpleError, h)
+  if (should_drop) {
+    # toKeep is a list of logical vectors, of which elements (stack frames) to keep
+    toKeep <- lapply(stackTraceCallNames, dropTrivialFrames)
+    # We apply the list of logical vector indices to each data structure
+    stackTraceCalls <- mapply(stackTraceCalls, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceCallNames <- mapply(stackTraceCallNames, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+    stackTraceParents <- mapply(stackTraceParents, FUN = `[`, toKeep, SIMPLIFY = FALSE)
+  }
+  
+  delayedAssign("all_true", {
+    # List of logical vectors that are all TRUE, the same shape as
+    # stackTraceCallNames. Delay the evaluation so we don't create it unless
+    # we need it, but if we need it twice then we don't pay to create it twice.
+    lapply(stackTraceCallNames, function(st) {
+      rep_len(TRUE, length(st))
+    })
+  })
+  
+  # stripStackTraces and lapply(stackTraceParents, pruneStackTrace) return lists
+  # of logical vectors. Use mapply(FUN = `&`) to boolean-and each pair of the
+  # logical vectors.
+  toShow <- mapply(
+    if (should_strip) stripStackTraces(stackTraceCallNames) else all_true,
+    if (should_prune) lapply(stackTraceParents, pruneStackTrace) else all_true,
+    FUN = `&`,
+    SIMPLIFY = FALSE
+  )
+  
+  dfs <- mapply(seq_along(stackTraceCalls), rev(stackTraceCalls), rev(stackTraceCallNames), rev(toShow), FUN = function(i, calls, nms, index) {
+    st <- data.frame(
+      num = rev(which(index)),
+      call = rev(nms[index]),
+      loc = rev(getLocs(calls[index])),
+      category = rev(getCallCategories(calls[index])),
+      stringsAsFactors = FALSE
+    )
+    
+    if (i != 1) {
+      message("From earlier call:")
+    }
+
+    if (nrow(st) == 0) {
+      message("  [No stack trace available]")
+    } else {
+      width <- floor(log10(max(st$num))) + 1
+      formatted <- paste0(
+        "  ",
+        formatC(st$num, width = width),
+        ": ",
+        mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+          if (category == "pkg")
+            crayon::silver(name)
+          else if (category == "user")
+            crayon::blue$bold(name)
+          else
+            crayon::white(name)
+        }),
+        "\n"
+      )
+      cat(file = stderr(), formatted, sep = "")
+    }
+
+    st
+  }, SIMPLIFY = FALSE)
+  
   invisible()
 }
 
@@ -196,12 +365,17 @@ printStackTrace <- function(cond,
 #'   from \code{conditionStackTrace(cond)}) and returns a data frame with one
 #'   row for each stack frame and the columns \code{num} (stack frame number),
 #'   \code{call} (a function name or similar), and \code{loc} (source file path
-#'   and line number, if available).
+#'   and line number, if available). It was deprecated after shiny 1.0.5 because
+#'   it doesn't support deep stack traces.
 #' @rdname stacktrace
 #' @export
 extractStackTrace <- function(calls,
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
+  
+  shinyDeprecated(NULL,
+    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
+    version = "1.0.5")
 
   srcrefs <- getSrcRefs(calls)
   if (offset) {
@@ -241,7 +415,11 @@ extractStackTrace <- function(calls,
     score <- rep.int(0, length(callnames))
     score[callnames == "..stacktraceoff.."] <- -1
     score[callnames == "..stacktraceon.."] <- 1
-    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff.."))
+    toShow <- (1 + cumsum(score)) > 0 & !(callnames %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
+
+    # doTryCatch, tryCatchOne, and tryCatchList are not informative--they're
+    # just internals for tryCatch
+    toShow <- toShow & !(callnames %in% c("doTryCatch", "tryCatchOne", "tryCatchList"))
   }
   calls <- calls[toShow]
 
@@ -253,12 +431,115 @@ extractStackTrace <- function(calls,
     num = index,
     call = getCallNames(calls),
     loc = getLocs(calls),
+    category = getCallCategories(calls),
     stringsAsFactors = FALSE
   )
 }
 
+stripStackTraces <- function(stackTraces, values = FALSE) {
+  score <- 1L  # >=1: show, <=0: hide
+  lapply(seq_along(stackTraces), function(i) {
+    res <- stripOneStackTrace(stackTraces[[i]], i != 1, score)
+    score <<- res$score
+    toShow <- as.logical(res$trace)
+    if (values) {
+      as.character(stackTraces[[i]][toShow])
+    } else {
+      as.logical(toShow)
+    }
+  })
+}
+
+stripOneStackTrace <- function(stackTrace, truncateFloor, startingScore) {
+  prefix <- logical(0)
+  if (truncateFloor) {
+    indexOfFloor <- utils::tail(which(stackTrace == "..stacktracefloor.."), 1)
+    if (length(indexOfFloor)) {
+      stackTrace <- stackTrace[(indexOfFloor+1L):length(stackTrace)]
+      prefix <- rep_len(FALSE, indexOfFloor)
+    }
+  }
+  
+  if (length(stackTrace) == 0) {
+    return(list(score = startingScore, character(0)))
+  }
+  
+  score <- rep.int(0L, length(stackTrace))
+  score[stackTrace == "..stacktraceon.."] <- 1L
+  score[stackTrace == "..stacktraceoff.."] <- -1L
+  score <- startingScore + cumsum(score)
+  
+  toShow <- score > 0 & !(stackTrace %in% c("..stacktraceon..", "..stacktraceoff..", "..stacktracefloor.."))
+  
+  
+  list(score = utils::tail(score, 1), trace = c(prefix, toShow))
+}
+
+# Given sys.parents() (which corresponds to sys.calls()), return a logical index
+# that prunes each subtree so that only the final branch remains. The result,
+# when applied to sys.calls(), is a linear list of calls without any "wrapper"
+# functions like tryCatch, try, with, hybrid_chain, etc. While these are often
+# part of the active call stack, they rarely are helpful when trying to identify
+# a broken bit of code.
+pruneStackTrace <- function(parents) {
+  # Detect nodes that are not the last child. This is necessary, but not
+  # sufficient; we also need to drop nodes that are the last child, but one of
+  # their ancestors is not.
+  is_dupe <- duplicated(parents, fromLast = TRUE)
+  
+  # The index of the most recently seen node that was actually kept instead of
+  # dropped.
+  current_node <- 0
+  
+  # Loop over the parent indices. Anything that is not parented by current_node
+  # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
+  # is kept becomes the new current_node.
+  include <- vapply(seq_along(parents), function(i) {
+    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+      current_node <<- i
+      TRUE
+    } else {
+      FALSE
+    }
+  }, FUN.VALUE = logical(1))
+  
+  include
+}
+
+dropTrivialFrames <- function(callnames) {
+  # Remove stop(), .handleSimpleError(), and h() calls from the end of
+  # the calls--they don't add any helpful information. But only remove
+  # the last *contiguous* block of them, and then, only if they are the
+  # last thing in the calls list.
+  hideable <- callnames %in% c(".handleSimpleError", "h", "base$wrapOnFulfilled")
+  # What's the last that *didn't* match stop/.handleSimpleError/h?
+  lastGoodCall <- max(which(!hideable))
+  toRemove <- length(callnames) - lastGoodCall
+  
+  c(
+    rep_len(TRUE, length(callnames) - toRemove),
+    rep_len(FALSE, toRemove)
+  )
+}
+
+offsetSrcrefs <- function(calls, offset = TRUE) {
+  if (offset) {
+    srcrefs <- getSrcRefs(calls)
+
+    # Offset calls vs. srcrefs by 1 to make them more intuitive.
+    # E.g. for "foo [bar.R:10]", line 10 of bar.R will be part of
+    # the definition of foo().
+    srcrefs <- c(utils::tail(srcrefs, -1), list(NULL))
+    
+    calls <- setSrcRefs(calls, srcrefs)
+  }
+  
+  calls
+}
+
 #' @details \code{formatStackTrace} is similar to \code{extractStackTrace}, but
-#'   it returns a preformatted character vector instead of a data frame.
+#'   it returns a preformatted character vector instead of a data frame. It was
+#'   deprecated after shiny 1.0.5 because it doesn't support deep stack traces.
 #' @param indent A string to prefix every line of the stack trace.
 #' @rdname stacktrace
 #' @export
@@ -266,6 +547,10 @@ formatStackTrace <- function(calls, indent = "    ",
   full = getOption("shiny.fullstacktrace", FALSE),
   offset = getOption("shiny.stacktraceoffset", TRUE)) {
 
+  shinyDeprecated(NULL,
+    "extractStackTrace is deprecated. Please contact the Shiny team if you were using this functionality.",
+    version = "1.0.5")
+  
   st <- extractStackTrace(calls, full = full, offset = offset)
   if (nrow(st) == 0) {
     return(character(0))
@@ -276,8 +561,14 @@ formatStackTrace <- function(calls, indent = "    ",
     indent,
     formatC(st$num, width = width),
     ": ",
-    st$call,
-    st$loc
+    mapply(paste0(st$call, st$loc), st$category, FUN = function(name, category) {
+      if (category == "pkg")
+        crayon::silver(name)
+      else if (category == "user")
+        crayon::blue$bold(name)
+      else
+        crayon::white(name)
+    })
   )
 }
 
@@ -332,3 +623,5 @@ conditionStackTrace <- function(cond) {
 #' @rdname stacktrace
 #' @export
 ..stacktraceoff.. <- function(expr) expr
+
+..stacktracefloor.. <- function(expr) expr

R/imageutils.R

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

R/input-checkboxgroup.R

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

R/input-date.R

@@ -41,6 +41,8 @@
 #'   "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".
+#' @param autoclose Whether or not to close the datepicker immediately when a
+#'   date is selected.
 #'
 #' @family input elements
 #' @seealso \code{\link{dateRangeInput}}, \code{\link{updateDateInput}}
@@ -76,7 +78,7 @@
 #' @export
 dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   format = "yyyy-mm-dd", startview = "month", weekstart = 0, language = "en",
-  width = NULL) {
+  width = NULL, autoclose = TRUE) {
 
   # If value is a date object, convert it to a string with yyyy-mm-dd format
   # Same for min and max
@@ -99,7 +101,8 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
                `data-date-start-view` = startview,
                `data-min-date` = min,
                `data-max-date` = max,
-               `data-initial-date` = value
+               `data-initial-date` = value,
+               `data-date-autoclose` = if (autoclose) "true" else "false"
     ),
     datePickerDependency
   )

R/input-daterange.R

@@ -73,7 +73,8 @@
 #' @export
 dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
     min = NULL, max = NULL, format = "yyyy-mm-dd", startview = "month",
-    weekstart = 0, language = "en", separator = " to ", width = NULL) {
+    weekstart = 0, language = "en", separator = " to ", width = NULL,
+    autoclose = TRUE) {
 
   # If start and end are date objects, convert to a string with yyyy-mm-dd format
   # Same for min and max
@@ -103,7 +104,8 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = start
+          `data-initial-date` = start,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
         ),
         span(class = "input-group-addon", separator),
         tags$input(
@@ -115,7 +117,8 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
           `data-date-start-view` = startview,
           `data-min-date` = min,
           `data-max-date` = max,
-          `data-initial-date` = end
+          `data-initial-date` = end,
+          `data-date-autoclose` = if (autoclose) "true" else "false"
         )
       )
     ),

R/input-radiobuttons.R

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

R/input-select.R

@@ -33,7 +33,7 @@
 #' @return A select list control that can be added to a UI definition.
 #'
 #' @family input elements
-#' @seealso \code{\link{updateSelectInput}}
+#' @seealso \code{\link{updateSelectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -59,9 +59,9 @@
 #' 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"))
+#'       list(`East Coast` = list("NY", "NJ", "CT"),
+#'            `West Coast` = list("WA", "OR", "CA"),
+#'            `Midwest` = list("MN", "WI", "IA"))
 #'     ),
 #'     textOutput("result")
 #'   ),
@@ -212,3 +212,135 @@ selectizeIt <- function(inputId, select, options, nonempty = FALSE) {
 
   attachDependencies(select, selectizeDep)
 }
+
+
+
+
+
+
+
+
+#' Select variables from a data frame
+#'
+#' Create a select list that can be used to choose a single or multiple items
+#' from the column names of a data frame.
+#'
+#' The resulting server \code{input} value will be returned as:
+#' \itemize{
+#'   \item a symbol if \code{multiple = FALSE}.  The \code{input} value should be
+#'         used with rlang's \code{\link[rlang]{!!}}. For example,
+#'         \code{ggplot2::aes(!!input$variable)}.
+#'   \item a list of symbols if \code{multiple = TRUE}. The \code{input} value
+#'         should be used with rlang's \code{\link[rlang]{!!!}} to expand
+#'         the symbol list as individual arguments. For example,
+#'         \code{dplyr::select(mtcars, !!!input$variabls)} which is
+#'         equivalent to \code{dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])}.
+#' }
+#'
+#' By default, \code{varSelectInput()} and \code{selectizeInput()} use the
+#' JavaScript library \pkg{selectize.js}
+#' (\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}.
+#'
+#' @inheritParams selectInput
+#' @param data A data frame. Used to retrieve the column names as choices for a \code{\link{selectInput}}
+#' @return A variable select list control that can be added to a UI definition.
+#'
+#' @family input elements
+#' @seealso \code{\link{updateSelectInput}}
+#' @examples
+#'
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' library(ggplot2)
+#'
+#' # single selection
+#' shinyApp(
+#'   ui = fluidPage(
+#'     varSelectInput("variable", "Variable:", mtcars),
+#'     plotOutput("data")
+#'   ),
+#'   server = function(input, output) {
+#'     output$data <- renderPlot({
+#'       ggplot(mtcars, aes(!!input$variable)) + geom_histogram()
+#'     })
+#'   }
+#' )
+#'
+#'
+#' # multiple selections
+#' \dontrun{
+#' shinyApp(
+#'  ui = fluidPage(
+#'    varSelectInput("variables", "Variable:", mtcars, multiple = TRUE),
+#'    tableOutput("data")
+#'  ),
+#'  server = function(input, output) {
+#'    output$data <- renderTable({
+#'       if (length(input$variables) == 0) return(mtcars)
+#'       mtcars %>% dplyr::select(!!!input$variables)
+#'    }, rownames = TRUE)
+#'  }
+#' )}
+#'
+#' }
+#' @export
+varSelectInput <- function(
+  inputId, label, data, selected = NULL,
+  multiple = FALSE, selectize = TRUE, width = NULL,
+  size = NULL
+) {
+  # no place holders
+  choices <- colnames(data)
+
+  selectInputVal <- selectInput(
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    multiple = multiple,
+    selectize = selectize,
+    width = width,
+    size = size
+  )
+
+  # set the select tag class to be "symbol"
+  selectClass <- selectInputVal$children[[2]]$children[[1]]$attribs$class
+  if (is.null(selectClass)) {
+    newClass <- "symbol"
+  } else {
+    newClass <- paste(selectClass, "symbol", sep = " ")
+  }
+  selectInputVal$children[[2]]$children[[1]]$attribs$class <- newClass
+
+  selectInputVal
+}
+
+
+
+#' @rdname varSelectInput
+#' @param ... Arguments passed to \code{varSelectInput()}.
+#' @param options A list of options. See the documentation of \pkg{selectize.js}
+#'   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\%'};
+#'   see \code{\link{validateCssUnit}}.
+#' @note The variable selectize input created from \code{varSelectizeInput()} allows
+#'   deletion of the selected option even in a single select input, which will
+#'   return an empty string as its value. This is the default behavior of
+#'   \pkg{selectize.js}. However, the selectize input created from
+#'   \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+#'   value when it is a single choice input and the empty string is not in the
+#'   \code{choices} argument. This is to keep compatibility with
+#'   \code{selectInput(..., selectize = FALSE)}.
+#' @export
+varSelectizeInput <- function(inputId, ..., options = NULL, width = NULL) {
+  selectizeIt(
+    inputId,
+    varSelectInput(inputId, ..., selectize = FALSE, width = width),
+    options
+  )
+}

R/input-slider.R

@@ -86,40 +86,25 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  value <- restoreInput(id = inputId, default = value)
+  dataType <- getSliderType(min, max, value)
 
-  # If step is NULL, use heuristic to set the step size.
-  findStepSize <- function(min, max, step) {
-    if (!is.null(step)) return(step)
-
-    range <- max - min
-    # If short range or decimals, use continuous decimal with ~100 points
-    if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
-      step <- pretty(c(min, max), n = 100)
-      step[2] - step[1]
-    } else {
-      1
-    }
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if (inherits(min, "Date")) {
-    if (!inherits(max, "Date") || !inherits(value, "Date"))
-      stop("`min`, `max`, and `value must all be Date or non-Date objects")
-    dataType <- "date"
+  # Restore bookmarked values here, after doing the type checking, because the
+  # restored value will be a character vector instead of Date or POSIXct, and we can do
+  # the conversion to correct type next.
+  value <- restoreInput(id = inputId, default = value)
 
-    if (is.null(timeFormat))
-      timeFormat <- "%F"
-
-  } else if (inherits(min, "POSIXt")) {
-    if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
-      stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
-    dataType <- "datetime"
-
-    if (is.null(timeFormat))
-      timeFormat <- "%F %T"
-
-  } else {
-    dataType <- "number"
+  if (is.character(value)) {
+    # If we got here, the value was restored from a URL-encoded bookmark.
+    if (dataType == "date") {
+      value <- as.Date(value, format = "%Y-%m-%d")
+    } else if (dataType == "datetime") {
+      # Date-times will have a format like "2018-02-28T03:46:26Z"
+      value <- as.POSIXct(value, format = "%Y-%m-%dT%H:%M:%SZ", tz = "UTC")
+    }
   }
 
   step <- findStepSize(min, max, step)
@@ -169,7 +154,6 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
     `data-prefix` = pre,
     `data-postfix` = post,
     `data-keyboard` = TRUE,
-    `data-keyboard-step` = step / (max - min) * 100,
     # This value is only relevant for range sliders; for non-range sliders it
     # causes problems since ion.RangeSlider 2.1.2 (issue #1605).
     `data-drag-interval` = if (length(value) > 1) dragRange,
@@ -238,6 +222,34 @@ hasDecimals <- function(value) {
   return (!identical(value, truncatedValue))
 }
 
+
+# If step is NULL, use heuristic to set the step size.
+findStepSize <- function(min, max, step) {
+  if (!is.null(step)) return(step)
+
+  range <- max - min
+  # If short range or decimals, use continuous decimal with ~100 points
+  if (range < 2 || hasDecimals(min) || hasDecimals(max)) {
+    # Workaround for rounding errors (#1006): the intervals between the items
+    # returned by pretty() can have rounding errors. To avoid this, we'll use
+    # pretty() to find the min, max, and number of steps, and then use those
+    # values to calculate the step size.
+    pretty_steps <- pretty(c(min, max), n = 100)
+    n_steps <- length(pretty_steps) - 1
+
+    # Fix for #2061: Windows has low-significance digits (like 17 digits out)
+    # even at the boundaries of pretty()'s output. Use signif(digits = 10),
+    # which should be way way less significant than any data we'd want to keep.
+    # It might make sense to use signif(steps[2] - steps[1], 10) instead, but
+    # for now trying to make the minimal change.
+    signif(digits = 10, (max(pretty_steps) - min(pretty_steps)) / n_steps)
+
+  } else {
+    1
+  }
+}
+
+
 #' @rdname sliderInput
 #'
 #' @param interval The interval, in milliseconds, between each animation step.

R/middleware.R

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

R/react.R

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

R/reactive-domains.R

@@ -95,11 +95,7 @@ getDefaultReactiveDomain <- function() {
 #' @rdname domains
 #' @export
 withReactiveDomain <- function(domain, expr) {
-  oldValue <- .globals$domain
-  .globals$domain <- domain
-  on.exit(.globals$domain <- oldValue)
-
-  expr
+  promises::with_promise_domain(createVarPromiseDomain(.globals, "domain", domain), expr)
 }
 
 #

R/reactives.R

@@ -91,7 +91,7 @@ ReactiveVal <- R6Class(
     format = function(...) {
       # capture.output(print()) is necessary because format() doesn't
       # necessarily return a character vector, e.g. data.frame.
-      label <- capture.output(print(base::format(private$value, ...)))
+      label <- utils::capture.output(print(base::format(private$value, ...)))
       if (length(label) == 1) {
         paste0("reactiveVal: ", label)
       } else {
@@ -278,8 +278,9 @@ ReactiveValues <- R6Class(
     .allValuesDeps = 'Dependents',
     # Dependents for all values
     .valuesDeps = 'Dependents',
+    .dedupe = logical(0),
 
-    initialize = function() {
+    initialize = function(dedupe = TRUE) {
       .label <<- paste('reactiveValues',
                        p_randomInt(1000, 10000),
                        sep="")
@@ -289,6 +290,7 @@ ReactiveValues <- R6Class(
       .namesDeps <<- Dependents$new()
       .allValuesDeps <<- Dependents$new()
       .valuesDeps <<- Dependents$new()
+      .dedupe <<- dedupe
     },
 
     get = function(key) {
@@ -317,7 +319,7 @@ ReactiveValues <- R6Class(
       hidden <- substr(key, 1, 1) == "."
 
       if (exists(key, envir=.values, inherits=FALSE)) {
-        if (identical(.values[[key]], value)) {
+        if (.dedupe && identical(.values[[key]], value)) {
           return(invisible())
         }
       }
@@ -781,18 +783,6 @@ Observable <- R6Class(
             # If an error occurs, we want to propagate the error, but we also
             # want to save a copy of it, so future callers of this reactive will
             # get the same error (i.e. the error is cached).
-
-            # We stripStackTrace in the next line, just in case someone
-            # downstream of us (i.e. deeper into the call stack) used
-            # captureStackTraces; otherwise the entire stack would always be the
-            # same (i.e. you'd always see the whole stack trace of the *first*
-            # time the code was run and the condition raised; there'd be no way
-            # to see the stack trace of the call site that caused the cached
-            # exception to be re-raised, and you need that information to figure
-            # out what's triggering the re-raise).
-            #
-            # We use try(stop()) as an easy way to generate a try-error object
-            # out of this condition.
             .value <<- cond
             .error <<- TRUE
             .visible <<- FALSE
@@ -969,19 +959,12 @@ Observer <- R6Class(
       if (length(formals(observerFunc)) > 0)
         stop("Can't make an observer from a function that takes parameters; ",
              "only functions without parameters can be reactive.")
-registerDebugHook("observerFunc", environment(), label)
-      .func <<- function() {
-        tryCatch(
-          if (..stacktraceon)
-            ..stacktraceon..(observerFunc())
-          else
-            observerFunc(),
-          # It's OK for shiny.silent.error errors to cause an observer to stop running
-          shiny.silent.error = function(e) NULL
-          # validation = function(e) NULL,
-          # shiny.output.cancel = function(e) NULL
-        )
+      if (grepl("\\s", label, perl = TRUE)) {
+        funcLabel <- "<observer>"
+      } else {
+        funcLabel <- paste0("<observer:", label, ">")
       }
+      .func <<- wrapFunctionLabel(observerFunc, funcLabel, ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
       .priority <<- normalizePriority(priority)
@@ -1026,6 +1009,9 @@ registerDebugHook("observerFunc", environment(), label)
 
         continue <- function() {
           ctx$addPendingFlush(.priority)
+          if (!is.null(.domain)) {
+            .domain$incrementBusyCount()
+          }
         }
 
         if (.suspended == FALSE)
@@ -1035,16 +1021,30 @@ registerDebugHook("observerFunc", environment(), label)
       })
 
       ctx$onFlush(function() {
-        tryCatch({
-          if (!.destroyed)
-            shinyCallingHandlers(run())
 
-        }, error = function(e) {
-          printError(e)
-          if (!is.null(.domain)) {
-            .domain$unhandledError(e)
-          }
-        })
+        hybrid_chain(
+          {
+            if (!.destroyed) {
+              shinyCallingHandlers(run())
+            }
+          },
+          catch = function(e) {
+            # It's OK for shiny.silent.error errors to cause an observer to stop running
+            # shiny.silent.error = function(e) NULL
+            # validation = function(e) NULL,
+            # shiny.output.cancel = function(e) NULL
+
+            if (inherits(e, "shiny.silent.error")) {
+              return()
+            }
+
+            printError(e)
+            if (!is.null(.domain)) {
+              .domain$unhandledError(e)
+            }
+          },
+          finally = .domain$decrementBusyCount
+        )
       })
 
       return(ctx)
@@ -1394,20 +1394,28 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   force(session)
 
   dependents <- Map$new()
-  timerCallbacks$schedule(intervalMs, function() {
+  timerHandle <- scheduleTask(intervalMs, function() {
     # Quit if the session is closed
     if (!is.null(session) && session$isClosed()) {
       return(invisible())
     }
 
-    timerCallbacks$schedule(intervalMs, sys.function())
-    lapply(
-      dependents$values(),
-      function(dep.ctx) {
-        dep.ctx$invalidate()
-        NULL
-      })
+    timerHandle <<- scheduleTask(intervalMs, sys.function())
+
+    session$cycleStartAction(function() {
+      lapply(
+        dependents$values(),
+        function(dep.ctx) {
+          dep.ctx$invalidate()
+          NULL
+        })
+    })
   })
+
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+
   return(function() {
     ctx <- .getReactiveEnvironment()$currentContext()
     if (!dependents$containsKey(ctx$id)) {
@@ -1475,14 +1483,27 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
+  force(session)
   ctx <- .getReactiveEnvironment()$currentContext()
-  timerCallbacks$schedule(millis, function() {
-    # Quit if the session is closed
-    if (!is.null(session) && session$isClosed()) {
+  timerHandle <- scheduleTask(millis, function() {
+    if (is.null(session)) {
+      ctx$invalidate()
       return(invisible())
     }
-    ctx$invalidate()
+
+    if (!session$isClosed()) {
+      session$cycleStartAction(function() {
+        ctx$invalidate()
+      })
+    }
+
+    invisible()
   })
+
+  if (!is.null(session)) {
+    session$onEnded(timerHandle)
+  }
+
   invisible()
 }
 
@@ -1800,15 +1821,20 @@ 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}
+#' Likewise, both \code{observeEvent} and \code{eventReactive} also take in an
+#' \code{ignoreInit} argument. By default, both of these will run right when they
+#' are 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.
+#' instead of also being triggered when it is created/initialized. Similarly,
+#' if you're setting up an \code{eventReactive} that responds to a dynamically
+#' created button used to refresh some data (then returned by that \code{eventReactive}),
+#' then you should use \code{eventReactive([...], ignoreInit = TRUE)} if you want
+#' to let the user decide if/when they want to refresh the data (since, depending
+#' on the app, this may be a computationally expensive operation).
 #'
 #' 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
@@ -1816,25 +1842,28 @@ maskReactiveContext <- function(expr) {
 #'
 #' \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.
+#'      This is the default. This combination means that \code{handlerExpr}/
+#'      \code{valueExpr} will run every time that \code{eventExpr} is not
+#'      \code{NULL}. If, at the time of the creation of the
+#'      \code{observeEvent}/\code{eventReactive}, \code{eventExpr} 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.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} 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.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} will
+#'      \emph{not} run when the \code{observeEvent}/\code{eventReactive} 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}.
+#'      This combination means that \code{handlerExpr}/\code{valueExpr} will
+#'      \emph{not} run when the \code{observeEvent}/\code{eventReactive} is
+#'      created (because  \code{ignoreInit = TRUE}). After that,
+#'      \code{handlerExpr}/\code{valueExpr} will run every time that
+#'      \code{eventExpr} is not \code{NULL}.
 #'   }
 #' }
 #'
@@ -1974,22 +2003,25 @@ observeEvent <- function(eventExpr, handlerExpr,
   initialized <- FALSE
 
   o <- observe({
-    e <- eventFunc()
+    hybrid_chain(
+      {eventFunc()},
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          return()
+        }
 
-    if (ignoreInit && !initialized) {
-      initialized <<- TRUE
-      return()
-    }
+        if (ignoreNULL && isNullEvent(value)) {
+          return()
+        }
 
-    if (ignoreNULL && isNullEvent(e)) {
-      return()
-    }
+        if (once) {
+          on.exit(o$destroy())
+        }
 
-    if (once) {
-      on.exit(o$destroy())
-    }
-
-    isolate(handlerFunc())
+        isolate(handlerFunc())
+      }
+    )
   }, label = label, suspended = suspended, priority = priority, domain = domain,
   autoDestroy = TRUE, ..stacktraceon = FALSE)
 
@@ -2015,16 +2047,19 @@ eventReactive <- function(eventExpr, valueExpr,
   initialized <- FALSE
 
   invisible(reactive({
-    e <- eventFunc()
+    hybrid_chain(
+      eventFunc(),
+      function(value) {
+        if (ignoreInit && !initialized) {
+          initialized <<- TRUE
+          req(FALSE)
+        }
 
-    if (ignoreInit && !initialized) {
-      initialized <<- TRUE
-      req(FALSE)
-    }
+        req(!ignoreNULL || !isNullEvent(value))
 
-    req(!ignoreNULL || !isNullEvent(e))
-
-    isolate(handlerFunc())
+        isolate(handlerFunc())
+      }
+    )
   }, label = label, domain = domain, ..stacktraceon = FALSE))
 }
 

R/render-plot.R

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

R/render-table.R

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

R/server-input-handlers.R

@@ -142,6 +142,7 @@ registerInputHandler("shiny.matrix", function(data, ...) {
   return(m)
 })
 
+
 registerInputHandler("shiny.number", function(val, ...){
   ifelse(is.null(val), NA, val)
 })
@@ -220,3 +221,21 @@ registerInputHandler("shiny.file", function(val, shinysession, name) {
 
   val
 })
+
+
+# to be used with !!!answer
+registerInputHandler("shiny.symbolList", function(val, ...) {
+  if (is.null(val)) {
+    list()
+  } else {
+    lapply(val, as.symbol)
+  }
+})
+# to be used with !!answer
+registerInputHandler("shiny.symbol", function(val, ...) {
+  if (is.null(val) || identical(val, "")) {
+    NULL
+  } else {
+    as.symbol(val)
+  }
+})

R/server.R

@@ -1,6 +1,7 @@
 #' @include server-input-handlers.R
 
 appsByToken <- Map$new()
+appsNeedingFlush <- Map$new()
 
 # Provide a character representation of the WS that can be used
 # as a key in a Map.
@@ -52,21 +53,23 @@ registerClient <- function(client) {
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z0-9\\-_][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")
   }
-
   if (prefix %in% c('shared')) {
     stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
          "please use a different prefix")
   }
-
-  directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
-
-  existing <- .globals$resources[[prefix]]
-
-  .globals$resources[[prefix]] <- list(directoryPath=directoryPath,
-                                       func=staticHandler(directoryPath))
+  normalizedPath <- tryCatch(normalizePath(directoryPath, mustWork = TRUE),
+    error = function(e) {
+      stop("Couldn't normalize path in `addResourcePath`, with arguments: ",
+        "`prefix` = '", prefix, "'; `directoryPath` = '" , directoryPath, "'")
+    }
+  )
+  .globals$resources[[prefix]] <- list(
+    directoryPath = normalizedPath,
+    func = staticHandler(normalizedPath)
+  )
 }
 
 resourcePathHandler <- function(req) {
@@ -155,7 +158,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
@@ -243,94 +246,87 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
             } else {
               # If there's bookmarked state, save it on the session object
               shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+              shinysession$createBookmarkObservers()
             }
           }
 
-          withRestoreContext(shinysession$restoreContext, {
 
-            msg$data <- applyInputHandlers(msg$data)
+          msg$data <- applyInputHandlers(msg$data)
 
-            switch(
-              msg$method,
-              init = {
+          switch(
+            msg$method,
+            init = {
 
-                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                  appvars$server <- serverFunc
-                  if (!is.null(appvars$server))
-                  {
-                    # Tag this function as the Shiny server function. A debugger may use this
-                    # tag to give this function special treatment.
-                    # It's very important that it's appvars$server itself and NOT a copy that
-                    # is invoked, otherwise new breakpoints won't be picked up.
-                    attr(appvars$server, "shinyServerFunction") <- TRUE
-                    registerDebugHook("server", appvars, "Server Function")
-                  }
+              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                appvars$server <- serverFunc
+                if (!is.null(appvars$server))
+                {
+                  # Tag this function as the Shiny server function. A debugger may use this
+                  # tag to give this function special treatment.
+                  # It's very important that it's appvars$server itself and NOT a copy that
+                  # is invoked, otherwise new breakpoints won't be picked up.
+                  attr(appvars$server, "shinyServerFunction") <- TRUE
+                  registerDebugHook("server", appvars, "Server Function")
                 }
+              }
 
-                # Check for switching into/out of showcase mode
-                if (.globals$showcaseOverride &&
-                    exists(".clientdata_url_search", where = msg$data)) {
-                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                  if (!is.null(mode))
-                    shinysession$setShowcase(mode)
-                }
+              # Check for switching into/out of showcase mode
+              if (.globals$showcaseOverride &&
+                  exists(".clientdata_url_search", where = msg$data)) {
+                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                if (!is.null(mode))
+                  shinysession$setShowcase(mode)
+              }
 
-                shinysession$manageInputs(msg$data)
+              # In shinysession$createBookmarkObservers() above, observers may be
+              # created, which puts the shiny session in busyCount > 0 state. That
+              # prevents the manageInputs here from taking immediate effect, by
+              # default. The manageInputs here needs to take effect though, because
+              # otherwise the bookmark observers won't find the clientData they are
+              # looking for. So use `now = TRUE` to force the changes to be
+              # immediate.
+              #
+              # FIXME: break createBookmarkObservers into two separate steps, one
+              # before and one after manageInputs, and put the observer creation
+              # in the latter. Then add an assertion that busyCount == 0L when
+              # this manageInputs is called.
+              shinysession$manageInputs(msg$data, now = TRUE)
 
-                # The client tells us what singletons were rendered into
-                # the initial page
-                if (!is.null(msg$data$.clientdata_singletons)) {
-                  shinysession$singletons <- strsplit(
-                    msg$data$.clientdata_singletons, ',')[[1]]
-                }
+              # The client tells us what singletons were rendered into
+              # the initial page
+              if (!is.null(msg$data$.clientdata_singletons)) {
+                shinysession$singletons <- strsplit(
+                  msg$data$.clientdata_singletons, ',')[[1]]
+              }
 
-                local({
-                  args <- argsForServerFunc(serverFunc, shinysession)
+              local({
+                args <- argsForServerFunc(serverFunc, shinysession)
 
-                  withReactiveDomain(shinysession, {
-                    do.call(
-                      # No corresponding ..stacktraceoff; the server func is pure
-                      # user code
-                      wrapFunctionLabel(appvars$server, "server",
-                        ..stacktraceon = TRUE
-                      ),
-                      args
-                    )
-                  })
+                withReactiveDomain(shinysession, {
+                  do.call(
+                    # No corresponding ..stacktraceoff; the server func is pure
+                    # user code
+                    wrapFunctionLabel(appvars$server, "server",
+                      ..stacktraceon = TRUE
+                    ),
+                    args
+                  )
                 })
-              },
-              update = {
-                shinysession$manageInputs(msg$data)
-              },
-              shinysession$dispatch(msg)
-            )
-            shinysession$manageHiddenOutputs()
+              })
+            },
+            update = {
+              shinysession$manageInputs(msg$data)
+            },
+            shinysession$dispatch(msg)
+          )
+          # The HTTP_GUID, if it exists, is for Shiny Server reporting purposes
+          shinysession$startTiming(ws$request$HTTP_GUID)
+          shinysession$requestFlush()
 
-            if (exists(".shiny__stdout", globalenv()) &&
-                exists("HTTP_GUID", ws$request)) {
-              # safe to assume we're in shiny-server
-              shiny_stdout <- get(".shiny__stdout", globalenv())
-
-              # eNter a flushReact
-              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-
-              flushReact()
-
-              # eXit a flushReact
-              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-                sep=""), con=shiny_stdout)
-              flush(shiny_stdout)
-            } else {
-              flushReact()
-            }
-
-            flushAllSessions()
-          })
+          # Make httpuv return control to Shiny quickly, instead of waiting
+          # for the usual timeout
+          httpuv::interrupt()
         })
       }
       ws$onMessage(function(binary, msg) {
@@ -341,6 +337,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       ws$onClose(function() {
         shinysession$wsClosed()
         appsByToken$remove(shinysession$token)
+        appsNeedingFlush$remove(shinysession$token)
       })
 
       return(TRUE)
@@ -422,7 +419,10 @@ startApp <- function(appObj, port, host, quiet) {
 
   if (is.numeric(port) || is.integer(port)) {
     if (!quiet) {
-      message('\n', 'Listening on http://', host, ':', port)
+      hostString <- host
+      if (httpuv::ipFamily(host) == 6L)
+        hostString <- paste0("[", hostString, "]")
+      message('\n', 'Listening on http://', hostString, ':', port)
     }
     return(startServer(host, port, handlerManager$createHttpuvApp()))
   } else if (is.character(port)) {
@@ -443,21 +443,20 @@ startApp <- function(appObj, port, host, quiet) {
 # Run an application that was created by \code{\link{startApp}}. This
 # function should normally be called in a \code{while(TRUE)} loop.
 serviceApp <- function() {
-  if (timerCallbacks$executeElapsed()) {
-    for (shinysession in appsByToken$values()) {
-      shinysession$manageHiddenOutputs()
-    }
+  timerCallbacks$executeElapsed()
 
-    flushReact()
-    flushAllSessions()
-  }
+  flushReact()
+  flushPendingSessions()
 
   # If this R session is interactive, then call service() with a short timeout
   # to keep the session responsive to user input
   maxTimeout <- ifelse(interactive(), 100, 1000)
 
-  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
+  timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent(), later::next_op_secs()))
   service(timeout)
+
+  flushReact()
+  flushPendingSessions()
 }
 
 .shinyServerMinVersion <- '0.3.4'
@@ -731,7 +730,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
           }
         }
@@ -773,8 +773,17 @@ runApp <- function(appDir=getwd(),
   }, add = TRUE)
 
   if (!is.character(port)) {
-    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
-    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
+    browseHost <- host
+    if (identical(host, "0.0.0.0")) {
+      # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
+      browseHost <- "127.0.0.1"
+    } else if (identical(host, "::")) {
+      browseHost <- "::1"
+    }
+
+    if (httpuv::ipFamily(browseHost) == 6L) {
+      browseHost <- paste0("[", browseHost, "]")
+    }
 
     appUrl <- paste("http://", browseHost, ":", port, sep="")
     if (is.function(launch.browser))
@@ -798,12 +807,8 @@ runApp <- function(appDir=getwd(),
   # reactive(), Callbacks$invoke(), and others
   ..stacktraceoff..(
     captureStackTraces({
-      # If any observers were created before runApp was called, this will make
-      # sure they run once the app starts. (Issue #1013)
-      scheduleFlush()
-
       while (!.globals$stopped) {
-        serviceApp()
+        ..stacktracefloor..(serviceApp())
         Sys.sleep(0.001)
       }
     })

R/shiny.R

@@ -142,6 +142,15 @@ toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
 }
 
+# If the input to jsonlite::fromJSON is not valid JSON, it will try to fetch a
+# URL or read a file from disk. We don't want to allow that.
+safeFromJSON <- function(txt, ...) {
+  if (!jsonlite::validate(txt)) {
+    stop("Argument 'txt' is not a valid JSON string.")
+  }
+  jsonlite::fromJSON(txt, ...)
+}
+
 # Call the workerId func with no args to get the worker id, and with an arg to
 # set it.
 #
@@ -301,7 +310,8 @@ workerId <- local({
 #'   Similar to \code{sendCustomMessage}, but the message must be a raw vector
 #'   and the registration method on the client is
 #'   \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
-#'   message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
+#'   message argument on the client will be a
+#'   \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
 #' }
 #' \item{sendInputMessage(inputId, message)}{
 #'   Sends a message to an input on the session's client web page; if the input
@@ -411,6 +421,7 @@ ShinySession <- R6Class(
     invalidatedOutputValues = 'Map',
     invalidatedOutputErrors = 'Map',
     inputMessageQueue = list(), # A list of inputMessages to send when flushed
+    cycleStartActionQueue = list(), # A list of actions to perform to start a cycle
     .outputs = list(),          # Keeps track of all the output observer objects
     .outputOptions = list(),     # Options for each of the output observer objects
     progressKeys = 'character',
@@ -429,6 +440,7 @@ ShinySession <- R6Class(
     restoredCallbacks = 'Callbacks',
     bookmarkExclude = character(0),  # Names of inputs to exclude from bookmarking
     getBookmarkExcludeFuns = list(),
+    timingRecorder = 'ShinyServerTimingRecorder',
 
     testMode = FALSE,                # Are we running in test mode?
     testExportExprs = list(),
@@ -504,95 +516,6 @@ ShinySession <- R6Class(
       self$onSessionEnded(private$fileUploadContext$rmUploadDirs)
     },
 
-    createBookmarkObservers = function() {
-      # This is to be called from the initialization. It registers observers
-      # for bookmarking to work.
-
-      # Get bookmarking config
-      store <- getShinyOption("bookmarkStore", default = "disable")
-      if (store == "disable")
-        return()
-
-      # Warn if trying to enable save-to-server bookmarking on a version of SS,
-      # SSP, or Connect that doesn't support it.
-      if (store == "server" && inShinyServer() &&
-          is.null(getShinyOption("save.interface")))
-      {
-        showNotification(
-          "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
-          duration = NULL, type = "warning", session = self
-        )
-        return()
-      }
-
-      withReactiveDomain(self, {
-        # This observer fires when the bookmark button is clicked.
-        observeEvent(self$input[["._bookmark_"]], {
-          self$doBookmark()
-        })
-
-        # If there was an error initializing the current restore context, show
-        # notification in the client.
-        observe({
-          rc <- getCurrentRestoreContext()
-          if (!is.null(rc$initErrorMessage)) {
-            showNotification(
-              paste("Error in RestoreContext initialization:", rc$initErrorMessage),
-              duration = NULL, type = "error"
-            )
-          }
-        })
-
-        # Run the onRestore function at the beginning of the flush cycle, but after
-        # the server function has been executed.
-        observe({
-          if (private$restoreCallbacks$count() > 0) {
-            tryCatch(
-              withLogErrors(
-                isolate({
-                  rc <- getCurrentRestoreContext()
-                  if (rc$active) {
-                    restoreState <- getCurrentRestoreContext()$asList()
-                    private$restoreCallbacks$invoke(restoreState)
-                  }
-                })
-              ),
-              error = function(e) {
-                showNotification(
-                  paste0("Error calling onRestore callback: ", e$message),
-                  duration = NULL, type = "error"
-                )
-              }
-            )
-          }
-        }, priority = 1000000)
-
-        # Run the onRestored function after the flush cycle completes and information
-        # is sent to the client.
-        self$onFlushed(function() {
-          if (private$restoredCallbacks$count() > 0) {
-
-            tryCatch(
-              withLogErrors(
-                isolate({
-                  rc <- getCurrentRestoreContext()
-                  if (rc$active) {
-                    restoreState <- getCurrentRestoreContext()$asList()
-                    private$restoredCallbacks$invoke(restoreState)
-                  }
-                })
-              ),
-              error = function(e) {
-                msg <- paste0("Error calling onRestored callback: ", e$message)
-                showNotification(msg, duration = NULL, type = "error")
-              }
-            )
-          }
-        })
-
-      }) # withReactiveDomain
-    },
-
     # Modules (scopes) call this to register a function that returns a vector
     # of names to exclude from bookmarking. The function should return
     # something like c("scope1-x", "scope1-y"). This doesn't use a Callback
@@ -720,7 +643,7 @@ ShinySession <- R6Class(
           } else if (identical(format, "rds")) {
             tmpfile <- tempfile("shinytest", fileext = ".rds")
             saveRDS(values, tmpfile)
-            on.exit(unlink(tmpfile))
+            on.exit(unlink(tmpfile), add = TRUE)
 
             content <- readBin(tmpfile, "raw", n = file.info(tmpfile)$size)
             httpResponse(200, "application/octet-stream", content)
@@ -744,6 +667,15 @@ ShinySession <- R6Class(
     getSnapshotPreprocessInput = function(name) {
       fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess")
       fun %OR% identity
+    },
+
+    # See cycleStartAction
+    startCycle = function() {
+      if (length(private$cycleStartActionQueue) > 0) {
+        head <- private$cycleStartActionQueue[[1L]]
+        private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
+        head()
+      }
     }
   ),
   public = list(
@@ -774,8 +706,9 @@ ShinySession <- R6Class(
       private$flushCallbacks <- Callbacks$new()
       private$flushedCallbacks <- Callbacks$new()
       private$inputReceivedCallbacks <- Callbacks$new()
-      private$.input      <- ReactiveValues$new()
-      private$.clientData <- ReactiveValues$new()
+      private$.input      <- ReactiveValues$new(dedupe = FALSE)
+      private$.clientData <- ReactiveValues$new(dedupe = TRUE)
+      private$timingRecorder <- ShinyServerTimingRecorder$new()
       self$progressStack <- Stack$new()
       self$files <- Map$new()
       self$downloads <- Map$new()
@@ -796,7 +729,6 @@ ShinySession <- R6Class(
       private$bookmarkedCallbacks <- Callbacks$new()
       private$restoreCallbacks <- Callbacks$new()
       private$restoredCallbacks <- Callbacks$new()
-      private$createBookmarkObservers()
 
       private$testMode <- .globals$testMode
       private$enableTestSnapshot()
@@ -805,7 +737,7 @@ ShinySession <- R6Class(
 
       if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
         try({
-          creds <- jsonlite::fromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
+          creds <- safeFromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
           self$user <- creds$user
           self$groups <- creds$groups
         }, silent=FALSE)
@@ -824,6 +756,15 @@ ShinySession <- R6Class(
         )
       )
     },
+    startTiming = function(guid) {
+      if (!is.null(guid)) {
+        private$timingRecorder$start(guid)
+        self$onFlush(private$timingRecorder$stop)
+      }
+    },
+    requestFlush = function() {
+      appsNeedingFlush$set(self$token, self)
+    },
     rootScope = function() {
       self
     },
@@ -1020,8 +961,9 @@ ShinySession <- R6Class(
         stop("x must be a reactivevalues object")
 
       impl <- .subset2(x, 'impl')
-      impl$freeze(name)
-      self$onFlushed(function() impl$thaw(name))
+      key <- .subset2(x, 'ns')(name)
+      impl$freeze(key)
+      self$onFlushed(function() impl$thaw(key))
     },
 
     onSessionEnded = function(sessionEndedCallback) {
@@ -1055,8 +997,6 @@ ShinySession <- R6Class(
       }
       # ..stacktraceon matches with the top-level ..stacktraceoff..
       private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
-      flushReact()
-      flushAllSessions()
     },
     isClosed = function() {
       return(self$closed)
@@ -1085,9 +1025,16 @@ ShinySession <- R6Class(
       # name not working unless name was eagerly evaluated. Yikes!
       force(name)
 
-      # If overwriting an output object, suspend the previous copy of it
+      # If overwriting an output object, destroy the previous copy of it
       if (!is.null(private$.outputs[[name]])) {
-        private$.outputs[[name]]$suspend()
+        private$.outputs[[name]]$destroy()
+      }
+
+      if (is.null(func)) {
+        # If func is null, give it an "empty" output function so it can go
+        # through the logic below. If we simply returned at this point, the
+        # previous output (if any) would continue to show in the client.
+        func <- missingOutput
       }
 
       if (is.function(func)) {
@@ -1120,56 +1067,64 @@ ShinySession <- R6Class(
             name = name, status = 'recalculating'
           ))
 
-          value <- tryCatch(
-            shinyCallingHandlers(func()),
-            shiny.custom.error = function(cond) {
-              if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              structure(list(), class = "try-error", condition = cond)
-            },
-            shiny.output.cancel = function(cond) {
-              structure(list(), class = "cancel-output")
-            },
-            shiny.silent.error = function(cond) {
-              # Don't let shiny.silent.error go through the normal stop
-              # path of try, because we don't want it to print. But we
-              # do want to try to return the same looking result so that
-              # the code below can send the error to the browser.
-              structure(list(), class = "try-error", condition = cond)
-            },
-            error = function(cond) {
-              if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              if (getOption("shiny.sanitize.errors", FALSE)) {
-                cond <- simpleError(paste("An error has occurred. Check your",
-                                          "logs or contact the app author for",
-                                          "clarification."))
+          # This shinyCallingHandlers should maybe be at a higher level,
+          # to include the $then/$catch calls below?
+          hybrid_chain(
+            hybrid_chain(
+              shinyCallingHandlers(func()),
+              catch = function(cond) {
+                if (inherits(cond, "shiny.custom.error")) {
+                  if (isTRUE(getOption("show.error.messages"))) printError(cond)
+                  structure(list(), class = "try-error", condition = cond)
+                } else if (inherits(cond, "shiny.output.cancel")) {
+                  structure(list(), class = "cancel-output")
+                } else if (inherits(cond, "shiny.silent.error")) {
+                  # Don't let shiny.silent.error go through the normal stop
+                  # path of try, because we don't want it to print. But we
+                  # do want to try to return the same looking result so that
+                  # the code below can send the error to the browser.
+                  structure(list(), class = "try-error", condition = cond)
+                } else {
+                  if (isTRUE(getOption("show.error.messages"))) printError(cond)
+                  if (getOption("shiny.sanitize.errors", FALSE)) {
+                    cond <- simpleError(paste("An error has occurred. Check your",
+                      "logs or contact the app author for",
+                      "clarification."))
+                  }
+                  invisible(structure(list(), class = "try-error", condition = cond))
+                }
               }
-              invisible(structure(list(), class = "try-error", condition = cond))
-            },
-            finally = {
+            ),
+            function(value) {
+              # Needed so that Shiny knows to flush the outputs. Even if no
+              # outputs/errors are queued, it's necessary to flush so that the
+              # client knows that progress is over.
+              self$requestFlush()
+
               private$sendMessage(recalculating = list(
                 name = name, status = 'recalculated'
               ))
+
+              if (inherits(value, "cancel-output")) {
+                return()
+              }
+
+              private$invalidatedOutputErrors$remove(name)
+              private$invalidatedOutputValues$remove(name)
+
+              if (inherits(value, 'try-error')) {
+                cond <- attr(value, 'condition')
+                type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
+                private$invalidatedOutputErrors$set(
+                  name,
+                  list(message = cond$message,
+                    call = utils::capture.output(print(cond$call)),
+                    type = if (length(type)) type))
+              }
+              else
+                private$invalidatedOutputValues$set(name, value)
             }
           )
-
-          if (inherits(value, "cancel-output")) {
-            return()
-          }
-
-          private$invalidatedOutputErrors$remove(name)
-          private$invalidatedOutputValues$remove(name)
-
-          if (inherits(value, 'try-error')) {
-            cond <- attr(value, 'condition')
-            type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
-            private$invalidatedOutputErrors$set(
-              name,
-              list(message = cond$message,
-                   call = utils::capture.output(print(cond$call)),
-                   type = if (length(type)) type))
-          }
-          else
-            private$invalidatedOutputValues$set(name, value)
         }, suspended=private$shouldSuspend(name), label=label)
 
         # If any output attributes were added to the render function attach
@@ -1191,6 +1146,11 @@ ShinySession <- R6Class(
       }
     },
     flushOutput = function() {
+      if (private$busyCount > 0)
+        return()
+
+      appsNeedingFlush$remove(self$token)
+
       if (self$isClosed())
         return()
 
@@ -1208,49 +1168,59 @@ ShinySession <- R6Class(
         )
       }
 
-      # ..stacktraceon matches with the top-level ..stacktraceoff..
-      private$flushCallbacks$invoke(..stacktraceon = TRUE)
-
-      # Schedule execution of onFlushed callbacks
-      on.exit({
+      withReactiveDomain(self, {
         # ..stacktraceon matches with the top-level ..stacktraceoff..
-        private$flushedCallbacks$invoke(..stacktraceon = TRUE)
+        private$flushCallbacks$invoke(..stacktraceon = TRUE)
 
-        # If one of the flushedCallbacks added anything to send to the client,
-        # or invalidated any observers, set up another flush cycle.
-        if (hasPendingUpdates() || .getReactiveEnvironment()$hasPendingFlush()) {
-          scheduleFlush()
+        # Schedule execution of onFlushed callbacks
+        on.exit({
+          withReactiveDomain(self, {
+            # ..stacktraceon matches with the top-level ..stacktraceoff..
+            private$flushedCallbacks$invoke(..stacktraceon = TRUE)
+          })
+        }, add = TRUE)
+
+        if (!hasPendingUpdates()) {
+          # Normally, if there are no updates, simply return without sending
+          # anything to the client. But if we are in test mode, we still want to
+          # send a message with blank `values`, so that the client knows that
+          # any changed inputs have been received by the server and processed.
+          if (isTRUE(private$testMode)) {
+            private$sendMessage( values = list() )
+          }
+          return(invisible())
         }
-      })
 
-      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.
+        private$progressKeys <- character(0)
+        values <- as.list(private$invalidatedOutputValues)
+        private$invalidatedOutputValues <- Map$new()
+        errors <- as.list(private$invalidatedOutputErrors)
+        private$invalidatedOutputErrors <- Map$new()
+        inputMessages <- private$inputMessageQueue
+        private$inputMessageQueue <- list()
+
         if (isTRUE(private$testMode)) {
-          private$sendMessage( values = list() )
+          private$storeOutputValues(mergeVectors(values, errors))
         }
-        return(invisible())
+
+        private$sendMessage(
+          errors = errors,
+          values = values,
+          inputMessages = inputMessages
+        )
+      })
+    },
+    # Schedule an action to execute not (necessarily) now, but when no observers
+    # that belong to this session are busy executing. This helps prevent (but
+    # does not guarantee) inputs and reactive values from changing underneath
+    # async observers as they run.
+    cycleStartAction = function(callback) {
+      private$cycleStartActionQueue <- c(private$cycleStartActionQueue, list(callback))
+      # If no observers are running in this session, we're safe to proceed.
+      # Otherwise, startCycle() will be called later, via decrementBusyCount().
+      if (private$busyCount == 0L) {
+        private$startCycle()
       }
-
-      private$progressKeys <- character(0)
-      values <- as.list(private$invalidatedOutputValues)
-      private$invalidatedOutputValues <- Map$new()
-      errors <- as.list(private$invalidatedOutputErrors)
-      private$invalidatedOutputErrors <- Map$new()
-      inputMessages <- private$inputMessageQueue
-      private$inputMessageQueue <- list()
-
-      if (isTRUE(private$testMode)) {
-        private$storeOutputValues(mergeVectors(values, errors))
-      }
-
-      private$sendMessage(
-        errors = errors,
-        values = values,
-        inputMessages = inputMessages
-      )
     },
     showProgress = function(id) {
       'Send a message to the client that recalculation of the output identified
@@ -1318,6 +1288,8 @@ ShinySession <- R6Class(
 
       # Add to input message queue
       private$inputMessageQueue[[length(private$inputMessageQueue) + 1]] <- data
+      # Needed so that Shiny knows to actually flush the input message queue
+      self$requestFlush()
     },
     onFlush = function(flushCallback, once = TRUE) {
       if (!isTRUE(once)) {
@@ -1342,6 +1314,94 @@ ShinySession <- R6Class(
       }
     },
 
+    createBookmarkObservers = function() {
+      # This registers observers for bookmarking to work.
+
+      # Get bookmarking config
+      store <- getShinyOption("bookmarkStore", default = "disable")
+      if (store == "disable")
+        return()
+
+      # Warn if trying to enable save-to-server bookmarking on a version of SS,
+      # SSP, or Connect that doesn't support it.
+      if (store == "server" && inShinyServer() &&
+          is.null(getShinyOption("save.interface")))
+      {
+        showNotification(
+          "This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
+          duration = NULL, type = "warning", session = self
+        )
+        return()
+      }
+
+      withReactiveDomain(self, {
+        # This observer fires when the bookmark button is clicked.
+        observeEvent(self$input[["._bookmark_"]], {
+          self$doBookmark()
+        })
+
+        # If there was an error initializing the current restore context, show
+        # notification in the client.
+        observe({
+          rc <- getCurrentRestoreContext()
+          if (!is.null(rc$initErrorMessage)) {
+            showNotification(
+              paste("Error in RestoreContext initialization:", rc$initErrorMessage),
+              duration = NULL, type = "error"
+            )
+          }
+        })
+
+        # Run the onRestore function at the beginning of the flush cycle, but after
+        # the server function has been executed.
+        observe({
+          if (private$restoreCallbacks$count() > 0) {
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoreCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                showNotification(
+                  paste0("Error calling onRestore callback: ", e$message),
+                  duration = NULL, type = "error"
+                )
+              }
+            )
+          }
+        }, priority = 1000000)
+
+        # Run the onRestored function after the flush cycle completes and information
+        # is sent to the client.
+        self$onFlushed(function() {
+          if (private$restoredCallbacks$count() > 0) {
+
+            tryCatch(
+              withLogErrors(
+                isolate({
+                  rc <- getCurrentRestoreContext()
+                  if (rc$active) {
+                    restoreState <- getCurrentRestoreContext()$asList()
+                    private$restoredCallbacks$invoke(restoreState)
+                  }
+                })
+              ),
+              error = function(e) {
+                msg <- paste0("Error calling onRestored callback: ", e$message)
+                showNotification(msg, duration = NULL, type = "error")
+              }
+            )
+          }
+        })
+
+      }) # withReactiveDomain
+    },
+
     setBookmarkExclude = function(names) {
       private$bookmarkExclude <- names
     },
@@ -1688,32 +1748,44 @@ ShinySession <- R6Class(
         if (nzchar(ext))
           ext <- paste(".", ext, sep = "")
         tmpdata <- tempfile(fileext = ext)
-        # ..stacktraceon matches with the top-level ..stacktraceoff..
-        result <- try(shinyCallingHandlers(Context$new(getDefaultReactiveDomain(), '[download]')$run(
-          function() { ..stacktraceon..(download$func(tmpdata)) }
-        )), silent = TRUE)
-        if (inherits(result, 'try-error')) {
-          unlink(tmpdata)
-          stop(attr(result, "condition", exact = TRUE))
-        }
-        if (!file.exists(tmpdata)) {
-          # If no file was created, return a 404
-          return(httpResponse(404, content = "404 Not found"))
-        }
-        return(httpResponse(
-          200,
-          download$contentType %OR% getContentType(filename),
-          # owned=TRUE means tmpdata will be deleted after response completes
-          list(file=tmpdata, owned=TRUE),
-          c(
-            'Content-Disposition' = ifelse(
-              dlmatches[3] == '',
-              'attachment; filename="' %.%
-                gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
-                '"',
-              'attachment'
-            ),
-            'Cache-Control'='no-cache')))
+        return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
+          promises::with_promise_domain(reactivePromiseDomain(), {
+            promises::with_promise_domain(createStackTracePromiseDomain(), {
+              self$incrementBusyCount()
+              hybrid_chain(
+                # ..stacktraceon matches with the top-level ..stacktraceoff..
+                try(..stacktraceon..(download$func(tmpdata)), silent = TRUE),
+                function(result) {
+                  if (inherits(result, 'try-error')) {
+                    unlink(tmpdata)
+                    stop(attr(result, "condition", exact = TRUE))
+                  }
+                  if (!file.exists(tmpdata)) {
+                    # If no file was created, return a 404
+                    return(httpResponse(404, content = "404 Not found"))
+                  }
+                  return(httpResponse(
+                    200,
+                    download$contentType %OR% getContentType(filename),
+                    # owned=TRUE means tmpdata will be deleted after response completes
+                    list(file=tmpdata, owned=TRUE),
+                    c(
+                      'Content-Disposition' = ifelse(
+                        dlmatches[3] == '',
+                        'attachment; filename="' %.%
+                          gsub('(["\\\\])', '\\\\\\1', filename) %.%  # yes, that many \'s
+                          '"',
+                        'attachment'
+                      ),
+                      'Cache-Control'='no-cache')))
+                },
+                finally = function() {
+                  self$decrementBusyCount()
+                }
+              )
+            })
+          })
+        }))
       }
 
       if (matches[2] == 'dataobj') {
@@ -1778,9 +1850,13 @@ ShinySession <- R6Class(
     },
     # This function suspends observers for hidden outputs and resumes observers
     # for un-hidden outputs.
-    manageHiddenOutputs = function() {
+    manageHiddenOutputs = function(outputsToCheck = NULL) {
+      if (is.null(outputsToCheck)) {
+        outputsToCheck <- names(private$.outputs)
+      }
+
       # Find hidden state for each output, and suspend/resume accordingly
-      for (outputName in names(private$.outputs)) {
+      for (outputName in outputsToCheck) {
         if (private$shouldSuspend(outputName)) {
           private$.outputs[[outputName]]$suspend()
         } else {
@@ -1788,24 +1864,39 @@ ShinySession <- R6Class(
         }
       }
     },
-    # Set the normal and client data input variables
-    manageInputs = function(data) {
+    # Set the normal and client data input variables. Normally, managing
+    # inputs doesn't take immediate effect when there are observers that
+    # are pending execution or currently executing (including having
+    # started async operations that have yielded control, but not yet
+    # completed). The `now` argument can force this. It should generally
+    # not be used, but we're adding it to get around a show-stopping bug
+    # for Shiny v1.1 (see the call site for more details).
+    manageInputs = function(data, now = FALSE) {
+      force(data)
+      doManageInputs <- function() {
+        private$inputReceivedCallbacks$invoke(data)
 
-      private$inputReceivedCallbacks$invoke(data)
+        data_names <- names(data)
 
-      data_names <- names(data)
+        # Separate normal input variables from client data input variables
+        clientdata_idx <- grepl("^.clientdata_", data_names)
 
-      # Separate normal input variables from client data input variables
-      clientdata_idx <- grepl("^.clientdata_", data_names)
+        # Set normal (non-clientData) input values
+        private$.input$mset(data[data_names[!clientdata_idx]])
 
-      # Set normal (non-clientData) input values
-      private$.input$mset(data[data_names[!clientdata_idx]])
+        # Strip off .clientdata_ from clientdata input names, and set values
+        input_clientdata <- data[data_names[clientdata_idx]]
+        names(input_clientdata) <- sub("^.clientdata_", "",
+          names(input_clientdata))
+        private$.clientData$mset(input_clientdata)
 
-      # Strip off .clientdata_ from clientdata input names, and set values
-      input_clientdata <- data[data_names[clientdata_idx]]
-      names(input_clientdata) <- sub("^.clientdata_", "",
-                                     names(input_clientdata))
-      private$.clientData$mset(input_clientdata)
+        self$manageHiddenOutputs()
+      }
+      if (isTRUE(now)) {
+        doManageInputs()
+      } else {
+        self$cycleStartAction(doManageInputs)
+      }
     },
     outputOptions = function(name, ...) {
       # If no name supplied, return the list of options for all outputs
@@ -1830,7 +1921,7 @@ ShinySession <- R6Class(
 
       # If any changes to suspendWhenHidden, need to re-run manageHiddenOutputs
       if ("suspendWhenHidden" %in% names(opts)) {
-        self$manageHiddenOutputs()
+        self$manageHiddenOutputs(name)
       }
 
       if ("priority" %in% names(opts)) {
@@ -1849,6 +1940,19 @@ ShinySession <- R6Class(
       private$busyCount <- private$busyCount - 1L
       if (private$busyCount == 0L) {
         private$sendMessage(busy = "idle")
+        self$requestFlush()
+        # We defer the call to startCycle() using later(), to defend against
+        # cycles where we continually call startCycle which causes an observer
+        # to fire which calls startCycle which causes an observer to fire...
+        #
+        # It's OK for these cycles to occur, but we must return control to the
+        # event loop between iterations (or at least sometimes) in order to not
+        # make the whole Shiny app go unresponsive.
+        later::later(function() {
+          if (private$busyCount == 0L) {
+            private$startCycle()
+          }
+        })
       }
     }
   ),
@@ -1993,12 +2097,8 @@ onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
 }
 
 
-scheduleFlush <- function() {
-  timerCallbacks$schedule(0, function() {})
-}
-
-flushAllSessions <- function() {
-  lapply(appsByToken$values(), function(shinysession) {
+flushPendingSessions <- function() {
+  lapply(appsNeedingFlush$values(), function(shinysession) {
     tryCatch(
       shinysession$flushOutput(),
 
@@ -2094,3 +2194,48 @@ onStop <- function(fun, session = getDefaultReactiveDomain()) {
     return(session$onSessionEnded(fun))
   }
 }
+
+# Helper class for emitting log messages to stdout that will be interpreted by
+# a Shiny Server parent process. The duration it's trying to record is the time
+# between a websocket message being received, and the next flush to the client.
+ShinyServerTimingRecorder <- R6Class("ShinyServerTimingRecorder",
+  cloneable = FALSE,
+  public = list(
+    initialize = function() {
+      private$shiny_stdout <- if (exists(".shiny__stdout", globalenv()))
+        get(".shiny__stdout", globalenv())
+      else
+        NULL
+      private$guid <- NULL
+    },
+    start = function(guid) {
+      if (is.null(private$shiny_stdout)) return()
+
+      private$guid <- guid
+      if (!is.null(guid)) {
+        private$write("n")
+      }
+    },
+    stop = function() {
+      if (is.null(private$shiny_stdout)) return()
+
+      if (!is.null(private$guid)) {
+        private$write("x")
+        private$guid <- NULL
+      }
+    }
+  ),
+  private = list(
+    shiny_stdout = NULL,
+    guid = character(),
+    write = function(code) {
+      # eNter or eXit a flushReact
+      writeLines(paste("_", code, "_flushReact ", private$guid,
+        " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+        sep=""), con=private$shiny_stdout)
+      flush(private$shiny_stdout)
+    }
+  )
+)
+
+missingOutput <- function(...) req(FALSE)

R/shinywrappers.R

@@ -1,4 +1,4 @@
-globalVariables('func')
+utils::globalVariables('func')
 
 #' Mark a function as a render function
 #'
@@ -52,6 +52,49 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
             hasExecuted = hasExecuted)
 }
 
+#' Implement render functions
+#'
+#' @param func A function without parameters, that returns user data. If the
+#'   returned value is a promise, then the render function will proceed in async
+#'   mode.
+#' @param transform A function that takes four arguments: \code{value},
+#'   \code{session}, \code{name}, and \code{...} (for future-proofing). This
+#'   function will be invoked each time a value is returned from \code{func},
+#'   and is responsible for changing the value into a JSON-ready value to be
+#'   JSON-encoded and sent to the browser.
+#' @param outputFunc The UI function that is used (or most commonly used) with
+#'   this render function. This can be used in R Markdown documents to create
+#'   complete output widgets out of just the render function.
+#' @param outputArgs A list of arguments to pass to the \code{outputFunc}.
+#'   Render functions should include \code{outputArgs = list()} in their own
+#'   parameter list, and pass through the value as this argument, to allow app
+#'   authors to customize outputs. (Currently, this is only supported for
+#'   dynamically generated UIs, such as those created by Shiny code snippets
+#'   embedded in R Markdown documents).
+#' @return An annotated render function, ready to be assigned to an
+#'   \code{output} slot.
+#'
+#' @export
+createRenderFunction <- function(
+  func, transform = function(value, session, name, ...) value,
+  outputFunc = NULL, outputArgs = NULL
+) {
+
+  renderFunc <- function(shinysession, name, ...) {
+    hybrid_chain(
+      func(),
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
+      }
+    )
+  }
+
+  if (!is.null(outputFunc))
+    markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+  else
+    renderFunc
+}
+
 useRenderFunction <- function(renderFunc, inline = FALSE) {
   outputFunction <- attr(renderFunc, "outputFunc")
   outputArgs <- attr(renderFunc, "outputArgs")
@@ -68,12 +111,16 @@ useRenderFunction <- function(renderFunc, inline = FALSE) {
   }
 
   id <- createUniqueId(8, "out")
-  # Make the id the first positional argument
-  outputArgs <- c(list(id), outputArgs)
 
   o <- getDefaultReactiveDomain()$output
-  if (!is.null(o))
+  if (!is.null(o)) {
     o[[id]] <- renderFunc
+    # If there's a namespace, we must respect it
+    id <- getDefaultReactiveDomain()$ns(id)
+  }
+
+  # Make the id the first positional argument
+  outputArgs <- c(list(id), outputArgs)
 
   if (is.logical(formals(outputFunction)[["inline"]]) && !("inline" %in% names(outputArgs))) {
     outputArgs[["inline"]] <- inline
@@ -222,26 +269,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
                         deleteFile=TRUE, outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    imageinfo <- func()
-    # Should the file be deleted after being sent? If .deleteFile not set or if
-    # TRUE, then delete; otherwise don't delete.
-    if (deleteFile) {
-      on.exit(unlink(imageinfo$src))
-    }
+  createRenderFunction(func,
+    transform = function(imageinfo, session, name, ...) {
+      # Should the file be deleted after being sent? If .deleteFile not set or if
+      # TRUE, then delete; otherwise don't delete.
+      if (deleteFile) {
+        on.exit(unlink(imageinfo$src))
+      }
 
-    # If contentType not specified, autodetect based on extension
-    contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
+      # If contentType not specified, autodetect based on extension
+      contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
 
-    # Extra values are everything in imageinfo except 'src' and 'contentType'
-    extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
+      # Extra values are everything in imageinfo except 'src' and 'contentType'
+      extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
 
-    # Return a list with src, and other img attributes
-    c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
-      extra_attr)
-  }
-
-  markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
+      # Return a list with src, and other img attributes
+      c(src = session$fileUrl(name, file=imageinfo$src, contentType=contentType),
+        extra_attr)
+    },
+    imageOutput, outputArgs)
 }
 
 
@@ -281,15 +327,74 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
                         width = getOption('width'), outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
+  # Set a promise domain that sets the console width
+  #   and captures output
+  # op <- options(width = width)
+  # on.exit(options(op), add = TRUE)
+
   renderFunc <- function(shinysession, name, ...) {
-    op <- options(width = width)
-    on.exit(options(op), add = TRUE)
-    paste(utils::capture.output(func()), collapse = "\n")
+    domain <- createRenderPrintPromiseDomain(width)
+    hybrid_chain(
+      {
+        promises::with_promise_domain(domain, func())
+      },
+      function(value, .visible) {
+        if (.visible) {
+          cat(file = domain$conn, paste(utils::capture.output(value, append = TRUE), collapse = "\n"))
+        }
+        res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+        res
+      },
+      finally = function() {
+        close(domain$conn)
+      }
+    )
   }
 
   markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
 }
 
+createRenderPrintPromiseDomain <- function(width) {
+  f <- file()
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(...) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
+
+        sink(f, append = TRUE)
+        on.exit(sink(NULL), add = TRUE)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      op <- options(width = width)
+      on.exit(options(op), add = TRUE)
+
+      sink(f, append = TRUE)
+      on.exit(sink(NULL), add = TRUE)
+
+      force(expr)
+    },
+    conn = f
+  )
+}
+
 #' Text Output
 #'
 #' Makes a reactive version of the given function that also uses
@@ -321,18 +426,18 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
                        outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    value <- func()
-    return(paste(utils::capture.output(cat(value)), collapse="\n"))
-  }
-
-  markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
+  createRenderFunction(
+    func,
+    function(value, session, name, ...) {
+      paste(utils::capture.output(cat(value)), collapse="\n")
+    },
+    textOutput, outputArgs
+  )
 }
 
 #' UI Output
 #'
-#' \bold{Experimental feature.} Makes a reactive version of a function that
-#' generates HTML using the Shiny UI library.
+#' Renders reactive HTML using the Shiny UI library.
 #'
 #' The corresponding HTML output tag should be \code{div} and have the CSS class
 #' name \code{shiny-html-output} (or use \code{\link{uiOutput}}).
@@ -346,7 +451,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso conditionalPanel
+#' @seealso \code{\link{uiOutput}}
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -371,15 +476,16 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
                      outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    result <- func()
-    if (is.null(result) || length(result) == 0)
-      return(NULL)
+  createRenderFunction(
+    func,
+    function(result, shinysession, name, ...) {
+      if (is.null(result) || length(result) == 0)
+        return(NULL)
 
-    processDeps(result, shinysession)
-  }
-
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads
@@ -517,27 +623,31 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
     if (is.function(options)) options <- options()
     options <- checkDT9(options)
     res <- checkAsIs(options)
-    data <- func()
-    if (length(dim(data)) != 2) return() # expects a rectangular data object
-    if (is.data.frame(data)) data <- as.data.frame(data)
-    action <- shinysession$registerDataObj(name, data, dataTablesJSON)
-    colnames <- colnames(data)
-    # if escape is column names, turn names to numeric indices
-    if (is.character(escape)) {
-      escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
-      if (any(is.na(escape)))
-        stop("Some column names in the 'escape' argument not found in data")
-    }
-    colnames[escape] <- htmlEscape(colnames[escape])
-    if (!is.logical(escape)) {
-      if (!is.numeric(escape))
-        stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
-      escape <- paste(escape, collapse = ',')
-    }
-    list(
-      colnames = colnames, action = action, options = res$options,
-      evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
-      callback = paste(callback, collapse = '\n'), escape = escape
+    hybrid_chain(
+      func(),
+      function(data) {
+        if (length(dim(data)) != 2) return() # expects a rectangular data object
+        if (is.data.frame(data)) data <- as.data.frame(data)
+        action <- shinysession$registerDataObj(name, data, dataTablesJSON)
+        colnames <- colnames(data)
+        # if escape is column names, turn names to numeric indices
+        if (is.character(escape)) {
+          escape <- stats::setNames(seq_len(ncol(data)), colnames)[escape]
+          if (any(is.na(escape)))
+            stop("Some column names in the 'escape' argument not found in data")
+        }
+        colnames[escape] <- htmlEscape(colnames[escape])
+        if (!is.logical(escape)) {
+          if (!is.numeric(escape))
+            stop("'escape' must be TRUE, FALSE, or a numeric vector, or column names")
+          escape <- paste(escape, collapse = ',')
+        }
+        list(
+          colnames = colnames, action = action, options = res$options,
+          evalOptions = if (length(res$eval)) I(res$eval), searchDelay = searchDelay,
+          callback = paste(callback, collapse = '\n'), escape = escape
+        )
+      }
     )
   }
 

R/timer.R

@@ -42,6 +42,17 @@ TimerCallbacks <- R6Class(
 
       return(id)
     },
+    unschedule = function(id) {
+      toRemoveIndices <- .times$id %in% id
+      toRemoveIds <- .times[toRemoveIndices, "id", drop = TRUE]
+      if (length(toRemoveIds) > 0) {
+        .times <<- .times[!toRemoveIndices,]
+        for (toRemoveId in as.character(toRemoveIds)) {
+          .funcs$remove(toRemoveId)
+        }
+      }
+      return(id %in% toRemoveIds)
+    },
     timeToNextEvent = function() {
       if (dim(.times)[1] == 0)
         return(Inf)
@@ -79,13 +90,9 @@ timerCallbacks <- TimerCallbacks$new()
 
 scheduleTask <- function(millis, callback) {
   cancelled <- FALSE
-  timerCallbacks$schedule(millis, function() {
-    if (!cancelled)
-      callback()
-  })
+  id <- timerCallbacks$schedule(millis, callback)
 
   function() {
-    cancelled <<- TRUE
-    callback <<- NULL # to allow for callback to be gc'ed
+    invisible(timerCallbacks$unschedule(id))
   }
 }

R/update-input.R

@@ -383,13 +383,17 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
   session$sendInputMessage(inputId, message)
 }
 
-#' Change the value of a slider input on the client
+#' Update Slider Input Widget
+#'
+#' Change the value of a slider input on the client.
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
 #' @param min Minimum value.
 #' @param max Maximum value.
 #' @param step Step size.
+#' @param timeFormat Date and POSIXt formatting.
+#' @param timezone The timezone offset for POSIXt objects.
 #'
 #' @seealso \code{\link{sliderInput}}
 #'
@@ -422,22 +426,15 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' }
 #' @export
 updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL)
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
-  # Make sure that value, min, max all have the same type, because we need
-  # special handling for dates and datetimes.
-  vals <- dropNulls(list(value, min, max))
+  dataType <- getSliderType(min, max, value)
 
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    stop("Type mismatch for value, min, and max")
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if ((length(type) == 1) && (type == "date" || type == "datetime")) {
+  if (dataType == "date" || dataType == "datetime") {
     to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
     if (!is.null(min))   min   <- to_ms(min)
     if (!is.null(max))   max   <- to_ms(max)
@@ -449,7 +446,10 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
-    step = formatNoSci(step)
+    step = formatNoSci(step),
+    `data-type` = dataType,
+    `time-format` = timeFormat,
+    timezone = timezone
   ))
   session$sendInputMessage(inputId, message)
 }
@@ -576,7 +576,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}}
+#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -642,8 +642,86 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   if (!server) {
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
+
+  noOptGroup <- TRUE
+  if (is.list(choices)) {
+    # check if list is nested
+    for (i in seq_along(choices)) {
+      if (is.list(choices[[i]]) || length(choices[[i]]) > 1) {
+        noOptGroup <- FALSE
+        break()
+      }
+    }
+  }
+  # convert choices to a data frame so it returns [{label: , value: , group: },...]
+  choices <- if (is.atomic(choices) || noOptGroup) {
+    # fast path for vectors and flat lists
+    if (is.list(choices)) {
+      choices <- unlist(choices)
+    }
+    if (is.null(names(choices))) {
+      lab <- as.character(choices)
+    } else {
+      lab <- names(choices)
+      # replace empty names like: choices = c(a = 1, 2)
+      # in this case: names(choices) = c("a", "")
+      # with replacement below choices will be: lab = c("a", "2")
+      empty_names_indices <- lab == ""
+      lab[empty_names_indices] <- as.character(choices[empty_names_indices])
+    }
+    data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
+  } else {
+    # slow path for nested lists/optgroups
+    list_names <- names(choices)
+    if (is.null(list_names)) {
+      list_names <- rep("", length(choices))
+    }
+
+    choice_list <- mapply(choices, list_names, FUN = function (choice, name) {
+      group <- ""
+      lab <- name
+      if (lab == "") lab <- as.character(choice)
+
+      if (is.list(choice) || length(choice) > 1) {
+        group <- rep(name, length(choice))
+        choice <- unlist(choice)
+
+        if (is.null(names(choice))) {
+          lab <- as.character(choice)
+        } else {
+          lab <- names(choice)
+          # replace empty names like: choices = c(a = 1, 2)
+          # in this case: names(choices) = c("a", "")
+          # with replacement below choices will be: lab = c("a", "2")
+          empty_names_indices <- lab == ""
+          lab[empty_names_indices] <- as.character(choice[empty_names_indices])
+        }
+      }
+
+      list(
+        label = lab,
+        value = as.character(choice),
+        group = group
+      )
+    }, SIMPLIFY = FALSE)
+
+
+    extract_vector <- function(x, name) {
+      vecs <- lapply(x, `[[`, name)
+      do.call(c, vecs)
+    }
+
+    data.frame(
+      label = extract_vector(choice_list, "label"),
+      value = extract_vector(choice_list, "value"),
+      group = extract_vector(choice_list, "group"),
+      stringsAsFactors = FALSE, row.names = NULL
+    )
+  }
+
   value <- unname(selected)
   attr(choices, 'selected_value') <- value
+
   message <- dropNulls(list(
     label = label,
     value = value,
@@ -651,38 +729,76 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   ))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateSelectInput
+#' @inheritParams varSelectInput
+#' @export
+updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected
+  )
+}
+#' @rdname updateSelectInput
+#' @export
+updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectizeInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    options = options,
+    server = server
+  )
+}
+
+
 
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)
+
   # extract the query variables, conjunction (and/or), search string, maximum options
-  var <- c(jsonlite::fromJSON(query$field))
-  cjn <- if (query$conju == 'and') all else any
+  var <- c(safeFromJSON(query$field))
+
   # all keywords in lower-case, for case-insensitive matching
   key <- unique(strsplit(tolower(query$query), '\\s+')[[1]])
+
   if (identical(key, '')) key <- character(0)
   mop <- as.numeric(query$maxop)
   vfd <- query$value  # the value field name
   sel <- attr(data, 'selected_value', exact = TRUE)
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # later in JSON; other objects return arbitrary JSON {x: , y: , foo: , ...}
-  data <- if (is.atomic(data)) {
-    data.frame(label = names(choicesWithNames(data)), value = data,
-               stringsAsFactors = FALSE)
-  } else as.data.frame(data, stringsAsFactors = FALSE)
-
   # start searching for keywords in all specified columns
   idx <- logical(nrow(data))
-  if (length(key)) for (v in var) {
-    matches <- do.call(
-      cbind,
-      lapply(key, function(k) {
-        grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
-      })
-    )
-    # merge column matches using OR, and match multiple keywords in one column
-    # using the conjunction setting (AND or OR)
-    idx <- idx | apply(matches, 1, cjn)
+  if (length(key)) {
+    for (v in var) {
+      matches <- do.call(
+        cbind,
+        lapply(key, function(k) {
+          grepl(k, tolower(as.character(data[[v]])), fixed = TRUE)
+        })
+      )
+      # merge column matches using OR, and match multiple keywords in one column
+      # using the conjunction setting (AND or OR)
+      matches <- rowSums(matches)
+      if (query$conju == 'and')
+        idx <- idx | (matches == length(key))
+      else
+        idx <- idx | matches
+    }
   }
   # only return the first n rows (n = maximum options in configuration)
   idx <- utils::head(if (length(key)) which(idx) else seq_along(idx), mop)

R/utils.R

@@ -1532,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)
@@ -1578,3 +1581,143 @@ Mutable <- R6Class("Mutable",
     get = function() { private$value }
   )
 )
+
+# More convenient way of chaining together promises than then/catch/finally,
+# without the performance impact of %...>%.
+promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    p <- Reduce(function(memo, func) {
+      promises::then(memo, func)
+    }, list(...), promise)
+
+    if (!is.null(catch)) {
+      p <- promises::catch(p, catch)
+    }
+
+    if (!is.null(finally)) {
+      p <- promises::finally(p, finally)
+    }
+
+    p
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`,
+# and `finally` are all executed synchronously
+hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
+  domain = NULL, replace = FALSE) {
+
+  do <- function() {
+    runFinally <- TRUE
+    tryCatch(
+      {
+        captureStackTraces({
+          result <- withVisible(force(expr))
+          if (promises::is.promising(result$value)) {
+            # Purposefully NOT including domain (nor replace), as we're already in
+            # the domain at this point
+            p <- promise_chain(setVisible(result), ..., catch = catch, finally = finally)
+            runFinally <- FALSE
+            p
+          } else {
+            result <- Reduce(function(v, func) {
+              if (".visible" %in% names(formals(func))) {
+                withVisible(func(v$value, .visible = v$visible))
+              } else {
+                withVisible(func(v$value))
+              }
+            }, list(...), result)
+
+            setVisible(result)
+          }
+        })
+      },
+      error = function(e) {
+        if (!is.null(catch))
+          catch(e)
+        else
+          stop(e)
+      },
+      finally = if (runFinally && !is.null(finally)) finally()
+    )
+  }
+
+  if (!is.null(domain)) {
+    promises::with_promise_domain(domain, do(), replace = replace)
+  } else {
+    do()
+  }
+}
+
+# Returns `value` with either `invisible()` applied or not, depending on the
+# value of `visible`.
+#
+# If the `visible` is missing, then `value` should be a list as returned from
+# `withVisible()`, and that visibility will be applied.
+setVisible <- function(value, visible) {
+  if (missing(visible)) {
+    visible <- value$visible
+    value <- value$value
+  }
+
+  if (!visible) {
+    invisible(value)
+  } else {
+    (value)
+  }
+}
+
+createVarPromiseDomain <- function(env, name, value) {
+  force(env)
+  force(name)
+  force(value)
+
+  promises::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onFulfilled(...)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      function(...) {
+        orig <- env[[name]]
+        env[[name]] <- value
+        on.exit(env[[name]] <- orig)
+
+        onRejected(...)
+      }
+    },
+    wrapSync = function(expr) {
+      orig <- env[[name]]
+      env[[name]] <- value
+      on.exit(env[[name]] <- orig)
+
+      force(expr)
+    }
+  )
+}
+
+getSliderType <- function(min, max, value) {
+  vals <- dropNulls(list(value, min, max))
+  type <- unique(lapply(vals, function(x) {
+    if      (inherits(x, "Date"))   "date"
+    else if (inherits(x, "POSIXt")) "datetime"
+    else                            "number"
+  }))
+  if (length(type) > 1) {
+    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
+  }
+  type[[1]]
+}

README.md

@@ -8,6 +8,8 @@ Shiny is a new package from RStudio that makes it incredibly easy to build inter
 
 For an introduction and examples, visit the [Shiny Dev Center](http://shiny.rstudio.com/).
 
+If you have general questions about using Shiny, please use the [RStudio Community website](https://community.rstudio.com). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
+
 ## Features
 
 * Build useful web applications with only a few lines of code—no JavaScript required.
@@ -41,8 +43,6 @@ devtools::install_github("rstudio/shiny")
 
 To learn more we highly recommend you check out the [Shiny Tutorial](http://shiny.rstudio.com/tutorial/). The tutorial explains the framework in-depth, walks you through building a simple application, and includes extensive annotated examples.
 
-We hope you enjoy using Shiny. If you have general questions about using Shiny, please use the Shiny [mailing list](https://groups.google.com/forum/#!forum/shiny-discuss). For bug reports, please use the [issue tracker](https://github.com/rstudio/shiny/issues).
-
 ## Bootstrap 3 migration
 
 Shiny versions 0.10.2.2 and below used the Bootstrap 2 web framework. After 0.10.2.2, Shiny switched to Bootstrap 3. For most users, the upgrade should be seamless. However, if you have have customized your HTML-generating code to use features specific to Bootstrap 2, you may need to update your code to work with Bootstrap 3.

TODO-promises.md

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

appveyor.yml

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

inst/staticdocs/index.r

@@ -41,6 +41,7 @@ sd_section("UI Inputs",
     "numericInput",
     "radioButtons",
     "selectInput",
+    "varSelectInput",
     "sliderInput",
     "submitButton",
     "textInput",
@@ -115,7 +116,8 @@ sd_section("Rendering functions",
     "reactivePrint",
     "reactiveTable",
     "reactiveText",
-    "reactiveUI"
+    "reactiveUI",
+    "createRenderFunction"
   )
 )
 sd_section("Reactive programming",

inst/www/reactive-graph.html

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

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

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

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

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

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

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

inst/www/shared/shiny.css

@@ -381,3 +381,10 @@ pre.shiny-text-output.noplaceholder:empty {
 .shiny-file-input-over {
   box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(76, 174, 76, .6);
 }
+
+/* Overrides bootstrap-datepicker3.css styling for invalid date ranges.
+   See https://github.com/rstudio/shiny/issues/2042 for details. */
+.datepicker table tbody tr td.disabled,
+.datepicker table tbody tr td.disabled:hover {
+  color: #aaa;
+}

inst/www/shared/shiny.js

@@ -1,4 +1,4 @@
-'use strict';
+"use strict";
 
 var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol" ? function (obj) { return typeof obj; } : function (obj) { return obj && typeof Symbol === "function" && obj.constructor === Symbol && obj !== Symbol.prototype ? "symbol" : typeof obj; };
 
@@ -14,6 +14,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
   var exports = window.Shiny = window.Shiny || {};
 
+  exports.version = "1.1.0.9000"; // Version number inserted by Grunt
+
   var origPushState = window.history.pushState;
   window.history.pushState = function () {
     var result = origPushState.apply(this, arguments);
@@ -179,9 +181,12 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
   // "with" on the argument value, and return the result.
   function scopeExprToFunc(expr) {
     /*jshint evil: true */
-    var expr_escaped = expr.replace(/[\\"']/g, '\\$&').replace(/\u0000/g, '\\0');
+    var expr_escaped = expr.replace(/[\\"']/g, '\\$&').replace(/\u0000/g, '\\0').replace(/\n/g, '\\n').replace(/\r/g, '\\r')
+    // \b has a special meaning; need [\b] to match backspace char.
+    .replace(/[\b]/g, '\\b');
+
     try {
-      var func = new Function('with (this) {\n        try {\n          return (' + expr + ');\n        } catch (e) {\n          console.error(\'Error evaluating expression: ' + expr_escaped + '\');\n          throw e;\n        }\n      }');
+      var func = new Function("with (this) {\n        try {\n          return (" + expr + ");\n        } catch (e) {\n          console.error('Error evaluating expression: " + expr_escaped + "');\n          throw e;\n        }\n      }");
     } catch (e) {
       console.error("Error parsing expression: " + expr);
       throw e;
@@ -285,6 +290,33 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     return true;
   };
 
+  // Compare version strings like "1.0.1", "1.4-2". `op` must be a string like
+  // "==" or "<".
+  exports.compareVersion = function (a, op, b) {
+    function versionParts(ver) {
+      return (ver + "").replace(/-/, ".").replace(/(\.0)+[^\.]*$/, "").split(".");
+    }
+
+    function cmpVersion(a, b) {
+      a = versionParts(a);
+      b = versionParts(b);
+      var len = Math.min(a.length, b.length);
+      var cmp;
+
+      for (var i = 0; i < len; i++) {
+        cmp = parseInt(a[i], 10) - parseInt(b[i], 10);
+        if (cmp !== 0) {
+          return cmp;
+        }
+      }
+      return a.length - b.length;
+    }
+
+    var diff = cmpVersion(a, b);
+
+    if (op === "==") return diff === 0;else if (op === ">=") return diff >= 0;else if (op === ">") return diff > 0;else if (op === "<=") return diff <= 0;else if (op === "<") return diff < 0;else throw "Unknown operator: " + op;
+  };
+
   // multimethod: Creates functions — "multimethods" — that are polymorphic on one
   // or more of their arguments.
   //
@@ -458,7 +490,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if (defaultMethod) {
         return defaultMethod.apply(invoke, args);
       } else {
-        throw new Error('No method for dispatch value ' + dispatchVal);
+        throw new Error("No method for dispatch value " + dispatchVal);
       }
     });
 
@@ -730,26 +762,34 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.lastChanceCallback = [];
   };
   (function () {
-    this.setInput = function (name, value) {
-      var self = this;
-
+    this.setInput = function (name, value, opts) {
       this.pendingData[name] = value;
 
-      if (!this.timerId && !this.reentrant) {
-        this.timerId = setTimeout(function () {
-          self.reentrant = true;
-          try {
-            $.each(self.lastChanceCallback, function (i, callback) {
-              callback();
-            });
-            self.timerId = null;
-            var currentData = self.pendingData;
-            self.pendingData = {};
-            self.shinyapp.sendInput(currentData);
-          } finally {
-            self.reentrant = false;
-          }
-        }, 0);
+      if (!this.reentrant) {
+        if (opts.priority === "event") {
+          this.$sendNow();
+        } else if (!this.timerId) {
+          this.timerId = setTimeout(this.$sendNow.bind(this), 0);
+        }
+      }
+    };
+
+    this.$sendNow = function () {
+      if (this.reentrant) {
+        console.trace("Unexpected reentrancy in InputBatchSender!");
+      }
+
+      this.reentrant = true;
+      try {
+        this.timerId = null;
+        $.each(this.lastChanceCallback, function (i, callback) {
+          callback();
+        });
+        var currentData = this.pendingData;
+        this.pendingData = {};
+        this.shinyapp.sendInput(currentData);
+      } finally {
+        this.reentrant = false;
       }
     };
   }).call(InputBatchSender.prototype);
@@ -759,11 +799,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.lastSentValues = this.reset(initialValues);
   };
   (function () {
-    this.setInput = function (name, value) {
-      // Note that opts is not passed to setInput at this stage of the input
-      // decorator stack. If in the future this setInput keeps track of opts, it
-      // would be best not to store the `el`, because that could prevent it from
-      // being GC'd.
+    this.setInput = function (name, value, opts) {
       var _splitInputNameType = splitInputNameType(name);
 
       var inputName = _splitInputNameType.name;
@@ -771,11 +807,11 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       var jsonValue = JSON.stringify(value);
 
-      if (this.lastSentValues[inputName] && this.lastSentValues[inputName].jsonValue === jsonValue && this.lastSentValues[inputName].inputType === inputType) {
+      if (opts.priority !== "event" && this.lastSentValues[inputName] && this.lastSentValues[inputName].jsonValue === jsonValue && this.lastSentValues[inputName].inputType === inputType) {
         return;
       }
       this.lastSentValues[inputName] = { jsonValue: jsonValue, inputType: inputType };
-      this.target.setInput(name, value);
+      this.target.setInput(name, value, opts);
     };
     this.reset = function () {
       var values = arguments.length > 0 && arguments[0] !== undefined ? arguments[0] : {};
@@ -818,6 +854,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       evt.value = value;
       evt.binding = opts.binding;
       evt.el = opts.el;
+      evt.priority = opts.priority;
 
       $(document).trigger(evt);
 
@@ -825,9 +862,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         name = evt.name;
         if (evt.inputType !== '') name += ':' + evt.inputType;
 
-        // opts aren't passed along to lower levels in the input decorator
+        // Most opts aren't passed along to lower levels in the input decorator
         // stack.
-        this.target.setInput(name, evt.value);
+        this.target.setInput(name, evt.value, { priority: opts.priority });
       }
     };
   }).call(InputEventDecorator.prototype);
@@ -840,7 +877,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.setInput = function (name, value, opts) {
       this.$ensureInit(name);
 
-      if (opts.immediate) this.inputRatePolicies[name].immediateCall(name, value, opts);else this.inputRatePolicies[name].normalCall(name, value, opts);
+      if (opts.priority !== "deferred") this.inputRatePolicies[name].immediateCall(name, value, opts);else this.inputRatePolicies[name].normalCall(name, value, opts);
     };
     this.setRatePolicy = function (name, mode, millis) {
       if (mode === 'direct') {
@@ -892,11 +929,25 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
   // Merge opts with defaults, and return a new object.
   function addDefaultInputOpts(opts) {
-    return $.extend({
-      immediate: false,
+
+    opts = $.extend({
+      priority: "immediate",
       binding: null,
       el: null
     }, opts);
+
+    if (opts && typeof opts.priority !== "undefined") {
+      switch (opts.priority) {
+        case "deferred":
+        case "immediate":
+        case "event":
+          break;
+        default:
+          throw new Error("Unexpected input value mode: '" + opts.priority + "'");
+      }
+    }
+
+    return opts;
   }
 
   function splitInputNameType(name) {
@@ -1233,17 +1284,22 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     };
 
     this.receiveOutput = function (name, value) {
-      if (this.$values[name] === value) return undefined;
-
-      this.$values[name] = value;
-      delete this.$errors[name];
-
       var binding = this.$bindings[name];
       var evt = jQuery.Event('shiny:value');
       evt.name = name;
       evt.value = value;
       evt.binding = binding;
+
+      if (this.$values[name] === value) {
+        $(binding ? binding.el : document).trigger(evt);
+        return undefined;
+      }
+
+      this.$values[name] = value;
+      delete this.$errors[name];
+
       $(binding ? binding.el : document).trigger(evt);
+
       if (!evt.isDefaultPrevented() && binding) {
         binding.onValueChange(evt.value);
       }
@@ -1939,7 +1995,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
           // Progress bar starts hidden; will be made visible if a value is provided
           // during updates.
           exports.notifications.show({
-            html: '<div id="shiny-progress-' + message.id + '" class="shiny-progress-notification">' + '<div class="progress progress-striped active" style="display: none;"><div class="progress-bar"></div></div>' + '<div class="progress-text">' + '<span class="progress-message">message</span> ' + '<span class="progress-detail"></span>' + '</div>' + '</div>',
+            html: "<div id=\"shiny-progress-" + message.id + "\" class=\"shiny-progress-notification\">" + '<div class="progress progress-striped active" style="display: none;"><div class="progress-bar"></div></div>' + '<div class="progress-text">' + '<span class="progress-message">message</span> ' + '<span class="progress-detail"></span>' + '</div>' + '</div>',
             id: message.id,
             duration: null
           });
@@ -2135,7 +2191,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if ($notification.length === 0) $notification = _create(id);
 
       // Render html and dependencies
-      var newHtml = '<div class="shiny-notification-content-text">' + html + '</div>' + ('<div class="shiny-notification-content-action">' + action + '</div>');
+      var newHtml = "<div class=\"shiny-notification-content-text\">" + html + "</div>" + ("<div class=\"shiny-notification-content-action\">" + action + "</div>");
       var $content = $notification.find('.shiny-notification-content');
       exports.renderContent($content, { html: newHtml, deps: deps });
 
@@ -2215,7 +2271,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       var $notification = _get(id);
 
       if ($notification.length === 0) {
-        $notification = $('<div id="shiny-notification-' + id + '" class="shiny-notification">' + '<div class="shiny-notification-close">&times;</div>' + '<div class="shiny-notification-content"></div>' + '</div>');
+        $notification = $("<div id=\"shiny-notification-" + id + "\" class=\"shiny-notification\">" + '<div class="shiny-notification-close">&times;</div>' + '<div class="shiny-notification-content"></div>' + '</div>');
 
         $notification.find('.shiny-notification-close').on('click', function (e) {
           e.preventDefault();
@@ -2931,7 +2987,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       return function (e) {
         if (e === null) {
-          exports.onInputChange(inputId, null);
+          exports.setInputValue(inputId, null);
           return;
         }
 
@@ -2939,7 +2995,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         // If outside of plotting region
         if (!coordmap.isInPanel(offset)) {
           if (nullOutside) {
-            exports.onInputChange(inputId, null);
+            exports.setInputValue(inputId, null);
             return;
           }
           if (clip) return;
@@ -2960,8 +3016,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         coords.range = panel.range;
         coords.log = panel.log;
 
-        coords[".nonce"] = Math.random();
-        exports.onInputChange(inputId, coords);
+        exports.setInputValue(inputId, coords, { priority: "event" });
       };
     };
   };
@@ -3148,7 +3203,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       // We're in a new or reset state
       if (isNaN(coords.xmin)) {
-        exports.onInputChange(inputId, null);
+        exports.setInputValue(inputId, null);
         // Must tell other brushes to clear.
         imageOutputBinding.find(document).trigger("shiny-internal:brushed", {
           brushId: inputId, outputId: null
@@ -3175,7 +3230,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       coords.outputId = outputId;
 
       // Send data to server
-      exports.onInputChange(inputId, coords);
+      exports.setInputValue(inputId, coords);
 
       $el.data("mostRecentBrush", true);
       imageOutputBinding.find(document).trigger("shiny-internal:brushed", coords);
@@ -3809,7 +3864,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
   };
 
   exports.resetBrush = function (brushId) {
-    exports.onInputChange(brushId, null);
+    exports.setInputValue(brushId, null);
     imageOutputBinding.find(document).trigger("shiny-internal:brushed", {
       brushId: brushId, outputId: null
     });
@@ -3857,7 +3912,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       html = '';
     } else if (typeof content === 'string') {
       html = content;
-    } else if ((typeof content === 'undefined' ? 'undefined' : _typeof(content)) === 'object') {
+    } else if ((typeof content === "undefined" ? "undefined" : _typeof(content)) === 'object') {
       html = content.html;
       dependencies = content.deps || [];
     }
@@ -4394,6 +4449,33 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     if (slider.$cache && slider.$cache.input) slider.$cache.input.trigger('change');else console.log("Couldn't force ion slider to update");
   }
 
+  function getTypePrettifyer(dataType, timeFormat, timezone) {
+    var timeFormatter;
+    var prettify;
+    if (dataType === 'date') {
+      timeFormatter = strftime.utc();
+      prettify = function prettify(num) {
+        return timeFormatter(timeFormat, new Date(num));
+      };
+    } else if (dataType === 'datetime') {
+      if (timezone) timeFormatter = strftime.timezone(timezone);else timeFormatter = strftime;
+
+      prettify = function prettify(num) {
+        return timeFormatter(timeFormat, new Date(num));
+      };
+    } else {
+      // The default prettify function for ion.rangeSlider adds thousands
+      // separators after the decimal mark, so we have our own version here.
+      // (#1958)
+      prettify = function prettify(num) {
+        // When executed, `this` will refer to the `IonRangeSlider.options`
+        // object.
+        return formatNumber(num, this.prettify_separator);
+      };
+    }
+    return prettify;
+  }
+
   var sliderInputBinding = {};
   $.extend(sliderInputBinding, textInputBinding, {
     find: function find(scope) {
@@ -4472,12 +4554,30 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
           msg.from = data.value;
         }
       }
-      if (data.hasOwnProperty('min')) msg.min = data.min;
-      if (data.hasOwnProperty('max')) msg.max = data.max;
-      if (data.hasOwnProperty('step')) msg.step = data.step;
+      var sliderFeatures = ['min', 'max', 'step'];
+      for (var i = 0; i < sliderFeatures.length; i++) {
+        var feats = sliderFeatures[i];
+        if (data.hasOwnProperty(feats)) {
+          msg[feats] = data[feats];
+        }
+      }
 
       if (data.hasOwnProperty('label')) $el.parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
 
+      var domElements = ['data-type', 'time-format', 'timezone'];
+      for (var i = 0; i < domElements.length; i++) {
+        var elem = domElements[i];
+        if (data.hasOwnProperty(elem)) {
+          $el.data(elem, data[elem]);
+        }
+      }
+
+      var dataType = $el.data('data-type');
+      var timeFormat = $el.data('time-format');
+      var timezone = $el.data('timezone');
+
+      msg.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
+
       $el.data('immediate', true);
       try {
         slider.update(msg);
@@ -4498,22 +4598,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       var $el = $(el);
       var dataType = $el.data('data-type');
       var timeFormat = $el.data('time-format');
-      var timeFormatter;
+      var timezone = $el.data('timezone');
 
-      // Set up formatting functions
-      if (dataType === 'date') {
-        timeFormatter = strftime.utc();
-        opts.prettify = function (num) {
-          return timeFormatter(timeFormat, new Date(num));
-        };
-      } else if (dataType === 'datetime') {
-        var timezone = $el.data('timezone');
-        if (timezone) timeFormatter = strftime.timezone(timezone);else timeFormatter = strftime;
-
-        opts.prettify = function (num) {
-          return timeFormatter(timeFormat, new Date(num));
-        };
-      }
+      opts.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
 
       $el.ionRangeSlider(opts);
     },
@@ -4525,6 +4612,24 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
   });
   inputBindings.register(sliderInputBinding, 'shiny.sliderInput');
 
+  // Format numbers for nicer output.
+  // formatNumber(1234567.12345)           === "1,234,567.12345"
+  // formatNumber(1234567.12345, ".", ",") === "1.234.567,12345"
+  // formatNumber(1000, " ")               === "1 000"
+  // formatNumber(20)                      === "20"
+  // formatNumber(1.2345e24)               === "1.2345e+24"
+  function formatNumber(num) {
+    var thousand_sep = arguments.length > 1 && arguments[1] !== undefined ? arguments[1] : ",";
+    var decimal_sep = arguments.length > 2 && arguments[2] !== undefined ? arguments[2] : ".";
+
+    var parts = num.toString().split(".");
+
+    // Add separators to portion before decimal mark.
+    parts[0] = parts[0].replace(/(\d{1,3}(?=(?:\d\d\d)+(?!\d)))/g, "$1" + thousand_sep);
+
+    if (parts.length === 1) return parts[0];else if (parts.length === 2) return parts[0] + decimal_sep + parts[1];else return "";
+  };
+
   $(document).on('click', '.slider-animate-button', function (evt) {
     evt.preventDefault();
     var self = $(this);
@@ -4961,6 +5066,18 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     find: function find(scope) {
       return $(scope).find('select');
     },
+    getType: function getType(el) {
+      var $el = $(el);
+      if (!$el.hasClass("symbol")) {
+        // default character type
+        return null;
+      }
+      if ($el.attr("multiple") === "multiple") {
+        return 'shiny.symbolList';
+      } else {
+        return 'shiny.symbol';
+      }
+    },
     getId: function getId(el) {
       return InputBinding.prototype.getId.call(this, el) || el.name;
     },
@@ -5012,8 +5129,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if (data.hasOwnProperty('url')) {
         selectize = this._selectize(el);
         selectize.clearOptions();
-        var thiz = this,
-            loaded = false;
+        var loaded = false;
         selectize.settings.load = function (query, callback) {
           var settings = selectize.settings;
           $.ajax({
@@ -5030,8 +5146,19 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
               callback();
             },
             success: function success(res) {
+              // res = [{label: '1', value: '1', group: '1'}, ...]
+              // success is called after options are added, but
+              // groups need to be added manually below
+              $.each(res, function (index, elem) {
+                selectize.addOptionGroup(elem.group, { group: elem.group });
+              });
               callback(res);
-              if (!loaded && data.hasOwnProperty('value')) thiz.setValue(el, data.value);
+              if (!loaded && data.hasOwnProperty('value')) {
+                selectize.setValue(data.value);
+              } else if (settings.maxItems === 1) {
+                // first item selected by default only for single-select
+                selectize.setValue(res[0].value);
+              }
               loaded = true;
             }
           });
@@ -5067,7 +5194,10 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       var options = $.extend({
         labelField: 'label',
         valueField: 'value',
-        searchField: ['label']
+        searchField: ['label'],
+        optgroupField: 'group',
+        optgroupLabelField: 'group',
+        optgroupValueField: 'group'
       }, JSON.parse(config.html()));
       // selectize created from selectInput()
       if (typeof config.data('nonempty') !== 'undefined') {
@@ -5713,7 +5843,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       // Attach a dragenter handler to $el and all of its children. When the first
       // child is entered, trigger a draghoverstart event.
       $el.on("dragenter.dragHover", function (e) {
-        if (collection.size() === 0) {
+        if (collection.length === 0) {
           $el.trigger("draghoverstart" + ns, e.originalEvent);
         }
         // Every child that has fired dragenter is added to the collection.
@@ -5728,7 +5858,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         collection = collection.not(e.originalEvent.target);
         // When the collection has no elements, all of the children have been
         // removed, and produce draghoverend event.
-        if (collection.size() === 0) {
+        if (collection.length === 0) {
           $el.trigger("draghoverend" + ns, e.originalEvent);
         }
       });
@@ -6008,7 +6138,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
     inputs = new InputValidateDecorator(inputs);
 
-    exports.onInputChange = function (name, value, opts) {
+    exports.setInputValue = exports.onInputChange = function (name, value, opts) {
       opts = addDefaultInputOpts(opts);
       inputs.setInput(name, value, opts);
     };
@@ -6022,7 +6152,11 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         var type = binding.getType(el);
         if (type) id = id + ":" + type;
 
-        var opts = { immediate: !allowDeferred, binding: binding, el: el };
+        var opts = {
+          priority: allowDeferred ? "deferred" : "immediate",
+          binding: binding,
+          el: el
+        };
         inputs.setInput(id, value, opts);
       }
     }
@@ -6185,7 +6319,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
     // The server needs to know the size of each image and plot output element,
     // in case it is auto-sizing
-    $('.shiny-image-output, .shiny-plot-output').each(function () {
+    $('.shiny-image-output, .shiny-plot-output, .shiny-report-size').each(function () {
       var id = getIdFromEl(this);
       if (this.offsetWidth !== 0 || this.offsetHeight !== 0) {
         initialValues['.clientdata_output_' + id + '_width'] = this.offsetWidth;
@@ -6193,7 +6327,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       }
     });
     function doSendImageSize() {
-      $('.shiny-image-output, .shiny-plot-output').each(function () {
+      $('.shiny-image-output, .shiny-plot-output, .shiny-report-size').each(function () {
         var id = getIdFromEl(this);
         if (this.offsetWidth !== 0 || this.offsetHeight !== 0) {
           inputs.setInput('.clientdata_output_' + id + '_width', this.offsetWidth);

man/actionButton.Rd

@@ -62,5 +62,7 @@ Other input elements: \code{\link{checkboxGroupInput}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}, \code{\link{textInput}}
+  \code{\link{textAreaInput}}, \code{\link{textInput}},
+  \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/checkboxGroupInput.Rd

@@ -15,7 +15,8 @@ checkboxGroupInput(inputId, label, choices = NULL, selected = NULL,
 \item{choices}{List of values to show checkboxes for. If elements of the list
 are named then that name rather than the value is displayed to the user. If
 this argument is provided, then \code{choiceNames} and \code{choiceValues}
-must not be provided, and vice-versa.}
+must not be provided, and vice-versa. The values should be strings; other
+types (such as logicals and numbers) will be coerced to strings.}
 
 \item{selected}{The values that should be initially selected, if any.}
 
@@ -92,5 +93,7 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}, \code{\link{textInput}}
+  \code{\link{textAreaInput}}, \code{\link{textInput}},
+  \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/checkboxInput.Rd

@@ -46,5 +46,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/createRenderFunction.Rd

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

man/dateInput.Rd

@@ -6,7 +6,7 @@
 \usage{
 dateInput(inputId, label, value = NULL, min = NULL, max = NULL,
   format = "yyyy-mm-dd", startview = "month", weekstart = 0,
-  language = "en", width = NULL)
+  language = "en", width = NULL, autoclose = TRUE)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -43,6 +43,9 @@ Other valid values include "ar", "az", "bg", "bs", "ca", "cs", "cy", "da",
 
 \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
 see \code{\link{validateCssUnit}}.}
+
+\item{autoclose}{Whether or not to close the datepicker immediately when a
+date is selected.}
 }
 \description{
 Creates a text input which, when clicked on, brings up a calendar that
@@ -104,5 +107,7 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}, \code{\link{textInput}}
+  \code{\link{textAreaInput}}, \code{\link{textInput}},
+  \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/dateRangeInput.Rd

@@ -6,7 +6,7 @@
 \usage{
 dateRangeInput(inputId, label, start = NULL, end = NULL, min = NULL,
   max = NULL, format = "yyyy-mm-dd", startview = "month", weekstart = 0,
-  language = "en", separator = " to ", width = NULL)
+  language = "en", separator = " to ", width = NULL, autoclose = TRUE)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -49,6 +49,9 @@ Other valid values include "ar", "az", "bg", "bs", "ca", "cs", "cy", "da",
 
 \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
 see \code{\link{validateCssUnit}}.}
+
+\item{autoclose}{Whether or not to close the datepicker immediately when a
+date is selected.}
 }
 \description{
 Creates a pair of text inputs which, when clicked on, bring up calendars that
@@ -121,5 +124,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/domains.Rd

@@ -5,7 +5,6 @@
 \alias{getDefaultReactiveDomain}
 \alias{withReactiveDomain}
 \alias{onReactiveDomainEnded}
-\alias{domains}
 \title{Reactive domains}
 \usage{
 getDefaultReactiveDomain()

man/downloadButton.Rd

@@ -3,7 +3,6 @@
 \name{downloadButton}
 \alias{downloadButton}
 \alias{downloadLink}
-\alias{downloadLink}
 \title{Create a download button or link}
 \usage{
 downloadButton(outputId, label = "Download", class = NULL, ...)

man/fileInput.Rd

@@ -97,5 +97,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/numericInput.Rd

@@ -53,5 +53,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/observeEvent.Rd

@@ -135,15 +135,20 @@ whereas \code{ignoreNULL=FALSE} is desirable if you want to initially perform
 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}
+Likewise, both \code{observeEvent} and \code{eventReactive} also take in an
+\code{ignoreInit} argument. By default, both of these will run right when they
+are 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.
+instead of also being triggered when it is created/initialized. Similarly,
+if you're setting up an \code{eventReactive} that responds to a dynamically
+created button used to refresh some data (then returned by that \code{eventReactive}),
+then you should use \code{eventReactive([...], ignoreInit = TRUE)} if you want
+to let the user decide if/when they want to refresh the data (since, depending
+on the app, this may be a computationally expensive operation).
 
 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
@@ -151,25 +156,28 @@ 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.
+     This is the default. This combination means that \code{handlerExpr}/
+     \code{valueExpr} will run every time that \code{eventExpr} is not
+     \code{NULL}. If, at the time of the creation of the
+     \code{observeEvent}/\code{eventReactive}, \code{eventExpr} 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.
+     This combination means that \code{handlerExpr}/\code{valueExpr} 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.
+     This combination means that \code{handlerExpr}/\code{valueExpr} will
+     \emph{not} run when the \code{observeEvent}/\code{eventReactive} 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}.
+     This combination means that \code{handlerExpr}/\code{valueExpr} will
+     \emph{not} run when the \code{observeEvent}/\code{eventReactive} is
+     created (because  \code{ignoreInit = TRUE}). After that,
+     \code{handlerExpr}/\code{valueExpr} will run every time that
+     \code{eventExpr} is not \code{NULL}.
   }
 }
 }

man/passwordInput.Rd

@@ -55,5 +55,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/plotOutput.Rd

@@ -3,7 +3,6 @@
 \name{plotOutput}
 \alias{plotOutput}
 \alias{imageOutput}
-\alias{plotOutput}
 \title{Create an plot or image output element}
 \usage{
 imageOutput(outputId, width = "100\%", height = "400px", click = NULL,

man/radioButtons.Rd

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

man/renderUI.Rd

@@ -20,8 +20,7 @@ call to \code{\link{uiOutput}} when \code{renderUI} is used in an
 interactive R Markdown document.}
 }
 \description{
-\bold{Experimental feature.} Makes a reactive version of a function that
-generates HTML using the Shiny UI library.
+Renders reactive HTML using the Shiny UI library.
 }
 \details{
 The corresponding HTML output tag should be \code{div} and have the CSS class
@@ -48,5 +47,5 @@ shinyApp(ui, server)
 
 }
 \seealso{
-conditionalPanel
+\code{\link{uiOutput}}
 }

man/selectInput.Rd

@@ -98,9 +98,9 @@ shinyApp(
 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"))
+      list(`East Coast` = list("NY", "NJ", "CT"),
+           `West Coast` = list("WA", "OR", "CA"),
+           `Midwest` = list("MN", "WI", "IA"))
     ),
     textOutput("result")
   ),
@@ -113,7 +113,7 @@ shinyApp(
 }
 }
 \seealso{
-\code{\link{updateSelectInput}}
+\code{\link{updateSelectInput}} \code{\link{varSelectInput}}
 
 Other input elements: \code{\link{actionButton}},
   \code{\link{checkboxGroupInput}},
@@ -122,5 +122,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/session.Rd

@@ -127,7 +127,8 @@
   Similar to \code{sendCustomMessage}, but the message must be a raw vector
   and the registration method on the client is
   \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
-  message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
+  message argument on the client will be a
+  \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
 }
 \item{sendInputMessage(inputId, message)}{
   Sends a message to an input on the session's client web page; if the input

man/sliderInput.Rd

@@ -125,5 +125,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/stacktrace.Rd

@@ -99,10 +99,12 @@ manipulating stack traces.
   from \code{conditionStackTrace(cond)}) and returns a data frame with one
   row for each stack frame and the columns \code{num} (stack frame number),
   \code{call} (a function name or similar), and \code{loc} (source file path
-  and line number, if available).
+  and line number, if available). It was deprecated after shiny 1.0.5 because
+  it doesn't support deep stack traces.
 
 \code{formatStackTrace} is similar to \code{extractStackTrace}, but
-  it returns a preformatted character vector instead of a data frame.
+  it returns a preformatted character vector instead of a data frame. It was
+  deprecated after shiny 1.0.5 because it doesn't support deep stack traces.
 
 \code{conditionStackTrace} and \code{conditionStackTrace<-} are
   accessor functions for getting/setting stack traces on conditions.

man/submitButton.Rd

@@ -72,5 +72,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/textAreaInput.Rd

@@ -68,5 +68,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/textInput.Rd

@@ -50,5 +50,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}
+  \code{\link{textAreaInput}}, \code{\link{varSelectInput}}
 }
+\concept{input elements}

man/updateCheckboxGroupInput.Rd

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

man/updateRadioButtons.Rd

@@ -19,32 +19,33 @@ updateRadioButtons(session, inputId, label = NULL, choices = NULL,
 \item{choices}{List of values to select from (if elements of the list are
 named then that name rather than the value is displayed to the user). If
 this argument is provided, then \code{choiceNames} and \code{choiceValues}
-must not be provided, and vice-versa.}
+must not be provided, and vice-versa. The values should be strings; other
+types (such as logicals and numbers) will be coerced to strings.}
 
-\item{selected}{The initially selected value (if not specified then
-defaults to the first value)}
+\item{selected}{The initially selected value (if not specified then defaults
+to the first value)}
 
 \item{inline}{If \code{TRUE}, render the choices inline (i.e. horizontally)}
 
-\item{choiceNames}{List of names and values, respectively,
-that are displayed to the user in the app and correspond to the each
-choice (for this reason, \code{choiceNames} and \code{choiceValues}
-must have the same length). If either of these arguments is
-provided, then the other \emph{must} be provided and \code{choices}
-\emph{must not} be provided. The advantage of using both of these over
-a named list for \code{choices} is that \code{choiceNames} allows any
-type of UI object to be passed through (tag objects, icons, HTML code,
-...), instead of just simple text. See Examples.}
+\item{choiceNames}{List of names and values, respectively, that
+are displayed to the user in the app and correspond to the each choice (for
+this reason, \code{choiceNames} and \code{choiceValues} must have the same
+length). If either of these arguments is provided, then the other
+\emph{must} be provided and \code{choices} \emph{must not} be provided. The
+advantage of using both of these over a named list for \code{choices} is
+that \code{choiceNames} allows any type of UI object to be passed through
+(tag objects, icons, HTML code, ...), instead of just simple text. See
+Examples.}
 
-\item{choiceValues}{List of names and values, respectively,
-that are displayed to the user in the app and correspond to the each
-choice (for this reason, \code{choiceNames} and \code{choiceValues}
-must have the same length). If either of these arguments is
-provided, then the other \emph{must} be provided and \code{choices}
-\emph{must not} be provided. The advantage of using both of these over
-a named list for \code{choices} is that \code{choiceNames} allows any
-type of UI object to be passed through (tag objects, icons, HTML code,
-...), instead of just simple text. See Examples.}
+\item{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.}
 }
 \description{
 Change the value of a radio input on the client

man/updateSelectInput.Rd

@@ -3,6 +3,8 @@
 \name{updateSelectInput}
 \alias{updateSelectInput}
 \alias{updateSelectizeInput}
+\alias{updateVarSelectInput}
+\alias{updateVarSelectizeInput}
 \title{Change the value of a select input on the client}
 \usage{
 updateSelectInput(session, inputId, label = NULL, choices = NULL,
@@ -10,6 +12,12 @@ updateSelectInput(session, inputId, label = NULL, choices = NULL,
 
 updateSelectizeInput(session, inputId, label = NULL, choices = NULL,
   selected = NULL, options = list(), server = FALSE)
+
+updateVarSelectInput(session, inputId, label = NULL, data = NULL,
+  selected = NULL)
+
+updateVarSelectizeInput(session, inputId, label = NULL, data = NULL,
+  selected = NULL, options = list(), server = FALSE)
 }
 \arguments{
 \item{session}{The \code{session} object passed to function given to
@@ -40,6 +48,8 @@ for details).}
 the select options dynamically on searching, instead of writing all
 \code{choices} into the page at once (i.e., only use the client-side
 version of \pkg{selectize.js})}
+
+\item{data}{A data frame. Used to retrieve the column names as choices for a \code{\link{selectInput}}}
 }
 \description{
 Change the value of a select input on the client
@@ -94,5 +104,5 @@ shinyApp(ui, server)
 }
 }
 \seealso{
-\code{\link{selectInput}}
+\code{\link{selectInput}} \code{\link{varSelectInput}}
 }

man/updateSliderInput.Rd

@@ -2,10 +2,11 @@
 % Please edit documentation in R/update-input.R
 \name{updateSliderInput}
 \alias{updateSliderInput}
-\title{Change the value of a slider input on the client}
+\title{Update Slider Input Widget}
 \usage{
 updateSliderInput(session, inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL)
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL,
+  timezone = NULL)
 }
 \arguments{
 \item{session}{The \code{session} object passed to function given to
@@ -22,9 +23,13 @@ updateSliderInput(session, inputId, label = NULL, value = NULL,
 \item{max}{Maximum value.}
 
 \item{step}{Step size.}
+
+\item{timeFormat}{Date and POSIXt formatting.}
+
+\item{timezone}{The timezone offset for POSIXt objects.}
 }
 \description{
-Change the value of a slider input on the client
+Change the value of a slider input on the client.
 }
 \details{
 The input updater functions send a message to the client, telling it to

man/varSelectInput.Rd

@@ -0,0 +1,129 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/input-select.R
+\name{varSelectInput}
+\alias{varSelectInput}
+\alias{varSelectizeInput}
+\title{Select variables from a data frame}
+\usage{
+varSelectInput(inputId, label, data, selected = NULL, multiple = FALSE,
+  selectize = TRUE, width = NULL, size = NULL)
+
+varSelectizeInput(inputId, ..., options = NULL, width = NULL)
+}
+\arguments{
+\item{inputId}{The \code{input} slot that will be used to access the value.}
+
+\item{label}{Display label for the control, or \code{NULL} for no label.}
+
+\item{data}{A data frame. Used to retrieve the column names as choices for a \code{\link{selectInput}}}
+
+\item{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.}
+
+\item{multiple}{Is selection of multiple items allowed?}
+
+\item{selectize}{Whether to use \pkg{selectize.js} or not.}
+
+\item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'};
+see \code{\link{validateCssUnit}}.}
+
+\item{size}{Number of items to show in the selection box; a larger number
+will result in a taller box. Not compatible with \code{selectize=TRUE}.
+Normally, when \code{multiple=FALSE}, a select input will be a drop-down
+list, but when \code{size} is set, it will be a box instead.}
+
+\item{...}{Arguments passed to \code{varSelectInput()}.}
+
+\item{options}{A list of options. See the documentation of \pkg{selectize.js}
+for possible options (character option values inside \code{\link[base]{I}()} will
+be treated as literal JavaScript code; see \code{\link{renderDataTable}()}
+for details).}
+}
+\value{
+A variable select list control that can be added to a UI definition.
+}
+\description{
+Create a select list that can be used to choose a single or multiple items
+from the column names of a data frame.
+}
+\details{
+The resulting server \code{input} value will be returned as:
+\itemize{
+  \item a symbol if \code{multiple = FALSE}.  The \code{input} value should be
+        used with rlang's \code{\link[rlang]{!!}}. For example,
+        \code{ggplot2::aes(!!input$variable)}.
+  \item a list of symbols if \code{multiple = TRUE}. The \code{input} value
+        should be used with rlang's \code{\link[rlang]{!!!}} to expand
+        the symbol list as individual arguments. For example,
+        \code{dplyr::select(mtcars, !!!input$variabls)} which is
+        equivalent to \code{dplyr::select(mtcars, !!input$variabls[[1]], !!input$variabls[[2]], ..., !!input$variabls[[length(input$variabls)]])}.
+}
+
+By default, \code{varSelectInput()} and \code{selectizeInput()} use the
+JavaScript library \pkg{selectize.js}
+(\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}.
+}
+\note{
+The variable selectize input created from \code{varSelectizeInput()} allows
+  deletion of the selected option even in a single select input, which will
+  return an empty string as its value. This is the default behavior of
+  \pkg{selectize.js}. However, the selectize input created from
+  \code{selectInput(..., selectize = TRUE)} will ignore the empty string
+  value when it is a single choice input and the empty string is not in the
+  \code{choices} argument. This is to keep compatibility with
+  \code{selectInput(..., selectize = FALSE)}.
+}
+\examples{
+
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+library(ggplot2)
+
+# single selection
+shinyApp(
+  ui = fluidPage(
+    varSelectInput("variable", "Variable:", mtcars),
+    plotOutput("data")
+  ),
+  server = function(input, output) {
+    output$data <- renderPlot({
+      ggplot(mtcars, aes(!!input$variable)) + geom_histogram()
+    })
+  }
+)
+
+
+# multiple selections
+\dontrun{
+shinyApp(
+ ui = fluidPage(
+   varSelectInput("variables", "Variable:", mtcars, multiple = TRUE),
+   tableOutput("data")
+ ),
+ server = function(input, output) {
+   output$data <- renderTable({
+      if (length(input$variables) == 0) return(mtcars)
+      mtcars \%>\% dplyr::select(!!!input$variables)
+   }, rownames = TRUE)
+ }
+)}
+
+}
+}
+\seealso{
+\code{\link{updateSelectInput}}
+
+Other input elements: \code{\link{actionButton}},
+  \code{\link{checkboxGroupInput}},
+  \code{\link{checkboxInput}}, \code{\link{dateInput}},
+  \code{\link{dateRangeInput}}, \code{\link{fileInput}},
+  \code{\link{numericInput}}, \code{\link{passwordInput}},
+  \code{\link{radioButtons}}, \code{\link{selectInput}},
+  \code{\link{sliderInput}}, \code{\link{submitButton}},
+  \code{\link{textAreaInput}}, \code{\link{textInput}}
+}
+\concept{input elements}

manualtests/async/timer.R

@@ -0,0 +1,36 @@
+library(shiny)
+library(future)
+library(promises)
+library(magrittr)
+plan(multisession)
+
+ui <- fluidPage(
+  p("This app tests that ", tags$code("invalidateLater()"), " calls are held until async operations are complete."),
+  tags$ol(
+    tags$li("You should see the number below increasing by 1, every 2 seconds."),
+    tags$li("The output should be semi-transparent (i.e. recalculating state) continuously."),
+    tags$li("You should see the word 'Flushed' in the R console, every 2 seconds.")
+  ),
+  verbatimTextOutput("out")
+)
+
+server <- function(input, output, session) {
+
+  value <- reactiveVal(0L)
+
+  observe({
+    invalidateLater(100)
+    isolate({ value(value() + 1L) })
+  })
+
+  session$onFlushed(function() {
+    print("Flushed")
+  }, once = FALSE)
+
+  output$out <- renderText({
+    future(Sys.sleep(2)) %...>%
+      { value() }
+  })
+}
+
+shinyApp(ui, server)

srcjs/_start.js

@@ -3,6 +3,8 @@
 
   var exports = window.Shiny = window.Shiny || {};
 
+  exports.version = "{{ VERSION }}";  // Version number inserted by Grunt
+
   var origPushState = window.history.pushState;
   window.history.pushState = function() {
     var result = origPushState.apply(this, arguments);

srcjs/init_shiny.js

@@ -101,7 +101,7 @@ function initShiny() {
 
   inputs = new InputValidateDecorator(inputs);
 
-  exports.onInputChange = function(name, value, opts) {
+  exports.setInputValue = exports.onInputChange = function(name, value, opts) {
     opts = addDefaultInputOpts(opts);
     inputs.setInput(name, value, opts);
   };
@@ -116,7 +116,11 @@ function initShiny() {
       if (type)
         id = id + ":" + type;
 
-      let opts = { immediate: !allowDeferred, binding: binding, el: el };
+      let opts = {
+        priority: allowDeferred ? "deferred" : "immediate",
+        binding: binding,
+        el: el
+      };
       inputs.setInput(id, value, opts);
     }
   }
@@ -277,7 +281,7 @@ function initShiny() {
 
   // The server needs to know the size of each image and plot output element,
   // in case it is auto-sizing
-  $('.shiny-image-output, .shiny-plot-output').each(function() {
+  $('.shiny-image-output, .shiny-plot-output, .shiny-report-size').each(function() {
     var id = getIdFromEl(this);
     if (this.offsetWidth !== 0 || this.offsetHeight !== 0) {
       initialValues['.clientdata_output_' + id + '_width'] = this.offsetWidth;
@@ -285,7 +289,7 @@ function initShiny() {
     }
   });
   function doSendImageSize() {
-    $('.shiny-image-output, .shiny-plot-output').each(function() {
+    $('.shiny-image-output, .shiny-plot-output, .shiny-report-size').each(function() {
       var id = getIdFromEl(this);
       if (this.offsetWidth !== 0 || this.offsetHeight !== 0) {
         inputs.setInput('.clientdata_output_' + id + '_width', this.offsetWidth);

srcjs/input_binding_fileinput.js

@@ -323,7 +323,7 @@ $.extend(fileInputBinding, {
     // Attach a dragenter handler to $el and all of its children. When the first
     // child is entered, trigger a draghoverstart event.
     $el.on("dragenter.dragHover", e => {
-      if (collection.size() === 0) {
+      if (collection.length === 0) {
         $el.trigger("draghoverstart" + ns, e.originalEvent);
       }
       // Every child that has fired dragenter is added to the collection.
@@ -338,7 +338,7 @@ $.extend(fileInputBinding, {
       collection = collection.not(e.originalEvent.target);
       // When the collection has no elements, all of the children have been
       // removed, and produce draghoverend event.
-      if (collection.size() === 0) {
+      if (collection.length === 0) {
         $el.trigger("draghoverend" + ns, e.originalEvent);
       }
     });

srcjs/input_binding_select.js

@@ -3,6 +3,18 @@ $.extend(selectInputBinding, {
   find: function(scope) {
     return $(scope).find('select');
   },
+  getType: function(el) {
+    var $el = $(el);
+    if (!$el.hasClass("symbol")) {
+      // default character type
+      return null;
+    }
+    if ($el.attr("multiple") === "multiple") {
+      return 'shiny.symbolList';
+    } else {
+      return 'shiny.symbol';
+    }
+  },
   getId: function(el) {
     return InputBinding.prototype.getId.call(this, el) || el.name;
   },
@@ -55,7 +67,7 @@ $.extend(selectInputBinding, {
     if (data.hasOwnProperty('url')) {
       selectize = this._selectize(el);
       selectize.clearOptions();
-      var thiz = this, loaded = false;
+      var loaded = false;
       selectize.settings.load = function(query, callback) {
         var settings = selectize.settings;
         $.ajax({
@@ -72,9 +84,19 @@ $.extend(selectInputBinding, {
             callback();
           },
           success: function(res) {
+            // res = [{label: '1', value: '1', group: '1'}, ...]
+            // success is called after options are added, but
+            // groups need to be added manually below
+            $.each(res, function(index, elem) {
+              selectize.addOptionGroup(elem.group, { group: elem.group });
+            });
             callback(res);
-            if (!loaded && data.hasOwnProperty('value'))
-              thiz.setValue(el, data.value);
+            if (!loaded && data.hasOwnProperty('value')) {
+              selectize.setValue(data.value);
+            } else if (settings.maxItems === 1) {
+              // first item selected by default only for single-select
+              selectize.setValue(res[0].value);
+            }
             loaded = true;
           }
         });
@@ -111,7 +133,10 @@ $.extend(selectInputBinding, {
     var options = $.extend({
       labelField: 'label',
       valueField: 'value',
-      searchField: ['label']
+      searchField: ['label'],
+      optgroupField: 'group',
+      optgroupLabelField: 'group',
+      optgroupValueField: 'group'
     }, JSON.parse(config.html()));
     // selectize created from selectInput()
     if (typeof(config.data('nonempty')) !== 'undefined') {

srcjs/input_binding_slider.js

@@ -6,6 +6,38 @@ function forceIonSliderUpdate(slider) {
     console.log("Couldn't force ion slider to update");
 }
 
+function getTypePrettifyer(dataType, timeFormat, timezone) {
+  var timeFormatter;
+  var prettify;
+  if (dataType === 'date') {
+    timeFormatter = strftime.utc();
+    prettify = function(num) {
+      return timeFormatter(timeFormat, new Date(num));
+    };
+
+  } else if (dataType === 'datetime') {
+    if (timezone)
+      timeFormatter = strftime.timezone(timezone);
+    else
+      timeFormatter = strftime;
+
+    prettify = function(num) {
+      return timeFormatter(timeFormat, new Date(num));
+    };
+
+  } else {
+    // The default prettify function for ion.rangeSlider adds thousands
+    // separators after the decimal mark, so we have our own version here.
+    // (#1958)
+    prettify = function(num) {
+      // When executed, `this` will refer to the `IonRangeSlider.options`
+      // object.
+      return formatNumber(num, this.prettify_separator);
+    };
+  }
+  return prettify;
+}
+
 var sliderInputBinding = {};
 $.extend(sliderInputBinding, textInputBinding, {
   find: function(scope) {
@@ -90,13 +122,31 @@ $.extend(sliderInputBinding, textInputBinding, {
         msg.from = data.value;
       }
     }
-    if (data.hasOwnProperty('min'))  msg.min   = data.min;
-    if (data.hasOwnProperty('max'))  msg.max   = data.max;
-    if (data.hasOwnProperty('step')) msg.step  = data.step;
+    var sliderFeatures = ['min', 'max', 'step'];
+    for (var i = 0; i < sliderFeatures.length; i++) {
+      var feats = sliderFeatures[i];
+      if (data.hasOwnProperty(feats)) {
+        msg[feats] = data[feats];
+      }
+    }
 
     if (data.hasOwnProperty('label'))
       $el.parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
 
+    var domElements = ['data-type', 'time-format', 'timezone'];
+    for (var i = 0; i < domElements.length; i++) {
+      var elem = domElements[i];
+      if (data.hasOwnProperty(elem)) {
+        $el.data(elem, data[elem]);
+      }
+    }
+
+    var dataType = $el.data('data-type');
+    var timeFormat = $el.data('time-format');
+    var timezone = $el.data('timezone');
+
+    msg.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
+
     $el.data('immediate', true);
     try {
       slider.update(msg);
@@ -118,26 +168,9 @@ $.extend(sliderInputBinding, textInputBinding, {
     var $el = $(el);
     var dataType = $el.data('data-type');
     var timeFormat = $el.data('time-format');
-    var timeFormatter;
+    var timezone = $el.data('timezone');
 
-    // Set up formatting functions
-    if (dataType === 'date') {
-      timeFormatter = strftime.utc();
-      opts.prettify = function(num) {
-        return timeFormatter(timeFormat, new Date(num));
-      };
-
-    } else if (dataType === 'datetime') {
-      var timezone = $el.data('timezone');
-      if (timezone)
-        timeFormatter = strftime.timezone(timezone);
-      else
-        timeFormatter = strftime;
-
-      opts.prettify = function(num) {
-        return timeFormatter(timeFormat, new Date(num));
-      };
-    }
+    opts.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
 
     $el.ionRangeSlider(opts);
   },
@@ -153,6 +186,25 @@ $.extend(sliderInputBinding, textInputBinding, {
 inputBindings.register(sliderInputBinding, 'shiny.sliderInput');
 
 
+// Format numbers for nicer output.
+// formatNumber(1234567.12345)           === "1,234,567.12345"
+// formatNumber(1234567.12345, ".", ",") === "1.234.567,12345"
+// formatNumber(1000, " ")               === "1 000"
+// formatNumber(20)                      === "20"
+// formatNumber(1.2345e24)               === "1.2345e+24"
+function formatNumber(num, thousand_sep = ",", decimal_sep = ".") {
+  let parts = num.toString().split(".");
+
+  // Add separators to portion before decimal mark.
+  parts[0] = parts[0].replace(/(\d{1,3}(?=(?:\d\d\d)+(?!\d)))/g, "$1" + thousand_sep);
+
+  if (parts.length === 1)
+    return parts[0];
+  else if (parts.length === 2)
+    return parts[0] + decimal_sep + parts[1];
+  else
+    return "";
+};
 
 $(document).on('click', '.slider-animate-button', function(evt) {
   evt.preventDefault();

srcjs/input_rate.js

@@ -189,26 +189,34 @@ var InputBatchSender = function(shinyapp) {
   this.lastChanceCallback = [];
 };
 (function() {
-  this.setInput = function(name, value) {
-    var self = this;
-
+  this.setInput = function(name, value, opts) {
     this.pendingData[name] = value;
 
-    if (!this.timerId && !this.reentrant) {
-      this.timerId = setTimeout(function() {
-        self.reentrant = true;
-        try {
-          $.each(self.lastChanceCallback, function(i, callback) {
-            callback();
-          });
-          self.timerId = null;
-          var currentData = self.pendingData;
-          self.pendingData = {};
-          self.shinyapp.sendInput(currentData);
-        } finally {
-          self.reentrant = false;
-        }
-      }, 0);
+    if (!this.reentrant) {
+      if (opts.priority === "event") {
+        this.$sendNow();
+      } else if (!this.timerId) {
+        this.timerId = setTimeout(this.$sendNow.bind(this), 0);
+      }
+    }
+  };
+
+  this.$sendNow = function() {
+    if (this.reentrant) {
+      console.trace("Unexpected reentrancy in InputBatchSender!");
+    }
+
+    this.reentrant = true;
+    try {
+      this.timerId = null;
+      $.each(this.lastChanceCallback, (i, callback) => {
+        callback();
+      });
+      var currentData = this.pendingData;
+      this.pendingData = {};
+      this.shinyapp.sendInput(currentData);
+    } finally {
+      this.reentrant = false;
     }
   };
 }).call(InputBatchSender.prototype);
@@ -219,21 +227,18 @@ var InputNoResendDecorator = function(target, initialValues) {
   this.lastSentValues = this.reset(initialValues);
 };
 (function() {
-  this.setInput = function(name, value) {
-    // Note that opts is not passed to setInput at this stage of the input
-    // decorator stack. If in the future this setInput keeps track of opts, it
-    // would be best not to store the `el`, because that could prevent it from
-    // being GC'd.
+  this.setInput = function(name, value, opts) {
     const { name: inputName, inputType: inputType } = splitInputNameType(name);
     const jsonValue = JSON.stringify(value);
 
-    if (this.lastSentValues[inputName] &&
+    if (opts.priority !== "event" &&
+        this.lastSentValues[inputName] &&
         this.lastSentValues[inputName].jsonValue === jsonValue &&
         this.lastSentValues[inputName].inputType === inputType) {
       return;
     }
     this.lastSentValues[inputName] = { jsonValue, inputType };
-    this.target.setInput(name, value);
+    this.target.setInput(name, value, opts);
   };
   this.reset = function(values = {}) {
     // Given an object with flat name-value format:
@@ -271,6 +276,7 @@ var InputEventDecorator = function(target) {
     evt.value     = value;
     evt.binding   = opts.binding;
     evt.el        = opts.el;
+    evt.priority    = opts.priority;
 
     $(document).trigger(evt);
 
@@ -278,9 +284,9 @@ var InputEventDecorator = function(target) {
       name = evt.name;
       if (evt.inputType !== '') name += ':' + evt.inputType;
 
-      // opts aren't passed along to lower levels in the input decorator
+      // Most opts aren't passed along to lower levels in the input decorator
       // stack.
-      this.target.setInput(name, evt.value);
+      this.target.setInput(name, evt.value, { priority: opts.priority });
     }
   };
 }).call(InputEventDecorator.prototype);
@@ -294,7 +300,7 @@ var InputRateDecorator = function(target) {
   this.setInput = function(name, value, opts) {
     this.$ensureInit(name);
 
-    if (opts.immediate)
+    if (opts.priority !== "deferred")
       this.inputRatePolicies[name].immediateCall(name, value, opts);
     else
       this.inputRatePolicies[name].normalCall(name, value, opts);
@@ -359,11 +365,25 @@ const InputValidateDecorator = function(target) {
 
 // Merge opts with defaults, and return a new object.
 function addDefaultInputOpts(opts) {
-  return $.extend({
-    immediate: false,
+
+  opts = $.extend({
+    priority: "immediate",
     binding: null,
     el: null
   }, opts);
+
+  if (opts && typeof(opts.priority) !== "undefined") {
+    switch (opts.priority) {
+      case "deferred":
+      case "immediate":
+      case "event":
+        break;
+      default:
+        throw new Error("Unexpected input value mode: '" + opts.priority + "'");
+    }
+  }
+
+  return opts;
 }
 
 

srcjs/output_binding_image.js

@@ -436,7 +436,7 @@ imageutils.initCoordmap = function($el, coordmap) {
 
     return function(e) {
       if (e === null) {
-        exports.onInputChange(inputId, null);
+        exports.setInputValue(inputId, null);
         return;
       }
 
@@ -444,7 +444,7 @@ imageutils.initCoordmap = function($el, coordmap) {
       // If outside of plotting region
       if (!coordmap.isInPanel(offset)) {
         if (nullOutside) {
-          exports.onInputChange(inputId, null);
+          exports.setInputValue(inputId, null);
           return;
         }
         if (clip)
@@ -466,8 +466,7 @@ imageutils.initCoordmap = function($el, coordmap) {
       coords.range  = panel.range;
       coords.log    = panel.log;
 
-      coords[".nonce"] = Math.random();
-      exports.onInputChange(inputId, coords);
+      exports.setInputValue(inputId, coords, {priority: "event"});
     };
   };
 };
@@ -662,7 +661,7 @@ imageutils.createBrushHandler = function(inputId, $el, opts, coordmap, outputId)
 
     // We're in a new or reset state
     if (isNaN(coords.xmin)) {
-      exports.onInputChange(inputId, null);
+      exports.setInputValue(inputId, null);
       // Must tell other brushes to clear.
       imageOutputBinding.find(document).trigger("shiny-internal:brushed", {
         brushId: inputId, outputId: null
@@ -689,7 +688,7 @@ imageutils.createBrushHandler = function(inputId, $el, opts, coordmap, outputId)
     coords.outputId = outputId;
 
     // Send data to server
-    exports.onInputChange(inputId, coords);
+    exports.setInputValue(inputId, coords);
 
     $el.data("mostRecentBrush", true);
     imageOutputBinding.find(document).trigger("shiny-internal:brushed", coords);
@@ -1373,7 +1372,7 @@ imageutils.createBrush = function($el, opts, coordmap, expandPixels) {
 };
 
 exports.resetBrush = function(brushId) {
-  exports.onInputChange(brushId, null);
+  exports.setInputValue(brushId, null);
   imageOutputBinding.find(document).trigger("shiny-internal:brushed", {
     brushId: brushId, outputId: null
   });

srcjs/shinyapp.js

@@ -331,18 +331,22 @@ var ShinyApp = function() {
   };
 
   this.receiveOutput = function(name, value) {
-    if (this.$values[name] === value)
-      return undefined;
-
-    this.$values[name] = value;
-    delete this.$errors[name];
-
     var binding = this.$bindings[name];
     var evt = jQuery.Event('shiny:value');
     evt.name = name;
     evt.value = value;
     evt.binding = binding;
+
+    if (this.$values[name] === value) {
+      $(binding ? binding.el : document).trigger(evt);
+      return undefined;
+    }
+
+    this.$values[name] = value;
+    delete this.$errors[name];
+
     $(binding ? binding.el : document).trigger(evt);
+
     if (!evt.isDefaultPrevented() && binding) {
       binding.onValueChange(evt.value);
     }

srcjs/utils.js

@@ -161,7 +161,14 @@ function pixelRatio() {
 // "with" on the argument value, and return the result.
 function scopeExprToFunc(expr) {
   /*jshint evil: true */
-  var expr_escaped = expr.replace(/[\\"']/g, '\\$&').replace(/\u0000/g, '\\0');
+  var expr_escaped = expr
+    .replace(/[\\"']/g, '\\$&')
+    .replace(/\u0000/g, '\\0')
+    .replace(/\n/g, '\\n')
+    .replace(/\r/g, '\\r')
+    // \b has a special meaning; need [\b] to match backspace char.
+    .replace(/[\b]/g, '\\b');
+
   try {
     var func = new Function(
       `with (this) {
@@ -279,6 +286,42 @@ function equal(...args) {
   return true;
 };
 
+// Compare version strings like "1.0.1", "1.4-2". `op` must be a string like
+// "==" or "<".
+exports.compareVersion = function(a, op, b) {
+  function versionParts(ver) {
+    return (ver + "")
+      .replace(/-/, ".")
+      .replace(/(\.0)+[^\.]*$/, "")
+      .split(".");
+  }
+
+  function cmpVersion(a, b) {
+    a = versionParts(a);
+    b = versionParts(b);
+    var len = Math.min(a.length, b.length);
+    var cmp;
+
+    for(var i=0; i<len; i++) {
+      cmp = parseInt(a[i], 10) - parseInt(b[i], 10);
+      if(cmp !== 0) {
+        return cmp;
+      }
+    }
+    return a.length - b.length;
+  }
+
+  var diff = cmpVersion(a, b);
+
+  if (op === "==")      return (diff === 0);
+  else if (op === ">=") return (diff >=  0);
+  else if (op === ">")  return (diff >   0);
+  else if (op === "<=") return (diff <=  0);
+  else if (op === "<")  return (diff <   0);
+  else                  throw `Unknown operator: ${op}`;
+};
+
+
 // multimethod: Creates functions — "multimethods" — that are polymorphic on one
 // or more of their arguments.
 //

tests/testthat/test-input-handler.R

@@ -1,7 +1,10 @@
 context("Parse Shiny Input")
 
 test_that("A new type can be registered successfully", {
-  registerInputHandler("shiny.someType", function(){})
+  expect_error(
+    registerInputHandler("shiny.someType", function(){}),
+    NA
+  )
 })
 
 test_that("A duplicated type throws", {
@@ -45,3 +48,34 @@ test_that("Nulls are not converted to NAs in parsing", {
     list(method="init", data=list(obs=500L, nullObs=NULL))
   )
 })
+
+
+test_that("characters turn into symbols", {
+  handler <- inputHandlers$get("shiny.symbol")
+  x <- "mpg"
+  expect_identical(
+    handler(x),
+    as.symbol(x)
+  )
+  expect_identical(
+    handler(NULL),
+    NULL
+  )
+})
+test_that("character vectors turn into symbol lists", {
+  handler <- inputHandlers$get("shiny.symbolList")
+  x <- list("mpg")
+  expect_identical(
+    handler(x),
+    list(as.symbol(x[[1]]))
+  )
+  x <- list("mpg", "cyl", "disp")
+  expect_identical(
+    handler(x),
+    list(as.symbol(x[[1]]), as.symbol(x[[2]]), as.symbol(x[[3]]))
+  )
+  expect_identical(
+    handler(NULL),
+    list()
+  )
+})

tests/testthat/test-js-version.R

@@ -0,0 +1,13 @@
+context("Validate Compiled shiny.js File")
+
+test_that("{{ VERSION }} was replaced", {
+  jsFiles <- system.file(
+    file.path("www", "shared", c("shiny.js", "shiny.min.js")),
+    package = "shiny"
+  )
+
+  lapply(jsFiles, function(jsFile) {
+    jsFileContent <- paste(suppressWarnings(readLines(jsFile)), collapse = "\n")
+    expect_false(grepl("\\{\\{\\sVERSION\\s\\}\\}", jsFileContent))
+  })
+})

tests/testthat/test-modules.R

@@ -56,3 +56,14 @@ test_that("reactiveValues with namespace", {
   expect_equivalent(isolate(names(rv1)), c("baz", "qux-quux"))
   expect_equivalent(isolate(names(rv2)), c("quux"))
 })
+
+test_that("implicit output respects module namespace", {
+  output <- new.env(parent = emptyenv())
+  ns <- NS("test")
+  result <- withReactiveDomain(list(output = output, ns = ns),
+    as.tags(renderText("hi"))
+  )
+  # Does the automatically-generated output id include the correct namespace qualifier?
+  # (See issue #2000)
+  expect_equivalent(result$attribs$id, ns(ls(output)))
+})

tests/testthat/test-plot-coordmap.R

@@ -6,14 +6,8 @@ sortList <- function(x) {
   x[sort(names(x))]
 }
 
-# Extract the print.ggplot function from inside of renderPlot. Yuck.
-print_ggplot_expr <- Filter(function(x) {
-  is.call(x) &&
-  x[[1]] == as.name("<-") &&
-  x[[2]] == as.name("print.ggplot")
-}, body(renderPlot))[[1]]
 # This will create print.ggplot in the current environment
-eval(print_ggplot_expr)
+print.ggplot <- custom_print.ggplot
 
 
 test_that("ggplot coordmap", {

tests/testthat/test-reactivity.r

@@ -779,8 +779,8 @@ test_that("classes of reactive object", {
 })
 
 test_that("{} and NULL also work in reactive()", {
-  reactive({})
-  reactive(NULL)
+  expect_error(reactive({}), NA)
+  expect_error(reactive(NULL), NA)
 })
 
 test_that("shiny.suppressMissingContextError option works", {
@@ -1127,3 +1127,20 @@ test_that("debounce/throttle work properly (with priming)", {
 test_that("debounce/throttle work properly (without priming)", {
   run_debounce_throttle(FALSE)
 })
+
+test_that("reactive domain works across async handlers", {
+  obj <- new.env()
+  hasReactiveDomain <- NULL
+  withReactiveDomain(obj, {
+    promises::then(
+      promises::promise_resolve(TRUE),
+      ~{hasReactiveDomain <<- identical(getDefaultReactiveDomain(), obj)}
+    )
+  })
+  
+  while (is.null(hasReactiveDomain) && !later::loop_empty()) {
+    later::run_now()
+  }
+  
+  testthat::expect_true(hasReactiveDomain)
+})

tests/testthat/test-stacks-deep.R

@@ -0,0 +1,47 @@
+context("deepstacks")
+
+describe("deep stack trace filtering", {
+  it("passes smoke test", {
+    st <- list(
+      c(
+        common <- c("1", "2", "..stacktraceoff..", "3", "..stacktracefloor.."),
+        "4", "..stacktraceon..", "5"
+      ),
+      c(common, "6", "..stacktraceoff..", "7"),
+      c(common, "8", "..stacktraceon.."),
+      c(common, "9")
+    )
+    
+    expect_equal(
+      stripStackTraces(values = TRUE, st),
+      jsonlite::fromJSON('[["1", "2", "5"],["6"],[],["9"]]')
+    )
+  })
+  
+  it("handles null cases", {
+    expect_equal(
+      stripStackTraces(values = TRUE, list(c())),
+      list(character(0))
+    )
+  })
+  
+  it("handles various edge cases", {
+    expect_equal(
+      stripStackTraces(values = TRUE, list(
+        c("..stacktraceoff..", "..stacktraceoff..")
+      )),
+      list(character(0))
+    )
+
+    expect_equal(
+      stripStackTraces(values = TRUE, list(
+        c("..stacktraceoff..", "..stacktraceoff.."),
+        c(),
+        c("..stacktraceon.."),
+        c("..stacktraceon.."),
+        c("1")
+      )),
+      list(character(0), character(0), character(0), character(0), "1")
+    )
+  })
+})

tests/testthat/test-stacks-pruning.R

@@ -0,0 +1,32 @@
+context("stack pruning")
+
+capture <- function() {
+  list(
+    calls = sys.calls(),
+    parents = sys.parents()
+  )
+}
+
+capture_1 <- function() {
+  capture()
+}
+
+capture_2 <- function() {
+  capture_1()
+}
+
+res <- do.call(
+  identity,
+  list(
+    identity(capture_2())
+  )
+)
+res$calls <- tail(res$calls, 5)
+res$parents <- tail(res$parents - (length(res$parents) - 5), 5)
+
+describe("stack pruning", {
+  it("passes basic example", {
+    expect_equal(pruneStackTrace(res$parents), c(F, F, T, T, T))
+    expect_equal(lapply(list(res$parents), pruneStackTrace), list(c(F, F, T, T, T)))
+  })
+})

tests/testthat/test-stacks.R

@@ -51,38 +51,48 @@ test_that("integration tests", {
   df <- causeError(full = FALSE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(32L, 31L, 30L, 19L, 18L, 17L, 16L, 15L,
-    8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
-  expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable",
-    "func", "origRenderFunc","renderTable({     C() }, server = FALSE)",
-    "isolate", "withCallingHandlers", "captureStackTraces", "doTryCatch",
-    "tryCatchOne", "tryCatchList", "tryCatch", "try"))
-  expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE,
-    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, FALSE,
-    FALSE, FALSE))
-
+  expect_equal(df$num, c(56L, 55L, 54L, 38L, 37L, 36L, 35L, 
+    34L, 33L, 32L, 31L, 30L))
+  expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable", 
+    "func", "force", "withVisible", "withCallingHandlers", "globals$domain$wrapSync", 
+    "promises::with_promise_domain", "captureStackTraces"))
+  expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
+  
   df <- causeError(full = TRUE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(35L, 34L, 33L, 32L, 31L, 30L, 29L, 28L,
-    27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L, 16L,
-    15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L,
-    2L, 1L))
-  expect_equal(df$call, c("h", ".handleSimpleError", "stop",
-    "A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible",
-    "withCallingHandlers", "contextFunc", "env$runWith", "withReactiveDomain",
-    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C",
-    "renderTable", "func", "origRenderFunc",
-    "renderTable({     C() }, server = FALSE)", "..stacktraceon..",
-    "contextFunc", "env$runWith", "withReactiveDomain", "ctx$run",
-    "..stacktraceoff..", "isolate", "withCallingHandlers",
-    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
+  expect_equal(df$num, c(59L, 58L, 57L, 56L, 55L, 54L, 53L, 
+    52L, 51L, 50L, 49L, 48L, 47L, 46L, 45L, 44L, 43L, 42L, 41L, 
+    40L, 39L, 38L, 37L, 36L, 35L, 34L, 33L, 32L, 31L, 30L, 29L, 
+    28L, 27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L, 
+    16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 
+    3L, 2L, 1L))
+  expect_equal(df$call, c("h", ".handleSimpleError", "stop", 
+    "A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible", 
+    "withCallingHandlers", "contextFunc", "env$runWith", "force", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "withReactiveDomain", "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C", 
+    "renderTable", "func", "force", "withVisible", "withCallingHandlers", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList", 
+    "tryCatch", "do", "hybrid_chain", "origRenderFunc", "renderTable({     C() }, server = FALSE)", 
+    "..stacktraceon..", "contextFunc", "env$runWith", "force", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "withReactiveDomain", "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "ctx$run", "..stacktraceoff..", "isolate", "withCallingHandlers", 
+    "globals$domain$wrapSync", "promises::with_promise_domain", 
+    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList", 
     "tryCatch", "try"))
-  expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE,
-    TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE,
-    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, TRUE,
-    FALSE, FALSE, FALSE, FALSE))
+  expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE, 
+    TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, 
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 
+    FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, 
+    FALSE))
 })
 
 test_that("shiny.error", {

tests/testthat/test-text.R

@@ -13,14 +13,14 @@ test_that("renderPrint and renderText behavior is correct", {
                '')
   expect_equal(isolate(renderPrint({ 1:5 })()),
                '[1] 1 2 3 4 5')
-  
+
   expect_equal(isolate(renderText({ "foo" })()),
                'foo')
   expect_equal(isolate(renderText({ invisible("foo") })()),
                'foo')
   # Capture the print output so it's not shown on console during test, and
   # also check that it is correct
-  print_out <- capture.output(ret <- isolate(renderText({ print("foo"); "bar"})()))
+  print_out <- utils::capture.output(ret <- isolate(renderText({ print("foo"); "bar"})()))
   expect_equal(ret, 'bar')
   expect_equal(print_out, '[1] "foo"')
   expect_equal(isolate(renderText({ NULL })()),
@@ -28,7 +28,7 @@ test_that("renderPrint and renderText behavior is correct", {
   expect_equal(isolate(renderText({ invisible() })()),
                '')
   expect_equal(isolate(renderText({ 1:5 })()),
-               '1 2 3 4 5')  
+               '1 2 3 4 5')
 })
 
 test_that("reactive functions save visibility state", {

tests/testthat/test-timer.R

@@ -23,3 +23,26 @@ test_that("Scheduling works", {
   expect_false(timerCallbacks$executeElapsed())
   expect_equal(0, nrow(timerCallbacks$takeElapsed()))
 })
+
+test_that("Unscheduling works", {
+  origTimes <- timerCallbacks$.times
+  origFuncKeys <- timerCallbacks$.funcs$keys()
+  
+  taskHandle <- scheduleTask(1000, function() {
+    message("Whatever")
+  })
+  # Unregister
+  taskHandle()
+  
+  expect_identical(timerCallbacks$.times, origTimes)
+  expect_identical(timerCallbacks$.funcs$keys(), origFuncKeys)
+})
+
+test_that("Vectorized unscheduling works", {
+  key1 <- timerCallbacks$schedule(1000, function() {})
+  key2 <- timerCallbacks$schedule(1000, function() {})
+  key3 <- timerCallbacks$schedule(1000, function() {})
+  
+  expect_identical(timerCallbacks$unschedule(key2), TRUE)
+  expect_identical(timerCallbacks$unschedule(c(key1, key2, key3)), c(TRUE, FALSE, TRUE))
+})

tests/testthat/test-ui.R

@@ -14,3 +14,49 @@ test_that("selectInput options are properly escaped", {
   expect_true(any(grepl("<option value=\"&#39;\">", si_str, fixed = TRUE)))
   expect_true(any(grepl("<optgroup label=\"&quot;Separators&quot;\">", si_str, fixed = TRUE)))
 })
+
+
+# For issue #1006
+test_that("sliderInput steps don't have rounding errors", {
+  # Need to use expect_identical; expect_equal is too forgiving of rounding error
+  expect_identical(findStepSize(-5.5, 4, NULL), 0.1)
+})
+
+
+test_that("selectInputUI has a select at an expected location", {
+  for (multiple in c(TRUE, FALSE)) {
+    for (selected in list(NULL, "", "A")) {
+      for (selectize in c(TRUE, FALSE)) {
+        selectInputVal <- selectInput(
+          inputId = "testId",
+          label = "test label",
+          choices = c("A", "B", "C"),
+          selected = selected,
+          multiple = multiple,
+          selectize = selectize
+        )
+        # if this getter is changed, varSelectInput getter needs to be changed
+        selectHtml <- selectInputVal$children[[2]]$children[[1]]
+        expect_true(inherits(selectHtml, "shiny.tag"))
+        expect_equal(selectHtml$name, "select")
+        if (!is.null(selectHtml$attribs$class)) {
+          expect_false(grepl(selectHtml$attribs$class, "symbol"))
+        }
+
+        varSelectInputVal <- varSelectInput(
+          inputId = "testId",
+          label = "test label",
+          data = data.frame(A = 1:2, B = 3:4, C = 5:6),
+          selected = selected,
+          multiple = multiple,
+          selectize = selectize
+        )
+        # if this getter is changed, varSelectInput getter needs to be changed
+        varSelectHtml <- varSelectInputVal$children[[2]]$children[[1]]
+        expect_true(inherits(varSelectHtml, "shiny.tag"))
+        expect_equal(varSelectHtml$name, "select")
+        expect_true(grepl("symbol", varSelectHtml$attribs$class, fixed = TRUE))
+      }
+    }
+  }
+})

tests/testthat/test-utils.R

@@ -6,7 +6,7 @@ test_that("Private randomness works at startup", {
     rm(".Random.seed", envir = .GlobalEnv)
   .globals$ownSeed <- NULL
   # Just make sure this doesn't blow up
-  createUniqueId(4)
+  expect_error(createUniqueId(4), NA)
 })
 
 test_that("Setting process-wide seed doesn't affect private randomness", {

tools/Gruntfile.js

@@ -74,6 +74,20 @@ module.exports = function(grunt) {
       },
     },
 
+    "string-replace": {
+      version: {
+        files: {
+          './temp_concat/shiny.js': './temp_concat/shiny.js'
+        },
+        options: {
+          replacements: [{
+            pattern: /{{\s*VERSION\s*}}/g,
+            replacement: pkgInfo().version
+          }]
+        }
+      }
+    },
+
     babel: {
       options: {
         sourceMap: true,
@@ -143,11 +157,7 @@ module.exports = function(grunt) {
       shiny: {
         files: ['<%= concat.shiny.src %>', '../DESCRIPTION'],
         tasks: [
-          'newer:concat',
-          'newer:eslint',
-          'configureBabel',
-          'newer:babel',
-          'newer:uglify'
+          'default'
         ]
       },
       datepicker: {
@@ -174,6 +184,7 @@ module.exports = function(grunt) {
 
   grunt.loadNpmTasks('grunt-contrib-clean');
   grunt.loadNpmTasks('grunt-contrib-concat');
+  grunt.loadNpmTasks('grunt-string-replace');
   grunt.loadNpmTasks('grunt-babel');
   grunt.loadNpmTasks('grunt-eslint');
   grunt.loadNpmTasks('grunt-contrib-uglify');
@@ -187,10 +198,23 @@ module.exports = function(grunt) {
     gruntConfig.babel.options.inputSourceMap = grunt.file.readJSON('./temp_concat/shiny.js.map');
   });
 
+  grunt.task.registerTask(
+    "validateStringReplace",
+    "tests to make sure the version value was replaced",
+    function() {
+      var shinyContent = require('fs').readFileSync('./temp_concat/shiny.js', 'utf8');
+      if (/{{\s*VERSION\s*}}/.test(shinyContent)) {
+        grunt.fail.fatal("{{ VERSION }} was not replaced in compiled shiny.js file!")
+      }
+    }
+  );
+
   grunt.initConfig(gruntConfig);
 
   grunt.registerTask('default', [
     'newer:concat',
+    'newer:string-replace',
+    'validateStringReplace',
     'newer:eslint',
     'configureBabel',
     'newer:babel',

tools/package.json

@@ -11,6 +11,7 @@
     "grunt-contrib-uglify": "1.0.1",
     "grunt-contrib-watch": "^1.0.0",
     "grunt-eslint": "^18.0.0",
-    "grunt-newer": "^1.1.2"
+    "grunt-newer": "^1.1.2",
+    "grunt-string-replace": "^1.3.1"
   }
 }

tools/yarn.lock

@@ -83,6 +83,12 @@ async@^1.5.0, async@^1.5.2, async@~1.5.2:
   version "1.5.2"
   resolved "https://registry.yarnpkg.com/async/-/async-1.5.2.tgz#ec6a61ae56480c0c3cb241c95618e20892f9672a"
 
+async@^2.0.0:
+  version "2.5.0"
+  resolved "https://registry.yarnpkg.com/async/-/async-2.5.0.tgz#843190fd6b7357a0b9e1c956edddd5ec8462b54d"
+  dependencies:
+    lodash "^4.14.0"
+
 async@~0.2.6:
   version "0.2.10"
   resolved "https://registry.yarnpkg.com/async/-/async-0.2.10.tgz#b6bbe0b0674b9d719708ca38de8c237cb526c3d1"
@@ -1120,6 +1126,13 @@ grunt-newer@^1.1.2:
     async "^1.5.2"
     rimraf "^2.5.2"
 
+grunt-string-replace@^1.3.1:
+  version "1.3.1"
+  resolved "https://registry.yarnpkg.com/grunt-string-replace/-/grunt-string-replace-1.3.1.tgz#633a03bc78482a0e0e1f9df7f645811fc1fbb162"
+  dependencies:
+    async "^2.0.0"
+    chalk "^1.0.0"
+
 grunt@^1.0.1:
   version "1.0.1"
   resolved "https://registry.yarnpkg.com/grunt/-/grunt-1.0.1.tgz#e8778764e944b18f32bb0f10b9078475c9dfb56b"
@@ -1386,7 +1399,7 @@ lodash@^3.10.1, lodash@~3.10.1:
   version "3.10.1"
   resolved "https://registry.yarnpkg.com/lodash/-/lodash-3.10.1.tgz#5bf45e8e49ba4189e17d482789dfd15bd140b7b6"
 
-lodash@^4.0.0, lodash@^4.0.1, lodash@^4.2.0, lodash@^4.3.0:
+lodash@^4.0.0, lodash@^4.0.1, lodash@^4.14.0, lodash@^4.2.0, lodash@^4.3.0:
   version "4.16.4"
   resolved "https://registry.yarnpkg.com/lodash/-/lodash-4.16.4.tgz#01ce306b9bad1319f2a5528674f88297aeb70127"