Add fallthrough for shared/ subdirectory

Fix #2385: R Markdown documents containing subapps not rendering properly

.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
 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

@@ -189,6 +189,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,53 @@
+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
+===========
+
+### 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,6 +55,10 @@ 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))
@@ -49,6 +103,10 @@ This release features plot caching, an important new tool for improving performa
 
 * 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))
@@ -109,7 +167,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/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}.
 #'

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,82 @@ 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 {
-        .namesDeps$invalidate()
-      }
-
-      if (hidden)
-        .allValuesDeps$invalidate()
-      else
-        .valuesDeps$invalidate()
 
+      # set the value for better logging
       .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 (key_exists) {
+        # key has been depended upon (can not happen if the key is being set)
+        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
+          )
+        }
+
+      } else {
+        # only invalidate if there are deps
+        if (isTRUE(.hasRetrieved$names)) {
+          rLog$valueChangeNames(.reactId, ls(.values, all.names = TRUE), domain)
+          .namesDeps$invalidate()
+        }
+      }
+
+      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 +451,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 +483,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 +499,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 +668,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 +790,7 @@ Observable <- R6Class(
   'Observable',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .origFunc = 'function',
     .func = 'function',
     .label = character(0),
@@ -719,16 +821,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 +843,6 @@ Observable <- R6Class(
         )
       }
 
-      .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)
-
       if (.error) {
         stop(.value)
       }
@@ -756,12 +858,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 +1037,7 @@ Observer <- R6Class(
   'Observer',
   portable = FALSE,
   public = list(
+    .reactId = character(0),
     .func = 'function',
     .label = character(0),
     .domain = 'ANY',
@@ -978,11 +1081,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 +1499,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 +1512,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 +1536,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 +1603,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 +1873,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/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,65 @@ 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)
   )
 }
 
+# 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='')
@@ -187,7 +218,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 +226,10 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
-      reactLogHandler)),
+      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 +448,30 @@ 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" = staticPath(
+        system.file(package = "shiny", "www", "shared"),
+        fallthrough = TRUE
+      )
+    ),
+    .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 +479,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 +491,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 +832,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/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()) {
@@ -1740,3 +1740,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.

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

@@ -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: {

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"; // Version number inserted by Grunt
 
   var origPushState = window.history.pushState;
   window.history.pushState = function () {
@@ -5095,10 +5095,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
@@ -5191,7 +5195,13 @@ 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);
+      if (data.hasOwnProperty('label')) {
+        var escaped_id = $escape(el.id);
+        if (this._is_selectize(el)) {
+          escaped_id += "-selectized";
+        }
+        $(el).parent().parent().find('label[for="' + escaped_id + '"]').text(data.label);
+      }
 
       $(el).trigger('change');
     },
@@ -5214,6 +5224,11 @@ function _defineProperty(obj, key, value) { if (key in obj) { Object.definePrope
     initialize: function initialize(el) {
       this._selectize(el);
     },
+    // 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);
@@ -6547,6 +6562,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

@@ -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_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_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
@@ -119,8 +123,15 @@ $.extend(selectInputBinding, {
       this.setValue(el, data.value);
     }
 
-    if (data.hasOwnProperty('label'))
-      $(el).parent().parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
+    if (data.hasOwnProperty('label')) {
+      let escaped_id = $escape(el.id);
+      if (this._is_selectize(el)) {
+        escaped_id += "-selectized";
+      }
+      $(el).parent().parent()
+        .find('label[for="' + escaped_id + '"]')
+        .text(data.label);
+    }
 
     $(el).trigger('change');
   },
@@ -141,6 +152,11 @@ $.extend(selectInputBinding, {
   initialize: function(el) {
     this._selectize(el);
   },
+  // 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/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

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-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
 )