Add worker id info to state parameter

Should allow Connect/SSP to reliably route oauth handshakes
among multiple R processes for the same app

.github/ISSUE_TEMPLATE/bug_report.md

@@ -0,0 +1,40 @@
+---
+name  : Bug report
+about : Report a bug in Shiny.
+---
+
+<!--
+This issue tracker is for bugs and feature requests in the Shiny package. If you're having trouble with Shiny Server or a related package, please file an issue in the appropriate repository. 
+
+If you're having trouble with shinyapps.io, and you have a paid account (Starter, Basic, Standard, or Pro), please file a support ticket via https://support.rstudio.com. If you have a Free account, please post to the RStudio Community with the shinyappsio tag: https://community.rstudio.com/tags/shinyappsio.
+
+Finally, if you are an RStudio customer and are having trouble with one of our Pro products, get in touch with our support team at support@rstudio.com.
+
+Before you file an issue, please upgrade to the latest version of Shiny from CRAN and confirm that the problem persists.
+
+# First, restart R.
+# To install latest shiny from CRAN:
+install.packages("shiny")
+
+See our guide to writing good bug reports for further guidance: https://github.com/rstudio/shiny/wiki/Writing-Good-Bug-Reports. The better your report is, the likelier we are to be able to reproduce and ultimately solve it.
+-->
+
+### System details
+
+Browser Version: <!-- If applicable -->
+
+Output of `sessionInfo()`:
+
+```
+# sessionInfo() output goes here
+```
+
+### Example application *or* steps to reproduce the problem
+
+<!-- If you're able to create one, a reproducible example is extremely helpful to us. For instructions on how to create one, please see: https://github.com/rstudio/shiny/wiki/Creating-a-Reproducible-Example --> 
+
+```R
+# Minimal, self-contained example app code goes here
+```
+
+### Describe the problem in detail

.github/ISSUE_TEMPLATE/feature_request.md

@@ -0,0 +1,17 @@
+---
+name  : Feature request
+about : Request a new feature.
+---
+
+<!--
+
+Thanks for taking the time to file a feature request! Please take the time to search for an existing feature request, to avoid creating duplicate requests. If you find an existing feature request, please give it a thumbs-up reaction, as we'll use these reactions to help prioritize the implementation of these features in the future.
+
+If the feature has not yet been filed, then please describe the feature you'd like to see become a part of Shiny. See:
+
+https://github.com/rstudio/shiny/wiki/Writing-Good-Feature-Requests
+
+for a guide on how to write good feature requests.
+
+-->
+

.github/ISSUE_TEMPLATE/question.md

@@ -0,0 +1,7 @@
+---
+name  : Ask a Question
+about : The issue tracker is not for questions -- please ask questions at https://community.rstudio.com/c/shiny.
+---
+
+The issue tracker is not for questions. If you have a question, please feel free to ask it on our community site, at https://community.rstudio.com/c/shiny.
+

.gitignore

@@ -9,3 +9,4 @@
 shinyapps/
 README.html
 .*.Rnb.cached
+tools/yarn-error.log

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.2.0
+Version: 1.3.2.9000
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -65,12 +65,12 @@ Depends:
 Imports:
     utils,
     grDevices,
-    httpuv (>= 1.4.4),
+    httpuv (>= 1.5.0),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
     digest,
-    htmltools (>= 0.3.5),
+    htmltools (>= 0.3.6),
     R6 (>= 2.0),
     sourcetools,
     later (>= 0.7.2),
@@ -86,6 +86,7 @@ Suggests:
     markdown,
     rmarkdown,
     ggplot2,
+    reactlog (>= 1.0.0),
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
@@ -106,6 +107,7 @@ Collate:
     'cache-utils.R'
     'diagnose.R'
     'fileupload.R'
+    'font-awesome.R'
     'graph.R'
     'reactives.R'
     'reactive-domains.R'
@@ -159,4 +161,5 @@ Collate:
     'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
+Encoding: UTF-8

NAMESPACE

@@ -40,6 +40,7 @@ export(absolutePanel)
 export(actionButton)
 export(actionLink)
 export(addResourcePath)
+export(addRouteHandler)
 export(animationOptions)
 export(appendTab)
 export(as.shiny.appobj)
@@ -189,6 +190,9 @@ export(reactiveUI)
 export(reactiveVal)
 export(reactiveValues)
 export(reactiveValuesToList)
+export(reactlog)
+export(reactlogReset)
+export(reactlogShow)
 export(registerInputHandler)
 export(removeInputHandler)
 export(removeModal)

NEWS.md

@@ -1,3 +1,82 @@
+shiny 1.3.2.9000
+=======
+
+## Changes
+
+* Resolved ([#1433](https://github.com/rstudio/shiny/issues/1433)): `plotOutput()`'s coordmap info now includes discrete axis limits for **ggplot2** plots. As a result, any **shinytest** tests that contain **ggplot2** plots with discrete axes (that were recorded before this change) will now report differences that can safely be updated. This new coordmap info was added to correctly infer what data points are within an input brush and/or near input click/hover in scenarios where a non-trivial discrete axis scale is involved (e.g., whenever `scale_[x/y]_discrete(limits = ...)` and/or free scales across multiple discrete axes are used). ([#2410](https://github.com/rstudio/shiny/pull/2410))
+
+### Improvements
+
+* Resolved ([#2402](https://github.com/rstudio/shiny/issues/2402)): An informative warning is now thrown for mis-specified (date) strings in `dateInput()`, `updateDateInput()`, `dateRangeInput()`, and `updateDateRangeInput()`. ([#2403](https://github.com/rstudio/shiny/pull/2403))
+
+### Bug fixes
+
+* Fixed [#2387](https://github.com/rstudio/shiny/issues/2387): Updating a `sliderInput()`'s type from numeric to date no longer changes the rate policy from debounced to immediate. More generally, updating an input binding with a new type should (no longer) incorrectly alter the input rate policy. ([#2404](https://github.com/rstudio/shiny/pull/2404))
+
+* Fixed [#868](https://github.com/rstudio/shiny/issues/868): If an input is initialized with a `NULL` label, it can now be updated with a string. Moreover, if an input label is initialized with a string, it can now be removed by updating with `label=character(0)` (similar to how `choices` and `selected` can be cleared in `updateSelectInput()`). ([#2406](https://github.com/rstudio/shiny/pull/2406))
+
+* Fixed [#2250](https://github.com/rstudio/shiny/issues/2250): `updateSliderInput()` now works with un-specified (or zero-length) `min`, `max`, and `value`. ([#2416](https://github.com/rstudio/shiny/pull/2416))
+
+* Fixed [#2396](https://github.com/rstudio/shiny/issues/2396): `selectInput("myID", ...)` resulting in an extra `myID-selectized` input (introduced in v1.2.0). ([#2418](https://github.com/rstudio/shiny/pull/2418))
+
+* Fixed [#2233](https://github.com/rstudio/shiny/issues/2233): `verbatimTextOutput()` produced wrapped text on Safari, but the text should not be wrapped. ([#2353](https://github.com/rstudio/shiny/pull/2353))
+
+* Fixed [rstudio/reactlog#36](https://github.com/rstudio/reactlog/issues/36): Changes to reactive values not displaying accurately in reactlog. ([#2424](https://github.com/rstudio/shiny/pull/2424))
+
+* Fixed [#2329](https://github.com/rstudio/shiny/issues/2329), [#1817](https://github.com/rstudio/shiny/issues/1817): These bugs were reported as fixed in Shiny 1.3.0 but were not actually fixed because some JavaScript changes were accidentally not included in the release. The fix resolves issues that occur when `withProgressBar()` or bookmarking are combined with the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot.
+
+shiny 1.3.2
+===========
+
+### Bug fixes
+
+* Fixed [#2285](https://github.com/rstudio/shiny/issues/2285), [#2288](https://github.com/rstudio/shiny/issues/2288): Static CSS/JS resources in subapps in R Markdown documents did not render properly. ([#2386](https://github.com/rstudio/shiny/pull/2386))
+
+* Fixed [#2280](https://github.com/rstudio/shiny/issues/2280): Shiny applications that used a www/index.html file did not serve up the index file. ([#2382](https://github.com/rstudio/shiny/pull/2382))
+
+
+shiny 1.3.1
+===========
+
+## Full changelog
+
+### Bug fixes
+
+* Fixed a performance issue introduced in v1.3.0 when using large nested lists within Shiny. ([#2377](https://github.com/rstudio/shiny/pull/2377))
+
+
+shiny 1.3.0
+===========
+
+## Full changelog
+
+### Breaking changes
+
+### New features
+
+* Revamped Shiny's [reactlog](https://github.com/rstudio/reactlog) viewer which debugs reactivity within a shiny application.  This allows users to traverse the reactivity history of a shiny application, filter to the dependency tree of a selected reactive object, and search for matching reactive objects.  See `?reactlogShow` for more details and how to enable this feature. ([#2107](https://github.com/rstudio/shiny/pull/2107))
+
+* Shiny now serves static files on a background thread. This means that things like JavaScript and CSS assets can be served without blocking or being blocked by the main R thread, and should result in significantly better performance for heavily loaded servers. ([#2280](https://github.com/rstudio/shiny/pull/2280))
+
+### Minor new features and improvements
+
+* The `Shiny-Shared-Secret` security header is now checked using constant-time comparison to prevent timing attacks (thanks @dirkschumacher!). ([#2319](https://github.com/rstudio/shiny/pull/2319))
+
+### Bug fixes
+
+* Fixed [#2245](https://github.com/rstudio/shiny/issues/2245): `updateSelectizeInput()` did not update labels. ([#2248](https://github.com/rstudio/shiny/pull/2248))
+
+* Fixed [#2308](https://github.com/rstudio/shiny/issues/2308): When restoring a bookmarked application, inputs with a leading `.` would not be restored. ([#2311](https://github.com/rstudio/shiny/pull/2311))
+
+* Fixed [#2305](https://github.com/rstudio/shiny/issues/2305), [#2322](https://github.com/rstudio/shiny/issues/2322), [#2351](https://github.com/rstudio/shiny/issues/2351): When an input in dynamic UI is restored from bookmarks, it would keep getting set to the same value. ([#2360](https://github.com/rstudio/shiny/pull/2360))
+
+* Fixed [#2349](https://github.com/rstudio/shiny/issues/2349), [#2329](https://github.com/rstudio/shiny/issues/2329), [#1817](https://github.com/rstudio/shiny/issues/1817): These were various bugs triggered by the presence of the [networkD3](https://christophergandrud.github.io/networkD3/) package's Sankey plot in an app. Impacted features included `dateRangeInput`, `withProgressBar`, and bookmarking ([#2359](https://github.com/rstudio/shiny/pull/2359))
+
+### Documentation Updates
+
+* Fixed [#2247](https://github.com/rstudio/shiny/issues/2247): `renderCachedPlot` now supports using promises for either `expr` or `cacheKeyExpr`. (Shiny v1.2.0 supported async `expr`, but only if `cacheKeyExpr` was async as well; now you can use any combination of sync/async for `expr` and `cacheKeyExpr`.) [#2261](https://github.com/rstudio/shiny/pull/2261)
+
+
 shiny 1.2.0
 ===========
 
@@ -5,13 +84,17 @@ This release features plot caching, an important new tool for improving performa
 
 ## Full changelog
 
+### Breaking changes
+
+* The URL paths for FontAwesome CSS/JS/font assets have changed, due to our upgrade from FontAwesome 4 to 5. This shouldn't affect you unless you're using `www/index.html` to provide your UI and have hardcoded the old FontAwesome paths into your HTML. If that's you, consider switching to [HTML templates](https://shiny.rstudio.com/articles/templates.html), which give you the syntax of raw HTML while still taking advantage of Shiny's automatic management of web dependencies.
+
 ### New features
 
 * Added `renderCachedPlot()`, which stores plots in a cache so that they can be served up almost instantly. ([#1997](https://github.com/rstudio/shiny/pull/1997))
 
 ### Minor new features and improvements
 
-* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable [#2186](https://github.com/rstudio/shiny/issues/2186).
+* Upgrade FontAwesome from 4.7.0 to 5.3.1 and made `icon` tags browsable, which means they will display in a web browser or RStudio viewer by default ([#2186](https://github.com/rstudio/shiny/issues/2186)). Note that if your application or library depends on FontAwesome directly using custom CSS, you may need to make some or all of the changes recommended in [Upgrade from Version 4](https://fontawesome.com/how-to-use/on-the-web/setup/upgrading-from-version-4). Font Awesome icons can also now be used in static R Markdown documents.
 
 * Address [#174](https://github.com/rstudio/shiny/issues/174): Added `datesdisabled` and `daysofweekdisabled` as new parameters to `dateInput()`. This resolves [#174](https://github.com/rstudio/shiny/issues/174) and exposes the underlying arguments of [Bootstrap Datepicker](http://bootstrap-datepicker.readthedocs.io/en/latest/options.html#datesdisabled). `datesdisabled` expects a character vector with values in `yyyy/mm/dd` format and `daysofweekdisabled` expects an integer vector with day interger ids (Sunday=0, Saturday=6). The default value for both is `NULL`, which leaves all days selectable. Thanks, @nathancday! ([#2147](https://github.com/rstudio/shiny/pull/2147))
 
@@ -47,6 +130,12 @@ This release features plot caching, an important new tool for improving performa
 
 * Fixed [#2142](https://github.com/rstudio/shiny/issues/2142): Dropping files on `fileInput`s stopped working on recent releases of Firefox. Thanks @dmenne for reporting! [#2203](https://github.com/rstudio/shiny/pull/2203)
 
+* Fixed [#2204](https://github.com/rstudio/shiny/issues/2204): `updateDateInput` could set the wrong date on days where DST begins. (Thanks @GaGaMan1101!) [#2212](https://github.com/rstudio/shiny/pull/2212)
+
+* Fixed [#2225](https://github.com/rstudio/shiny/issues/2225): Input event queue can stall in apps that use async. [#2226](https://github.com/rstudio/shiny/pull/2226)
+
+* Fixed [#2228](https://github.com/rstudio/shiny/issues/2228): `reactiveTimer` fails when not owned by a session. Thanks, @P-Bettega! [#2229](https://github.com/rstudio/shiny/pull/2229)
+
 ### 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))
@@ -107,7 +196,7 @@ This is a significant release for Shiny, with a major new feature that was nearl
 
 * 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))
+* Changed script tags in reactlog ([inst/www/reactive-graph.html](https://github.com/rstudio/shiny/blob/v1.1.0/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.
 

R/app.R

@@ -170,7 +170,14 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
   }
 
   wwwDir <- file.path.ci(appDir, "www")
+  if (dirExists(wwwDir)) {
+    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
+  } else {
+    staticPaths <- list()
+  }
+
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
+
   serverSource <- cachedFuncWithFile(appDir, "server.R", case.sensitive = FALSE,
     function(serverR) {
       # If server.R contains a call to shinyServer (which sets .globals$server),
@@ -220,6 +227,13 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
 
   structure(
     list(
+      staticPaths = staticPaths,
+      # Even though the wwwDir is handled as a static path, we need to include
+      # it here to be handled by R as well. This is because the special case
+      # of index.html: it is specifically not handled as a staticPath for
+      # reasons explained above, but if someone does want to serve up an
+      # index.html, we need to handle it, and we do it by using the
+      # staticHandler in the R code path. (#2380)
       httpHandler = joinHandlers(c(uiHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = serverFuncSource,
       onStart = onStart,
@@ -309,6 +323,20 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
   }
 
   wwwDir <- file.path.ci(appDir, "www")
+  if (dirExists(wwwDir)) {
+    # wwwDir is a static path served by httpuv. It does _not_ serve up
+    # index.html, for two reasons. (1) It's possible that the user's
+    # www/index.html file is not actually used as the index, but as a template
+    # that gets processed before being sent; and (2) the index content may be
+    # modified by the hosting environment (as in SockJSAdapter.R).
+    #
+    # The call to staticPath normalizes the path, so that if the working dir
+    # later changes, it will continue to point to the right place.
+    staticPaths <- list("/" = staticPath(wwwDir, indexhtml = FALSE, fallthrough = TRUE))
+  } else {
+    staticPaths <- list()
+  }
+
   fallbackWWWDir <- system.file("www-dir", package = "shiny")
 
   oldwd <- NULL
@@ -327,6 +355,18 @@ shinyAppDir_appR <- function(fileName, appDir, options=list())
 
   structure(
     list(
+      # fallbackWWWDir is _not_ listed in staticPaths, because it needs to
+      # come after the uiHandler. It also does not need to be fast, since it
+      # should rarely be hit. The order is wwwDir (in staticPaths), then
+      # uiHandler, then falbackWWWDir (which is served up by the R
+      # staticHandler function).
+      staticPaths = staticPaths,
+      # Even though the wwwDir is handled as a static path, we need to include
+      # it here to be handled by R as well. This is because the special case
+      # of index.html: it is specifically not handled as a staticPath for
+      # reasons explained above, but if someone does want to serve up an
+      # index.html, we need to handle it, and we do it by using the
+      # staticHandler in the R code path. (#2380)
       httpHandler = joinHandlers(c(dynHttpHandler, wwwDir, fallbackWWWDir)),
       serverFuncSource = dynServerFuncSource,
       onStart = onStart,

R/bookmark-state.R

@@ -426,7 +426,7 @@ RestoreInputSet <- R6Class("RestoreInputSet",
     },
 
     asList = function() {
-      as.list.environment(private$values)
+      as.list.environment(private$values, all.names = TRUE)
     }
   )
 )

R/bootstrap.R

@@ -1508,10 +1508,6 @@ downloadLink <- function(outputId, label="Download", class=NULL, ...) {
 #'
 #'
 #' @examples
-#' icon("calendar")               # standard icon
-#' icon("calendar", "fa-3x")      # 3x normal size
-#' icon("cog", lib = "glyphicon") # From glyphicon library
-#'
 #' # add an icon to a submit button
 #' submitButton("Update View", icon = icon("refresh"))
 #'
@@ -1537,8 +1533,13 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # build the icon class (allow name to be null so that other functions
   # e.g. buildTabset can pass an explicit class value)
   iconClass <- ""
-  if (!is.null(name))
-    iconClass <- paste0(prefix, " ", prefix, "-", name)
+  if (!is.null(name)) {
+    prefix_class <- prefix
+    if (prefix_class == "fa" && name %in% font_awesome_brands) {
+      prefix_class <- "fab"
+    }
+    iconClass <- paste0(prefix_class, " ", prefix, "-", name)
+  }
   if (!is.null(class))
     iconClass <- paste(iconClass, class)
 

R/font-awesome.R

@@ -0,0 +1,75 @@
+font_awesome_brands <- c(
+  "500px", "accessible-icon", "accusoft", "adn", "adversal",
+  "affiliatetheme", "algolia", "alipay", "amazon", "amazon-pay",
+  "amilia", "android", "angellist", "angrycreative", "angular",
+  "app-store", "app-store-ios", "apper", "apple", "apple-pay",
+  "asymmetrik", "audible", "autoprefixer", "avianex", "aviato",
+  "aws", "bandcamp", "behance", "behance-square", "bimobject",
+  "bitbucket", "bitcoin", "bity", "black-tie", "blackberry", "blogger",
+  "blogger-b", "bluetooth", "bluetooth-b", "btc", "buromobelexperte",
+  "buysellads", "cc-amazon-pay", "cc-amex", "cc-apple-pay", "cc-diners-club",
+  "cc-discover", "cc-jcb", "cc-mastercard", "cc-paypal", "cc-stripe",
+  "cc-visa", "centercode", "chrome", "cloudscale", "cloudsmith",
+  "cloudversify", "codepen", "codiepie", "connectdevelop", "contao",
+  "cpanel", "creative-commons", "creative-commons-by", "creative-commons-nc",
+  "creative-commons-nc-eu", "creative-commons-nc-jp", "creative-commons-nd",
+  "creative-commons-pd", "creative-commons-pd-alt", "creative-commons-remix",
+  "creative-commons-sa", "creative-commons-sampling", "creative-commons-sampling-plus",
+  "creative-commons-share", "css3", "css3-alt", "cuttlefish", "d-and-d",
+  "dashcube", "delicious", "deploydog", "deskpro", "deviantart",
+  "digg", "digital-ocean", "discord", "discourse", "dochub", "docker",
+  "draft2digital", "dribbble", "dribbble-square", "dropbox", "drupal",
+  "dyalog", "earlybirds", "ebay", "edge", "elementor", "ello",
+  "ember", "empire", "envira", "erlang", "ethereum", "etsy", "expeditedssl",
+  "facebook", "facebook-f", "facebook-messenger", "facebook-square",
+  "firefox", "first-order", "first-order-alt", "firstdraft", "flickr",
+  "flipboard", "fly", "font-awesome", "font-awesome-alt", "font-awesome-flag",
+  "font-awesome-logo-full", "fonticons", "fonticons-fi", "fort-awesome",
+  "fort-awesome-alt", "forumbee", "foursquare", "free-code-camp",
+  "freebsd", "fulcrum", "galactic-republic", "galactic-senate",
+  "get-pocket", "gg", "gg-circle", "git", "git-square", "github",
+  "github-alt", "github-square", "gitkraken", "gitlab", "gitter",
+  "glide", "glide-g", "gofore", "goodreads", "goodreads-g", "google",
+  "google-drive", "google-play", "google-plus", "google-plus-g",
+  "google-plus-square", "google-wallet", "gratipay", "grav", "gripfire",
+  "grunt", "gulp", "hacker-news", "hacker-news-square", "hackerrank",
+  "hips", "hire-a-helper", "hooli", "hornbill", "hotjar", "houzz",
+  "html5", "hubspot", "imdb", "instagram", "internet-explorer",
+  "ioxhost", "itunes", "itunes-note", "java", "jedi-order", "jenkins",
+  "joget", "joomla", "js", "js-square", "jsfiddle", "kaggle", "keybase",
+  "keycdn", "kickstarter", "kickstarter-k", "korvue", "laravel",
+  "lastfm", "lastfm-square", "leanpub", "less", "line", "linkedin",
+  "linkedin-in", "linode", "linux", "lyft", "magento", "mailchimp",
+  "mandalorian", "markdown", "mastodon", "maxcdn", "medapps", "medium",
+  "medium-m", "medrt", "meetup", "megaport", "microsoft", "mix",
+  "mixcloud", "mizuni", "modx", "monero", "napster", "neos", "nimblr",
+  "nintendo-switch", "node", "node-js", "npm", "ns8", "nutritionix",
+  "odnoklassniki", "odnoklassniki-square", "old-republic", "opencart",
+  "openid", "opera", "optin-monster", "osi", "page4", "pagelines",
+  "palfed", "patreon", "paypal", "periscope", "phabricator", "phoenix-framework",
+  "phoenix-squadron", "php", "pied-piper", "pied-piper-alt", "pied-piper-hat",
+  "pied-piper-pp", "pinterest", "pinterest-p", "pinterest-square",
+  "playstation", "product-hunt", "pushed", "python", "qq", "quinscape",
+  "quora", "r-project", "ravelry", "react", "readme", "rebel",
+  "red-river", "reddit", "reddit-alien", "reddit-square", "rendact",
+  "renren", "replyd", "researchgate", "resolving", "rev", "rocketchat",
+  "rockrms", "safari", "sass", "schlix", "scribd", "searchengin",
+  "sellcast", "sellsy", "servicestack", "shirtsinbulk", "shopware",
+  "simplybuilt", "sistrix", "sith", "skyatlas", "skype", "slack",
+  "slack-hash", "slideshare", "snapchat", "snapchat-ghost", "snapchat-square",
+  "soundcloud", "speakap", "spotify", "squarespace", "stack-exchange",
+  "stack-overflow", "staylinked", "steam", "steam-square", "steam-symbol",
+  "sticker-mule", "strava", "stripe", "stripe-s", "studiovinari",
+  "stumbleupon", "stumbleupon-circle", "superpowers", "supple",
+  "teamspeak", "telegram", "telegram-plane", "tencent-weibo", "the-red-yeti",
+  "themeco", "themeisle", "trade-federation", "trello", "tripadvisor",
+  "tumblr", "tumblr-square", "twitch", "twitter", "twitter-square",
+  "typo3", "uber", "uikit", "uniregistry", "untappd", "usb", "ussunnah",
+  "vaadin", "viacoin", "viadeo", "viadeo-square", "viber", "vimeo",
+  "vimeo-square", "vimeo-v", "vine", "vk", "vnv", "vuejs", "weebly",
+  "weibo", "weixin", "whatsapp", "whatsapp-square", "whmcs", "wikipedia-w",
+  "windows", "wix", "wolf-pack-battalion", "wordpress", "wordpress-simple",
+  "wpbeginner", "wpexplorer", "wpforms", "xbox", "xing", "xing-square",
+  "y-combinator", "yahoo", "yandex", "yandex-international", "yelp",
+  "yoast", "youtube", "youtube-square", "zhihu"
+)

R/graph.R

@@ -1,13 +1,58 @@
-writeReactLog <- function(file=stdout(), sessionToken = NULL) {
-  log <- .graphStack$as_list()
-  if (!is.null(sessionToken)) {
-    log <- Filter(function(x) {
-      is.null(x$session) || identical(x$session, sessionToken)
-    }, log)
-  }
-  cat(toJSON(log, pretty=TRUE), file=file)
+is_installed <- function(package, version) {
+  installedVersion <- tryCatch(utils::packageVersion(package), error = function(e) NA)
+  !is.na(installedVersion) && installedVersion >= version
 }
 
+# Check that the version of an suggested package satisfies the requirements
+#
+# @param package The name of the suggested package
+# @param version The version of the package
+check_suggested <- function(package, version, location) {
+
+  if (is_installed(package, version)) {
+    return()
+  }
+
+  missing_location <- missing(location)
+  msg <- paste0(
+    sQuote(package),
+    if (is.na(version)) "" else paste0("(>= ", version, ")"),
+    " must be installed for this functionality.",
+    if (!missing_location)
+      paste0(
+        "\nPlease install the missing package: \n",
+        "  source(\"https://install-github.me/", location, "\")"
+      )
+  )
+
+  if (interactive() && missing_location) {
+    message(msg, "\nWould you like to install it?")
+    if (utils::menu(c("Yes", "No")) == 1) {
+      return(utils::install.packages(package))
+    }
+  }
+
+  stop(msg, call. = FALSE)
+}
+
+
+
+
+# domain is like session
+
+
+# used to help define truly global react id's.
+# should work across session and in global namespace
+.globals$reactIdCounter <- 0L
+nextGlobalReactId <- function() {
+  .globals$reactIdCounter <- .globals$reactIdCounter + 1L
+  reactIdStr(.globals$reactIdCounter)
+}
+reactIdStr <- function(num) {
+  paste0("r", num)
+}
+
+
 #' Reactive Log Visualizer
 #'
 #' Provides an interactive browser-based tool for visualizing reactive
@@ -30,88 +75,499 @@ writeReactLog <- function(file=stdout(), sessionToken = NULL) {
 #'
 #' As an alternative to pressing Ctrl/Command+F3--for example, if you
 #' are using reactives outside of the context of a Shiny
-#' application--you can run the \code{showReactLog} function, which will
+#' application--you can run the \code{reactlogShow} function, which will
 #' generate the reactive log visualization as a static HTML file and
 #' launch it in your default browser. In this case, refreshing your
 #' browser will not load new activity into the report; you will need to
-#' call \code{showReactLog()} explicitly.
+#' call \code{reactlogShow()} explicitly.
 #'
 #' For security and performance reasons, do not enable
 #' \code{shiny.reactlog} in production environments. When the option is
 #' enabled, it's possible for any user of your app to see at least some
 #' of the source code of your reactive expressions and observers.
 #'
-#' @param time A boolean that specifies whether or not to display the
-#' time that each reactive.
+#' @name reactlog
+NULL
+
+
+#' @describeIn reactlog Return a list of reactive information.  Can be used in conjunction with
+#'   \code{reactlog::\link[reactlog]{reactlog_show}} to later display the reactlog graph.
 #' @export
+reactlog <- function() {
+  rLog$asList()
+}
+
+#' @describeIn reactlog Display a full reactlog graph for all sessions.
+#' @inheritParams reactlog::reactlog_show
+#' @export
+reactlogShow <- function(time = TRUE) {
+  check_reactlog()
+  reactlog::reactlog_show(reactlog(), time = time)
+}
+#' @describeIn reactlog This function is deprecated. You should use \code{\link{reactlogShow}}
+#' @export
+# legacy purposes
 showReactLog <- function(time = TRUE) {
-  utils::browseURL(renderReactLog(time = as.logical(time)))
+  shinyDeprecated(new = "`reactlogShow`", version = "1.2.0")
+  reactlogShow(time = time)
+}
+#' @describeIn reactlog Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
+#' @export
+reactlogReset <- function() {
+  rLog$reset()
 }
 
-renderReactLog <- function(sessionToken = NULL, time = TRUE) {
-  templateFile <- system.file('www/reactive-graph.html', package='shiny')
-  html <- paste(readLines(templateFile, warn=FALSE), collapse='\r\n')
-  tc <- textConnection(NULL, 'w')
-  on.exit(close(tc))
-  writeReactLog(tc, sessionToken)
-  cat('\n', file=tc)
-  flush(tc)
-  html <- sub('__DATA__', paste(textConnectionValue(tc), collapse='\r\n'), html, fixed=TRUE)
-  html <- sub('__TIME__', paste0('"', time, '"'), html, fixed=TRUE)
-  file <- tempfile(fileext = '.html')
-  writeLines(html, file)
-  return(file)
+# called in "/reactlog" middleware
+renderReactlog <- function(sessionToken = NULL, time = TRUE) {
+  check_reactlog()
+  reactlog::reactlog_render(
+    reactlog(),
+    session_token = sessionToken,
+    time = time
+  )
 }
+check_reactlog <- function() {
+  check_suggested("reactlog", reactlog_version())
+}
+# read reactlog version from description file
+# prevents version mismatch in code and description file
+reactlog_version <- function() {
+  desc <- read.dcf(system.file("DESCRIPTION", package = "shiny", mustWork = TRUE))
+  suggests <- desc[1,"Suggests"][[1]]
+  suggests_pkgs <- strsplit(suggests, "\n")[[1]]
 
-.graphAppend <- function(logEntry, domain = getDefaultReactiveDomain()) {
-  if (isTRUE(getOption('shiny.reactlog'))) {
-    sessionToken <- if (is.null(domain)) NULL else domain$token
-    .graphStack$push(c(logEntry, list(
-      session = sessionToken,
-      time = as.numeric(Sys.time())
-    )))
+  reactlog_info <- suggests_pkgs[grepl("reactlog", suggests_pkgs)]
+  if (length(reactlog_info) == 0) {
+    stop("reactlog can not be found in shiny DESCRIPTION file")
   }
 
-  if (!is.null(domain)) {
-    domain$reactlog(logEntry)
-  }
+  reactlog_info <- sub("^[^\\(]*\\(", "", reactlog_info)
+  reactlog_info <- sub("\\)[^\\)]*$", "", reactlog_info)
+  reactlog_info <- sub("^[>= ]*", "", reactlog_info)
+
+  package_version(reactlog_info)
 }
 
-.graphDependsOn <- function(id, label) {
-  .graphAppend(list(action='dep', id=id, dependsOn=label))
-}
 
-.graphDependsOnId <- function(id, dependee) {
-  .graphAppend(list(action='depId', id=id, dependsOn=dependee))
-}
+RLog <- R6Class(
+  "RLog",
+  portable = FALSE,
+  private = list(
+    option = "shiny.reactlog",
+    msgOption = "shiny.reactlog.console",
 
-.graphCreateContext <- function(id, label, type, prevId, domain) {
-  .graphAppend(list(
-    action='ctx', id=id, label=paste(label, collapse='\n'),
-    srcref=as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile"),
-    type=type, prevId=prevId
-  ), domain = domain)
-}
+    appendEntry = function(domain, logEntry) {
+      if (self$isLogging()) {
+        sessionToken <- if (is.null(domain)) NULL else domain$token
+        logStack$push(c(logEntry, list(
+          session = sessionToken,
+          time = as.numeric(Sys.time())
+        )))
+      }
+      if (!is.null(domain)) domain$reactlog(logEntry)
+    }
+  ),
+  public = list(
+    msg = "<MessageLogger>",
+    logStack = "<Stack>",
 
-.graphEnterContext <- function(id) {
-  .graphAppend(list(action='enter', id=id))
-}
+    noReactIdLabel = "NoCtxReactId",
+    noReactId = reactIdStr("NoCtxReactId"),
+    dummyReactIdLabel = "DummyReactId",
+    dummyReactId = reactIdStr("DummyReactId"),
 
-.graphExitContext <- function(id, domain) {
-  .graphAppend(list(action='exit', id=id), domain = domain)
-}
+    asList = function() {
+      ret <- self$logStack$as_list()
+      attr(ret, "version") <- "1"
+      ret
+    },
 
-.graphValueChange <- function(label, value) {
-  .graphAppend(list(
-    action = 'valueChange',
-    id = label,
-    value = paste(utils::capture.output(utils::str(value)), collapse='\n')
-  ))
-}
+    ctxIdStr = function(ctxId) {
+      if (is.null(ctxId) || identical(ctxId, "")) return(NULL)
+      paste0("ctx", ctxId)
+    },
+    namesIdStr = function(reactId) {
+      paste0("names(", reactId, ")")
+    },
+    asListIdStr = function(reactId) {
+      paste0("as.list(", reactId, ")")
+    },
+    asListAllIdStr = function(reactId) {
+      paste0("as.list(", reactId, ", all.names = TRUE)")
+    },
+    keyIdStr = function(reactId, key) {
+      paste0(reactId, "$", key)
+    },
 
-.graphInvalidate <- function(id, domain) {
-  .graphAppend(list(action='invalidate', id=id), domain)
-}
+    valueStr = function(value, n = 200) {
+      if (!self$isLogging()) {
+        # return a placeholder string to avoid calling str
+        return("<reactlog is turned off>")
+      }
+      output <- try(silent = TRUE, {
+        # only capture the first level of the object
+        utils::capture.output(utils::str(value, max.level = 1))
+      })
+      outputTxt <- paste0(output, collapse="\n")
+      msg$shortenString(outputTxt, n = n)
+    },
+
+    initialize = function(rlogOption = "shiny.reactlog", msgOption = "shiny.reactlog.console") {
+      private$option <- rlogOption
+      private$msgOption <- msgOption
+
+      self$reset()
+    },
+    reset = function() {
+      .globals$reactIdCounter <- 0L
+
+      self$logStack <- Stack$new()
+      self$msg <- MessageLogger$new(option = private$msgOption)
+
+      # setup dummy and missing react information
+      self$msg$setReact(force = TRUE, list(reactId = self$noReactId, label = self$noReactIdLabel))
+      self$msg$setReact(force = TRUE, list(reactId = self$dummyReactId, label = self$dummyReactIdLabel))
+    },
+    isLogging = function() {
+      isTRUE(getOption(private$option, FALSE))
+    },
+
+    define = function(reactId, value, label, type, domain) {
+      valueStr <- self$valueStr(value)
+      if (msg$hasReact(reactId)) {
+        stop("react definition for id: ", reactId, " already found!!", "Label: ", label, "Type: ", type)
+      }
+      msg$setReact(list(reactId = reactId, label = label))
+      msg$log("define:", msg$reactStr(reactId), msg$typeStr(type = type), msg$valueStr(valueStr))
+      private$appendEntry(domain, list(
+        action = "define",
+        reactId = reactId,
+        label = msg$shortenString(label),
+        type = type,
+        value = valueStr
+      ))
+    },
+    defineNames = function(reactId, value, label, domain) {
+      self$define(self$namesIdStr(reactId), value, self$namesIdStr(label), "reactiveValuesNames", domain)
+    },
+    defineAsList = function(reactId, value, label, domain) {
+      self$define(self$asListIdStr(reactId), value, self$asListIdStr(label), "reactiveValuesAsList", domain)
+    },
+    defineAsListAll = function(reactId, value, label, domain) {
+      self$define(self$asListAllIdStr(reactId), value, self$asListAllIdStr(label), "reactiveValuesAsListAll", domain)
+    },
+    defineKey = function(reactId, value, key, label, domain) {
+      self$define(self$keyIdStr(reactId, key), value, self$keyIdStr(label, key), "reactiveValuesKey", domain)
+    },
+    defineObserver = function(reactId, label, domain) {
+      self$define(reactId, value = NULL, label, "observer", domain)
+    },
+
+    dependsOn = function(reactId, depOnReactId, ctxId, domain) {
+      if (is.null(reactId)) return()
+      ctxId <- ctxIdStr(ctxId)
+      msg$log("dependsOn:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
+      private$appendEntry(domain, list(
+        action = "dependsOn",
+        reactId = reactId,
+        depOnReactId = depOnReactId,
+        ctxId = ctxId
+      ))
+    },
+    dependsOnKey = function(reactId, depOnReactId, key, ctxId, domain) {
+      self$dependsOn(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
+    },
+
+    dependsOnRemove = function(reactId, depOnReactId, ctxId, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      msg$log("dependsOnRemove:", msg$reactStr(reactId), " on", msg$reactStr(depOnReactId), msg$ctxStr(ctxId))
+      private$appendEntry(domain, list(
+        action = "dependsOnRemove",
+        reactId = reactId,
+        depOnReactId = depOnReactId,
+        ctxId = ctxId
+      ))
+    },
+    dependsOnKeyRemove = function(reactId, depOnReactId, key, ctxId, domain) {
+      self$dependsOnRemove(reactId, self$keyIdStr(depOnReactId, key), ctxId, domain)
+    },
+
+    createContext = function(ctxId, label, type, prevCtxId, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      prevCtxId <- self$ctxIdStr(prevCtxId)
+      msg$log("createContext:", msg$ctxPrevCtxStr(preCtxIdTxt = " ", ctxId, prevCtxId, type))
+      private$appendEntry(domain, list(
+        action = "createContext",
+        ctxId = ctxId,
+        label = msg$shortenString(label),
+        type = type,
+        prevCtxId = prevCtxId,
+        srcref = as.vector(attr(label, "srcref")), srcfile=attr(label, "srcfile")
+      ))
+    },
+
+    enter = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$log("isolateEnter:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "isolateEnter",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$log("enter:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "enter",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+    exit = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$depthDecrement()
+        msg$log("isolateExit:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        private$appendEntry(domain, list(
+          action = "isolateExit",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$depthDecrement()
+        msg$log("exit:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        private$appendEntry(domain, list(
+          action = "exit",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+
+    valueChange = function(reactId, value, domain) {
+      valueStr <- self$valueStr(value)
+      msg$log("valueChange:", msg$reactStr(reactId), msg$valueStr(valueStr))
+      private$appendEntry(domain, list(
+        action = "valueChange",
+        reactId = reactId,
+        value = valueStr
+      ))
+    },
+    valueChangeNames = function(reactId, nameValues, domain) {
+      self$valueChange(self$namesIdStr(reactId), nameValues, domain)
+    },
+    valueChangeAsList = function(reactId, listValue, domain) {
+      self$valueChange(self$asListIdStr(reactId), listValue, domain)
+    },
+    valueChangeAsListAll = function(reactId, listValue, domain) {
+      self$valueChange(self$asListAllIdStr(reactId), listValue, domain)
+    },
+    valueChangeKey = function(reactId, key, value, domain) {
+      self$valueChange(self$keyIdStr(reactId, key), value, domain)
+    },
+
+
+    invalidateStart = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$log("isolateInvalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "isolateInvalidateStart",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$log("invalidateStart:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        msg$depthIncrement()
+        private$appendEntry(domain, list(
+          action = "invalidateStart",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+    invalidateEnd = function(reactId, ctxId, type, domain) {
+      ctxId <- self$ctxIdStr(ctxId)
+      if (identical(type, "isolate")) {
+        msg$depthDecrement()
+        msg$log("isolateInvalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId))
+        private$appendEntry(domain, list(
+          action = "isolateInvalidateEnd",
+          reactId = reactId,
+          ctxId = ctxId
+        ))
+      } else {
+        msg$depthDecrement()
+        msg$log("invalidateEnd:", msg$reactStr(reactId), msg$ctxStr(ctxId, type))
+        private$appendEntry(domain, list(
+          action = "invalidateEnd",
+          reactId = reactId,
+          ctxId = ctxId,
+          type = type
+        ))
+      }
+    },
+
+    invalidateLater = function(reactId, runningCtx, millis, domain) {
+      msg$log("invalidateLater: ", millis, "ms", msg$reactStr(reactId), msg$ctxStr(runningCtx))
+      private$appendEntry(domain, list(
+        action = "invalidateLater",
+        reactId = reactId,
+        ctxId = runningCtx,
+        millis = millis
+      ))
+    },
+
+    idle = function(domain = NULL) {
+      msg$log("idle")
+      private$appendEntry(domain, list(
+        action = "idle"
+      ))
+    },
+
+    asyncStart = function(domain = NULL) {
+      msg$log("asyncStart")
+      private$appendEntry(domain, list(
+        action = "asyncStart"
+      ))
+    },
+    asyncStop = function(domain = NULL) {
+      msg$log("asyncStop")
+      private$appendEntry(domain, list(
+        action = "asyncStop"
+      ))
+    },
+
+    freezeReactiveVal = function(reactId, domain) {
+      msg$log("freeze:", msg$reactStr(reactId))
+      private$appendEntry(domain, list(
+        action = "freeze",
+        reactId = reactId
+      ))
+    },
+    freezeReactiveKey = function(reactId, key, domain) {
+      self$freezeReactiveVal(self$keyIdStr(reactId, key), domain)
+    },
+
+    thawReactiveVal = function(reactId, domain) {
+      msg$log("thaw:", msg$reactStr(reactId))
+      private$appendEntry(domain, list(
+        action = "thaw",
+        reactId = reactId
+      ))
+    },
+    thawReactiveKey = function(reactId, key, domain) {
+      self$thawReactiveVal(self$keyIdStr(reactId, key), domain)
+    },
+
+    userMark = function(domain = NULL) {
+      msg$log("userMark")
+      private$appendEntry(domain, list(
+        action = "userMark"
+      ))
+    }
+
+  )
+)
+
+MessageLogger = R6Class(
+  "MessageLogger",
+  portable = FALSE,
+  public = list(
+    depth = 0L,
+    reactCache = list(),
+    option = "shiny.reactlog.console",
+
+    initialize = function(option = "shiny.reactlog.console", depth = 0L) {
+      if (!missing(depth)) self$depth <- depth
+      if (!missing(option)) self$option <- option
+    },
+
+    isLogging = function() {
+      isTRUE(getOption(self$option))
+    },
+    isNotLogging = function() {
+      ! isTRUE(getOption(self$option))
+    },
+    depthIncrement = function() {
+      if (self$isNotLogging()) return(NULL)
+      self$depth <- self$depth + 1L
+    },
+    depthDecrement = function() {
+      if (self$isNotLogging()) return(NULL)
+      self$depth <- self$depth - 1L
+    },
+    hasReact = function(reactId) {
+      if (self$isNotLogging()) return(FALSE)
+      !is.null(self$getReact(reactId))
+    },
+    getReact = function(reactId, force = FALSE) {
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
+      self$reactCache[[reactId]]
+    },
+    setReact = function(reactObj, force = FALSE) {
+      if (identical(force, FALSE) && self$isNotLogging()) return(NULL)
+      self$reactCache[[reactObj$reactId]] <- reactObj
+    },
+    shortenString = function(txt, n = 250) {
+      if (is.null(txt) || isTRUE(is.na(txt))) {
+        return("")
+      }
+      if (nchar(txt) > n) {
+        return(
+          paste0(substr(txt, 1, n - 3), "...")
+        )
+      }
+      return(txt)
+    },
+    singleLine = function(txt) {
+      gsub("[^\\]\\n", "\\\\n", txt)
+    },
+    valueStr = function(valueStr) {
+      paste0(
+        " '",  self$shortenString(self$singleLine(valueStr)), "'"
+      )
+    },
+    reactStr = function(reactId) {
+      if (self$isNotLogging()) return(NULL)
+      reactInfo <- self$getReact(reactId)
+      if (is.null(reactInfo)) return(" <UNKNOWN_REACTID>")
+      paste0(
+        " ", reactInfo$reactId, ":'", self$shortenString(self$singleLine(reactInfo$label)), "'"
+      )
+    },
+    typeStr = function(type = NULL) {
+      self$ctxStr(ctxId = NULL, type = type)
+    },
+    ctxStr = function(ctxId = NULL, type = NULL) {
+      if (self$isNotLogging()) return(NULL)
+      self$ctxPrevCtxStr(ctxId = ctxId, prevCtxId = NULL, type = type)
+    },
+    ctxPrevCtxStr = function(ctxId = NULL, prevCtxId = NULL, type = NULL, preCtxIdTxt = " in ") {
+      if (self$isNotLogging()) return(NULL)
+      paste0(
+        if (!is.null(ctxId)) paste0(preCtxIdTxt, ctxId),
+        if (!is.null(prevCtxId)) paste0(" from ", prevCtxId),
+        if (!is.null(type) && !identical(type, "other")) paste0(" - ", type)
+      )
+    },
+    log = function(...) {
+      if (self$isNotLogging()) return(NULL)
+      msg <- paste0(
+        paste0(rep("= ", depth), collapse = ""), "- ", paste0(..., collapse = ""),
+        collapse = ""
+      )
+      message(msg)
+    }
+  )
+)
 
 #' @include stack.R
-.graphStack <- Stack$new()
+rLog <- RLog$new("shiny.reactlog", "shiny.reactlog.console")

R/image-interact.R

@@ -88,17 +88,14 @@ brushedPoints <- function(df, brush, xvar = NULL, yvar = NULL,
       stop("brushedPoints: not able to automatically infer `xvar` from brush")
     if (!(xvar %in% names(df)))
       stop("brushedPoints: `xvar` ('", xvar ,"')  not in names of input")
-    # Extract data values from the data frame
-    x <- asNumber(df[[xvar]])
-    keep_rows <- keep_rows & (x >= brush$xmin & x <= brush$xmax)
+    keep_rows <- keep_rows & within_brush(df[[xvar]], brush, "x")
   }
   if (use_y) {
     if (is.null(yvar))
       stop("brushedPoints: not able to automatically infer `yvar` from brush")
     if (!(yvar %in% names(df)))
       stop("brushedPoints: `yvar` ('", yvar ,"') not in names of input")
-    y <- asNumber(df[[yvar]])
-    keep_rows <- keep_rows & (y >= brush$ymin & y <= brush$ymax)
+    keep_rows <- keep_rows & within_brush(df[[yvar]], brush, "y")
   }
 
   # Find which rows are matches for the panel vars (if present)
@@ -281,8 +278,8 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
     stop("nearPoints: `yvar` ('", yvar ,"')  not in names of input")
 
   # Extract data values from the data frame
-  x <- asNumber(df[[xvar]])
-  y <- asNumber(df[[yvar]])
+  x <- asNumber(df[[xvar]], coordinfo$domain$discrete_limits$x)
+  y <- asNumber(df[[yvar]], coordinfo$domain$discrete_limits$y)
 
   # Get the coordinates of the point (in img pixel coordinates)
   point_img <- coordinfo$coords_img
@@ -402,11 +399,27 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 #   ..$ y: NULL
 #  $ .nonce    : num 0.603
 
-
+# Helper to determine if data values are within the limits of
+# an input brush
+within_brush <- function(vals, brush, var = "x") {
+  var <- match.arg(var, c("x", "y"))
+  vals <- asNumber(vals, brush$domain$discrete_limits[[var]])
+  # It's possible for a non-missing data values to not
+  # map to the axis limits, for example:
+  # https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881
+  !is.na(vals) &
+    vals >= brush[[paste0(var, "min")]] &
+    vals <= brush[[paste0(var, "max")]]
+}
 
 # Coerce various types of variables to numbers. This works for Date, POSIXt,
 # characters, and factors. Used because the mouse coords are numeric.
-asNumber <- function(x) {
+# The `levels` argument should be used when mapping this variable to
+# a known set of discrete levels, which is needed for ggplot2 since
+# it allows you to control ordering and possible values of a discrete
+# positional scale (#2410)
+asNumber <- function(x, levels = NULL) {
+  if (length(levels)) return(match(x, levels))
   if (is.character(x)) x <- as.factor(x)
   if (is.factor(x)) x <- as.integer(x)
   as.numeric(x)

R/input-checkboxgroup.R

@@ -94,7 +94,7 @@ checkboxGroupInput <- function(inputId, label, choices = NULL, selected = NULL,
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     options
   )
 }

R/input-date.R

@@ -78,7 +78,7 @@
 #'
 #'   # Disable Mondays and Tuesdays.
 #'   dateInput("date7", "Date:", daysofweekdisabled = c(1,2)),
-#'   
+#'
 #'   # Disable specific dates.
 #'   dateInput("date8", "Date:", value = "2012-02-29",
 #'             datesdisabled = c("2012-03-01", "2012-03-02"))
@@ -92,14 +92,10 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   language = "en", width = NULL, autoclose = TRUE,
   datesdisabled = NULL, daysofweekdisabled = NULL) {
 
-  # If value is a date object, convert it to a string with yyyy-mm-dd format
-  # Same for min and max
-  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
-  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
-  if (inherits(datesdisabled, "Date")) {
-      datesdisabled <- format(datesdisabled,   "%Y-%m-%d")
-  }
+  value <- dateYMD(value, "value")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
+  datesdisabled <- dateYMD(datesdisabled, "datesdisabled")
 
   value <- restoreInput(id = inputId, default = value)
 
@@ -107,7 +103,7 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
     class = "shiny-date-input form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     tags$input(type = "text",
                class = "form-control",
                `data-date-language` = language,

R/input-daterange.R

@@ -76,12 +76,10 @@ dateRangeInput <- function(inputId, label, start = NULL, end = 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
-  if (inherits(start, "Date"))  start <- format(start, "%Y-%m-%d")
-  if (inherits(end,   "Date"))  end   <- format(end,   "%Y-%m-%d")
-  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
-  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
+  start <- dateYMD(start, "start")
+  end   <- dateYMD(end, "end")
+  min   <- dateYMD(min, "min")
+  max   <- dateYMD(max, "max")
 
   restored <- restoreInput(id = inputId, default = list(start, end))
   start <- restored[[1]]
@@ -92,7 +90,7 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
       class = "shiny-date-range-input form-group shiny-input-container",
       style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
 
-      controlLabel(inputId, label),
+      shinyInputLabel(inputId, label),
       # input-daterange class is needed for dropdown behavior
       div(class = "input-daterange input-group",
         tags$input(

R/input-file.R

@@ -103,7 +103,7 @@ fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label),
+    shinyInputLabel(inputId, label),
 
     div(class = "input-group",
       tags$label(class = "input-group-btn",

R/input-numeric.R

@@ -42,7 +42,7 @@ numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     inputTag
   )
 }

R/input-password.R

@@ -30,7 +30,7 @@ passwordInput <- function(inputId, label, value = "", width = NULL,
                           placeholder = NULL) {
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     tags$input(id = inputId, type="password", class="form-control", value=value,
                placeholder = placeholder)
   )

R/input-radiobuttons.R

@@ -102,7 +102,7 @@ radioButtons <- function(inputId, label, choices = NULL, selected = NULL,
   tags$div(id = inputId,
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     class = divClass,
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     options
   )
 }

R/input-select.R

@@ -5,7 +5,7 @@
 #'
 #' By default, \code{selectInput()} and \code{selectizeInput()} use the
 #' JavaScript library \pkg{selectize.js}
-#' (\url{https://github.com/selectize/selectize.js}) to instead of the basic
+#' (\url{https://github.com/selectize/selectize.js}) instead of the basic
 #' select input element. To use the standard HTML select input element, use
 #' \code{selectInput()} with \code{selectize=FALSE}.
 #'
@@ -105,7 +105,7 @@ selectInput <- function(inputId, label, choices, selected = NULL,
   res <- div(
     class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     div(selectTag)
   )
 

R/input-slider.R

@@ -172,7 +172,7 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
 
   sliderTag <- div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    if (!is.null(label)) controlLabel(inputId, label),
+    shinyInputLabel(inputId, label),
     do.call(tags$input, sliderProps)
   )
 

R/input-text.R

@@ -36,7 +36,7 @@ textInput <- function(inputId, label, value = "", width = NULL,
 
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     tags$input(id = inputId, type="text", class="form-control", value=value,
       placeholder = placeholder)
   )

R/input-textarea.R

@@ -55,7 +55,7 @@ textAreaInput <- function(inputId, label, value = "", width = NULL, height = NUL
   if (length(style) == 0) style <- NULL
 
   div(class = "form-group shiny-input-container",
-    label %AND% tags$label(label, `for` = inputId),
+    shinyInputLabel(inputId, label),
     tags$textarea(
       id = inputId,
       class = "form-control",

R/input-utils.R

@@ -1,5 +1,10 @@
-controlLabel <- function(controlName, label) {
-  label %AND% tags$label(class = "control-label", `for` = controlName, label)
+shinyInputLabel <- function(inputId, label = NULL) {
+  tags$label(
+    label,
+    class = "control-label",
+    class = if (is.null(label)) "shiny-label-null",
+    `for` = inputId
+  )
 }
 
 # This function takes in either a list or vector for `choices` (and

R/middleware-shiny.R

@@ -2,19 +2,43 @@
 NULL
 
 reactLogHandler <- function(req) {
-  if (!identical(req$PATH_INFO, '/reactlog'))
-    return(NULL)
-
-  if (!isTRUE(getOption('shiny.reactlog'))) {
+  if (! rLog$isLogging()) {
     return(NULL)
   }
 
-  sessionToken <- parseQueryString(req$QUERY_STRING)$s
+  if (identical(req$PATH_INFO, "/reactlog/mark")) {
+    sessionToken <- parseQueryString(req$QUERY_STRING)$s
+    shinysession <- appsByToken$get(sessionToken)
 
-  return(httpResponse(
-    status=200,
-    content=list(file=renderReactLog(sessionToken), owned=TRUE)
-  ))
+    # log time
+    withReactiveDomain(shinysession, {
+      rLog$userMark(getDefaultReactiveDomain())
+    })
+
+    return(httpResponse(
+      status = 200,
+      content = "marked",
+      content_type = "text/plain"
+    ))
+
+  } else if (identical(req$PATH_INFO, "/reactlog")){
+
+    sessionToken <- parseQueryString(req$QUERY_STRING)$s
+
+    # `renderReactLog` will check/throw if reactlog doesn't exist
+    reactlogFile <- renderReactlog(sessionToken)
+
+    return(httpResponse(
+      status = 200,
+      content = list(
+        file = reactlogFile,
+        owned = TRUE
+      )
+    ))
+
+  } else {
+    return(NULL)
+  }
 }
 
 sessionHandler <- function(req) {

R/middleware.R

@@ -321,21 +321,20 @@ HandlerManager <- R6Class("HandlerManager",
               }
             )
           },
-          getOption('shiny.sharedSecret')
+          loadSharedSecret()
         ),
         onWSOpen = function(ws) {
           return(wsHandlers$invoke(ws))
         }
       )
     },
-    .httpServer = function(handler, sharedSecret) {
+    .httpServer = function(handler, checkSharedSecret) {
       filter <- getOption('shiny.http.response.filter')
       if (is.null(filter))
         filter <- function(req, response) response
 
       function(req) {
-        if (!is.null(sharedSecret)
-          && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
+        if (!checkSharedSecret(req$HTTP_SHINY_SHARED_SECRET)) {
           return(list(status=403,
             body='<h1>403 Forbidden</h1><p>Shared secret mismatch</p>',
             headers=list('Content-Type' = 'text/html')))

R/react.R

@@ -16,12 +16,15 @@ processId <- local({
   }
 })
 
+#' @include graph.R
 Context <- R6Class(
   'Context',
   portable = FALSE,
   class = FALSE,
   public = list(
     id = character(0),
+    .reactId = character(0),
+    .reactType = "other",
     .label = character(0),      # For debug purposes
     .invalidated = FALSE,
     .invalidateCallbacks = list(),
@@ -29,12 +32,18 @@ Context <- R6Class(
     .domain = NULL,
     .pid = NULL,
 
-    initialize = function(domain, label='', type='other', prevId='') {
-      id <<- .getReactiveEnvironment()$nextId()
+    initialize = function(
+      domain, label='', type='other', prevId='',
+      reactId = rLog$noReactId,
+      id = .getReactiveEnvironment()$nextId() # For dummy context
+    ) {
+      id <<- id
       .label <<- label
       .domain <<- domain
       .pid <<- processId()
-      .graphCreateContext(id, label, type, prevId, domain)
+      .reactId <<- reactId
+      .reactType <<- type
+      rLog$createContext(id, label, type, prevId, domain)
     },
     run = function(func) {
       "Run the provided function under this context."
@@ -42,10 +51,8 @@ Context <- R6Class(
       promises::with_promise_domain(reactivePromiseDomain(), {
         withReactiveDomain(.domain, {
           env <- .getReactiveEnvironment()
-          .graphEnterContext(id)
-          on.exit({
-            .graphExitContext(id, domain = .domain)
-          }, add = TRUE)
+          rLog$enter(.reactId, id, .reactType, .domain)
+          on.exit(rLog$exit(.reactId, id, .reactType, .domain), add = TRUE)
           env$runWith(self, func)
         })
       })
@@ -62,7 +69,9 @@ Context <- R6Class(
         return()
       .invalidated <<- TRUE
 
-      .graphInvalidate(id, .domain)
+      rLog$invalidateStart(.reactId, id, .reactType, .domain)
+      on.exit(rLog$invalidateEnd(.reactId, id, .reactType, .domain), add = TRUE)
+
       lapply(.invalidateCallbacks, function(func) {
         func()
       })
@@ -151,7 +160,10 @@ ReactiveEnvironment <- R6Class(
       # If already in a flush, don't start another one
       if (.inFlush) return(invisible(FALSE))
       .inFlush <<- TRUE
-      on.exit(.inFlush <<- FALSE)
+      on.exit({
+        .inFlush <<- FALSE
+        rLog$idle(domain = NULL)
+      })
 
       while (hasPendingFlush()) {
         ctx <- .pendingFlush$dequeue()
@@ -183,18 +195,16 @@ flushReact <- function() {
 getCurrentContext <- function() {
   .getReactiveEnvironment()$currentContext()
 }
+hasCurrentContext <- function() {
+  !is.null(.getReactiveEnvironment()$.currentContext)
+}
 
-getDummyContext <- function() {}
-local({
-  dummyContext <- NULL
-  getDummyContext <<- function() {
-    if (is.null(dummyContext)) {
-      dummyContext <<- Context$new(getDefaultReactiveDomain(), '[none]',
-        type='isolate')
-    }
-    return(dummyContext)
-  }
-})
+getDummyContext <- function() {
+  Context$new(
+    getDefaultReactiveDomain(), '[none]', type = 'isolate',
+    id = "Dummy", reactId = rLog$dummyReactId
+  )
+}
 
 wrapForContext <- function(func, ctx) {
   force(func)

R/reactives.R

@@ -6,26 +6,43 @@ Dependents <- R6Class(
   portable = FALSE,
   class = FALSE,
   public = list(
+    .reactId = character(0),
     .dependents = 'Map',
 
-    initialize = function() {
+    initialize = function(reactId = NULL) {
+      .reactId <<- reactId
       .dependents <<- Map$new()
     },
-    register = function(depId=NULL, depLabel=NULL) {
-      ctx <- .getReactiveEnvironment()$currentContext()
+    # ... ignored, use to be depLabel and depId, not used anymore
+    register = function(...) {
+      ctx <- getCurrentContext()
       if (!.dependents$containsKey(ctx$id)) {
+
+        # must wrap in if statement as ctx react id could be NULL
+        #   if options(shiny.suppressMissingContextError = TRUE)
+        if (is.character(.reactId) && is.character(ctx$.reactId)) {
+          rLog$dependsOn(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
+        }
+
         .dependents$set(ctx$id, ctx)
+
         ctx$onInvalidate(function() {
+          rLog$dependsOnRemove(ctx$.reactId, .reactId, ctx$id, ctx$.domain)
           .dependents$remove(ctx$id)
         })
-
-        if (!is.null(depId) && nchar(depId) > 0)
-          .graphDependsOnId(ctx$id, depId)
-        if (!is.null(depLabel))
-          .graphDependsOn(ctx$id, depLabel)
       }
     },
-    invalidate = function() {
+    # at times, the context is run in a ctx$onInvalidate(...) which has no runtime context
+    invalidate = function(log = TRUE) {
+      if (isTRUE(log)) {
+
+        domain <- getDefaultReactiveDomain()
+        rLog$invalidateStart(.reactId, NULL, "other", domain)
+        on.exit(
+          rLog$invalidateEnd(.reactId, NULL, "other", domain),
+          add = TRUE
+        )
+      }
       lapply(
         .dependents$values(),
         function(ctx) {
@@ -44,6 +61,7 @@ ReactiveVal <- R6Class(
   'ReactiveVal',
   portable = FALSE,
   private = list(
+    reactId = character(0),
     value = NULL,
     label = NULL,
     frozen = FALSE,
@@ -51,13 +69,15 @@ ReactiveVal <- R6Class(
   ),
   public = list(
     initialize = function(value, label = NULL) {
+      reactId <- nextGlobalReactId()
+      private$reactId <- reactId
       private$value <- value
       private$label <- label
-      private$dependents <- Dependents$new()
-      .graphValueChange(private$label, value)
+      private$dependents <- Dependents$new(reactId = private$reactId)
+      rLog$define(private$reactId, value, private$label, type = "reactiveVal", getDefaultReactiveDomain())
     },
     get = function() {
-      private$dependents$register(depLabel = private$label)
+      private$dependents$register()
 
       if (private$frozen)
         reactiveStop()
@@ -68,8 +88,8 @@ ReactiveVal <- R6Class(
       if (identical(private$value, value)) {
         return(invisible(FALSE))
       }
+      rLog$valueChange(private$reactId, value, getDefaultReactiveDomain())
       private$value <- value
-      .graphValueChange(private$label, value)
       private$dependents$invalidate()
       invisible(TRUE)
     },
@@ -77,12 +97,14 @@ ReactiveVal <- R6Class(
       if (is.null(session)) {
         stop("Can't freeze a reactiveVal without a reactive domain")
       }
+      rLog$freezeReactiveVal(private$reactId, session)
       session$onFlushed(function() {
-        self$thaw()
+        self$thaw(session)
       })
       private$frozen <- TRUE
     },
-    thaw = function() {
+    thaw = function(session = getDefaultReactiveDomain()) {
+      rLog$thawReactiveVal(private$reactId, session)
       private$frozen <- FALSE
     },
     isFrozen = function() {
@@ -118,7 +140,7 @@ ReactiveVal <- R6Class(
 #'
 #' @param value An optional initial value.
 #' @param label An optional label, for debugging purposes (see
-#'   \code{\link{showReactLog}}). If missing, a label will be automatically
+#'   \code{\link{reactlog}}). If missing, a label will be automatically
 #'   created.
 #'
 #' @return A function. Call the function with no arguments to (reactively) read
@@ -268,6 +290,7 @@ ReactiveValues <- R6Class(
   portable = FALSE,
   public = list(
     # For debug purposes
+    .reactId = character(0),
     .label = character(0),
     .values = 'environment',
     .metadata = 'environment',
@@ -279,29 +302,48 @@ ReactiveValues <- R6Class(
     # Dependents for all values
     .valuesDeps = 'Dependents',
     .dedupe = logical(0),
+    # Key, asList(), or names() have been retrieved
+    .hasRetrieved = list(),
 
-    initialize = function(dedupe = TRUE) {
-      .label <<- paste('reactiveValues',
-                       p_randomInt(1000, 10000),
-                       sep="")
+
+    initialize = function(
+      dedupe = TRUE,
+      label = paste0('reactiveValues', p_randomInt(1000, 10000))
+    ) {
+      .reactId <<- nextGlobalReactId()
+      .label <<- label
       .values <<- new.env(parent=emptyenv())
       .metadata <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
-      .namesDeps <<- Dependents$new()
-      .allValuesDeps <<- Dependents$new()
-      .valuesDeps <<- Dependents$new()
+      .hasRetrieved <<- list(names = FALSE, asListAll = FALSE, asList = FALSE, keys = list())
+      .namesDeps <<- Dependents$new(reactId = rLog$namesIdStr(.reactId))
+      .allValuesDeps <<- Dependents$new(reactId = rLog$asListAllIdStr(.reactId))
+      .valuesDeps <<- Dependents$new(reactId = rLog$asListIdStr(.reactId))
       .dedupe <<- dedupe
     },
 
     get = function(key) {
+      # get value right away to use for logging
+      if (!exists(key, envir=.values, inherits=FALSE))
+        keyValue <- NULL
+      else
+        keyValue <- .values[[key]]
+
       # Register the "downstream" reactive which is accessing this value, so
       # that we know to invalidate them when this value changes.
-      ctx <- .getReactiveEnvironment()$currentContext()
+      ctx <- getCurrentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
       if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
-        .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
+        reactKeyId <- rLog$keyIdStr(.reactId, key)
+
+        if (!isTRUE(.hasRetrieved$keys[[key]])) {
+          rLog$defineKey(.reactId, keyValue, key, .label, ctx$.domain)
+          .hasRetrieved$keys[[key]] <<- TRUE
+        }
+        rLog$dependsOnKey(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
         .dependents[[dep.key]] <- ctx
         ctx$onInvalidate(function() {
+          rLog$dependsOnKeyRemove(ctx$.reactId, .reactId, key, ctx$id, ctx$.domain)
           rm(list=dep.key, envir=.dependents, inherits=FALSE)
         })
       }
@@ -309,34 +351,79 @@ ReactiveValues <- R6Class(
       if (isFrozen(key))
         reactiveStop()
 
-      if (!exists(key, envir=.values, inherits=FALSE))
-        NULL
-      else
-        .values[[key]]
+      keyValue
     },
 
     set = function(key, value) {
+      # if key exists
+      #   if it is the same value, return
+      #
+      # update value of `key`
+      #
+      # if key exists
+      #   if `key` has been read,
+      #     log `update key`
+      #     ## (invalidate key later in code)
+      # else # if new key
+      #   if `names()` have been read,
+      #     log `update names()`
+      #     invalidate `names()`
+      #
+      # if hidden
+      #   if asListAll has been read,
+      #     log `update asList(all.names = TRUE)`
+      #     invalidate `asListAll`
+      # else # not hidden
+      #   if asList has been read,
+      #     log `update asList()`
+      #     invalidate `asList`
+      #
+      # update value of `key`
+      # invalidate all deps of `key`
+
+      domain <- getDefaultReactiveDomain()
       hidden <- substr(key, 1, 1) == "."
 
-      if (exists(key, envir=.values, inherits=FALSE)) {
+      key_exists <- exists(key, envir=.values, inherits=FALSE)
+
+      if (key_exists) {
         if (.dedupe && identical(.values[[key]], value)) {
           return(invisible())
         }
       }
-      else {
+
+      # set the value for better logging
+      .values[[key]] <- value
+
+      # key has been depended upon
+      if (isTRUE(.hasRetrieved$keys[[key]])) {
+        rLog$valueChangeKey(.reactId, key, value, domain)
+        keyReactId <- rLog$keyIdStr(.reactId, key)
+        rLog$invalidateStart(keyReactId, NULL, "other", domain)
+        on.exit(
+          rLog$invalidateEnd(keyReactId, NULL, "other", domain),
+          add = TRUE
+        )
+      }
+
+      # only invalidate if there are deps
+      if (!key_exists && isTRUE(.hasRetrieved$names)) {
+        rLog$valueChangeNames(.reactId, ls(.values, all.names = TRUE), domain)
         .namesDeps$invalidate()
       }
 
-      if (hidden)
-        .allValuesDeps$invalidate()
-      else
-        .valuesDeps$invalidate()
-
-      .values[[key]] <- value
-
-      .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
-      .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
-      .graphValueChange(sprintf('%s$%s', .label, key), value)
+      if (hidden) {
+        if (isTRUE(.hasRetrieved$asListAll)) {
+          rLog$valueChangeAsListAll(.reactId, as.list(.values, all.names = TRUE), domain)
+          .allValuesDeps$invalidate()
+        }
+      } else {
+        if (isTRUE(.hasRetrieved$asList)) {
+          # leave as is. both object would be registered to the listening object
+          rLog$valueChangeAsList(.reactId, as.list(.values, all.names = FALSE), domain)
+          .valuesDeps$invalidate()
+        }
+      }
 
       dep.keys <- objects(
         envir=.dependents,
@@ -361,10 +448,14 @@ ReactiveValues <- R6Class(
     },
 
     names = function() {
-      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
-                      sprintf('names(%s)', .label))
+      nameValues <- ls(.values, all.names=TRUE)
+      if (!isTRUE(.hasRetrieved$names)) {
+        domain <- getDefaultReactiveDomain()
+        rLog$defineNames(.reactId, nameValues, .label, domain)
+        .hasRetrieved$names <<- TRUE
+      }
       .namesDeps$register()
-      return(ls(.values, all.names=TRUE))
+      return(nameValues)
     },
 
     # Get a metadata value. Does not trigger reactivity.
@@ -389,10 +480,14 @@ ReactiveValues <- R6Class(
     # Mark a value as frozen If accessed while frozen, a shiny.silent.error will
     # be thrown.
     freeze = function(key) {
+      domain <- getDefaultReactiveDomain()
+      rLog$freezeReactiveKey(.reactId, key, domain)
       setMeta(key, "frozen", TRUE)
     },
 
     thaw = function(key) {
+      domain <- getDefaultReactiveDomain()
+      rLog$thawReactiveKey(.reactId, key, domain)
       setMeta(key, "frozen", NULL)
     },
 
@@ -401,19 +496,27 @@ ReactiveValues <- R6Class(
     },
 
     toList = function(all.names=FALSE) {
-      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
-                      sprintf('%s (all)', .label))
-      if (all.names)
+      listValue <- as.list(.values, all.names=all.names)
+      if (all.names) {
+        if (!isTRUE(.hasRetrieved$asListAll)) {
+          domain <- getDefaultReactiveDomain()
+          rLog$defineAsListAll(.reactId, listValue, .label, domain)
+          .hasRetrieved$asListAll <<- TRUE
+        }
         .allValuesDeps$register()
+      }
 
+      if (!isTRUE(.hasRetrieved$asList)) {
+        domain <- getDefaultReactiveDomain()
+        # making sure the value being recorded is with `all.names = FALSE`
+        rLog$defineAsList(.reactId, as.list(.values, all.names=FALSE), .label, domain)
+        .hasRetrieved$asList <<- TRUE
+      }
       .valuesDeps$register()
 
-      return(as.list(.values, all.names=all.names))
-    },
-
-    .setLabel = function(label) {
-      .label <<- label
+      return(listValue)
     }
+
   )
 )
 
@@ -562,11 +665,6 @@ as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
   reactiveValuesToList(x, all.names)
 }
 
-# For debug purposes
-.setLabel <- function(x, label) {
-  .subset2(x, 'impl')$.setLabel(label)
-}
-
 #' Convert a reactivevalues object to a list
 #'
 #' This function does something similar to what you might \code{\link[base]{as.list}}
@@ -689,6 +787,7 @@ Observable <- R6Class(
   'Observable',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .origFunc = 'function',
     .func = 'function',
     .label = character(0),
@@ -719,16 +818,18 @@ Observable <- R6Class(
         funcLabel <- paste0("<reactive:", label, ">")
       }
 
+      .reactId <<- nextGlobalReactId()
       .origFunc <<- func
       .func <<- wrapFunctionLabel(func, funcLabel,
         ..stacktraceon = ..stacktraceon)
       .label <<- label
       .domain <<- domain
-      .dependents <<- Dependents$new()
+      .dependents <<- Dependents$new(reactId = .reactId)
       .invalidated <<- TRUE
       .running <<- FALSE
       .execCount <<- 0L
       .mostRecentCtxId <<- ""
+      rLog$define(.reactId, .value, .label, type = "observable", .domain)
     },
     getValue = function() {
       .dependents$register()
@@ -739,8 +840,6 @@ Observable <- R6Class(
         )
       }
 
-      .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)
-
       if (.error) {
         stop(.value)
       }
@@ -756,12 +855,12 @@ Observable <- R6Class(
     },
     .updateValue = function() {
       ctx <- Context$new(.domain, .label, type = 'observable',
-                         prevId = .mostRecentCtxId)
+                         prevId = .mostRecentCtxId, reactId = .reactId)
       .mostRecentCtxId <<- ctx$id
       ctx$onInvalidate(function() {
         .invalidated <<- TRUE
         .value <<- NULL # Value can be GC'd, it won't be read once invalidated
-        .dependents$invalidate()
+        .dependents$invalidate(log = FALSE)
       })
       .execCount <<- .execCount + 1L
 
@@ -935,6 +1034,7 @@ Observer <- R6Class(
   'Observer',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .func = 'function',
     .label = character(0),
     .domain = 'ANY',
@@ -978,11 +1078,14 @@ Observer <- R6Class(
       .autoDestroyHandle <<- NULL
       setAutoDestroy(autoDestroy)
 
+      .reactId <<- nextGlobalReactId()
+      rLog$defineObserver(.reactId, .label, .domain)
+
       # Defer the first running of this until flushReact is called
       .createContext()$invalidate()
     },
     .createContext = function() {
-      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId)
+      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId, reactId = .reactId)
       .prevId <<- ctx$id
 
       if (!is.null(.ctx)) {
@@ -1393,6 +1496,10 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   # callback below is fired (see #1621).
   force(session)
 
+  # TODO-barret - ## leave alone for now
+  # reactId <- nextGlobalReactId()
+  # rLog$define(reactId, paste0("timer(", intervalMs, ")"))
+
   dependents <- Map$new()
   timerHandle <- scheduleTask(intervalMs, function() {
     # Quit if the session is closed
@@ -1402,14 +1509,23 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 
     timerHandle <<- scheduleTask(intervalMs, sys.function())
 
-    session$cycleStartAction(function() {
+    doInvalidate <- function() {
       lapply(
         dependents$values(),
         function(dep.ctx) {
           dep.ctx$invalidate()
           NULL
         })
-    })
+    }
+
+    if (!is.null(session)) {
+      # If this timer belongs to a session, we must wait until the next cycle is
+      # ready to invalidate.
+      session$cycleStartAction(doInvalidate)
+    } else {
+      # If this timer doesn't belong to a session, we invalidate right away.
+      doInvalidate()
+    }
   })
 
   if (!is.null(session)) {
@@ -1417,14 +1533,15 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
   }
 
   return(function() {
-    ctx <- .getReactiveEnvironment()$currentContext()
+    newValue <- Sys.time()
+    ctx <- getCurrentContext()
     if (!dependents$containsKey(ctx$id)) {
       dependents$set(ctx$id, ctx)
       ctx$onInvalidate(function() {
         dependents$remove(ctx$id)
       })
     }
-    return(Sys.time())
+    return(newValue)
   })
 }
 
@@ -1483,8 +1600,12 @@ reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain())
 #' }
 #' @export
 invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
+
   force(session)
-  ctx <- .getReactiveEnvironment()$currentContext()
+
+  ctx <- getCurrentContext()
+  rLog$invalidateLater(ctx$.reactId, ctx$id, millis, session)
+
   timerHandle <- scheduleTask(millis, function() {
     if (is.null(session)) {
       ctx$invalidate()
@@ -1749,7 +1870,12 @@ reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...)
 #' # input object, like input$x
 #' @export
 isolate <- function(expr) {
-  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate')
+  if (hasCurrentContext()) {
+    reactId <- getCurrentContext()$.reactId
+  } else {
+    reactId <- rLog$noReactId
+  }
+  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate', reactId = reactId)
   on.exit(ctx$invalidate())
   # Matching ..stacktraceon../..stacktraceoff.. pair
   ..stacktraceoff..(ctx$run(function() {

R/render-cached-plot.R

@@ -476,62 +476,64 @@ renderCachedPlot <- function(expr,
           }
         )
       },
-      function(result) {
-        width      <- result$width
-        height     <- result$height
-        pixelratio <- result$pixelratio
+      function(possiblyAsyncResult) {
+        hybrid_chain(possiblyAsyncResult, function(result) {
+          width      <- result$width
+          height     <- result$height
+          pixelratio <- result$pixelratio
 
-        # Three possibilities when we get here:
-        # 1. There was a cache hit. No need to set a value in the cache.
-        # 2. There was a cache miss, and the plotObj is already the correct
-        #    size (because drawReactive re-executed). In this case, we need
-        #    to cache it.
-        # 3. There was a cache miss, and the plotObj was not the corect size.
-        #    In this case, we need to replay the display list, and then cache
-        #    the result.
-        if (!result$cacheHit) {
-          # If the image is already the correct size, this just returns the
-          # object unchanged.
-          result$plotObj <- do.call("resizeSavedPlot", c(
-            list(
-              name,
-              shinysession,
-              result$plotObj,
-              width,
-              height,
-              pixelratio,
-              res
-            ),
-            args
-          ))
+          # Three possibilities when we get here:
+          # 1. There was a cache hit. No need to set a value in the cache.
+          # 2. There was a cache miss, and the plotObj is already the correct
+          #    size (because drawReactive re-executed). In this case, we need
+          #    to cache it.
+          # 3. There was a cache miss, and the plotObj was not the corect size.
+          #    In this case, we need to replay the display list, and then cache
+          #    the result.
+          if (!result$cacheHit) {
+            # If the image is already the correct size, this just returns the
+            # object unchanged.
+            result$plotObj <- do.call("resizeSavedPlot", c(
+              list(
+                name,
+                shinysession,
+                result$plotObj,
+                width,
+                height,
+                pixelratio,
+                res
+              ),
+              args
+            ))
 
-          # Save a cached copy of the plotObj. The recorded displaylist for
-          # the plot can't be serialized and restored properly within the same
-          # R session, so we NULL it out before saving. (The image data and
-          # other metadata be saved and restored just fine.) Displaylists can
-          # also be very large (~1.5MB for a basic ggplot), and they would not
-          # be commonly used. Note that displaylist serialization was fixed in
-          # revision 74506 (2e6c669), and should be in R 3.6. A MemoryCache
-          # doesn't need to serialize objects, so it could actually save a
-          # display list, but for the reasons listed previously, it's
-          # generally not worth it.
-          # The plotResult is not the same as the recordedPlot (it is used to
-          # retrieve coordmap information for ggplot2 objects) but it is only
-          # used in conjunction with the recordedPlot, and we'll remove it
-          # because it can be quite large.
-          result$plotObj$plotResult <- NULL
-          result$plotObj$recordedPlot <- NULL
-          cache$set(result$key, result$plotObj)
-        }
+            # Save a cached copy of the plotObj. The recorded displaylist for
+            # the plot can't be serialized and restored properly within the same
+            # R session, so we NULL it out before saving. (The image data and
+            # other metadata be saved and restored just fine.) Displaylists can
+            # also be very large (~1.5MB for a basic ggplot), and they would not
+            # be commonly used. Note that displaylist serialization was fixed in
+            # revision 74506 (2e6c669), and should be in R 3.6. A MemoryCache
+            # doesn't need to serialize objects, so it could actually save a
+            # display list, but for the reasons listed previously, it's
+            # generally not worth it.
+            # The plotResult is not the same as the recordedPlot (it is used to
+            # retrieve coordmap information for ggplot2 objects) but it is only
+            # used in conjunction with the recordedPlot, and we'll remove it
+            # because it can be quite large.
+            result$plotObj$plotResult <- NULL
+            result$plotObj$recordedPlot <- NULL
+            cache$set(result$key, result$plotObj)
+          }
 
-        img <- result$plotObj$img
-        # Replace exact pixel dimensions; instead, the max-height and
-        # max-width will be set to 100% from CSS.
-        img$class <- "shiny-scalable"
-        img$width  <- NULL
-        img$height <- NULL
+          img <- result$plotObj$img
+          # Replace exact pixel dimensions; instead, the max-height and
+          # max-width will be set to 100% from CSS.
+          img$class <- "shiny-scalable"
+          img$width  <- NULL
+          img$height <- NULL
 
-        img
+          img
+        })
       }
     )
   }

R/render-plot.R

@@ -353,62 +353,88 @@ custom_print.ggplot <- function(x) {
 # With a faceted ggplot2 plot, the outer list contains two objects, each of
 # which represents one panel. In this example, there is one panelvar, but there
 # can be up to two of them.
-# mtc <- mtcars
-# mtc$am <- factor(mtc$am)
-# p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
-# str(getGgplotCoordmap(p, 400, 300, 72))
+# p <- print(ggplot(mpg) + geom_point(aes(fl, cty), alpha = 0.2) + facet_wrap(~drv, scales = "free_x"))
+# str(getGgplotCoordmap(p, 500, 400, 72))
 # List of 2
-#  $ panels:List of 2
+#  $ panels:List of 3
 #   ..$ :List of 8
 #   .. ..$ panel     : num 1
 #   .. ..$ row       : int 1
 #   .. ..$ col       : int 1
 #   .. ..$ panel_vars:List of 1
-#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
+#   .. .. ..$ panelvar1: chr "4"
 #   .. ..$ log       :List of 2
 #   .. .. ..$ x: NULL
 #   .. .. ..$ y: NULL
-#   .. ..$ domain    :List of 4
-#   .. .. ..$ left  : num 1.32
-#   .. .. ..$ right : num 5.62
-#   .. .. ..$ bottom: num 9.22
-#   .. .. ..$ top   : num 35.1
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 4.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:4] "d" "e" "p" "r"
 #   .. ..$ mapping   :List of 3
-#   .. .. ..$ x        : chr "wt"
-#   .. .. ..$ y        : chr "mpg"
-#   .. .. ..$ panelvar1: chr "am"
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
 #   .. ..$ range     :List of 4
 #   .. .. ..$ left  : num 33.3
-#   .. .. ..$ right : num 191
-#   .. .. ..$ bottom: num 328
+#   .. .. ..$ right : num 177
+#   .. .. ..$ bottom: num 448
 #   .. .. ..$ top   : num 23.1
 #   ..$ :List of 8
 #   .. ..$ panel     : num 2
 #   .. ..$ row       : int 1
 #   .. ..$ col       : int 2
 #   .. ..$ panel_vars:List of 1
-#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
+#   .. .. ..$ panelvar1: chr "f"
 #   .. ..$ log       :List of 2
 #   .. .. ..$ x: NULL
 #   .. .. ..$ y: NULL
-#   .. ..$ domain    :List of 4
-#   .. .. ..$ left  : num 1.32
-#   .. .. ..$ right : num 5.62
-#   .. .. ..$ bottom: num 9.22
-#   .. .. ..$ top   : num 35.1
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 5.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:5] "c" "d" "e" "p" ...
 #   .. ..$ mapping   :List of 3
-#   .. .. ..$ x        : chr "wt"
-#   .. .. ..$ y        : chr "mpg"
-#   .. .. ..$ panelvar1: chr "am"
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
 #   .. ..$ range     :List of 4
-#   .. .. ..$ left  : num 197
-#   .. .. ..$ right : num 355
-#   .. .. ..$ bottom: num 328
+#   .. .. ..$ left  : num 182
+#   .. .. ..$ right : num 326
+#   .. .. ..$ bottom: num 448
+#   .. .. ..$ top   : num 23.1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 3
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 3
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: chr "r"
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 5
+#   .. .. ..$ left           : num 0.4
+#   .. .. ..$ right          : num 3.6
+#   .. .. ..$ bottom         : num 7.7
+#   .. .. ..$ top            : num 36.3
+#   .. .. ..$ discrete_limits:List of 1
+#   .. .. .. ..$ x: chr [1:3] "e" "p" "r"
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "fl"
+#   .. .. ..$ y        : chr "cty"
+#   .. .. ..$ panelvar1: chr "drv"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 331
+#   .. .. ..$ right : num 475
+#   .. .. ..$ bottom: num 448
 #   .. .. ..$ top   : num 23.1
 #  $ dims  :List of 2
-#   ..$ width : num 400
-#   ..$ height: num 300
-
+#   ..$ width : num 500
+#   ..$ height: num 400
 
 getCoordmap <- function(x, width, height, res) {
   if (inherits(x, "ggplot_build_gtable")) {
@@ -570,6 +596,9 @@ find_panel_info_api <- function(b) {
       domain$bottom <- -domain$bottom
     }
 
+    domain <- add_discrete_limits(domain, xscale, "x")
+    domain <- add_discrete_limits(domain, yscale, "y")
+
     domain
   }
 
@@ -689,6 +718,9 @@ find_panel_info_non_api <- function(b, ggplot_format) {
       domain$bottom <- -domain$bottom
     }
 
+    domain <- add_discrete_limits(domain, xscale, "x")
+    domain <- add_discrete_limits(domain, yscale, "y")
+
     domain
   }
 
@@ -995,3 +1027,23 @@ find_panel_ranges <- function(g, res) {
     )
   })
 }
+
+# Remember the x/y limits of discrete axes. This info is
+# necessary to properly inverse map the numeric (i.e., trained)
+# positions back to the data scale, for example:
+# https://github.com/rstudio/shiny/pull/2410#issuecomment-487783828
+# https://github.com/rstudio/shiny/pull/2410#issuecomment-488100881
+#
+# Eventually, we may want to consider storing the entire ggplot2
+# object server-side and querying information from that object
+# as we need it...that's the only way we'll ever be able to
+# faithfully brush examples like this:
+# https://github.com/rstudio/shiny/issues/2411
+add_discrete_limits <- function(domain, scale, var = "x") {
+  var <- match.arg(var, c("x", "y"))
+  if (!is.function(scale$is_discrete) || !is.function(scale$get_limits)) return(domain)
+  if (scale$is_discrete()) {
+    domain$discrete_limits[[var]] <- scale$get_limits()
+  }
+  domain
+}

R/server.R

@@ -22,6 +22,7 @@ registerClient <- function(client) {
 }
 
 
+.globals$resourcePaths <- list()
 .globals$resources <- list()
 
 .globals$showcaseDefault <- 0
@@ -41,11 +42,6 @@ registerClient <- function(client) {
 #' @param directoryPath The directory that contains the static resources to be
 #'   served.
 #'
-#' @details You can call \code{addResourcePath} multiple times for a given
-#'   \code{prefix}; only the most recent value will be retained. If the
-#'   normalized \code{directoryPath} is different than the directory that's
-#'   currently mapped to the \code{prefix}, a warning will be issued.
-#'
 #' @seealso \code{\link{singleton}}
 #'
 #' @examples
@@ -66,30 +62,75 @@ addResourcePath <- function(prefix, directoryPath) {
         "`prefix` = '", prefix, "'; `directoryPath` = '" , directoryPath, "'")
     }
   )
+
+  # If a shiny app is currently running, dynamically register this path with
+  # the corresponding httpuv server object.
+  if (!is.null(getShinyOption("server")))
+  {
+    getShinyOption("server")$setStaticPath(.list = stats::setNames(normalizedPath, prefix))
+  }
+
+  # .globals$resourcePaths and .globals$resources persist across runs of applications.
+  .globals$resourcePaths[[prefix]] <- staticPath(normalizedPath)
+  # This is necessary because resourcePaths is only for serving assets out of C++;
+  # to support subapps, we also need assets to be served out of R, because those
+  # URLs are rewritten by R code (i.e. routeHandler) before they can be matched to
+  # a resource path.
   .globals$resources[[prefix]] <- list(
     directoryPath = normalizedPath,
     func = staticHandler(normalizedPath)
   )
 }
 
+#' @export
+addRouteHandler <- function(urlPath, handler) {
+  if (!is.function(handler)) {
+    stop("addHandlerPath handler must be a function")
+  }
+  .globals$userHandlers[[urlPath]] <- handler
+  invisible()
+}
+.globals$userHandlers <- list()
+
+# This function handles any GET request with two or more path elements where the
+# first path element matches a prefix that was previously added using
+# addResourcePath().
+#
+# For example, if `addResourcePath("foo", "~/bar")` was called, then a GET
+# request for /foo/one/two.html would rewrite the PATH_INFO as /one/two.html and
+# send it to the resource path function for "foo". As of this writing, that
+# function will always be a staticHandler, which serves up a file if it exists
+# and NULL if it does not.
+#
+# Since Shiny 1.3.x, assets registered via addResourcePath should mostly be
+# served out of httpuv's native static file serving features. However, in the
+# specific case of subapps, the R code path must be used, because subapps insert
+# a giant random ID into the beginning of the URL that must be stripped off by
+# an R route handler (see addSubApp()).
 resourcePathHandler <- function(req) {
   if (!identical(req$REQUEST_METHOD, 'GET'))
     return(NULL)
 
+  # e.g. "/foo/one/two.html"
   path <- req$PATH_INFO
 
   match <- regexpr('^/([^/]+)/', path, perl=TRUE)
   if (match == -1)
     return(NULL)
   len <- attr(match, 'capture.length')
+  # e.g. "foo"
   prefix <- substr(path, 2, 2 + len - 1)
 
   resInfo <- .globals$resources[[prefix]]
   if (is.null(resInfo))
     return(NULL)
 
+  # e.g. "/one/two.html"
   suffix <- substr(path, 2 + len, nchar(path))
 
+  # Create a new request that's a clone of the current request, but adjust
+  # PATH_INFO and SCRIPT_NAME to reflect that we have already matched the first
+  # path element (e.g. "/foo"). See routeHandler() for more info.
   subreq <- as.environment(as.list(req, all.names=TRUE))
   subreq$PATH_INFO <- suffix
   subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
@@ -97,6 +138,17 @@ resourcePathHandler <- function(req) {
   return(resInfo$func(subreq))
 }
 
+userHandlersHandler <- function(req) {
+  # e.g. "/foo/one/two.html"
+  path <- req$PATH_INFO
+
+  handler <- .globals$userHandlers[[path]]
+  if (is.null(handler))
+    return(NULL)
+
+  return(..stacktraceon..(handler(req)))
+}
+
 #' Define Server Functionality
 #'
 #' Defines the server-side logic of the Shiny application. This generally
@@ -187,7 +239,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   # This value, if non-NULL, must be present on all HTTP and WebSocket
   # requests as the Shiny-Shared-Secret header or else access will be
   # denied (403 response for HTTP, and instant close for websocket).
-  sharedSecret <- getOption('shiny.sharedSecret')
+  checkSharedSecret <- loadSharedSecret()
 
   appHandlers <- list(
     http = joinHandlers(c(
@@ -195,10 +247,11 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
-      reactLogHandler)),
+      userHandlersHandler,
+      reactLogHandler
+    )),
     ws = function(ws) {
-      if (!is.null(sharedSecret)
-          && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
+      if (!checkSharedSecret(ws$request$HTTP_SHINY_SHARED_SECRET)) {
         ws$close()
         return(TRUE)
       }
@@ -417,6 +470,27 @@ startApp <- function(appObj, port, host, quiet) {
   handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
   handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
 
+  httpuvApp <- handlerManager$createHttpuvApp()
+  httpuvApp$staticPaths <- c(
+    appObj$staticPaths,
+    list(
+      # Always handle /session URLs dynamically, even if / is a static path.
+      "session" = excludeStaticPath(),
+      "shared" = system.file(package = "shiny", "www", "shared")
+    ),
+    .globals$resourcePaths
+  )
+  httpuvApp$staticPathOptions <- httpuv::staticPathOptions(
+    html_charset = "utf-8",
+    headers = list("X-UA-Compatible" = "IE=edge,chrome=1"),
+    validation =
+      if (!is.null(getOption("shiny.sharedSecret"))) {
+        sprintf('"Shiny-Shared-Secret" == "%s"', getOption("shiny.sharedSecret"))
+      } else {
+        character(0)
+      }
+  )
+
   if (is.numeric(port) || is.integer(port)) {
     if (!quiet) {
       hostString <- host
@@ -424,7 +498,7 @@ startApp <- function(appObj, port, host, quiet) {
         hostString <- paste0("[", hostString, "]")
       message('\n', 'Listening on http://', hostString, ':', port)
     }
-    return(startServer(host, port, handlerManager$createHttpuvApp()))
+    return(startServer(host, port, httpuvApp))
   } else if (is.character(port)) {
     if (!quiet) {
       message('\n', 'Listening on domain socket ', port)
@@ -436,7 +510,7 @@ startApp <- function(appObj, port, host, quiet) {
            "configuration (and not domain sockets), then `port` must ",
            "be numeric, not a string.")
     }
-    return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
+    return(startPipeServer(port, mask, httpuvApp))
   }
 }
 
@@ -777,6 +851,10 @@ runApp <- function(appDir=getwd(),
 
   server <- startApp(appParts, port, host, quiet)
 
+  # Make the httpuv server object accessible. Needed for calling
+  # addResourcePath while app is running.
+  shinyOptions(server = server)
+
   on.exit({
     stopServer(server)
   }, add = TRUE)

R/shiny.R

@@ -62,7 +62,7 @@ NULL
 #'     by setting e.g. \code{options(shiny.autoreload.interval = 2000)} (every
 #'     two seconds).}
 #'   \item{shiny.reactlog}{If \code{TRUE}, enable logging of reactive events,
-#'     which can be viewed later with the \code{\link{showReactLog}} function.
+#'     which can be viewed later with the \code{\link{reactlogShow}} function.
 #'     This incurs a substantial performance penalty and should not be used in
 #'     production.}
 #'   \item{shiny.usecairo}{This is used to disable graphical rendering by the
@@ -576,7 +576,7 @@ ShinySession <- R6Class(
 
             # Apply preprocessor functions for inputs that have them.
             values$input <- lapply(
-              setNames(names(values$input), names(values$input)),
+              stats::setNames(names(values$input), names(values$input)),
               function(name) {
                 preprocess <- private$getSnapshotPreprocessInput(name)
                 preprocess(values$input[[name]])
@@ -604,7 +604,7 @@ ShinySession <- R6Class(
 
             # Apply snapshotPreprocess functions for outputs that have them.
             values$output <- lapply(
-              setNames(names(values$output), names(values$output)),
+              stats::setNames(names(values$output), names(values$output)),
               function(name) {
                 preprocess <- private$getSnapshotPreprocessOutput(name)
                 preprocess(values$output[[name]])
@@ -683,11 +683,42 @@ ShinySession <- R6Class(
 
     # See cycleStartAction
     startCycle = function() {
+      # TODO: This should check for busyCount == 0L, and remove the checks from
+      # the call sites
       if (length(private$cycleStartActionQueue) > 0) {
         head <- private$cycleStartActionQueue[[1L]]
         private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
+
+        # After we execute the current cycleStartAction (head), there may be
+        # more items left on the queue. If the current busyCount > 0, then that
+        # means an async task is running; whenever that task finishes, it will
+        # decrement the busyCount back to 0 and a startCycle will then be
+        # scheduled. But if the current busyCount is 0, it means that either
+        # busyCount was incremented and then decremented; OR that running head()
+        # never touched busyCount (one example of the latter is that an input
+        # changed that didn't actually cause any observers to be invalidated,
+        # i.e. an input that's used in the body of an observeEvent). Because of
+        # the possibility of the latter case, we need to conditionally schedule
+        # a startCycle ourselves to ensure that the remaining queue items get
+        # processed.
+        #
+        # Since we can't actually tell whether head() increment and decremented
+        # busyCount, it's possible we're calling startCycle spuriously; that's
+        # OK, it's essentially a no-op in that case.
+        on.exit({
+          if (private$busyCount == 0L && length(private$cycleStartActionQueue) > 0L) {
+            later::later(function() {
+              if (private$busyCount == 0L) {
+                private$startCycle()
+              }
+            })
+          }
+        }, add = TRUE)
+
         head()
       }
+
+      invisible()
     }
   ),
   public = list(
@@ -719,8 +750,8 @@ ShinySession <- R6Class(
       private$flushCallbacks <- Callbacks$new()
       private$flushedCallbacks <- Callbacks$new()
       private$inputReceivedCallbacks <- Callbacks$new()
-      private$.input      <- ReactiveValues$new(dedupe = FALSE)
-      private$.clientData <- ReactiveValues$new(dedupe = TRUE)
+      private$.input      <- ReactiveValues$new(dedupe = FALSE, label = "input")
+      private$.clientData <- ReactiveValues$new(dedupe = TRUE, label = "clientData")
       private$timingRecorder <- ShinyServerTimingRecorder$new()
       self$progressStack <- Stack$new()
       self$files <- Map$new()
@@ -728,9 +759,7 @@ ShinySession <- R6Class(
       self$userData <- new.env(parent = emptyenv())
 
       self$input <- .createReactiveValues(private$.input, readonly=TRUE)
-      .setLabel(self$input, 'input')
       self$clientData <- .createReactiveValues(private$.clientData, readonly=TRUE)
-      .setLabel(self$clientData, 'clientData')
 
       self$output <- .createOutputWriter(self)
 
@@ -1175,6 +1204,11 @@ ShinySession <- R6Class(
       if (self$isClosed())
         return()
 
+      # This is the only place in the session where the restoreContext is
+      # flushed.
+      if (!is.null(self$restoreContext))
+        self$restoreContext$flushPending()
+
       # Return TRUE if there's any stuff to send to the client.
       hasPendingUpdates <- function() {
         # Even though progressKeys isn't sent to the client, we use it in this
@@ -1994,6 +2028,7 @@ ShinySession <- R6Class(
     },
     incrementBusyCount = function() {
       if (private$busyCount == 0L) {
+        rLog$asyncStart(domain = self)
         private$sendMessage(busy = "busy")
       }
       private$busyCount <- private$busyCount + 1L
@@ -2001,6 +2036,7 @@ ShinySession <- R6Class(
     decrementBusyCount = function() {
       private$busyCount <- private$busyCount - 1L
       if (private$busyCount == 0L) {
+        rLog$asyncStop(domain = self)
         private$sendMessage(busy = "idle")
         self$requestFlush()
         # We defer the call to startCycle() using later(), to defend against

R/update-input.R

@@ -205,18 +205,9 @@ updateActionButton <- function(session, inputId, label = NULL, icon = NULL) {
 updateDateInput <- function(session, inputId, label = NULL, value = NULL,
                             min = NULL, max = NULL) {
 
-  # Make sure values are NULL or Date objects. This is so we can ensure that
-  # they will be formatted correctly. For example, the string "2016-08-9" is not
-  # correctly formatted, but the conversion to Date and back to string will fix
-  # it.
-  formatDate <- function(x) {
-    if (is.null(x))
-      return(NULL)
-    format(as.Date(x), "%Y-%m-%d")
-  }
-  value <- formatDate(value)
-  min   <- formatDate(min)
-  max   <- formatDate(max)
+  value <- dateYMD(value, "value")
+  min   <- dateYMD(min, "min")
+  max   <- dateYMD(max, "max")
 
   message <- dropNulls(list(label=label, value=value, min=min, max=max))
   session$sendInputMessage(inputId, message)
@@ -266,12 +257,11 @@ updateDateInput <- function(session, inputId, label = NULL, value = NULL,
 updateDateRangeInput <- function(session, inputId, label = NULL,
                                  start = NULL, end = NULL, min = NULL,
                                  max = NULL) {
-  # Make sure start and end are strings, not date objects. This is for
-  # consistency across different locales.
-  if (inherits(start, "Date"))  start <- format(start, '%Y-%m-%d')
-  if (inherits(end, "Date"))    end <- format(end, '%Y-%m-%d')
-  if (inherits(min, "Date"))    min <- format(min, '%Y-%m-%d')
-  if (inherits(max, "Date"))    max <- format(max, '%Y-%m-%d')
+
+  start <- dateYMD(start, "start")
+  end <- dateYMD(end, "end")
+  min <- dateYMD(min, "min")
+  max <- dateYMD(max, "max")
 
   message <- dropNulls(list(
     label = label,
@@ -428,13 +418,15 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
   min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
+  # If no min/max/value is provided, we won't know the
+  # type, and this will return an empty string
   dataType <- getSliderType(min, max, value)
 
   if (is.null(timeFormat)) {
     timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if (dataType == "date" || dataType == "datetime") {
+  if (isTRUE(dataType %in% c("date", "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)

R/utils.R

@@ -121,8 +121,8 @@ isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
 }
 
 `%AND%` <- function(x, y) {
-  if (!is.null(x) && !is.na(x))
-    if (!is.null(y) && !is.na(y))
+  if (!is.null(x) && !isTRUE(is.na(x)))
+    if (!is.null(y) && !isTRUE(is.na(y)))
       return(y)
   return(NULL)
 }
@@ -1050,7 +1050,7 @@ safeError <- function(error) {
 # #' @examples
 # #' ## Note: the breaking of the reactive chain that happens in the app
 # #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is
-# #' ## easily visualized with `showReactLog()`
+# #' ## easily visualized with `reactlogShow()`
 # #'
 # #' ## Only run examples in interactive R sessions
 # #' if (interactive()) {
@@ -1560,6 +1560,25 @@ URLencode <- function(value, reserved = FALSE) {
   if (reserved) encodeURIComponent(value) else encodeURI(value)
 }
 
+# Make user-supplied dates are either NULL or can be coerced
+# to a yyyy-mm-dd formatted string. If a date is specified, this
+# function returns a string for consistency across locales.
+# Also, `as.Date()` is used to coerce strings to date objects
+# so that strings like "2016-08-9" are expanded to "2016-08-09"
+dateYMD <- function(date = NULL, argName = "value") {
+  if (!length(date)) return(NULL)
+  if (length(date) > 1) warning("Expected `", argName, "` to be of length 1.")
+  tryCatch(date <- format(as.Date(date), "%Y-%m-%d"),
+    error = function(e) {
+      warning(
+        "Couldn't coerce the `", argName,
+        "` argument to a date string with format yyyy-mm-dd",
+        call. = FALSE
+      )
+    }
+  )
+  date
+}
 
 # This function takes a name and function, and it wraps that function in a new
 # function which calls the original function using the specified name. This can
@@ -1730,6 +1749,7 @@ createVarPromiseDomain <- function(env, name, value) {
 
 getSliderType <- function(min, max, value) {
   vals <- dropNulls(list(value, min, max))
+  if (length(vals) == 0) return("")
   type <- unique(lapply(vals, function(x) {
     if      (inherits(x, "Date"))   "date"
     else if (inherits(x, "POSIXt")) "datetime"
@@ -1740,3 +1760,42 @@ getSliderType <- function(min, max, value) {
   }
   type[[1]]
 }
+
+# Reads the `shiny.sharedSecret` global option, and returns a function that can
+# be used to test header values for a match.
+loadSharedSecret <- function() {
+  normalizeToRaw <- function(value, label = "value") {
+    if (is.null(value)) {
+      raw()
+    } else if (is.character(value)) {
+      charToRaw(paste(value, collapse = "\n"))
+    } else if (is.raw(value)) {
+      value
+    } else {
+      stop("Wrong type for ", label, "; character or raw expected")
+    }
+  }
+
+  sharedSecret <- normalizeToRaw(getOption("shiny.sharedSecret"))
+  if (is.null(sharedSecret)) {
+    function(x) TRUE
+  } else {
+    # We compare the digest of the two values so that their lengths are equalized
+    function(x) {
+      x <- normalizeToRaw(x)
+      # Constant time comparison to avoid timing attacks
+      constantTimeEquals(sharedSecret, x)
+    }
+  }
+}
+
+# Compares two raw vectors of equal length for equality, in constant time
+constantTimeEquals <- function(raw1, raw2) {
+  stopifnot(is.raw(raw1))
+  stopifnot(is.raw(raw2))
+  if (length(raw1) != length(raw2)) {
+    return(FALSE)
+  }
+
+  sum(as.integer(xor(raw1, raw2))) == 0
+}

README.md

@@ -65,7 +65,4 @@ We welcome contributions to the **shiny** package. Please see our [CONTRIBUTING.
 
 ## License
 
-The shiny package is licensed under the GPLv3. See these files in the inst directory for additional details:
-
-- COPYING - shiny package license (GPLv3)
-- NOTICE  - Copyright notices for additional included software
+The shiny package as a whole is licensed under the GPLv3. See the [LICENSE](LICENSE) file for more details.

examples/oauth/app.R

@@ -0,0 +1,81 @@
+library(shiny)
+
+options(shiny.port=8100)
+
+# TODO: Figure out how not to require shiny.port to be set in advance
+# TODO: Verify that cookies work in Connect/SSP
+# TODO: Whole-page protection behind oauth
+
+source("oauth.R")
+
+github_oauth_config <- oauth_config(
+  oauth_endpoint_uri = "https://github.com/login/oauth/authorize",
+  token_endpoint_uri = "https://github.com/login/oauth/access_token",
+  app_uri = "http://127.0.0.1:8100/",
+
+  # Store client_id and client_secret however you want--just hardcoded for this example
+  client_id = "700d40c400de637d9780",
+  client_secret = "e6383430779d9df9b253e7d6b1fb53308033873d",
+
+  scope = ""
+)
+
+google_oauth_config <- oauth_config(
+  oauth_endpoint_uri = "https://accounts.google.com/o/oauth2/v2/auth",
+  token_endpoint_uri = "https://www.googleapis.com/oauth2/v4/token",
+  app_uri = "http://127.0.0.1:8100/",
+
+  # Store client_id and client_secret however you want--just hardcoded for this example
+  client_id = "350280321053-7bq89pep4da46df2g66ddjnj6e3qrnie.apps.googleusercontent.com",
+  client_secret = "8_AHVNXyKyO3tBAZFAy-2y0B",
+
+  scope = "https://www.googleapis.com/auth/drive.metadata.readonly"
+)
+
+
+ui <- fluidPage(
+  textOutput("username", inline = TRUE),
+  p(
+    oauth_login_ui("oauth_login")
+  )
+)
+
+server <- function(input, output, session) {
+
+  ### GITHUB
+
+  token <- callModule(oauth_login, id = "oauth_login", github_oauth_config)
+
+  output$username <- renderText({
+    if (is.null(token())) {
+      "Not logged in"
+    } else {
+      resp <- httr::GET("https://api.github.com/user",
+        httr::add_headers("Authorization" = paste("token", token()))
+      )
+
+      paste0("Logged in as ", httr::content(resp)$login)
+    }
+  })
+
+
+
+  ## GOOGLE
+
+  # token <- callModule(oauth_login, id = "oauth_login", google_oauth_config)
+  #
+  # output$username <- renderText({
+  #   if (is.null(token())) {
+  #     # Not logged in
+  #     "(nobody)"
+  #   } else {
+  #     req <- gargle::request_build(method = "GET", path = "oauth2/v3/tokeninfo",
+  #       params = list(access_token=token()),
+  #       base_url = "https://www.googleapis.com")
+  #     resp <- gargle::request_make(req)
+  #     gargle::response_process(resp)$email
+  #   }
+  # })
+}
+
+shinyApp(ui, server, options = list(port = 8100))

examples/oauth/oauth.R

@@ -0,0 +1,293 @@
+# remotes::install_github("r-lib/fastmap")
+
+# Include in your Shiny UI wherever you want OAuth login UI to appear
+oauth_login_ui <- function(id) {
+  ns <- NS(id)
+  tagList(
+    uiOutput(ns("container")),
+    htmltools::singleton(tags$head(clear_cookie_custom_handler))
+  )
+}
+
+# A simple Bootstrap OAuth login button
+oauth_login_button <- function(login_url) {
+  #tags$a(href=login_url, target="_blank", class="btn btn-default", "Login")
+  tags$a(href=sprintf("javascript:window.open('%s');", login_url), class = "btn btn-default", "Login")
+}
+
+oauth_logout_button <- function(input_id) {
+  actionLink(input_id, "Logout")
+}
+
+oauth_do_logout <- function(rv, session = getDefaultReactiveDomain()) {
+  xsrf_token <- shiny:::createUniqueId(16)
+  clear_cookie_xsrf$set(xsrf_token, TRUE)
+
+  session$sendCustomMessage("oauth-clear-cookie-handler", list(
+    xsrf_token = xsrf_token
+  ))
+  rv(NULL)
+}
+
+oauth_config <- function(oauth_endpoint_uri, token_endpoint_uri, app_uri,
+  client_id, client_secret, scope, login_ui = oauth_login_button,
+  logout_ui = oauth_logout_button) {
+
+  list(
+    oauth_endpoint_uri = oauth_endpoint_uri,
+    token_endpoint_uri = token_endpoint_uri,
+    app_uri = app_uri,
+    client_id = client_id,
+    client_secret = client_secret,
+    scope = scope,
+    login_ui = login_ui,
+    logout_ui = logout_ui
+  )
+}
+
+# Server module for initializing oauth
+oauth_login <- function(input, output, session, oauth_config) {
+
+  force(oauth_config)
+
+  token <- reactiveVal(NULL)
+
+  # TODO: make parsing robust (escaping)
+  cookie <- session$request$HTTP_COOKIE
+  if (!is.null(cookie)) {
+    m <- regmatches(cookie, regexec("shinyoauthaccesstoken=([^;]+)", cookie, perl = TRUE))[[1]]
+    if (length(m) > 0) {
+      token(m[[2]])
+    }
+  }
+
+  redirect_uri <- sub("/?$", "/oauth_callback", oauth_config$app_uri)
+
+  state <- store_oauth_request_state(token,
+    redirect_uri,
+    oauth_config$token_endpoint_uri,
+    oauth_config$client_id,
+    oauth_config$client_secret,
+    session)
+
+  # Prepend the worker ID onto the state parameter. Servers like
+  # Connect and SSP use the `w` query string parameter to determine
+  # what R process needs to handle a request. But we can't add a
+  # `w` parameter to our callback URI; the only part of the path or
+  # query string we can safely influence is `state`.
+  #
+  # When this state parameter is read by our callback handler, then
+  # this worker id information will be unpacked, and the browser
+  # will redirect back to the same page but with `w` extracted from
+  # state and added as its own standalone query string param.
+  state <- paste0(
+    "_w_", shiny:::workerId(), "_",
+    state
+  )
+
+  output$container <- renderUI({
+    if (is.null(token())) {
+      # login button
+      url <- make_authorization_url(oauth_config, redirect_uri, state, session)
+
+      oauth_config$login_ui(url)
+    } else {
+      oauth_config$logout_ui(session$ns("btn_logout"))
+    }
+  })
+
+  observeEvent(input$btn_logout, {
+    oauth_do_logout(token)
+  })
+
+  return(token)
+}
+
+oauth_request_state <- fastmap::fastmap()
+
+store_oauth_request_state <- function(rv, redirect_uri, token_endpoint_uri, client_id, client_secret, session = getDefaultReactiveDomain()) {
+  state <- shiny:::createUniqueId(16)
+  oauth_request_state$set(state, list(
+    rv = rv,
+    redirect_uri = redirect_uri,
+    token_endpoint_uri = token_endpoint_uri,
+    client_id = client_id,
+    client_secret = client_secret
+  ))
+
+  # In case the session ends, clean out the state so we don't leak memory
+  shiny::onSessionEnded(function() {
+    oauth_request_state$remove(state)
+  })
+
+  state
+}
+
+
+make_authorization_url <- function(oauth_config, redirect_uri, state, session = getDefaultReactiveDomain()) {
+  # TODO: Implement for real
+  #
+  # The req object is a Rook request. This is just an environment object that
+  # gives you access to the request URL, HTTP headers, etc. The documentation
+  # for this object is here:
+  # https://github.com/jeffreyhorner/Rook#the-environment
+  url_template <- "%s?client_id=%s&redirect_uri=%s&response_type=code&state=%s&access_type=offline&include_granted_scopes=true&scope=%s"
+  auth_url <- sprintf(url_template,
+    oauth_config$oauth_endpoint_uri,
+    utils::URLencode(oauth_config$client_id, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(redirect_uri, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(state, reserved = TRUE, repeated = TRUE),
+    utils::URLencode(oauth_config$scope, reserved = TRUE, repeated = TRUE)
+  )
+
+  auth_url
+}
+
+# This is the Rook handler that is invoked when the browser returns
+# from authenticating with the OAuth provider. Based on the `code`
+# and `state` in the query string, we'll look up oauth_request_state
+# and retrieve the oauth token.
+oauth_callback_handler <- function(req) {
+  if (!identical(req$REQUEST_METHOD, 'GET'))
+    return(NULL)
+
+  qs_info <- parseQueryString(req$QUERY_STRING)
+  err <- qs_info$error
+  code <- qs_info$code
+
+  # TODO: state should be signed/verified
+  state <- qs_info$state
+  if (!is.null(err)) {
+    # TODO: Report error to user
+    message(jsonlite::toJSON(qs_info, pretty = TRUE, auto_unbox = TRUE))
+    return(list(
+      status = 500L,
+      headers = list("Content-Type" = "text/plain"),
+      body = "Authorization failure"
+    ))
+  } else if (!is.null(code) && !is.null(state)) {
+
+    # See if state has worker information in it that we need to extract.
+    # If so, we need to redirect the browser with a `w=` parameter, so
+    # that server environments can ensure we end up at the right R
+    # process
+
+    if (is.null(qs_info$w)) {
+      m <- regexec("^_w_([a-fA-F0-9]*)_([a-fA-f0-9]+)$", state)
+      m <- regmatches(qs_info$state, m)[[1]]
+      if (length(m) > 0) {
+        worker_id <- m[[2]]
+        new_state <- m[[3]]
+        new_qs <- sub(
+          "([&?])state=.*?(&|$)",
+          sprintf("\\1state=%s&w=%s\\2",
+            utils::URLencode(new_state, reserved = TRUE, repeated = TRUE),
+            utils::URLencode(worker_id, reserved = TRUE, repeated = TRUE)
+          ),
+          req$QUERY_STRING
+        )
+        return(list(
+          status = 307L,
+          headers = list(
+            "Content-Type" = "text/plain",
+            "Location" = new_qs
+          ),
+          body = ""
+        ))
+      }
+    }
+
+    req_info <- oauth_request_state$get(state)
+    if (is.null(req_info)) {
+      # TODO: Report error to user
+      stop("OAuth authentication request not recognized")
+    }
+
+    redirect_uri <- req_info$redirect_uri
+    token_endpoint_uri <- req_info$token_endpoint_uri
+    client_id <- req_info$client_id
+    client_secret <- req_info$client_secret
+    rv <- req_info$rv
+
+    resp <- httr::POST(token_endpoint_uri,
+      body = list(
+        client_id = client_id,
+        code = code,
+        redirect_uri = redirect_uri,
+        grant_type = "authorization_code",
+        client_secret = client_secret
+      )
+    )
+    respObj <- httr::content(resp, as = "parsed")
+
+    rv(respObj$access_token)
+
+    return(list(
+      status = 200L,
+      headers = list(
+        "Content-Type" = "text/html",
+        # TODO: encrypt
+        # TODO: expiration
+        # TODO: secure (optionally)
+        # TODO: escaping
+        # TODO: path/samesite
+        "Set-Cookie" = sprintf("shinyoauthaccesstoken=%s; HttpOnly; Path=/", respObj$access_token)
+      ),
+      body = as.character(
+        tags$html(
+          HTML("<head><script>window.close();</script></head>"),
+          tags$body(
+            "You can close this window now"
+          )
+        )
+      )
+    ))
+  } else {
+    # TODO: Report malformed request
+  }
+}
+
+addRouteHandler("/oauth_callback", oauth_callback_handler)
+
+
+clear_cookie_xsrf <- fastmap::fastmap()
+
+oauth_clear_cookie_handler <- function(req) {
+  if (req$REQUEST_METHOD != "POST") {
+    return(NULL)
+  }
+
+  xsrf_token <- req$rook.input$read_lines(1)
+  if (is.null(clear_cookie_xsrf$get(xsrf_token))) {
+    return(list(
+      status = 403L,
+      headers = list(
+        "Content-Type" = "text/plain"
+      ),
+      body = "Unrecognized XSRF token"
+    ))
+  }
+  clear_cookie_xsrf$remove(xsrf_token)
+
+  return(list(
+    status = 200L,
+    headers = list(
+      "Content-Type" = "text/plain",
+      "Set-Cookie" = "shinyoauthaccesstoken=; HttpOnly; Path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT"
+    ),
+    body = ""
+  ))
+}
+
+addRouteHandler("/oauth_clear_cookie", oauth_clear_cookie_handler)
+
+clear_cookie_custom_handler <- tags$script(
+  "
+    Shiny.addCustomMessageHandler('oauth-clear-cookie-handler', function(msg) {
+      var req = new XMLHttpRequest();
+      req.open('POST', 'oauth_clear_cookie');
+      req.setRequestHeader('Content-Type', 'text/plain');
+      req.send(msg.xsrf_token);
+    });
+  "
+)

inst/staticdocs/index.r

@@ -134,7 +134,7 @@ sd_section("Reactive programming",
     "isolate",
     "invalidateLater",
     "debounce",
-    "showReactLog",
+    "reactlog",
     "makeReactiveBinding",
     "reactiveFileReader",
     "reactivePoll",

inst/www/shared/datepicker/js/bootstrap-datepicker.js

@@ -529,7 +529,17 @@
 		},
 
 		_utc_to_local: function(utc){
-			return utc && new Date(utc.getTime() + (utc.getTimezoneOffset()*60000));
+
+			if (!utc) return utc;
+
+			var local = new Date(utc.getTime() + (utc.getTimezoneOffset() * 60000));
+
+			if (local.getTimezoneOffset() != utc.getTimezoneOffset())
+			{
+				local = new Date(utc.getTime() + (local.getTimezoneOffset() * 60000));
+			}
+
+			return utc && local;
 		},
 		_local_to_utc: function(local){
 			return local && new Date(local.getTime() - (local.getTimezoneOffset()*60000));
@@ -661,7 +671,7 @@
 				visualPadding = 10,
 				container = $(this.o.container),
 				windowWidth = container.width(),
-				scrollTop = this.o.container === 'body' ? $(document).scrollTop() : container.scrollTop(),
+				scrollTop = this.o.container === 'body:first' ? $(document).scrollTop() : container.scrollTop(),
 				appendOffset = container.offset();
 
 			var parentsZindex = [];
@@ -676,7 +686,7 @@
 			var left = offset.left - appendOffset.left,
 				top = offset.top - appendOffset.top;
 
-			if (this.o.container !== 'body') {
+			if (this.o.container !== 'body:first') {
 				top += scrollTop;
 			}
 
@@ -1756,7 +1766,7 @@
 		enableOnReadonly: true,
 		showOnFocus: true,
 		zIndexOffset: 10,
-		container: 'body',
+		container: 'body:first',
 		immediateUpdates: false,
 		title: '',
 		templates: {

inst/www/shared/shiny.css

@@ -12,6 +12,13 @@ pre.shiny-text-output.noplaceholder:empty {
   height: 0;
 }
 
+/* Some browsers (like Safari) will wrap text in <pre> tags with Bootstrap's
+   CSS. This changes the behavior to not wrap.
+*/
+pre.shiny-text-output {
+  word-wrap: normal;
+}
+
 .shiny-image-output img.shiny-scalable, .shiny-plot-output img.shiny-scalable {
   max-width: 100%;
   max-height: 100%;
@@ -209,6 +216,10 @@ pre.shiny-text-output.noplaceholder:empty {
   font-size: 80%;
 }
 
+.shiny-label-null {
+  display: none;
+}
+
 .crosshair {
   cursor: crosshair;
 }

inst/www/shared/shiny.js

@@ -12,7 +12,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
   var exports = window.Shiny = window.Shiny || {};
 
-  exports.version = "1.2.0"; // Version number inserted by Grunt
+  exports.version = "1.3.2.9000"; // Version number inserted by Grunt
 
   var origPushState = window.history.pushState;
   window.history.pushState = function () {
@@ -321,6 +321,24 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     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;
   };
 
+  function updateLabel(labelTxt, labelNode) {
+    // Only update if label was specified in the update method
+    if (typeof labelTxt === "undefined") return;
+    if (labelNode.length !== 1) {
+      throw new Error("labelNode must be of length 1");
+    }
+
+    // Should the label be empty?
+    var emptyLabel = $.isArray(labelTxt) && labelTxt.length === 0;
+
+    if (emptyLabel) {
+      labelNode.addClass("shiny-label-null");
+    } else {
+      labelNode.text(labelTxt);
+      labelNode.removeClass("shiny-label-null");
+    }
+  }
+
   //---------------------------------------------------------------------
   // Source file: ../srcjs/browser.js
 
@@ -545,8 +563,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.lastChanceCallback = [];
   };
   (function () {
-    this.setInput = function (name, value, opts) {
-      this.pendingData[name] = value;
+    this.setInput = function (nameType, value, opts) {
+      this.pendingData[nameType] = value;
 
       if (!this.reentrant) {
         if (opts.priority === "event") {
@@ -582,8 +600,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.lastSentValues = this.reset(initialValues);
   };
   (function () {
-    this.setInput = function (name, value, opts) {
-      var _splitInputNameType = splitInputNameType(name);
+    this.setInput = function (nameType, value, opts) {
+      var _splitInputNameType = splitInputNameType(nameType);
 
       var inputName = _splitInputNameType.name;
       var inputType = _splitInputNameType.inputType;
@@ -610,10 +628,10 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         if (values.hasOwnProperty(inputName)) {
           var _splitInputNameType2 = splitInputNameType(inputName);
 
-          var name = _splitInputNameType2.name;
+          var _name = _splitInputNameType2.name;
           var inputType = _splitInputNameType2.inputType;
 
-          cacheValues[name] = {
+          cacheValues[_name] = {
             jsonValue: JSON.stringify(values[inputName]),
             inputType: inputType
           };
@@ -628,10 +646,10 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.target = target;
   };
   (function () {
-    this.setInput = function (name, value, opts) {
+    this.setInput = function (nameType, value, opts) {
       var evt = jQuery.Event("shiny:inputchanged");
 
-      var input = splitInputNameType(name);
+      var input = splitInputNameType(nameType);
       evt.name = input.name;
       evt.inputType = input.inputType;
       evt.value = value;
@@ -657,25 +675,41 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.inputRatePolicies = {};
   };
   (function () {
-    this.setInput = function (name, value, opts) {
-      this.$ensureInit(name);
+    // Note that the first argument of setInput() and setRatePolicy()
+    // are passed both the input name (i.e., inputId) and type.
+    // https://github.com/rstudio/shiny/blob/67d3a/srcjs/init_shiny.js#L111-L126
+    // However, $ensureInit() and $doSetInput() are meant to be passed just
+    // the input name (i.e., inputId), which is why we distinguish between
+    // nameType and name.
+    this.setInput = function (nameType, value, opts) {
+      var _splitInputNameType3 = splitInputNameType(nameType);
 
-      if (opts.priority !== "deferred") this.inputRatePolicies[name].immediateCall(name, value, opts);else this.inputRatePolicies[name].normalCall(name, value, opts);
+      var inputName = _splitInputNameType3.name;
+
+
+      this.$ensureInit(inputName);
+
+      if (opts.priority !== "deferred") this.inputRatePolicies[inputName].immediateCall(nameType, value, opts);else this.inputRatePolicies[inputName].normalCall(nameType, value, opts);
     };
-    this.setRatePolicy = function (name, mode, millis) {
+    this.setRatePolicy = function (nameType, mode, millis) {
+      var _splitInputNameType4 = splitInputNameType(nameType);
+
+      var inputName = _splitInputNameType4.name;
+
+
       if (mode === 'direct') {
-        this.inputRatePolicies[name] = new Invoker(this, this.$doSetInput);
+        this.inputRatePolicies[inputName] = new Invoker(this, this.$doSetInput);
       } else if (mode === 'debounce') {
-        this.inputRatePolicies[name] = new Debouncer(this, this.$doSetInput, millis);
+        this.inputRatePolicies[inputName] = new Debouncer(this, this.$doSetInput, millis);
       } else if (mode === 'throttle') {
-        this.inputRatePolicies[name] = new Throttler(this, this.$doSetInput, millis);
+        this.inputRatePolicies[inputName] = new Throttler(this, this.$doSetInput, millis);
       }
     };
     this.$ensureInit = function (name) {
       if (!(name in this.inputRatePolicies)) this.setRatePolicy(name, 'direct');
     };
-    this.$doSetInput = function (name, value, opts) {
-      this.target.setInput(name, value, opts);
+    this.$doSetInput = function (nameType, value, opts) {
+      this.target.setInput(nameType, value, opts);
     };
   }).call(InputRateDecorator.prototype);
 
@@ -684,8 +718,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.pendingInput = {};
   };
   (function () {
-    this.setInput = function (name, value, opts) {
-      if (/^\./.test(name)) this.target.setInput(name, value, opts);else this.pendingInput[name] = { value: value, opts: opts };
+    this.setInput = function (nameType, value, opts) {
+      if (/^\./.test(nameType)) this.target.setInput(nameType, value, opts);else this.pendingInput[name] = { value: value, opts: opts };
     };
     this.submit = function () {
       for (var name in this.pendingInput) {
@@ -701,12 +735,12 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     this.target = target;
   };
   (function () {
-    this.setInput = function (name, value, opts) {
-      if (!name) throw "Can't set input with empty name.";
+    this.setInput = function (nameType, value, opts) {
+      if (!nameType) throw "Can't set input with empty name.";
 
       opts = addDefaultInputOpts(opts);
 
-      this.target.setInput(name, value, opts);
+      this.target.setInput(nameType, value, opts);
     };
   }).call(InputValidateDecorator.prototype);
 
@@ -733,8 +767,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     return opts;
   }
 
-  function splitInputNameType(name) {
-    var name2 = name.split(':');
+  function splitInputNameType(nameType) {
+    var name2 = nameType.split(':');
     return {
       name: name2[0],
       inputType: name2.length > 1 ? name2[1] : ''
@@ -1771,7 +1805,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
           var $container = $('.shiny-progress-container');
           if ($container.length === 0) {
             $container = $('<div class="shiny-progress-container"></div>');
-            $('body').append($container);
+            $(document.body).append($container);
           }
 
           // Add div for just this progress ID
@@ -2025,7 +2059,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       if ($panel.length > 0) return $panel;
 
-      $('body').append('<div id="shiny-notification-panel">');
+      $(document.body).append('<div id="shiny-notification-panel">');
 
       return $panel;
     }
@@ -2105,7 +2139,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       var $modal = $('#shiny-modal-wrapper');
       if ($modal.length === 0) {
         $modal = $('<div id="shiny-modal-wrapper"></div>');
-        $('body').append($modal);
+        $(document.body).append($modal);
 
         // If the wrapper's content is a Bootstrap modal, then when the inner
         // modal is hidden, remove the entire thing, including wrapper.
@@ -4301,7 +4335,12 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
   var textInputBinding = new InputBinding();
   $.extend(textInputBinding, {
     find: function find(scope) {
-      return $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
+      var $inputs = $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
+      // selectize.js 0.12.4 inserts a hidden text input with an
+      // id that ends in '-selectized'. The .not() selector below
+      // is to prevent textInputBinding from accidentally picking up
+      // this hidden element as a shiny input (#2396)
+      return $inputs.not('input[type="text"][id$="-selectized"]');
     },
     getId: function getId(el) {
       return InputBinding.prototype.getId.call(this, el) || el.name;
@@ -4326,7 +4365,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     receiveMessage: function receiveMessage(el, data) {
       if (data.hasOwnProperty('value')) this.setValue(el, data.value);
 
-      if (data.hasOwnProperty('label')) $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       if (data.hasOwnProperty('placeholder')) el.placeholder = data.placeholder;
 
@@ -4334,7 +4373,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     },
     getState: function getState(el) {
       return {
-        label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+        label: this._getLabelNode(el).text(),
         value: el.value,
         placeholder: el.placeholder
       };
@@ -4344,6 +4383,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         policy: 'debounce',
         delay: 250
       };
+    },
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
     }
   });
   inputBindings.register(textInputBinding, 'shiny.textInput');
@@ -4399,16 +4441,19 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if (data.hasOwnProperty('max')) el.max = data.max;
       if (data.hasOwnProperty('step')) el.step = data.step;
 
-      if (data.hasOwnProperty('label')) $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       $(el).trigger('change');
     },
     getState: function getState(el) {
-      return { label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+      return { label: this._getLabelNode(el).text(),
         value: this.getValue(el),
         min: Number(el.min),
         max: Number(el.max),
         step: Number(el.step) };
+    },
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
     }
   });
   inputBindings.register(numberInputBinding, 'shiny.numberInput');
@@ -4444,6 +4489,8 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     receiveMessage: function receiveMessage(el, data) {
       if (data.hasOwnProperty('value')) el.checked = data.value;
 
+      // checkboxInput()'s label works different from other
+      // input labels...the label container should always exist
       if (data.hasOwnProperty('label')) $(el).parent().find('span').text(data.label);
 
       $(el).trigger('change');
@@ -4572,7 +4619,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         }
       }
 
-      if (data.hasOwnProperty('label')) $el.parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       var domElements = ['data-type', 'time-format', 'timezone'];
       for (var i = 0; i < domElements.length; i++) {
@@ -4614,7 +4661,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       $el.ionRangeSlider(opts);
     },
-
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
+    },
     // Number of values; 1 for single slider, 2 for range slider
     _numValues: function _numValues(el) {
       if ($(el).data('ionRangeSlider').options.type === 'double') return 2;else return 1;
@@ -4776,7 +4825,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if (startview === 2) startview = 'decade';else if (startview === 1) startview = 'year';else if (startview === 0) startview = 'month';
 
       return {
-        label: $el.find('label[for="' + $escape(el.id) + '"]').text(),
+        label: this._getLabelNode(el).text(),
         value: this.getValue(el),
         valueString: $input.val(),
         min: min,
@@ -4790,7 +4839,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     receiveMessage: function receiveMessage(el, data) {
       var $input = $(el).find('input');
 
-      if (data.hasOwnProperty('label')) $(el).find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       if (data.hasOwnProperty('min')) this._setMin($input[0], data.min);
 
@@ -4845,6 +4894,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         this._setMax($input[0], $input.data('max-date'));
       }
     },
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).find('label[for="' + $escape(el.id) + '"]');
+    },
     // Given a format object from a date picker, return a string
     _formatToString: function _formatToString(format) {
       // Format object has structure like:
@@ -4991,7 +5043,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       if (startview === 2) startview = 'decade';else if (startview === 1) startview = 'year';else if (startview === 0) startview = 'month';
 
       return {
-        label: $el.find('label[for="' + $escape(el.id) + '"]').text(),
+        label: this._getLabelNode(el).text(),
         value: this.getValue(el),
         valueString: [$startinput.val(), $endinput.val()],
         min: min,
@@ -5008,7 +5060,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       var $startinput = $inputs.eq(0);
       var $endinput = $inputs.eq(1);
 
-      if (data.hasOwnProperty('label')) $el.find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       if (data.hasOwnProperty('min')) {
         this._setMin($startinput[0], data.min);
@@ -5064,6 +5116,9 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     },
     unsubscribe: function unsubscribe(el) {
       $(el).off('.dateRangeInputBinding');
+    },
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).find('label[for="' + $escape(el.id) + '"]');
     }
   });
   inputBindings.register(dateRangeInputBinding, 'shiny.dateRangeInput');
@@ -5095,10 +5150,14 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       return $(el).val();
     },
     setValue: function setValue(el, value) {
-      var selectize = this._selectize(el);
-      if (typeof selectize !== 'undefined') {
-        selectize.setValue(value);
-      } else $(el).val(value);
+      if (!this._is_selectize(el)) {
+        $(el).val(value);
+      } else {
+        var selectize = this._selectize(el);
+        if (selectize) {
+          selectize.setValue(value);
+        }
+      }
     },
     getState: function getState(el) {
       // Store options in an array of objects, each with with value and label
@@ -5109,7 +5168,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       }
 
       return {
-        label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+        label: this._getLabelNode(el),
         value: this.getValue(el),
         options: options
       };
@@ -5191,7 +5250,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
         this.setValue(el, data.value);
       }
 
-      if (data.hasOwnProperty('label')) $(el).parent().parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       $(el).trigger('change');
     },
@@ -5214,6 +5273,18 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     initialize: function initialize(el) {
       this._selectize(el);
     },
+    _getLabelNode: function _getLabelNode(el) {
+      var escaped_id = $escape(el.id);
+      if (this._is_selectize(el)) {
+        escaped_id += "-selectized";
+      }
+      return $(el).parent().parent().find('label[for="' + escaped_id + '"]');
+    },
+    // Return true if it's a selectize input, false if it's a regular select input.
+    _is_selectize: function _is_selectize(el) {
+      var config = $(el).parent().find('script[data-for="' + $escape(el.id) + '"]');
+      return config.length > 0;
+    },
     _selectize: function _selectize(el, update) {
       if (!$.fn.selectize) return undefined;
       var $el = $(el);
@@ -5286,7 +5357,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       }
 
       return {
-        label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+        label: this._getLabelNode(el).text(),
         value: this.getValue(el),
         options: options
       };
@@ -5305,7 +5376,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       if (data.hasOwnProperty('value')) this.setValue(el, data.value);
 
-      if (data.hasOwnProperty('label')) $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       $(el).trigger('change');
     },
@@ -5317,6 +5388,10 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     unsubscribe: function unsubscribe(el) {
       $(el).off('.radioInputBinding');
     },
+    // Get the DOM element that contains the top-level label
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
+    },
     // Given an input DOM object, get the associated label. Handles labels
     // that wrap the input as well as labels associated with 'for' attribute.
     _getLabel: function _getLabel(obj) {
@@ -5382,7 +5457,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
           label: this._getLabel($objs[i]) };
       }
 
-      return { label: $(el).find('label[for="' + $escape(el.id) + '"]').text(),
+      return { label: this._getLabelNode(el).text(),
         value: this.getValue(el),
         options: options
       };
@@ -5401,7 +5476,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
 
       if (data.hasOwnProperty('value')) this.setValue(el, data.value);
 
-      if (data.hasOwnProperty('label')) $el.find('label[for="' + $escape(el.id) + '"]').text(data.label);
+      updateLabel(data.label, this._getLabelNode(el));
 
       $(el).trigger('change');
     },
@@ -5413,6 +5488,10 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     unsubscribe: function unsubscribe(el) {
       $(el).off('.checkboxGroupInputBinding');
     },
+    // Get the DOM element that contains the top-level label
+    _getLabelNode: function _getLabelNode(el) {
+      return $(el).find('label[for="' + $escape(el.id) + '"]');
+    },
     // Given an input DOM object, get the associated label. Handles labels
     // that wrap the input as well as labels associated with 'for' attribute.
     _getLabel: function _getLabel(obj) {
@@ -5578,7 +5657,7 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
       this.iframe.id = iframeId;
       this.iframe.name = iframeId;
       this.iframe.setAttribute('style', 'position: fixed; top: 0; left: 0; width: 0; height: 0; border: none');
-      $('body').append(this.iframe);
+      $(document.body).append(this.iframe);
       var iframeDestroy = function iframeDestroy() {
         // Forces Shiny to flushReact, flush outputs, etc. Without this we get
         // invalidated reactives, but observers don't actually execute.
@@ -6442,14 +6521,14 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     // Need to register callbacks for each Bootstrap 3 class.
     var bs3classes = ['modal', 'dropdown', 'tab', 'tooltip', 'popover', 'collapse'];
     $.each(bs3classes, function (idx, classname) {
-      $('body').on('shown.bs.' + classname + '.sendImageSize', '*', filterEventsByNamespace('bs', sendImageSize));
-      $('body').on('shown.bs.' + classname + '.sendOutputHiddenState ' + 'hidden.bs.' + classname + '.sendOutputHiddenState', '*', filterEventsByNamespace('bs', sendOutputHiddenState));
+      $(document.body).on('shown.bs.' + classname + '.sendImageSize', '*', filterEventsByNamespace('bs', sendImageSize));
+      $(document.body).on('shown.bs.' + classname + '.sendOutputHiddenState ' + 'hidden.bs.' + classname + '.sendOutputHiddenState', '*', filterEventsByNamespace('bs', sendOutputHiddenState));
     });
 
     // This is needed for Bootstrap 2 compatibility and for non-Bootstrap
     // related shown/hidden events (like conditionalPanel)
-    $('body').on('shown.sendImageSize', '*', sendImageSize);
-    $('body').on('shown.sendOutputHiddenState hidden.sendOutputHiddenState', '*', sendOutputHiddenState);
+    $(document.body).on('shown.sendImageSize', '*', sendImageSize);
+    $(document.body).on('shown.sendOutputHiddenState hidden.sendOutputHiddenState', '*', sendOutputHiddenState);
 
     // Send initial pixel ratio, and update it if it changes
     initialValues['.clientdata_pixelratio'] = pixelRatio();
@@ -6547,6 +6626,25 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     e.preventDefault();
   });
 
+  $(document).on('keydown', function (e) {
+    if (e.which !== 115 || !e.ctrlKey && !e.metaKey || e.shiftKey || e.altKey) return;
+    var url = 'reactlog/mark?w=' + window.escape(exports.shinyapp.config.workerId) + "&s=" + window.escape(exports.shinyapp.config.sessionId);
+
+    // send notification
+    $.get(url, function (result) {
+      if (result !== "marked") return;
+
+      var html = '<span id="shiny-reactlog-mark-text">Marked time point in reactlog</span>';
+
+      exports.notifications.show({
+        html: html,
+        closeButton: true
+      });
+    });
+
+    e.preventDefault();
+  });
+
   //---------------------------------------------------------------------
   // Source file: ../srcjs/_end.js
 })();

man/addResourcePath.Rd

@@ -20,12 +20,6 @@ Adds a directory of static resources to Shiny's web server, with the given
 path prefix. Primarily intended for package authors to make supporting
 JavaScript/CSS files available to their components.
 }
-\details{
-You can call \code{addResourcePath} multiple times for a given
-  \code{prefix}; only the most recent value will be retained. If the
-  normalized \code{directoryPath} is different than the directory that's
-  currently mapped to the \code{prefix}, a warning will be issued.
-}
 \examples{
 addResourcePath('datasets', system.file('data', package='datasets'))
 }

man/icon.Rd

@@ -8,8 +8,8 @@ icon(name, class = NULL, lib = "font-awesome")
 }
 \arguments{
 \item{name}{Name of icon. Icons are drawn from the
-\href{https://fontawesome.com/}{Font Awesome} (currently icons from
-the v5.3.1 set are supported) and
+\href{https://fontawesome.com/}{Font Awesome Free} (currently icons from
+the v5.3.1 set are supported with the v4 naming convention) and
 \href{http://getbootstrap.com/components/#glyphicons}{Glyphicons}
 libraries. Note that the "fa-" and "glyphicon-" prefixes should not be used
 in icon names (i.e. the "fa-calendar" icon should be referred to as
@@ -30,10 +30,6 @@ of a button, or as an icon for a \code{\link{tabPanel}} within a
 \code{\link{navbarPage}}.
 }
 \examples{
-icon("calendar")               # standard icon
-icon("calendar", "fa-3x")      # 3x normal size
-icon("cog", lib = "glyphicon") # From glyphicon library
-
 # add an icon to a submit button
 submitButton("Update View", icon = icon("refresh"))
 

man/reactiveVal.Rd

@@ -10,7 +10,7 @@ reactiveVal(value = NULL, label = NULL)
 \item{value}{An optional initial value.}
 
 \item{label}{An optional label, for debugging purposes (see
-\code{\link{showReactLog}}). If missing, a label will be automatically
+\code{\link{reactlog}}). If missing, a label will be automatically
 created.}
 }
 \value{

man/reactlog.Rd

@@ -1,14 +1,23 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/graph.R
-\name{showReactLog}
+\name{reactlog}
+\alias{reactlog}
+\alias{reactlogShow}
 \alias{showReactLog}
+\alias{reactlogReset}
 \title{Reactive Log Visualizer}
 \usage{
+reactlog()
+
+reactlogShow(time = TRUE)
+
 showReactLog(time = TRUE)
+
+reactlogReset()
 }
 \arguments{
 \item{time}{A boolean that specifies whether or not to display the
-time that each reactive.}
+time that each reactive takes to calculate a result.}
 }
 \description{
 Provides an interactive browser-based tool for visualizing reactive
@@ -32,14 +41,26 @@ in the process, not just for a particular application or session.
 
 As an alternative to pressing Ctrl/Command+F3--for example, if you
 are using reactives outside of the context of a Shiny
-application--you can run the \code{showReactLog} function, which will
+application--you can run the \code{reactlogShow} function, which will
 generate the reactive log visualization as a static HTML file and
 launch it in your default browser. In this case, refreshing your
 browser will not load new activity into the report; you will need to
-call \code{showReactLog()} explicitly.
+call \code{reactlogShow()} explicitly.
 
 For security and performance reasons, do not enable
 \code{shiny.reactlog} in production environments. When the option is
 enabled, it's possible for any user of your app to see at least some
 of the source code of your reactive expressions and observers.
 }
+\section{Functions}{
+\itemize{
+\item \code{reactlog}: Return a list of reactive information.  Can be used in conjunction with
+\code{reactlog::\link[reactlog]{reactlog_show}} to later display the reactlog graph.
+
+\item \code{reactlogShow}: Display a full reactlog graph for all sessions.
+
+\item \code{showReactLog}: This function is deprecated. You should use \code{\link{reactlogShow}}
+
+\item \code{reactlogReset}: Resets the entire reactlog stack.  Useful for debugging and removing all prior reactive history.
+}}
+

man/selectInput.Rd

@@ -56,7 +56,7 @@ from a list of values.
 \details{
 By default, \code{selectInput()} and \code{selectizeInput()} use the
 JavaScript library \pkg{selectize.js}
-(\url{https://github.com/selectize/selectize.js}) to instead of the basic
+(\url{https://github.com/selectize/selectize.js}) instead of the basic
 select input element. To use the standard HTML select input element, use
 \code{selectInput()} with \code{selectize=FALSE}.
 

man/shiny-options.Rd

@@ -36,7 +36,7 @@ The default polling interval is 500 milliseconds. You can change this
     by setting e.g. \code{options(shiny.autoreload.interval = 2000)} (every
     two seconds).}
   \item{shiny.reactlog}{If \code{TRUE}, enable logging of reactive events,
-    which can be viewed later with the \code{\link{showReactLog}} function.
+    which can be viewed later with the \code{\link{reactlogShow}} function.
     This incurs a substantial performance penalty and should not be used in
     production.}
   \item{shiny.usecairo}{This is used to disable graphical rendering by the

shiny.Rproj

@@ -3,7 +3,6 @@ Version: 1.0
 RestoreWorkspace: No
 SaveWorkspace: No
 AlwaysSaveHistory: Default
-QuitChildProcessesOnExit: Default
 
 EnableCodeIndexing: Yes
 UseSpacesForTab: Yes
@@ -18,6 +17,6 @@ StripTrailingWhitespace: Yes
 
 BuildType: Package
 PackageUseDevtools: Yes
-PackageInstallArgs: --with-keep.source
+PackageInstallArgs: --with-keep.source --no-byte-compile
 PackageCheckArgs: --as-cran --no-manual --run-donttest
 PackageRoxygenize: rd,collate,namespace

srcjs/init_shiny.js

@@ -413,17 +413,17 @@ function initShiny() {
   // Need to register callbacks for each Bootstrap 3 class.
   var bs3classes = ['modal', 'dropdown', 'tab', 'tooltip', 'popover', 'collapse'];
   $.each(bs3classes, function(idx, classname) {
-    $('body').on('shown.bs.' + classname + '.sendImageSize', '*',
+    $(document.body).on('shown.bs.' + classname + '.sendImageSize', '*',
       filterEventsByNamespace('bs', sendImageSize));
-    $('body').on('shown.bs.' + classname + '.sendOutputHiddenState ' +
+    $(document.body).on('shown.bs.' + classname + '.sendOutputHiddenState ' +
                  'hidden.bs.' + classname + '.sendOutputHiddenState',
                  '*', filterEventsByNamespace('bs', sendOutputHiddenState));
   });
 
   // This is needed for Bootstrap 2 compatibility and for non-Bootstrap
   // related shown/hidden events (like conditionalPanel)
-  $('body').on('shown.sendImageSize', '*', sendImageSize);
-  $('body').on('shown.sendOutputHiddenState hidden.sendOutputHiddenState', '*',
+  $(document.body).on('shown.sendImageSize', '*', sendImageSize);
+  $(document.body).on('shown.sendOutputHiddenState hidden.sendOutputHiddenState', '*',
                sendOutputHiddenState);
 
   // Send initial pixel ratio, and update it if it changes

srcjs/input_binding_checkbox.js

@@ -27,6 +27,8 @@ $.extend(checkboxInputBinding, {
     if (data.hasOwnProperty('value'))
       el.checked = data.value;
 
+    // checkboxInput()'s label works different from other
+    // input labels...the label container should always exist
     if (data.hasOwnProperty('label'))
       $(el).parent().find('span').text(data.label);
 

srcjs/input_binding_checkboxgroup.js

@@ -39,7 +39,7 @@ $.extend(checkboxGroupInputBinding, {
                      label:   this._getLabel($objs[i]) };
     }
 
-    return { label:    $(el).find('label[for="' + $escape(el.id) + '"]').text(),
+    return { label:    this._getLabelNode(el).text(),
              value:    this.getValue(el),
              options:  options
            };
@@ -59,8 +59,7 @@ $.extend(checkboxGroupInputBinding, {
     if (data.hasOwnProperty('value'))
       this.setValue(el, data.value);
 
-    if (data.hasOwnProperty('label'))
-      $el.find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     $(el).trigger('change');
   },
@@ -72,6 +71,10 @@ $.extend(checkboxGroupInputBinding, {
   unsubscribe: function(el) {
     $(el).off('.checkboxGroupInputBinding');
   },
+  // Get the DOM element that contains the top-level label
+  _getLabelNode: function(el) {
+      return $(el).find('label[for="' + $escape(el.id) + '"]');
+  },
   // Given an input DOM object, get the associated label. Handles labels
   // that wrap the input as well as labels associated with 'for' attribute.
   _getLabel: function(obj) {

srcjs/input_binding_date.js

@@ -46,7 +46,7 @@ $.extend(dateInputBinding, {
     else if (startview === 0)  startview = 'month';
 
     return {
-      label:       $el.find('label[for="' + $escape(el.id) + '"]').text(),
+      label:       this._getLabelNode(el).text(),
       value:       this.getValue(el),
       valueString: $input.val(),
       min:         min,
@@ -60,8 +60,7 @@ $.extend(dateInputBinding, {
   receiveMessage: function(el, data) {
     var $input = $(el).find('input');
 
-    if (data.hasOwnProperty('label'))
-      $(el).find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     if (data.hasOwnProperty('min'))
       this._setMin($input[0], data.min);
@@ -119,6 +118,9 @@ $.extend(dateInputBinding, {
       this._setMax($input[0], $input.data('max-date'));
     }
   },
+  _getLabelNode: function(el) {
+    return $(el).find('label[for="' + $escape(el.id) + '"]');
+  },
   // Given a format object from a date picker, return a string
   _formatToString: function(format) {
     // Format object has structure like:

srcjs/input_binding_daterange.js

@@ -63,7 +63,7 @@ $.extend(dateRangeInputBinding, dateInputBinding, {
     else if (startview === 0)  startview = 'month';
 
     return {
-      label:       $el.find('label[for="' + $escape(el.id) + '"]').text(),
+      label:       this._getLabelNode(el).text(),
       value:       this.getValue(el),
       valueString: [ $startinput.val(), $endinput.val() ],
       min:         min,
@@ -80,8 +80,7 @@ $.extend(dateRangeInputBinding, dateInputBinding, {
     var $startinput = $inputs.eq(0);
     var $endinput   = $inputs.eq(1);
 
-    if (data.hasOwnProperty('label'))
-      $el.find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     if (data.hasOwnProperty('min')) {
       this._setMin($startinput[0], data.min);
@@ -140,6 +139,9 @@ $.extend(dateRangeInputBinding, dateInputBinding, {
   },
   unsubscribe: function(el) {
     $(el).off('.dateRangeInputBinding');
-  }
+  },
+  _getLabelNode: function(el) {
+    return $(el).find('label[for="' + $escape(el.id) + '"]');
+  },
 });
 inputBindings.register(dateRangeInputBinding, 'shiny.dateRangeInput');

srcjs/input_binding_fileinput.js

@@ -13,7 +13,7 @@ var IE8FileUploader = function(shinyapp, id, fileEl) {
     this.iframe.id = iframeId;
     this.iframe.name = iframeId;
     this.iframe.setAttribute('style', 'position: fixed; top: 0; left: 0; width: 0; height: 0; border: none');
-    $('body').append(this.iframe);
+    $(document.body).append(this.iframe);
     var iframeDestroy = function() {
       // Forces Shiny to flushReact, flush outputs, etc. Without this we get
       // invalidated reactives, but observers don't actually execute.

srcjs/input_binding_number.js

@@ -24,17 +24,19 @@ $.extend(numberInputBinding, textInputBinding, {
     if (data.hasOwnProperty('max'))    el.max   = data.max;
     if (data.hasOwnProperty('step'))   el.step  = data.step;
 
-    if (data.hasOwnProperty('label'))
-      $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     $(el).trigger('change');
   },
   getState: function(el) {
-    return { label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+    return { label: this._getLabelNode(el).text(),
              value: this.getValue(el),
              min:   Number(el.min),
              max:   Number(el.max),
              step:  Number(el.step) };
+  },
+  _getLabelNode: function(el) {
+    return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
   }
 });
 inputBindings.register(numberInputBinding, 'shiny.numberInput');

srcjs/input_binding_radio.js

@@ -21,7 +21,7 @@ $.extend(radioInputBinding, {
     }
 
     return {
-      label:    $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+      label:    this._getLabelNode(el).text(),
       value:    this.getValue(el),
       options:  options
     };
@@ -41,8 +41,7 @@ $.extend(radioInputBinding, {
     if (data.hasOwnProperty('value'))
       this.setValue(el, data.value);
 
-    if (data.hasOwnProperty('label'))
-      $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     $(el).trigger('change');
   },
@@ -54,6 +53,10 @@ $.extend(radioInputBinding, {
   unsubscribe: function(el) {
     $(el).off('.radioInputBinding');
   },
+  // Get the DOM element that contains the top-level label
+  _getLabelNode: function(el) {
+      return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
+  },
   // Given an input DOM object, get the associated label. Handles labels
   // that wrap the input as well as labels associated with 'for' attribute.
   _getLabel: function(obj) {

srcjs/input_binding_select.js

@@ -22,10 +22,14 @@ $.extend(selectInputBinding, {
     return $(el).val();
   },
   setValue: function(el, value) {
-    var selectize = this._selectize(el);
-    if (typeof(selectize) !== 'undefined') {
-      selectize.setValue(value);
-    } else $(el).val(value);
+    if (!this._is_selectize(el)) {
+      $(el).val(value);
+    } else {
+      let selectize = this._selectize(el);
+      if (selectize) {
+        selectize.setValue(value);
+      }
+    }
   },
   getState: function(el) {
     // Store options in an array of objects, each with with value and label
@@ -36,7 +40,7 @@ $.extend(selectInputBinding, {
     }
 
     return {
-      label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+      label:    this._getLabelNode(el),
       value:    this.getValue(el),
       options:  options
     };
@@ -119,8 +123,7 @@ $.extend(selectInputBinding, {
       this.setValue(el, data.value);
     }
 
-    if (data.hasOwnProperty('label'))
-      $(el).parent().parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     $(el).trigger('change');
   },
@@ -141,6 +144,18 @@ $.extend(selectInputBinding, {
   initialize: function(el) {
     this._selectize(el);
   },
+  _getLabelNode: function(el) {
+    let escaped_id = $escape(el.id);
+    if (this._is_selectize(el)) {
+      escaped_id += "-selectized";
+    }
+    return $(el).parent().parent().find('label[for="' + escaped_id + '"]');
+  },
+  // Return true if it's a selectize input, false if it's a regular select input.
+  _is_selectize: function(el) {
+    var config = $(el).parent().find('script[data-for="' + $escape(el.id) + '"]');
+    return (config.length > 0);
+  },
   _selectize: function(el, update) {
     if (!$.fn.selectize) return undefined;
     var $el = $(el);

srcjs/input_binding_slider.js

@@ -130,8 +130,7 @@ $.extend(sliderInputBinding, textInputBinding, {
       }
     }
 
-    if (data.hasOwnProperty('label'))
-      $el.parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     var domElements = ['data-type', 'time-format', 'timezone'];
     for (var i = 0; i < domElements.length; i++) {
@@ -174,7 +173,9 @@ $.extend(sliderInputBinding, textInputBinding, {
 
     $el.ionRangeSlider(opts);
   },
-
+  _getLabelNode: function(el) {
+    return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
+  },
   // Number of values; 1 for single slider, 2 for range slider
   _numValues: function(el) {
     if ($(el).data('ionRangeSlider').options.type === 'double')

srcjs/input_binding_text.js

@@ -1,7 +1,12 @@
 var textInputBinding = new InputBinding();
 $.extend(textInputBinding, {
   find: function(scope) {
-    return $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
+    var $inputs = $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
+    // selectize.js 0.12.4 inserts a hidden text input with an
+    // id that ends in '-selectized'. The .not() selector below
+    // is to prevent textInputBinding from accidentally picking up
+    // this hidden element as a shiny input (#2396)
+    return $inputs.not('input[type="text"][id$="-selectized"]');
   },
   getId: function(el) {
     return InputBinding.prototype.getId.call(this, el) || el.name;
@@ -27,8 +32,7 @@ $.extend(textInputBinding, {
     if (data.hasOwnProperty('value'))
       this.setValue(el, data.value);
 
-    if (data.hasOwnProperty('label'))
-      $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    updateLabel(data.label, this._getLabelNode(el));
 
     if (data.hasOwnProperty('placeholder'))
       el.placeholder = data.placeholder;
@@ -37,7 +41,7 @@ $.extend(textInputBinding, {
   },
   getState: function(el) {
     return {
-      label: $(el).parent().find('label[for="' + $escape(el.id) + '"]').text(),
+      label: this._getLabelNode(el).text(),
       value: el.value,
       placeholder: el.placeholder
     };
@@ -47,6 +51,9 @@ $.extend(textInputBinding, {
       policy: 'debounce',
       delay: 250
     };
+  },
+  _getLabelNode: function(el) {
+    return $(el).parent().find('label[for="' + $escape(el.id) + '"]');
   }
 });
 inputBindings.register(textInputBinding, 'shiny.textInput');

srcjs/input_rate.js

@@ -189,8 +189,8 @@ var InputBatchSender = function(shinyapp) {
   this.lastChanceCallback = [];
 };
 (function() {
-  this.setInput = function(name, value, opts) {
-    this.pendingData[name] = value;
+  this.setInput = function(nameType, value, opts) {
+    this.pendingData[nameType] = value;
 
     if (!this.reentrant) {
       if (opts.priority === "event") {
@@ -227,8 +227,8 @@ var InputNoResendDecorator = function(target, initialValues) {
   this.lastSentValues = this.reset(initialValues);
 };
 (function() {
-  this.setInput = function(name, value, opts) {
-    const { name: inputName, inputType: inputType } = splitInputNameType(name);
+  this.setInput = function(nameType, value, opts) {
+    const { name: inputName, inputType: inputType } = splitInputNameType(nameType);
     const jsonValue = JSON.stringify(value);
 
     if (opts.priority !== "event" &&
@@ -267,10 +267,10 @@ var InputEventDecorator = function(target) {
   this.target = target;
 };
 (function() {
-  this.setInput = function(name, value, opts) {
+  this.setInput = function(nameType, value, opts) {
     var evt = jQuery.Event("shiny:inputchanged");
 
-    const input = splitInputNameType(name);
+    const input = splitInputNameType(nameType);
     evt.name      = input.name;
     evt.inputType = input.inputType;
     evt.value     = value;
@@ -297,31 +297,41 @@ var InputRateDecorator = function(target) {
   this.inputRatePolicies = {};
 };
 (function() {
-  this.setInput = function(name, value, opts) {
-    this.$ensureInit(name);
+  // Note that the first argument of setInput() and setRatePolicy()
+  // are passed both the input name (i.e., inputId) and type.
+  // https://github.com/rstudio/shiny/blob/67d3a/srcjs/init_shiny.js#L111-L126
+  // However, $ensureInit() and $doSetInput() are meant to be passed just
+  // the input name (i.e., inputId), which is why we distinguish between
+  // nameType and name.
+  this.setInput = function(nameType, value, opts) {
+    const {name: inputName} = splitInputNameType(nameType);
+
+    this.$ensureInit(inputName);
 
     if (opts.priority !== "deferred")
-      this.inputRatePolicies[name].immediateCall(name, value, opts);
+      this.inputRatePolicies[inputName].immediateCall(nameType, value, opts);
     else
-      this.inputRatePolicies[name].normalCall(name, value, opts);
+      this.inputRatePolicies[inputName].normalCall(nameType, value, opts);
   };
-  this.setRatePolicy = function(name, mode, millis) {
+  this.setRatePolicy = function(nameType, mode, millis) {
+    const {name: inputName} = splitInputNameType(nameType);
+
     if (mode === 'direct') {
-      this.inputRatePolicies[name] = new Invoker(this, this.$doSetInput);
+      this.inputRatePolicies[inputName] = new Invoker(this, this.$doSetInput);
     }
     else if (mode === 'debounce') {
-      this.inputRatePolicies[name] = new Debouncer(this, this.$doSetInput, millis);
+      this.inputRatePolicies[inputName] = new Debouncer(this, this.$doSetInput, millis);
     }
     else if (mode === 'throttle') {
-      this.inputRatePolicies[name] = new Throttler(this, this.$doSetInput, millis);
+      this.inputRatePolicies[inputName] = new Throttler(this, this.$doSetInput, millis);
     }
   };
   this.$ensureInit = function(name) {
     if (!(name in this.inputRatePolicies))
       this.setRatePolicy(name, 'direct');
   };
-  this.$doSetInput = function(name, value, opts) {
-    this.target.setInput(name, value, opts);
+  this.$doSetInput = function(nameType, value, opts) {
+    this.target.setInput(nameType, value, opts);
   };
 }).call(InputRateDecorator.prototype);
 
@@ -331,9 +341,9 @@ var InputDeferDecorator = function(target) {
   this.pendingInput = {};
 };
 (function() {
-  this.setInput = function(name, value, opts) {
-    if (/^\./.test(name))
-      this.target.setInput(name, value, opts);
+  this.setInput = function(nameType, value, opts) {
+    if (/^\./.test(nameType))
+      this.target.setInput(nameType, value, opts);
     else
       this.pendingInput[name] = { value, opts };
   };
@@ -352,13 +362,13 @@ const InputValidateDecorator = function(target) {
   this.target = target;
 };
 (function() {
-  this.setInput = function(name, value, opts) {
-    if (!name)
+  this.setInput = function(nameType, value, opts) {
+    if (!nameType)
       throw "Can't set input with empty name.";
 
     opts = addDefaultInputOpts(opts);
 
-    this.target.setInput(name, value, opts);
+    this.target.setInput(nameType, value, opts);
   };
 }).call(InputValidateDecorator.prototype);
 
@@ -387,8 +397,8 @@ function addDefaultInputOpts(opts) {
 }
 
 
-function splitInputNameType(name) {
-  const name2 = name.split(':');
+function splitInputNameType(nameType) {
+  const name2 = nameType.split(':');
   return {
     name:      name2[0],
     inputType: name2.length > 1 ? name2[1] : ''

srcjs/modal.js

@@ -15,7 +15,7 @@ exports.modal = {
     let $modal = $('#shiny-modal-wrapper');
     if ($modal.length === 0) {
       $modal = $('<div id="shiny-modal-wrapper"></div>');
-      $('body').append($modal);
+      $(document.body).append($modal);
 
       // If the wrapper's content is a Bootstrap modal, then when the inner
       // modal is hidden, remove the entire thing, including wrapper.

srcjs/notifications.js

@@ -97,7 +97,7 @@ exports.notifications = (function() {
     if ($panel.length > 0)
       return $panel;
 
-    $('body').append('<div id="shiny-notification-panel">');
+    $(document.body).append('<div id="shiny-notification-panel">');
 
     return $panel;
   }

srcjs/reactlog.js

@@ -7,3 +7,24 @@ $(document).on('keydown', function(e) {
   e.preventDefault();
 });
 
+
+$(document).on('keydown', function(e) {
+  if (e.which !== 115 || (!e.ctrlKey && !e.metaKey) || (e.shiftKey || e.altKey))
+    return;
+  var url = 'reactlog/mark?w=' + window.escape(exports.shinyapp.config.workerId) +
+    "&s=" + window.escape(exports.shinyapp.config.sessionId);
+
+  // send notification
+  $.get(url, function(result) {
+    if (result !== "marked") return;
+
+    var html = '<span id="shiny-reactlog-mark-text">Marked time point in reactlog</span>';
+
+    exports.notifications.show({
+      html: html,
+      closeButton: true,
+    });
+  });
+
+  e.preventDefault();
+});

srcjs/shinyapp.js

@@ -1078,7 +1078,7 @@ var ShinyApp = function() {
         var $container = $('.shiny-progress-container');
         if ($container.length === 0) {
           $container = $('<div class="shiny-progress-container"></div>');
-          $('body').append($container);
+          $(document.body).append($container);
         }
 
         // Add div for just this progress ID

srcjs/utils.js

@@ -326,3 +326,23 @@ exports.compareVersion = function(a, op, b) {
   else if (op === "<")  return (diff <   0);
   else                  throw `Unknown operator: ${op}`;
 };
+
+
+function updateLabel(labelTxt, labelNode) {
+  // Only update if label was specified in the update method
+  if (typeof labelTxt === "undefined") return;
+  if (labelNode.length !== 1) {
+    throw new Error("labelNode must be of length 1");
+  }
+
+  // Should the label be empty?
+  var emptyLabel = $.isArray(labelTxt) && labelTxt.length === 0;
+
+  if (emptyLabel) {
+    labelNode.addClass("shiny-label-null");
+  } else {
+    labelNode.text(labelTxt);
+    labelNode.removeClass("shiny-label-null");
+  }
+
+}

tests/testthat/test-options.R

@@ -51,3 +51,19 @@ test_that("Local options", {
   # Finish tests; reset shinyOptions
   shinyOptions(a = NULL)
 })
+
+test_that("Shared secret", {
+  op <- options(shiny.sharedSecret = "This is a secret string")
+  on.exit(options(op))
+
+  checkSharedSecret <- loadSharedSecret()
+
+  expect_true(checkSharedSecret("This is a secret string"))
+  expect_true(checkSharedSecret(charToRaw("This is a secret string")))
+
+  expect_false(checkSharedSecret("this is a secret string"))
+  expect_false(checkSharedSecret("This is a secret string "))
+  expect_false(checkSharedSecret(""))
+  expect_false(checkSharedSecret(NULL))
+  expect_error(checkSharedSecret(1:10))
+})

tests/testthat/test-plot-coordmap.R

@@ -14,7 +14,7 @@ test_that("ggplot coordmap", {
   dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20))
 
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   # Basic scatterplot
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
@@ -75,7 +75,7 @@ test_that("ggplot coordmap with facet_wrap", {
                     g = c("a", "b", "c"))
 
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   # facet_wrap
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
@@ -123,7 +123,7 @@ test_that("ggplot coordmap with facet_grid", {
                     g = c("a", "b", "c"))
 
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
     scale_x_continuous(expand = c(0, 0)) +
@@ -209,7 +209,7 @@ test_that("ggplot coordmap with 2D facet_grid", {
                     g = c("a", "b"), h = c("i", "j"))
 
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   p <- ggplot(dat, aes(xvar, yvar)) + geom_point() +
     scale_x_continuous(expand = c(0, 0)) +
@@ -259,7 +259,7 @@ test_that("ggplot coordmap with 2D facet_grid", {
 
 test_that("ggplot coordmap with various data types", {
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   # Factors
   dat <- expand.grid(xvar = letters[1:3], yvar = LETTERS[1:4])
@@ -271,9 +271,20 @@ test_that("ggplot coordmap with various data types", {
   dev.off()
 
   # Check domain
+  expectation <- list(
+    left = 1,
+    right = 3,
+    bottom = 1,
+    top = 4,
+    discrete_limits = list(
+      x = letters[1:3],
+      y = LETTERS[1:4]
+    )
+  )
+
   expect_equal(
     sortList(m$panels[[1]]$domain),
-    sortList(list(left=1, right=3, bottom=1, top=4))
+    sortList(expectation)
   )
 
   # Dates and date-times
@@ -302,7 +313,7 @@ test_that("ggplot coordmap with various data types", {
 
 test_that("ggplot coordmap with various scales and coords", {
   tmpfile <- tempfile("test-shiny", fileext = ".png")
-  on.exit(rm(tmpfile))
+  on.exit(unlink(tmpfile))
 
   # Reversed scales
   dat <- data.frame(xvar = c(0, 5), yvar = c(10, 20))
@@ -357,3 +368,103 @@ test_that("ggplot coordmap with various scales and coords", {
     sortList(list(left=-1, right=3, bottom=-2, top=4))
   )
 })
+
+
+test_that("ggplot coordmap maintains discrete limits", {
+  tmpfile <- tempfile("test-shiny", fileext = ".png")
+  on.exit(unlink(tmpfile))
+
+  # check discrete limits are correct for free x scales
+  p <- ggplot(mpg) +
+    geom_point(aes(fl, cty), alpha = 0.2) +
+    facet_wrap(~drv, scales = "free_x")
+  png(tmpfile)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
+  dev.off()
+
+  expect_length(m$panels, 3)
+  expect_equal(
+    m$panels[[1]]$domain$discrete_limits,
+    list(x = c("d", "e", "p", "r"))
+  )
+  expect_equal(
+    m$panels[[2]]$domain$discrete_limits,
+    list(x = c("c", "d", "e", "p", "r"))
+  )
+  expect_equal(
+    m$panels[[3]]$domain$discrete_limits,
+    list(x = c("e", "p", "r"))
+  )
+
+  # same for free y
+  p2 <- ggplot(mpg) +
+    geom_point(aes(cty, fl), alpha = 0.2) +
+    facet_wrap(~drv, scales = "free_y")
+  png(tmpfile)
+  m2 <- getGgplotCoordmap(print(p2), 500, 400, 72)
+  dev.off()
+
+  expect_length(m2$panels, 3)
+  expect_equal(
+    m2$panels[[1]]$domain$discrete_limits,
+    list(y = c("d", "e", "p", "r"))
+  )
+  expect_equal(
+    m2$panels[[2]]$domain$discrete_limits,
+    list(y = c("c", "d", "e", "p", "r"))
+  )
+  expect_equal(
+    m2$panels[[3]]$domain$discrete_limits,
+    list(y = c("e", "p", "r"))
+  )
+
+  # check that specifying x limits is captured
+  p3 <- ggplot(mpg) +
+    geom_point(aes(fl, cty), alpha = 0.2) +
+    scale_x_discrete(limits = c("c", "d", "e"))
+
+  png(tmpfile)
+  m3 <- getGgplotCoordmap(suppressWarnings(print(p3)), 500, 400, 72)
+  dev.off()
+
+  expect_length(m3$panels, 1)
+  expect_equal(
+    m3$panels[[1]]$domain$discrete_limits,
+    list(x = c("c", "d", "e"))
+  )
+
+  # same for y
+  p4 <- ggplot(mpg) +
+    geom_point(aes(cty, fl), alpha = 0.2) +
+    scale_y_discrete(limits = c("e", "f"))
+
+  png(tmpfile)
+  m4 <- getGgplotCoordmap(suppressWarnings(print(p4)), 500, 400, 72)
+  dev.off()
+
+  expect_length(m4$panels, 1)
+  expect_equal(
+    m4$panels[[1]]$domain$discrete_limits,
+    list(y = c("e", "f"))
+  )
+
+  # make sure that when labels are specified, where
+  # still relaying the input data
+  p5 <- ggplot(mpg) +
+    geom_point(aes(fl, cty), alpha = 0.2) +
+    scale_x_discrete(
+      limits = c("e", "f"),
+      labels = c("foo", "bar")
+    )
+
+  png(tmpfile)
+  m5 <- getGgplotCoordmap(suppressWarnings(print(p5)), 500, 400, 72)
+  dev.off()
+
+  expect_length(m5$panels, 1)
+  expect_equal(
+    m5$panels[[1]]$domain$discrete_limits,
+    list(x = c("e", "f"))
+  )
+
+})

tests/testthat/test-reactlog.R

@@ -0,0 +1,131 @@
+
+context("reactlog")
+
+keyValList <- function(key, value) {
+  ret <- list()
+  ret[[key]] <- value
+  ret
+}
+withOption <- function(key, value, oldVal = NULL, expr) {
+  oldVal <- getOption(key, oldVal)
+  do.call("options", keyValList(key, value))
+  on.exit({
+    do.call("options", keyValList(key, oldVal))
+  })
+  force(expr)
+}
+
+withLogging <- function(expr) {
+
+  rLog$reset()
+
+  # reset ctx counter
+  reactiveEnvr <- .getReactiveEnvironment()
+  reactiveEnvr$.nextId <- 0L
+
+  withOption("shiny.reactlog", TRUE, FALSE, {
+    withOption("shiny.reactlog.console", TRUE, FALSE, {
+      withOption("shiny.suppressMissingContextError", TRUE, FALSE, {
+        force(expr)
+      })
+    })
+  })
+}
+
+expect_logs <- function(expr, ...) {
+  expected_messages <- unlist(list(...))
+  captured_messages <- capture_messages(expr)
+  captured_messages <- sub("\n$", "", captured_messages)
+  if (length(captured_messages) != length(expected_messages)) {
+    cat("\nCaptured: \n"); print(captured_messages)
+    cat("Expected: \n"); print(expected_messages)
+  }
+  expect_equal(
+    captured_messages,
+    expected_messages
+  )
+}
+
+test_that("rLog resets when options are FALSE", {
+
+  withOption("shiny.reactlog", FALSE, FALSE, {
+    withOption("shiny.reactlog.console", FALSE, FALSE, {
+      rLog$reset()
+
+      # check for dummy and no reactid information
+      expect_true(!is.null(rLog$noReactId))
+      expect_true(!is.null(rLog$dummyReactId))
+      expect_equal(rLog$msg$getReact(rLog$noReactId, force = TRUE)$reactId, rLog$noReactId)
+      expect_equal(rLog$msg$getReact(rLog$dummyReactId, force = TRUE)$reactId, rLog$dummyReactId)
+      expect_equal(length(rLog$msg$reactCache), 2)
+    })
+  })
+
+})
+
+test_that("message logger appears", {
+
+  withLogging({
+
+    expect_logs(
+      {
+        val <- reactiveVal(1, label = "val")
+      },
+      "- define: r1:'val' - reactiveVal ' num 1'"
+    )
+    expect_silent(
+      {
+        values <- reactiveValues(a = 2, b = 3)
+        local({
+          values_obj <- .subset2(values, 'impl')
+          values_obj$.label <- "values"
+        })
+      }
+    )
+    expect_logs(
+      {
+        react <- reactive(val() + values$a)
+      },
+      "- define: r3:'reactive(val() + values$a)' - observable ' NULL'"
+    )
+
+    expect_logs(
+      {
+        react()
+      },
+      "- createContext: ctxDummy - isolate",
+      "- dependsOn: rDummyReactId:'DummyReactId' on r3:'reactive(val() + values$a)' in ctxDummy",
+      "- createContext: ctx1 - observable",
+      "- enter: r3:'reactive(val() + values$a)' in ctx1 - observable",
+      "= - dependsOn: r3:'reactive(val() + values$a)' on r1:'val' in ctx1",
+      "= - define: r2$a:'values$a' - reactiveValuesKey ' num 2'",
+      "= - dependsOn: r3:'reactive(val() + values$a)' on r2$a:'values$a' in ctx1",
+      "- exit: r3:'reactive(val() + values$a)' in ctx1 - observable"
+    )
+
+    expect_logs(
+      {
+        val(4)
+      },
+      "- valueChange: r1:'val' ' num 4'",
+      "- invalidateStart: r1:'val'",
+      "= - invalidateStart: r3:'reactive(val() + values$a)' in ctx1 - observable",
+      "= = - isolateInvalidateStart: rDummyReactId:'DummyReactId' in ctxDummy",
+      "= = = - dependsOnRemove: rDummyReactId:'DummyReactId' on r3:'reactive(val() + values$a)' in ctxDummy",
+      "= = - isolateInvalidateEnd: rDummyReactId:'DummyReactId' in ctxDummy",
+      "= = - dependsOnRemove: r3:'reactive(val() + values$a)' on r1:'val' in ctx1",
+      "= = - dependsOnRemove: r3:'reactive(val() + values$a)' on r2$a:'values$a' in ctx1",
+      "= - invalidateEnd: r3:'reactive(val() + values$a)' in ctx1 - observable",
+      "- invalidateEnd: r1:'val'"
+    )
+
+    expect_logs(
+      {values$a <- 5},
+      "- valueChange: r2$a:'values$a' ' num 5'",
+      "- invalidateStart: r2$a:'values$a'",
+      "- invalidateEnd: r2$a:'values$a'"
+    )
+
+  })
+
+})

tools/README.md

@@ -31,7 +31,7 @@ Periodically, it's good to upgrade the packages to a recent version. There's two
 1. Use `yarn upgrade` to upgrade all dependencies to their latest version based on the version range specified in the package.json file (the yarn.lock file will be recreated as well. Yarn packages use [semantic versioning](https://yarnpkg.com/en/docs/dependency-versions), i.e. each version is writen with a maximum of 3 dot-separated numbers such that: `major.minor.patch`. For example in the version `3.1.4`, 3 is the major version number, 1 is the minor version number and 4 is the patch version number. Here are the most used operators (these appear before the version number):
 
   - `~` is for upgrades that keep the minor version the same (assuming that was specified);
-  
+
   - `^` is for upgrades that keep the major version the same (more or less -- more specifically, it allow changes that do not modify the first non-zero digit in the version, either the 3 in 3.1.4 or the 4 in 0.4.2.). This is the default operator added to the package.json when you run `yarn add [package-name]`.
 
 2. Use `yarn upgrade [package]` to upgrade a single named package to the version specified by the latest tag (potentially upgrading the package across major versions).
@@ -41,52 +41,32 @@ For more information about upgrading or installing new packages, see the [yarn w
 ### Grunt
 Grunt is a build tool that runs on node.js (and installed using `yarn`). In Shiny, it is used for concatenating, minifying, and linting Javascript code.
 
-#### Installing Grunt and the Grunt CLI (command line interface)
-Grunt is a package listed in package.json, so if you've done the previous step, that's already installed. However, as a developer, you also need to install a sister package (called `grunt-cli`) globally:
-
-```
-# Install grunt command line tool globally
-sudo yarn global add grunt-cli
-```
-
-Here's what has happened (from the [Grunt Getting Started guide](http://gruntjs.com/getting-started)):
-
-> This will put the `grunt` command in your system path, allowing it to be run from any directory.
->
-> Note that installing `grunt-cli` does not install the Grunt task runner! The job of the Grunt CLI is simple: run the version of Grunt which has been installed next to a `Gruntfile`. This allows multiple versions of Grunt to be installed on the same machine simultaneously.
-
-And here is how the CLI works (same source):
-
-> Each time `grunt` is run, it looks for a locally installed Grunt using node's `require()` system. Because of this, you can run `grunt` from any subfolder in your project.
->
-> If a locally installed Grunt is found, the CLI loads the local installation of the Grunt library, applies the configuration from your `Gruntfile`, and executes any tasks you've requested for it to run. To really understand what is happening, [read the code](https://github.com/gruntjs/grunt-cli/blob/master/bin/grunt).
-
 ### Using Grunt
 To run all default grunt tasks specified in the Gruntfile (concatenation, minification, and jshint), simply go into the `tools` directory and run:
 
 ```
-grunt
+yarn build
 ```
 
 Sometimes grunt gets confused about whether the output files are up to date, and won't overwrite them even if the input files have changed. If this happens, run:
 
 ```
-grunt clean
+yarn clean
 ```
 
 It's also useful to run `grunt` so that it monitors files for changes and run tasks as necessary. This is done with:
 
 ```
-grunt watch
+yarn watch
 ```
 
 One of the tasks concatenates all the .js files in `/srcjs` together into `/inst/www/shared/shiny.js`. Another task minifies `shiny.js` to generate `shiny.min.js`. The minified file is supplied to the browser, along with a source map file, `shiny.min.js.map`, which allows a user to view the original Javascript source when using the debugging console in the browser.
 
-During development of Shiny's Javascript code, it's best to use `grunt watch` so that the minified file will get updated whenever you make changes the Javascript sources.
+During development of Shiny's Javascript code, it's best to use `yarn watch` so that the minified file will get updated whenever you make changes the Javascript sources.
 
 #### Auto build and browser refresh
 
-An alternative to `grunt watch` is to use `entr` to trigger `grunt` when sources change. `entr` can be installed with `brew install entr` on a Mac, or on Linux using your distribution's package manager. Using this technique, it's possible to both automatically rebuild sources and reload Chrome at the same time:
+An alternative to `yarn watch` is to use `entr` to trigger `grunt` when sources change. `entr` can be installed with `brew install entr` on a Mac, or on Linux using your distribution's package manager. Using this technique, it's possible to both automatically rebuild sources and reload Chrome at the same time:
 
 *macOS*:
 
@@ -112,3 +92,27 @@ To update the version of babel-polyfill:
 * Run `yarn add --dev babel-polyfill --exact`.
 * Edit R/shinyui.R. The `renderPage` function has an `htmlDependency` for
   `babel-polyfill`. Update this to the new version number.
+
+# Updating and patching `bootstrap-datepicker`
+
+## Updating
+
+[bootstrap-datepicker](https://github.com/uxsolutions/bootstrap-datepicker) can be updated with the script `updateBootstrapDatepicker.R`.
+
+After updating, our patches to `bootstrap-datepicker` must be applied using the script `applyDatepickerPatches.R`
+
+After updating and applying patches, `yarn grunt` should be run per the instructions above in order to generate a minified JavaScript file.
+
+## Making a new patch
+
+To create a new patch:
+
+1. Make any necessary changes to files in `inst/www/shared/datepicker`
+1. **Do not commit your changes.**
+1. Instead, create a patch with a command like `git diff > tools/datepicker-patches/012-a-description.patch`. Patches are applied in alphabetic order (per `list.files`), so you should name your patch based on the last one in `tools/datepicker-patches` so that it's applied last.
+1. Add the new `.patch` file to the repo with a descriptive commit message
+1. Revert `bootstrap-datepicker` to its unpatched state by running `updateBootstrapDatepicker.R`
+1. Apply all patches, including the one you just made, by running `applyDatepickerPatches.R`
+1. Run `yarn grunt`
+1. Test your changes
+1. `git add` the new `.patch` and any resulting changes

tools/applyDatepickerPatches.R

@@ -0,0 +1,18 @@
+#!/usr/bin/env Rscript
+# Applies patches stored in tools/datepicker-patches
+# Should be run after running tools/updateBootstrapDatepicker.R
+
+library(rprojroot)
+
+patch_dir <- rprojroot::find_package_root_file("tools/datepicker-patches")
+
+for (patch in list.files(patch_dir, full.names = TRUE)) {
+  tryCatch({
+      message(sprintf("Applying %s", basename(patch)))
+      system(sprintf("git apply '%s'", patch))
+    },
+    error = function(e) {
+      quit(save = "no", status = 1)
+    }
+  )
+}

tools/datepicker-patches/000-fix-datepicker-dst-bug.patch

@@ -0,0 +1,23 @@
+diff --git a/inst/www/shared/datepicker/js/bootstrap-datepicker.js b/inst/www/shared/datepicker/js/bootstrap-datepicker.js
+index 76a99fc2..97f5c086 100644
+--- a/inst/www/shared/datepicker/js/bootstrap-datepicker.js
++++ b/inst/www/shared/datepicker/js/bootstrap-datepicker.js
+@@ -529,7 +529,17 @@
+ 		},
+ 
+ 		_utc_to_local: function(utc){
+-			return utc && new Date(utc.getTime() + (utc.getTimezoneOffset()*60000));
++
++			if (!utc) return utc;
++
++			var local = new Date(utc.getTime() + (utc.getTimezoneOffset() * 60000));
++
++			if (local.getTimezoneOffset() != utc.getTimezoneOffset())
++			{
++				local = new Date(utc.getTime() + (local.getTimezoneOffset() * 60000));
++			}
++
++			return utc && local;
+ 		},
+ 		_local_to_utc: function(local){
+ 			return local && new Date(local.getTime() - (local.getTimezoneOffset()*60000));

tools/datepicker-patches/001-fix-networkD3-sankey-svg-bugs.patch

@@ -0,0 +1,31 @@
+diff --git a/inst/www/shared/datepicker/js/bootstrap-datepicker.js b/inst/www/shared/datepicker/js/bootstrap-datepicker.js
+index 97f5c086..2a0d8ae6 100644
+--- a/inst/www/shared/datepicker/js/bootstrap-datepicker.js
++++ b/inst/www/shared/datepicker/js/bootstrap-datepicker.js
+@@ -671,7 +671,7 @@
+ 				visualPadding = 10,
+ 				container = $(this.o.container),
+ 				windowWidth = container.width(),
+-				scrollTop = this.o.container === 'body' ? $(document).scrollTop() : container.scrollTop(),
++				scrollTop = this.o.container === 'body:first' ? $(document).scrollTop() : container.scrollTop(),
+ 				appendOffset = container.offset();
+ 
+ 			var parentsZindex = [];
+@@ -686,7 +686,7 @@
+ 			var left = offset.left - appendOffset.left,
+ 				top = offset.top - appendOffset.top;
+ 
+-			if (this.o.container !== 'body') {
++			if (this.o.container !== 'body:first') {
+ 				top += scrollTop;
+ 			}
+ 
+@@ -1766,7 +1766,7 @@
+ 		enableOnReadonly: true,
+ 		showOnFocus: true,
+ 		zIndexOffset: 10,
+-		container: 'body',
++		container: 'body:first',
+ 		immediateUpdates: false,
+ 		title: '',
+ 		templates: {

tools/package.json

@@ -1,4 +1,10 @@
 {
+  "private": true,
+  "scripts": {
+    "build": "grunt",
+    "clean": "grunt clean",
+    "watch": "grunt default watch"
+  },
   "devDependencies": {
     "babel-eslint": "^6.0.0",
     "babel-preset-es2015": "^6.6.0",

tools/updateBootstrapDatepicker.R

@@ -1,47 +1,41 @@
 #!/usr/bin/env Rscript
+# Retrieves a particular version of bootstrap-datepicker:
+#  https://github.com/uxsolutions/bootstrap-datepicker
+# After retrieving, you can apply patches stored in
+# tools/datepicker-patches with applyDatepickerPatches.R
 
-# This script copies resources from Bootstrap Datepicker to shiny's inst
-# directory. The bootstrap-datepicker/ project directory should be on the same
-# level as the shiny/ project directory.
+library(rprojroot)
 
-# It is necessary to run Grunt after running this script: This copies the
-# un-minified JS file over, and running Grunt minifies it and inlines the locale
-# files into the minified JS.
+version   <- "1.6.4"
+dest_dir  <- rprojroot::find_package_root_file("inst/www/shared/datepicker")
+tag       <- paste0("v", version)
+dest_file <- file.path(tempdir(), paste0("bootstrap-datepicker-", version, ".zip"))
+url       <- sprintf("https://github.com/uxsolutions/bootstrap-datepicker/releases/download/%s/bootstrap-datepicker-%s-dist.zip", tag, version)
 
-# This script can be sourced from RStudio, or run with Rscript.
+download.file(url, dest_file)
+unzipped <- tempdir()
+unzip(dest_file, exdir = unzipped)
 
-# Returns the file currently being sourced or run with Rscript
-thisFile <- function() {
-  cmdArgs <- commandArgs(trailingOnly = FALSE)
-  needle <- "--file="
-  match <- grep(needle, cmdArgs)
-  if (length(match) > 0) {
-    # Rscript
-    return(normalizePath(sub(needle, "", cmdArgs[match])))
-  } else {
-    # 'source'd via R console
-    return(normalizePath(sys.frames()[[1]]$ofile))
-  }
-}
-
-srcdir <- normalizePath(file.path(dirname(thisFile()), "../../bootstrap-datepicker/dist"))
-destdir <- normalizePath(file.path(dirname(thisFile()), "../inst/www/shared/datepicker"))
+unlink(dest_dir, recursive = TRUE)
 
+dir.create(file.path(dest_dir, "js"), recursive = TRUE)
 file.copy(
-  file.path(srcdir, "js", "bootstrap-datepicker.js"),
-  file.path(destdir, "js"),
+  file.path(unzipped, "js", "bootstrap-datepicker.js"),
+  file.path(dest_dir, "js"),
   overwrite = TRUE
 )
 
+dir.create(file.path(dest_dir, "js", "locales"), recursive = TRUE)
 file.copy(
-  dir(file.path(srcdir, "locales"), "\\.js$", full.names = TRUE),
-  file.path(destdir, "js", "locales"),
+  dir(file.path(unzipped, "locales"), "\\.js$", full.names = TRUE),
+  file.path(dest_dir, "js", "locales"),
   overwrite = TRUE
 )
 
+dir.create(file.path(dest_dir, "css"), recursive = TRUE)
 file.copy(
-  dir(file.path(srcdir, "css"), "^bootstrap-datepicker3(\\.min)?\\.css$",
+  dir(file.path(unzipped, "css"), "^bootstrap-datepicker3(\\.min)?\\.css$",
       full.names = TRUE),
-  file.path(destdir, "css"),
+  file.path(dest_dir, "css"),
   overwrite = TRUE
 )