Clean up correctly after API caller leaves

This gives us more accurate data types (numbers as ints/reals instead of strings)

Also adds serveRaw (raw vectors)

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 0.14.2.9001
+Version: 1.0.0
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -79,7 +79,8 @@ Suggests:
     knitr (>= 1.6),
     markdown,
     rmarkdown,
-    ggplot2
+    ggplot2,
+    magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:

NAMESPACE

@@ -2,18 +2,24 @@
 
 S3method("$",reactivevalues)
 S3method("$",session_proxy)
+S3method("$",shinyapi)
 S3method("$",shinyoutput)
 S3method("$<-",reactivevalues)
 S3method("$<-",session_proxy)
+S3method("$<-",shinyapi)
 S3method("$<-",shinyoutput)
 S3method("[",reactivevalues)
+S3method("[",shinyapi)
 S3method("[",shinyoutput)
 S3method("[<-",reactivevalues)
+S3method("[<-",shinyapi)
 S3method("[<-",shinyoutput)
 S3method("[[",reactivevalues)
 S3method("[[",session_proxy)
+S3method("[[",shinyapi)
 S3method("[[",shinyoutput)
 S3method("[[<-",reactivevalues)
+S3method("[[<-",shinyapi)
 S3method("[[<-",shinyoutput)
 S3method("names<-",reactivevalues)
 S3method(as.list,reactivevalues)
@@ -61,6 +67,7 @@ export(dataTableOutput)
 export(dateInput)
 export(dateRangeInput)
 export(dblclickOpts)
+export(debounce)
 export(dialogViewer)
 export(div)
 export(downloadButton)
@@ -193,6 +200,11 @@ export(runUrl)
 export(safeError)
 export(selectInput)
 export(selectizeInput)
+export(serveCSV)
+export(serveJSON)
+export(servePlot)
+export(serveRaw)
+export(serveText)
 export(serverInfo)
 export(setBookmarkExclude)
 export(setProgress)
@@ -229,6 +241,7 @@ export(tags)
 export(textAreaInput)
 export(textInput)
 export(textOutput)
+export(throttle)
 export(titlePanel)
 export(uiOutput)
 export(updateActionButton)
@@ -265,3 +278,4 @@ import(httpuv)
 import(methods)
 import(mime)
 import(xtable)
+importFrom(utils,write.csv)

NEWS.md

@@ -1,5 +1,17 @@
-shiny 0.14.2.9000
-============
+shiny 1.0.0
+===========
+
+Shiny has reached a milestone: version 1.0.0! In the last year, we've added two major features that we considered essential for a 1.0.0 release: bookmarking, and support for testing Shiny applications. As usual, this version of Shiny also includes many minor features and bug fixes.
+
+Here are some highlights from this release. For more details, see the full changelog below.
+
+## Support for testing Shiny applications
+
+Shiny now supports automated testing of applications, with the [shinytest](https://github.com/rstudio/shinytest) package. Shinytest has not yet been released on CRAN, but will be soon. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
+
+## Debounce/throttle reactives
+
+Now there's an official way to slow down reactive values and expressions that invalidate too quickly. Pass a reactive expression to the new `debounce` or `throttle` function, and get back a modified reactive expression that doesn't invalidate as often. ([#1510](https://github.com/rstudio/shiny/pull/1510))
 
 ## Full changelog
 
@@ -7,16 +19,30 @@ shiny 0.14.2.9000
 
 * Added a new `placeholder` argument to `verbatimTextOutput()`. The default is `FALSE`, which means that, if there is no content for this output, no representation of this slot will be made in the UI. Previsouly, even if there was no content, you'd see an empty rectangle in the UI that served as a placeholder. You can set `placeholder = TRUE` to revert back to that look. ([#1480](https://github.com/rstudio/shiny/pull/1480))
 
+### New features
+
+* Added support for testing Shiny applications with the shinytest package. ([#18](https://github.com/rstudio/shiny/issues/18), [#1464](https://github.com/rstudio/shiny/pull/1464))
+
+* Added `debounce` and `throttle` functions, to control the rate at which reactive values and expressions invalidate. ([#1510](https://github.com/rstudio/shiny/pull/1510))
+
 ### Minor new features and improvements
 
+* Addressed [#1486](https://github.com/rstudio/shiny/issues/1486) by adding a new argument to `observeEvent` and `eventReactive`, called `ignoreInit` (defaults to `FALSE` for backwards compatibility). When set to `TRUE`, the action (i.e. the second argument: `handlerExpr` and `valueExpr`, respectively) will not be triggered when the observer/reactive is first created/initialized. In other words, `ignoreInit = TRUE` ensures that the `observeEvent` (or `eventReactive`) is *never* run right away. For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
+    
+* Added a new argument to `observeEvent` called `once`. When set to `TRUE`, it results in the observer being destroyed (stop observing) after the first time that `handlerExpr` is run (i.e. `once = TRUE` guarantees that the observer only runs, at most, once). For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
+
+* Addressed [#1358](https://github.com/rstudio/shiny/issues/1358): more informative error message when calling `runApp()` inside of an app's app.R (or inside ui.R or server.R). ([#1482](https://github.com/rstudio/shiny/pull/1482))
+
 * Added a more descriptive JS warning for `insertUI()` when the selector argument does not match anything in DOM. ([#1488](https://github.com/rstudio/shiny/pull/1488))
 
-* Added support for injecting JavaScript code when the `shiny.testmode` option is set to `TRUE`. This makes it possible to record test events interactively. ([#1464]https://github.com/rstudio/shiny/pull/1464))
+* Added support for injecting JavaScript code when the `shiny.testmode` option is set to `TRUE`. This makes it possible to record test events interactively. ([#1464](https://github.com/rstudio/shiny/pull/1464))
 
 * Added ability through arguments to the `a` tag function called inside `downloadButton()` and `downloadLink()`. Closes [#986](https://github.com/rstudio/shiny/issues/986). ([#1492](https://github.com/rstudio/shiny/pulls/1492))
 
 * Implemented [#1512](https://github.com/rstudio/shiny/issues/1512): added a `userData` environment to `session`, for storing arbitrary session-related variables. Generally, session-scoped variables are created just by declaring normal variables that are local to the Shiny server function, but `session$userData` may be more convenient for some advanced scenarios. ([#1513](https://github.com/rstudio/shiny/pull/1513))
 
+* Relaxed naming requirements for `addResourcePath()` (the first character no longer needs to be a letter). ([#1529](https://github.com/rstudio/shiny/pull/1529))
+
 ### Bug fixes
 
 * Fixed [#969](https://github.com/rstudio/shiny/issues/969): allow navbarPage's `fluid` param to control both containers. ([#1481](https://github.com/rstudio/shiny/pull/1481))
@@ -31,6 +57,13 @@ shiny 0.14.2.9000
 
 * Fixed [#1013](https://github.com/rstudio/shiny/issues/1013): `flushReact` should be called after app loads. Observers set up outside of server functions were not running until after the first user connects. ([#1503](https://github.com/rstudio/shiny/pull/1503))
 
+* Fixed [#1453](https://github.com/rstudio/shiny/issues/1453): When using a modal dialog with `easyClose=TRUE` in a Shiny gadget, pressing Esc would close both the modal and the gadget. Now pressing Esc only closes the modal. ([#1523](https://github.com/rstudio/shiny/pull/1523))
+
+### Library updates
+
+* Updated to Font Awesome 4.7.0.
+
+
 shiny 0.14.2
 ============
 

R/app.R

@@ -41,6 +41,8 @@
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   shinyApp(
 #'     ui = fluidPage(
 #'       numericInput("n", "n", 1),

R/bookmark-state.R

@@ -342,26 +342,10 @@ RestoreContext <- R6Class("RestoreContext",
       }
 
 
-      inputs <- parseQueryString(inputStr, nested = TRUE)
-      values <- parseQueryString(valueStr, nested = TRUE)
+      inputs <- parseQueryStringJSON(inputStr, nested = TRUE)
+      values <- parseQueryStringJSON(valueStr, nested = TRUE)
 
-      valuesFromJSON <- function(vals) {
-        mapply(names(vals), vals, SIMPLIFY = FALSE,
-          FUN = function(name, value) {
-            tryCatch(
-              jsonlite::fromJSON(value),
-              error = function(e) {
-                stop("Failed to parse URL parameter \"", name, "\"")
-              }
-            )
-          }
-        )
-      }
-
-      inputs <- valuesFromJSON(inputs)
       self$input <- RestoreInputSet$new(inputs)
-
-      values <- valuesFromJSON(values)
       self$values <- list2env2(values, self$values)
     }
   )

R/bootstrap-layout.R

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

R/bootstrap.R

@@ -1543,7 +1543,7 @@ icon <- function(name, class = NULL, lib = "font-awesome") {
   # font-awesome needs an additional dependency (glyphicon is in bootstrap)
   if (lib == "font-awesome") {
     htmlDependencies(iconTag) <- htmlDependency(
-      "font-awesome", "4.6.3", c(href="shared/font-awesome"),
+      "font-awesome", "4.7.0", c(href="shared/font-awesome"),
       stylesheet = "css/font-awesome.min.css"
     )
   }

R/input-slider.R

@@ -51,6 +51,7 @@
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("obs", "Number of observations:",

R/middleware-shiny.R

@@ -41,3 +41,229 @@ sessionHandler <- function(req) {
     shinysession$handleRequest(subreq)
   })
 }
+
+apiHandler <- function(serverFuncSource) {
+  function(req) {
+    path <- req$PATH_INFO
+    if (is.null(path))
+      return(NULL)
+
+    matches <- regmatches(path, regexec('^/api/(.*)$', path))
+    if (length(matches[[1]]) == 0)
+      return(NULL)
+
+    apiName <- matches[[1]][2]
+
+    sharedSecret <- getOption('shiny.sharedSecret')
+    if (!is.null(sharedSecret)
+      && !identical(sharedSecret, req$HTTP_SHINY_SHARED_SECRET)) {
+      stop("Incorrect shared secret")
+    }
+
+    if (!is.null(getOption("shiny.observer.error", NULL))) {
+      warning(
+        call. = FALSE,
+        "options(shiny.observer.error) is no longer supported; please unset it!"
+      )
+      stopApp()
+    }
+
+    # need to give a fake websocket to the session
+    ws <- list(
+      request = req,
+      sendMessage = function(...) {
+        #print(list(...))
+      }
+    )
+
+    # Accept JSON query string and/or JSON body as input values
+    inputVals <- c(
+      parseQueryStringJSON(req$QUERY_STRING),
+      parseJSONBody(req)
+    )
+
+    shinysession <- ShinySession$new(ws)
+    on.exit({
+      try({
+        # Clean up the session. Very important, so that observers
+        # and such don't hang around, and to let memory get gc'd.
+        shinysession$wsClosed()
+        appsByToken$remove(shinysession$token)
+      })
+    }, add = TRUE)
+    appsByToken$set(shinysession$token, shinysession)
+    shinysession$setShowcase(.globals$showcaseDefault)
+
+    serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+
+    tryCatch({
+      withReactiveDomain(shinysession, {
+        shinysession$manageInputs(inputVals)
+        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
+        result <- NULL
+        shinysession$enableApi(apiName, function(value) {
+          result <<- try(withLogErrors(value), silent = TRUE)
+        })
+        flushReact()
+        resultToResponse(result)
+      })
+    }, error = function(e) {
+      return(httpResponse(
+        status=500,
+        content=htmlEscape(conditionMessage(e))
+      ))
+    })
+  }
+}
+
+apiWsHandler <- function(serverFuncSource) {
+  function(ws) {
+    path <- ws$request$PATH_INFO
+    if (is.null(path))
+      return(NULL)
+
+    matches <- regmatches(path, regexec('^/api/(.*)$', path))
+    if (length(matches[[1]]) == 0)
+      return(NULL)
+
+    apiName <- matches[[1]][2]
+
+    sharedSecret <- getOption('shiny.sharedSecret')
+    if (!is.null(sharedSecret)
+      && !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
+      ws$close()
+      return(TRUE)
+    }
+
+    if (!is.null(getOption("shiny.observer.error", NULL))) {
+      warning(
+        call. = FALSE,
+        "options(shiny.observer.error) is no longer supported; please unset it!"
+      )
+      stopApp()
+    }
+
+    inputVals <- parseQueryStringJSON(ws$request$QUERY_STRING)
+
+    # Give a fake websocket to suppress messages from session
+    shinysession <- ShinySession$new(list(
+      request = ws$request,
+      sendMessage = function(...) {
+        #print(list(...))
+      }
+    ))
+    appsByToken$set(shinysession$token, shinysession)
+    shinysession$setShowcase(.globals$showcaseDefault)
+
+    serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+
+    tryCatch({
+      withReactiveDomain(shinysession, {
+        shinysession$manageInputs(inputVals)
+        do.call(serverFunc, argsForServerFunc(serverFunc, shinysession))
+        shinysession$enableApi(apiName, function(value) {
+          resp <- resultToResponse(value)
+          if (resp$status != 200L) {
+            warning("Error: ", responseToContent(resp))
+            ws$close()
+          } else {
+            content <- responseToContent(resp)
+            if (grepl("^image/", resp$content_type)) {
+              content <- paste0("data:", resp$content_type, ";base64,",
+                httpuv::rawToBase64(content))
+            }
+            try(ws$send(content), silent=TRUE)
+          }
+        })
+        flushReact()
+      })
+    }, error = function(e) {
+      ws$close()
+    })
+
+    ws$onClose(function() {
+      # Clean up the session. Very important, so that observers
+      # and such don't hang around, and to let memory get gc'd.
+      shinysession$wsClosed()
+      appsByToken$remove(shinysession$token)
+    })
+
+    # TODO: What to do on ws$onMessage?
+  }
+}
+
+parseJSONBody <- function(req) {
+  if (identical(req[["REQUEST_METHOD"]], "POST")) {
+    if (isTRUE(grepl(perl=TRUE, "^(text|application)/json(;\\s*charset\\s*=\\s*utf-8)?$", req[["HTTP_CONTENT_TYPE"]]))) {
+      tmp <- file("", "w+b")
+      on.exit(close(tmp))
+
+      input_file <- req[["rook.input"]]
+      while (TRUE) {
+        chunk <- input_file$read(8192L)
+        if (length(chunk) == 0)
+          break
+        writeBin(chunk, tmp)
+      }
+
+      return(jsonlite::fromJSON(tmp))
+    }
+
+    if (is.null(req[["HTTP_CONTENT_TYPE"]])) {
+      if (!is.null(req[["rook.input"]]) && length(req[["rook.input"]]$read(1L)) > 0) {
+        stop("Invalid POST request (body provided without content type)")
+      }
+      return()
+    }
+
+    stop("Invalid POST request (content type not supported)")
+  }
+}
+
+resultToResponse <- function(result) {
+  if (inherits(result, "httpResponse")) {
+    return(result)
+  } else if (inherits(result, "try-error")) {
+    return(httpResponse(
+      status=500,
+      content_type="text/plain",
+      content=conditionMessage(attr(result, "condition"))
+    ))
+  } else if (!is.null(attr(result, "content.type"))) {
+    return(httpResponse(
+      status=200L,
+      content_type=attr(result, "content.type"),
+      content=result
+    ))
+  } else {
+    return(httpResponse(
+      status=200L,
+      content_type="application/json",
+      content=toJSON(result, pretty=TRUE)
+    ))
+  }
+}
+
+responseToContent <- function(result) {
+  ct <- result$content_type
+  textMode <- grepl("^text/", ct) || ct == "application/json" ||
+    grepl("^application/xml($|\\+)", ct)
+
+  # TODO: Make sure text is UTF-8
+
+  if ("file" %in% names(result$content)) {
+    filename <- result$content$file
+    if ("owned" %in% names(result$content) && result$content$owned) {
+      on.exit(unlink(filename), add = TRUE)
+    }
+    if (textMode)
+      return(paste(readLines(filename), collapse = "\n"))
+    else
+      return(readBin(filename, raw(), file.info(filename)$size))
+  } else {
+    if (textMode)
+      return(paste(result$content, collapse = "\n"))
+    else
+      return(result$content)
+  }
+}

R/progress.R

@@ -245,6 +245,7 @@ Progress <- R6Class(
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   plotOutput("plot")

R/reactives.R

@@ -1531,6 +1531,8 @@ maskReactiveContext <- function(expr) {
 #' invalidations that come from its reactive dependencies; it only invalidates
 #' in response to the given event.
 #'
+#' @section \code{ignoreNULL} and \code{ignoreInit}:
+#'
 #' Both \code{observeEvent} and \code{eventReactive} take an \code{ignoreNULL}
 #' parameter that affects behavior when the \code{eventExpr} evaluates to
 #' \code{NULL} (or in the special case of an \code{\link{actionButton}},
@@ -1543,6 +1545,44 @@ maskReactiveContext <- function(expr) {
 #' the action/calculation and just let the user re-initiate it (like a
 #' "Recalculate" button).
 #'
+#' Unlike what happens for \code{ignoreNULL}, only \code{observeEvent} takes in an
+#' \code{ignoreInit} argument. By default, \code{observeEvent} will run right when
+#' it is created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
+#' and \code{ignoreNULL} is \code{TRUE}). But when responding to a click of an action
+#' button, it may often be useful to set \code{ignoreInit} to \code{TRUE}. For
+#' example, if you're setting up an \code{observeEvent} for a dynamically created
+#' button, then \code{ignoreInit = TRUE} will guarantee that the action (in
+#' \code{handlerExpr}) will only be triggered when the button is actually clicked,
+#' instead of also being triggered when it is created/initialized.
+#'
+#' Even though \code{ignoreNULL} and \code{ignoreInit} can be used for similar
+#' purposes they are independent from one another. Here's the result of combining
+#' these:
+#'
+#' \describe{
+#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = FALSE}}{
+#'      This is the default. This combination means that \code{handlerExpr} will
+#'      run every time that \code{eventExpr} is not \code{NULL}. If, at the time
+#'      of the \code{observeEvent}'s creation, \code{handleExpr} happens to
+#'      \emph{not} be \code{NULL}, then the code runs.
+#'   }
+#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
+#'      This combination means that \code{handlerExpr} will run every time no
+#'      matter what.
+#'   }
+#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = TRUE}}{
+#'      This combination means that \code{handlerExpr} will \emph{not} run when
+#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}),
+#'      but it will run every other time.
+#'   }
+#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = TRUE}}{
+#'      This combination means that \code{handlerExpr} will \emph{not} run when
+#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}).
+#'      After that, \code{handlerExpr} will run every time that \code{eventExpr}
+#'      is not \code{NULL}.
+#'   }
+#' }
+#'
 #' @param eventExpr A (quoted or unquoted) expression that represents the event;
 #'   this can be a simple reactive value like \code{input$click}, a call to a
 #'   reactive expression like \code{dataset()}, or even a complex expression
@@ -1584,6 +1624,15 @@ maskReactiveContext <- function(expr) {
 #' @param ignoreNULL Whether the action should be triggered (or value
 #'   calculated, in the case of \code{eventReactive}) when the input is
 #'   \code{NULL}. See Details.
+#' @param ignoreInit If \code{TRUE}, then, when this \code{observeEvent} is
+#'   first created/initialized, ignore the \code{handlerExpr} (the second
+#'   argument), whether it is otherwise supposed to run or not. The default is
+#'   \code{FALSE}. See Details.
+#' @param once Whether this \code{observeEvent} should be immediately destroyed
+#'   after the first time that the code in \code{handlerExpr} is run. This
+#'   pattern is useful when you want to subscribe to a event that should only
+#'   happen once.
+#'
 #' @return \code{observeEvent} returns an observer reference class object (see
 #'   \code{\link{observe}}). \code{eventReactive} returns a reactive expression
 #'   object (see \code{\link{reactive}}).
@@ -1593,37 +1642,71 @@ maskReactiveContext <- function(expr) {
 #' @examples
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
-#'   ui <- fluidPage(
-#'     column(4,
-#'       numericInput("x", "Value", 5),
-#'       br(),
-#'       actionButton("button", "Show")
+#'
+#'   ## App 1: Sample usage
+#'   shinyApp(
+#'     ui = fluidPage(
+#'       column(4,
+#'         numericInput("x", "Value", 5),
+#'         br(),
+#'         actionButton("button", "Show")
+#'       ),
+#'       column(8, tableOutput("table"))
 #'     ),
-#'     column(8, tableOutput("table"))
+#'     server = function(input, output) {
+#'       # Take an action every time button is pressed;
+#'       # here, we just print a message to the console
+#'       observeEvent(input$button, {
+#'         cat("Showing", input$x, "rows\n")
+#'       })
+#'       # Take a reactive dependency on input$button, but
+#'       # not on any of the stuff inside the function
+#'       df <- eventReactive(input$button, {
+#'         head(cars, input$x)
+#'       })
+#'       output$table <- renderTable({
+#'         df()
+#'       })
+#'     }
+#'   )
+#'
+#'   ## App 2: Using `once`
+#'   shinyApp(
+#'     ui = basicPage( actionButton("go", "Go")),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         print(paste("This will only be printed once; all",
+#'               "subsequent button clicks won't do anything"))
+#'       }, once = TRUE)
+#'     }
+#'   )
+#'
+#'   ## App 3: Using `ignoreInit` and `once`
+#'   shinyApp(
+#'     ui = basicPage(actionButton("go", "Go")),
+#'     server = function(input, output, session) {
+#'       observeEvent(input$go, {
+#'         insertUI("#go", "afterEnd",
+#'                  actionButton("dynamic", "click to remove"))
+#'
+#'         # set up an observer that depends on the dynamic
+#'         # input, so that it doesn't run when the input is
+#'         # created, and only runs once after that (since
+#'         # the side effect is remove the input from the DOM)
+#'         observeEvent(input$dynamic, {
+#'           removeUI("#dynamic")
+#'         }, ignoreInit = TRUE, once = TRUE)
+#'       })
+#'     }
 #'   )
-#'   server <- function(input, output) {
-#'     # Take an action every time button is pressed;
-#'     # here, we just print a message to the console
-#'     observeEvent(input$button, {
-#'       cat("Showing", input$x, "rows\n")
-#'     })
-#'     # Take a reactive dependency on input$button, but
-#'     # not on any of the stuff inside the function
-#'     df <- eventReactive(input$button, {
-#'       head(cars, input$x)
-#'     })
-#'     output$table <- renderTable({
-#'       df()
-#'     })
-#'   }
-#'   shinyApp(ui=ui, server=server)
 #' }
 #' @export
 observeEvent <- function(eventExpr, handlerExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   handler.env = parent.frame(), handler.quoted = FALSE,
-  label=NULL, suspended=FALSE, priority=0, domain=getDefaultReactiveDomain(),
-  autoDestroy = TRUE, ignoreNULL = TRUE) {
+  label = NULL, suspended = FALSE, priority = 0,
+  domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
+  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {
 
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
@@ -1633,16 +1716,29 @@ observeEvent <- function(eventExpr, handlerExpr,
   handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
   handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)
 
-  invisible(observe({
+  initialized <- FALSE
+
+  o <- observe({
     e <- eventFunc()
 
+    if (ignoreInit && !initialized) {
+      initialized <<- TRUE
+      return()
+    }
+
     if (ignoreNULL && isNullEvent(e)) {
       return()
     }
 
+    if (once) {
+      on.exit(o$destroy())
+    }
+
     isolate(handlerFunc())
   }, label = label, suspended = suspended, priority = priority, domain = domain,
-    autoDestroy = TRUE, ..stacktraceon = FALSE))
+  autoDestroy = TRUE, ..stacktraceon = FALSE)
+
+  invisible(o)
 }
 
 #' @rdname observeEvent
@@ -1650,8 +1746,8 @@ observeEvent <- function(eventExpr, handlerExpr,
 eventReactive <- function(eventExpr, valueExpr,
   event.env = parent.frame(), event.quoted = FALSE,
   value.env = parent.frame(), value.quoted = FALSE,
-  label=NULL, domain=getDefaultReactiveDomain(),
-  ignoreNULL = TRUE) {
+  label = NULL, domain = getDefaultReactiveDomain(),
+  ignoreNULL = TRUE, ignoreInit = FALSE) {
 
   eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
   if (is.null(label))
@@ -1661,13 +1757,17 @@ eventReactive <- function(eventExpr, valueExpr,
   handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
   handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)
 
+  initialized <- FALSE
+
   invisible(reactive({
     e <- eventFunc()
 
-    validate(need(
-      !ignoreNULL || !isNullEvent(e),
-      message = FALSE
-    ))
+    if (ignoreInit && !initialized) {
+      initialized <<- TRUE
+      req(FALSE)
+    }
+
+    req(!ignoreNULL || !isNullEvent(e))
 
     isolate(handlerFunc())
   }, label = label, domain = domain, ..stacktraceon = FALSE))
@@ -1676,3 +1776,246 @@ eventReactive <- function(eventExpr, valueExpr,
 isNullEvent <- function(value) {
   is.null(value) || (inherits(value, 'shinyActionButtonValue') && value == 0)
 }
+
+#' Slow down a reactive expression with debounce/throttle
+#'
+#' Transforms a reactive expression by preventing its invalidation signals from
+#' being sent unnecessarily often. This lets you ignore a very "chatty" reactive
+#' expression until it becomes idle, which is useful when the intermediate
+#' values don't matter as much as the final value, and the downstream
+#' calculations that depend on the reactive expression take a long time.
+#' \code{debounce} and \code{throttle} use different algorithms for slowing down
+#' invalidation signals; see Details.
+#'
+#' @section Limitations:
+#'
+#'   Because R is single threaded, we can't come close to guaranteeing that the
+#'   timing of debounce/throttle (or any other timing-related functions in
+#'   Shiny) will be consistent or accurate; at the time we want to emit an
+#'   invalidation signal, R may be performing a different task and we have no
+#'   way to interrupt it (nor would we necessarily want to if we could).
+#'   Therefore, it's best to think of the time windows you pass to these
+#'   functions as minimums.
+#'
+#'   You may also see undesirable behavior if the amount of time spent doing
+#'   downstream processing for each change approaches or exceeds the time
+#'   window: in this case, debounce/throttle may not have any effect, as the
+#'   time each subsequent event is considered is already after the time window
+#'   has expired.
+#'
+#' @details
+#'
+#' This is not a true debounce/throttle in that it will not prevent \code{r}
+#' from being called many times (in fact it may be called more times than
+#' usual), but rather, the reactive invalidation signal that is produced by
+#' \code{r} is debounced/throttled instead. Therefore, these functions should be
+#' used when \code{r} is cheap but the things it will trigger (downstream
+#' outputs and reactives) are expensive.
+#'
+#' Debouncing means that every invalidation from \code{r} will be held for the
+#' specified time window. If \code{r} invalidates again within that time window,
+#' then the timer starts over again. This means that as long as invalidations
+#' continually arrive from \code{r} within the time window, the debounced
+#' reactive will not invalidate at all. Only after the invalidations stop (or
+#' slow down sufficiently) will the downstream invalidation be sent.
+#'
+#' \code{ooo-oo-oo---- => -----------o-}
+#'
+#' (In this graphical depiction, each character represents a unit of time, and
+#' the time window is 3 characters.)
+#'
+#' Throttling, on the other hand, delays invalidation if the \emph{throttled}
+#' reactive recently (within the time window) invalidated. New \code{r}
+#' invalidations do not reset the time window. This means that if invalidations
+#' continually come from \code{r} within the time window, the throttled reactive
+#' will invalidate regularly, at a rate equal to or slower than than the time
+#' window.
+#'
+#' \code{ooo-oo-oo---- => o--o--o--o---}
+#'
+#' @param r A reactive expression (that invalidates too often).
+#' @param millis The debounce/throttle time window. You may optionally pass a
+#'   no-arg function or reactive expression instead, e.g. to let the end-user
+#'   control the time window.
+#' @param priority Debounce/throttle is implemented under the hood using
+#'   \link[=observe]{observers}. Use this parameter to set the priority of
+#'   these observers. Generally, this should be higher than the priorities of
+#'   downstream observers and outputs (which default to zero).
+#' @param domain See \link{domains}.
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#' options(device.ask.default = FALSE)
+#'
+#' library(shiny)
+#' library(magrittr)
+#'
+#' ui <- fluidPage(
+#'   plotOutput("plot", click = clickOpts("hover")),
+#'   helpText("Quickly click on the plot above, while watching the result table below:"),
+#'   tableOutput("result")
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   hover <- reactive({
+#'     if (is.null(input$hover))
+#'       list(x = NA, y = NA)
+#'     else
+#'       input$hover
+#'   })
+#'   hover_d <- hover %>% debounce(1000)
+#'   hover_t <- hover %>% throttle(1000)
+#'
+#'   output$plot <- renderPlot({
+#'     plot(cars)
+#'   })
+#'
+#'   output$result <- renderTable({
+#'     data.frame(
+#'       mode = c("raw", "throttle", "debounce"),
+#'       x = c(hover()$x, hover_t()$x, hover_d()$x),
+#'       y = c(hover()$y, hover_t()$y, hover_d()$y)
+#'     )
+#'   })
+#' }
+#'
+#' shinyApp(ui, server)
+#' }
+#'
+#' @export
+debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
+
+  # TODO: make a nice label for the observer(s)
+
+  force(r)
+  force(millis)
+
+  if (!is.function(millis)) {
+    origMillis <- millis
+    millis <- function() origMillis
+  }
+
+  v <- reactiveValues(
+    trigger = NULL,
+    when = NULL # the deadline for the timer to fire; NULL if not scheduled
+  )
+
+  # Responsible for tracking when f() changes.
+  firstRun <- TRUE
+  observe({
+    r()
+
+    if (firstRun) {
+      # During the first run we don't want to set v$when, as this will kick off
+      # the timer. We only want to do that when we see r() change.
+      firstRun <<- FALSE
+      return()
+    }
+
+    # The value (or possibly millis) changed. Start or reset the timer.
+    v$when <- Sys.time() + millis()/1000
+  }, label = "debounce tracker", domain = domain, priority = priority)
+
+  # This observer is the timer. It rests until v$when elapses, then touches
+  # v$trigger.
+  observe({
+    if (is.null(v$when))
+      return()
+
+    now <- Sys.time()
+    if (now >= v$when) {
+      # Mod by 999999999 to get predictable overflow behavior
+      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
+      v$when <- NULL
+    } else {
+      invalidateLater((v$when - now) * 1000)
+    }
+  }, label = "debounce timer", domain = domain, priority = priority)
+
+  # This is the actual reactive that is returned to the user. It returns the
+  # value of r(), but only invalidates/updates when v$trigger is touched.
+  er <- eventReactive(v$trigger, {
+    r()
+  }, label = "debounce result", ignoreNULL = FALSE, domain = domain)
+
+  # Force the value of er to be immediately cached upon creation. It's very hard
+  # to explain why this observer is needed, but if you want to understand, try
+  # commenting it out and studying the unit test failure that results.
+  primer <- observe({
+    primer$destroy()
+    er()
+  }, label = "debounce primer", domain = domain, priority = priority)
+
+  er
+}
+
+#' @rdname debounce
+#' @export
+throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
+
+  # TODO: make a nice label for the observer(s)
+
+  force(r)
+  force(millis)
+
+  if (!is.function(millis)) {
+    origMillis <- millis
+    millis <- function() origMillis
+  }
+
+  v <- reactiveValues(
+    trigger = 0,
+    lastTriggeredAt = NULL, # Last time we fired; NULL if never
+    pending = FALSE # If TRUE, trigger again when timer elapses
+  )
+
+  blackoutMillisLeft <- function() {
+    if (is.null(v$lastTriggeredAt)) {
+      0
+    } else {
+      max(0, (v$lastTriggeredAt + millis()/1000) - Sys.time()) * 1000
+    }
+  }
+
+  trigger <- function() {
+    v$lastTriggeredAt <- Sys.time()
+    # Mod by 999999999 to get predictable overflow behavior
+    v$trigger <- isolate(v$trigger) %% 999999999 + 1
+    v$pending <- FALSE
+  }
+
+  # Responsible for tracking when f() changes.
+  observeEvent(r(), {
+    if (v$pending) {
+      # In a blackout period and someone already scheduled; do nothing
+    } else if (blackoutMillisLeft() > 0) {
+      # In a blackout period but this is the first change in that period; set
+      # v$pending so that a trigger will be scheduled at the end of the period
+      v$pending <- TRUE
+    } else {
+      # Not in a blackout period. Trigger, which will start a new blackout
+      # period.
+      trigger()
+    }
+  }, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)
+
+  observe({
+    if (!v$pending) {
+      return()
+    }
+
+    timeout <- blackoutMillisLeft()
+    if (timeout > 0) {
+      invalidateLater(timeout)
+    } else {
+      trigger()
+    }
+  }, priority = priority, domain = domain)
+
+  # This is the actual reactive that is returned to the user. It returns the
+  # value of r(), but only invalidates/updates when v$trigger is touched.
+  eventReactive(v$trigger, {
+    r()
+  }, label = "throttle result", ignoreNULL = FALSE, domain = domain)
+}

R/server.R

@@ -34,7 +34,7 @@ registerClient <- function(client) {
 #' JavaScript/CSS files available to their components.
 #'
 #' @param prefix The URL prefix (without slashes). Valid characters are a-z,
-#'   A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+#'   A-Z, 0-9, hyphen, period, and underscore.
 #'   For example, a value of 'foo' means that any request paths that begin with
 #'   '/foo' will be mapped to the given directory.
 #' @param directoryPath The directory that contains the static resources to be
@@ -52,7 +52,7 @@ registerClient <- function(client) {
 #' @export
 addResourcePath <- function(prefix, directoryPath) {
   prefix <- prefix[1]
-  if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
+  if (!grepl('^[a-z0-9\\-_][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
     stop("addResourcePath called with invalid prefix; please see documentation")
   }
 
@@ -189,6 +189,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
   appHandlers <- list(
     http = joinHandlers(c(
       sessionHandler,
+      apiHandler(serverFuncSource),
       httpHandlers,
       sys.www.root,
       resourcePathHandler,
@@ -200,6 +201,11 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
         return(TRUE)
       }
 
+      if (grepl("^/api/", ws$request$PATH_INFO)) {
+        apiWsHandler(serverFuncSource)(ws)
+        return(TRUE)
+      }
+
       if (!is.null(getOption("shiny.observer.error", NULL))) {
         warning(
           call. = FALSE,
@@ -462,6 +468,9 @@ serviceApp <- function() {
 
 .shinyServerMinVersion <- '0.3.4'
 
+# Global flag that's TRUE whenever we're inside of the scope of a call to runApp
+.globals$running <- FALSE
+
 #' Run Shiny Application
 #'
 #' Runs a Shiny application. This function normally does not return; interrupt R
@@ -518,6 +527,8 @@ serviceApp <- function() {
 #'
 #' ## Only run this example in interactive R sessions
 #' if (interactive()) {
+#'   options(device.ask.default = FALSE)
+#'
 #'   # Apps can be run without a server.r and ui.r file
 #'   runApp(list(
 #'     ui = bootstrapPage(
@@ -555,6 +566,15 @@ runApp <- function(appDir=getwd(),
     handlerManager$clear()
   }, add = TRUE)
 
+  if (.globals$running) {
+    stop("Can't call `runApp()` from within `runApp()`. If your ,",
+         "application code contains `runApp()`, please remove it.")
+  }
+  .globals$running <- TRUE
+  on.exit({
+    .globals$running <- FALSE
+  }, add = TRUE)
+
   # Enable per-app Shiny options
   oldOptionSet <- .globals$options
   on.exit({

R/shiny.R

@@ -405,6 +405,7 @@ ShinySession <- R6Class(
     fileUploadContext = 'FileUploadContext',
     .input      = 'ANY', # Internal ReactiveValues object for normal input sent from client
     .clientData = 'ANY', # Internal ReactiveValues object for other data sent from the client
+    apiObservers = list(),
     busyCount = 0L, # Number of observer callbacks that are pending. When 0, we are idle
     closedCallbacks = 'Callbacks',
     flushCallbacks = 'Callbacks',
@@ -689,6 +690,7 @@ ShinySession <- R6Class(
     progressStack = 'Stack', # Stack of progress objects
     input       = 'reactivevalues', # Externally-usable S3 wrapper object for .input
     output      = 'ANY',    # Externally-usable S3 wrapper object for .outputs
+    api         = 'ANY',    # Externally-usable S3 wrapper object for APIs
     clientData  = 'reactivevalues', # Externally-usable S3 wrapper object for .clientData
     token = 'character',  # Used to identify this instance in URLs
     files = 'Map',        # For keeping track of files sent to client
@@ -725,6 +727,7 @@ ShinySession <- R6Class(
       .setLabel(self$clientData, 'clientData')
 
       self$output <- .createOutputWriter(self)
+      self$api <- .createApiWriter(self)
 
       self$token <- createUniqueId(16)
       private$.outputs <- list()
@@ -1051,17 +1054,17 @@ ShinySession <- R6Class(
             shinyCallingHandlers(func()),
             shiny.custom.error = function(cond) {
               if (isTRUE(getOption("show.error.messages"))) printError(cond)
-              structure(NULL, class = "try-error", condition = cond)
+              structure(list(), class = "try-error", condition = cond)
             },
             shiny.output.cancel = function(cond) {
-              structure(NULL, class = "cancel-output")
+              structure(list(), class = "cancel-output")
             },
             shiny.silent.error = function(cond) {
               # Don't let shiny.silent.error go through the normal stop
               # path of try, because we don't want it to print. But we
               # do want to try to return the same looking result so that
               # the code below can send the error to the browser.
-              structure(NULL, class = "try-error", condition = cond)
+              structure(list(), class = "try-error", condition = cond)
             },
             error = function(cond) {
               if (isTRUE(getOption("show.error.messages"))) printError(cond)
@@ -1070,7 +1073,7 @@ ShinySession <- R6Class(
                                           "logs or contact the app author for",
                                           "clarification."))
               }
-              invisible(structure(NULL, class = "try-error", condition = cond))
+              invisible(structure(list(), class = "try-error", condition = cond))
             },
             finally = {
               private$sendMessage(recalculating = list(
@@ -1632,6 +1635,19 @@ ShinySession <- R6Class(
                      workerId(),
                      URLencode(createUniqueId(8), TRUE)))
     },
+    registerApi = function(name, func) {
+      private$apiObservers[[name]] <- func
+    },
+    enableApi = function(name, callback) {
+      rexpr <- private$apiObservers[[name]]
+      if (is.null(rexpr)) {
+        stop("API not found")
+      }
+
+      observe({
+        callback(..stacktraceon..(rexpr()))
+      }, ..stacktraceon = FALSE)
+    },
     # This function suspends observers for hidden outputs and resumes observers
     # for un-hidden outputs.
     manageHiddenOutputs = function() {
@@ -1809,7 +1825,6 @@ outputOptions <- function(x, name, ...) {
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
 
-
 #' Add callbacks for Shiny session events
 #'
 #' These functions are for registering callbacks on Shiny session events.
@@ -1865,3 +1880,47 @@ flushAllSessions <- function() {
     NULL
   })
 }
+
+.createApiWriter <- function(shinysession, ns = identity) {
+  structure(list(impl=shinysession, ns=ns), class='shinyapi')
+}
+
+#' @export
+`$<-.shinyapi` <- function(x, name, value) {
+  name <- .subset2(x, 'ns')(name)
+
+  label <- deparse(substitute(value))
+  if (length(substitute(value)) > 1) {
+    # value is an object consisting of a call and its arguments. Here we want
+    # to find the source references for the first argument (if there are
+    # arguments), which generally corresponds to the reactive expression--
+    # e.g. in renderTable({ x }), { x } is the expression to trace.
+    attr(label, "srcref") <- srcrefFromShinyCall(substitute(value)[[2]])
+    srcref <- attr(substitute(value)[[2]], "srcref")
+    if (length(srcref) > 0)
+      attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
+  }
+  .subset2(x, 'impl')$registerApi(name, value)
+  return(invisible(x))
+}
+
+#' @export
+`[[<-.shinyapi` <- `$<-.shinyapi`
+
+#' @export
+`$.shinyapi` <- function(x, name) {
+  stop("Reading objects from shinyapi object not allowed.")
+}
+
+#' @export
+`[[.shinyapi` <- `$.shinyapi`
+
+#' @export
+`[.shinyapi` <- function(values, name) {
+  stop("Single-bracket indexing of shinyapi object is not allowed.")
+}
+
+#' @export
+`[<-.shinyapi` <- function(values, name, value) {
+  stop("Single-bracket indexing of shinyapi object is not allowed.")
+}

R/shinywrappers.R

@@ -127,6 +127,7 @@ as.tags.shiny.render.function <- function(x, ..., inline = FALSE) {
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   sliderInput("n", "Number of observations", 2, 1000, 500),
@@ -353,6 +354,98 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
   markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
 }
 
+#' @export
+serveJSON <- function(expr, env=parent.frame(), quoted=FALSE) {
+  installExprFunction(expr, "func", env, quoted)
+  function() {
+    structure(
+      toJSON(func(), pretty = TRUE),
+      content.type = "application/json"
+    )
+  }
+}
+
+#' @export
+servePlot <- function(expr, env=parent.frame(), quoted=FALSE,
+  defaultWidth = 600, defaultHeight = 400) {
+
+  if (!is.function(defaultWidth))
+    defaultWidth <- valueToFunc(defaultWidth)
+  if (!is.function(defaultHeight))
+    defaultHeight <- valueToFunc(defaultHeight)
+
+  installExprFunction(expr, "func", env, quoted)
+  function() {
+    input <- getDefaultReactiveDomain()$input
+    w <- if (!is.null(input$`plot-width`)) as.numeric(input$`plot-width`) else defaultWidth()
+    h <- if (!is.null(input$`plot-height`)) as.numeric(input$`plot-height`) else defaultHeight()
+
+    pngfile <- plotPNG(function() {
+      result <- withVisible(func())
+      if (result$visible) {
+        # Use capture.output to squelch printing to the actual console; we
+        # are only interested in plot output
+        utils::capture.output({
+          # The value needs to be printed just in case it's an object that
+          # requires printing to generate plot output, similar to ggplot2. But
+          # for base graphics, it would already have been rendered when func was
+          # called above, and the print should have no effect.
+          print(result$value)
+        })
+      }
+    }, width = w, height = h)
+
+    structure(
+      list(file = pngfile, owned = TRUE),
+      content.type = "image/png"
+    )
+  }
+}
+
+#' @importFrom utils write.csv
+#' @export
+serveCSV <- function(expr, env=parent.frame(), quoted=FALSE, row.names=FALSE) {
+  installExprFunction(expr, "func", env, quoted)
+  function() {
+    tmp <- tempfile(".csv")
+    write.csv(func(), tmp, row.names=row.names)
+    structure(
+      list(file = tmp, owned = TRUE),
+      content.type = "text/csv"
+    )
+  }
+}
+
+#' @export
+serveText <- function(expr, env=parent.frame(), quoted=FALSE) {
+  installExprFunction(expr, "func", env, quoted)
+  function() {
+    structure(
+      paste(func(), collapse = "\n"),
+      content.type = "text/plain"
+    )
+  }
+}
+
+#' @export
+serveRaw <- function(expr, env=parent.frame(), quoted=FALSE, contentType) {
+
+  if (!is.function(contentType))
+    contentType <- valueToFunc(contentType)
+
+  installExprFunction(expr, "func", env, quoted)
+  function() {
+    bytes <- func()
+    if (!is.raw(bytes)) {
+      stop("serveRaw expects raw vector data")
+    }
+    structure(
+      bytes,
+      content.type = contentType()
+    )
+  }
+}
+
 #' File Downloads
 #'
 #' Allows content from the Shiny application to be made available to the user as

R/utils.R

@@ -576,6 +576,20 @@ parseQueryString <- function(str, nested = FALSE) {
   res
 }
 
+parseQueryStringJSON <- function(str, nested = FALSE) {
+  vals <- parseQueryString(str, nested)
+  mapply(names(vals), vals, SIMPLIFY = FALSE,
+    FUN = function(name, value) {
+      tryCatch(
+        jsonlite::fromJSON(value),
+        error = function(e) {
+          stop("Failed to parse URL parameter \"", name, "\"")
+        }
+      )
+    }
+  )
+}
+
 # Assign value to the bottom element of the list x using recursive indices idx
 assignNestedList <- function(x = list(), idx, value) {
   for (i in seq_along(idx)) {
@@ -1128,6 +1142,7 @@ reactiveStop <- function(message = "", class = NULL) {
 #' @examples
 #' ## Only run examples in interactive R sessions
 #' if (interactive()) {
+#' options(device.ask.default = FALSE)
 #'
 #' ui <- fluidPage(
 #'   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
@@ -1584,3 +1599,9 @@ Mutable <- R6Class("Mutable",
     get = function() { private$value }
   )
 )
+
+# Turn a value into a no-arg function that returns that value
+valueToFunc <- function(val) {
+  force(val)
+  function() val
+}

inst/staticdocs/index.r

@@ -115,24 +115,25 @@ sd_section("Rendering functions",
     "reactiveUI"
   )
 )
-sd_section("Reactive constructs",
+sd_section("Reactive programming",
   "A sub-library that provides reactive programming facilities for R.",
   c(
-    "invalidateLater",
-    "is.reactivevalues",
-    "isolate",
-    "makeReactiveBinding",
+    "reactive",
     "observe",
     "observeEvent",
-    "reactive",
+    "reactiveValues",
+    "reactiveValuesToList",
+    "is.reactivevalues",
+    "isolate",
+    "invalidateLater",
+    "debounce",
+    "showReactLog",
+    "makeReactiveBinding",
     "reactiveFileReader",
     "reactivePoll",
     "reactiveTimer",
-    "reactiveValues",
-    "reactiveValuesToList",
-    "freezeReactiveValue",
     "domains",
-    "showReactLog"
+    "freezeReactiveValue"
   )
 )
 sd_section("Boilerplate",

inst/www/shared/font-awesome/css/font-awesome.css

@@ -1,13 +1,13 @@
 /*!
- *  Font Awesome 4.6.3 by @davegandy - http://fontawesome.io - @fontawesome
+ *  Font Awesome 4.7.0 by @davegandy - http://fontawesome.io - @fontawesome
  *  License - http://fontawesome.io/license (Font: SIL OFL 1.1, CSS: MIT License)
  */
 /* FONT PATH
  * -------------------------- */
 @font-face {
   font-family: 'FontAwesome';
-  src: url('../fonts/fontawesome-webfont.eot?v=4.6.3');
-  src: url('../fonts/fontawesome-webfont.eot?#iefix&v=4.6.3') format('embedded-opentype'), url('../fonts/fontawesome-webfont.woff2?v=4.6.3') format('woff2'), url('../fonts/fontawesome-webfont.woff?v=4.6.3') format('woff'), url('../fonts/fontawesome-webfont.ttf?v=4.6.3') format('truetype'), url('../fonts/fontawesome-webfont.svg?v=4.6.3#fontawesomeregular') format('svg');
+  src: url('../fonts/fontawesome-webfont.eot?v=4.7.0');
+  src: url('../fonts/fontawesome-webfont.eot?#iefix&v=4.7.0') format('embedded-opentype'), url('../fonts/fontawesome-webfont.woff2?v=4.7.0') format('woff2'), url('../fonts/fontawesome-webfont.woff?v=4.7.0') format('woff'), url('../fonts/fontawesome-webfont.ttf?v=4.7.0') format('truetype'), url('../fonts/fontawesome-webfont.svg?v=4.7.0#fontawesomeregular') format('svg');
   font-weight: normal;
   font-style: normal;
 }
@@ -1832,6 +1832,7 @@
   content: "\f23e";
 }
 .fa-battery-4:before,
+.fa-battery:before,
 .fa-battery-full:before {
   content: "\f240";
 }
@@ -2178,6 +2179,143 @@
 .fa-font-awesome:before {
   content: "\f2b4";
 }
+.fa-handshake-o:before {
+  content: "\f2b5";
+}
+.fa-envelope-open:before {
+  content: "\f2b6";
+}
+.fa-envelope-open-o:before {
+  content: "\f2b7";
+}
+.fa-linode:before {
+  content: "\f2b8";
+}
+.fa-address-book:before {
+  content: "\f2b9";
+}
+.fa-address-book-o:before {
+  content: "\f2ba";
+}
+.fa-vcard:before,
+.fa-address-card:before {
+  content: "\f2bb";
+}
+.fa-vcard-o:before,
+.fa-address-card-o:before {
+  content: "\f2bc";
+}
+.fa-user-circle:before {
+  content: "\f2bd";
+}
+.fa-user-circle-o:before {
+  content: "\f2be";
+}
+.fa-user-o:before {
+  content: "\f2c0";
+}
+.fa-id-badge:before {
+  content: "\f2c1";
+}
+.fa-drivers-license:before,
+.fa-id-card:before {
+  content: "\f2c2";
+}
+.fa-drivers-license-o:before,
+.fa-id-card-o:before {
+  content: "\f2c3";
+}
+.fa-quora:before {
+  content: "\f2c4";
+}
+.fa-free-code-camp:before {
+  content: "\f2c5";
+}
+.fa-telegram:before {
+  content: "\f2c6";
+}
+.fa-thermometer-4:before,
+.fa-thermometer:before,
+.fa-thermometer-full:before {
+  content: "\f2c7";
+}
+.fa-thermometer-3:before,
+.fa-thermometer-three-quarters:before {
+  content: "\f2c8";
+}
+.fa-thermometer-2:before,
+.fa-thermometer-half:before {
+  content: "\f2c9";
+}
+.fa-thermometer-1:before,
+.fa-thermometer-quarter:before {
+  content: "\f2ca";
+}
+.fa-thermometer-0:before,
+.fa-thermometer-empty:before {
+  content: "\f2cb";
+}
+.fa-shower:before {
+  content: "\f2cc";
+}
+.fa-bathtub:before,
+.fa-s15:before,
+.fa-bath:before {
+  content: "\f2cd";
+}
+.fa-podcast:before {
+  content: "\f2ce";
+}
+.fa-window-maximize:before {
+  content: "\f2d0";
+}
+.fa-window-minimize:before {
+  content: "\f2d1";
+}
+.fa-window-restore:before {
+  content: "\f2d2";
+}
+.fa-times-rectangle:before,
+.fa-window-close:before {
+  content: "\f2d3";
+}
+.fa-times-rectangle-o:before,
+.fa-window-close-o:before {
+  content: "\f2d4";
+}
+.fa-bandcamp:before {
+  content: "\f2d5";
+}
+.fa-grav:before {
+  content: "\f2d6";
+}
+.fa-etsy:before {
+  content: "\f2d7";
+}
+.fa-imdb:before {
+  content: "\f2d8";
+}
+.fa-ravelry:before {
+  content: "\f2d9";
+}
+.fa-eercast:before {
+  content: "\f2da";
+}
+.fa-microchip:before {
+  content: "\f2db";
+}
+.fa-snowflake-o:before {
+  content: "\f2dc";
+}
+.fa-superpowers:before {
+  content: "\f2dd";
+}
+.fa-wpexplorer:before {
+  content: "\f2de";
+}
+.fa-meetup:before {
+  content: "\f2e0";
+}
 .sr-only {
   position: absolute;
   width: 1px;

inst/www/shared/shiny.js

@@ -1576,6 +1576,20 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
         });
       }
 
+      $modal.on('keydown.shinymodal', function (e) {
+        // If we're listening for Esc, don't let the event propagate. See
+        // https://github.com/rstudio/shiny/issues/1453. The value of
+        // data("keyboard") needs to be checked inside the handler, because at
+        // the time that $modal.on() is called, the $("#shiny-modal") div doesn't
+        // yet exist.
+        if ($("#shiny-modal").data("keyboard") === false) return;
+
+        if (e.keyCode === 27) {
+          e.stopPropagation();
+          e.preventDefault();
+        }
+      });
+
       // Set/replace contents of wrapper with html.
       exports.renderContent($modal, { html: html, deps: deps });
     },
@@ -1583,6 +1597,8 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
     remove: function remove() {
       var $modal = $('#shiny-modal-wrapper');
 
+      $modal.off('keydown.shinymodal');
+
       // Look for a Bootstrap modal and if present, trigger hide event. This will
       // trigger the hidden.bs.modal callback that we set in show(), which unbinds
       // and removes the element.

man/addResourcePath.Rd

@@ -8,7 +8,7 @@ addResourcePath(prefix, directoryPath)
 }
 \arguments{
 \item{prefix}{The URL prefix (without slashes). Valid characters are a-z,
-A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
+A-Z, 0-9, hyphen, period, and underscore.
 For example, a value of 'foo' means that any request paths that begin with
 '/foo' will be mapped to the given directory.}
 

man/debounce.Rd

@@ -0,0 +1,122 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/reactives.R
+\name{debounce}
+\alias{debounce}
+\alias{throttle}
+\title{Slow down a reactive expression with debounce/throttle}
+\usage{
+debounce(r, millis, priority = 100, domain = getDefaultReactiveDomain())
+
+throttle(r, millis, priority = 100, domain = getDefaultReactiveDomain())
+}
+\arguments{
+\item{r}{A reactive expression (that invalidates too often).}
+
+\item{millis}{The debounce/throttle time window. You may optionally pass a
+no-arg function or reactive expression instead, e.g. to let the end-user
+control the time window.}
+
+\item{priority}{Debounce/throttle is implemented under the hood using
+\link[=observe]{observers}. Use this parameter to set the priority of
+these observers. Generally, this should be higher than the priorities of
+downstream observers and outputs (which default to zero).}
+
+\item{domain}{See \link{domains}.}
+}
+\description{
+Transforms a reactive expression by preventing its invalidation signals from
+being sent unnecessarily often. This lets you ignore a very "chatty" reactive
+expression until it becomes idle, which is useful when the intermediate
+values don't matter as much as the final value, and the downstream
+calculations that depend on the reactive expression take a long time.
+\code{debounce} and \code{throttle} use different algorithms for slowing down
+invalidation signals; see Details.
+}
+\details{
+This is not a true debounce/throttle in that it will not prevent \code{r}
+from being called many times (in fact it may be called more times than
+usual), but rather, the reactive invalidation signal that is produced by
+\code{r} is debounced/throttled instead. Therefore, these functions should be
+used when \code{r} is cheap but the things it will trigger (downstream
+outputs and reactives) are expensive.
+
+Debouncing means that every invalidation from \code{r} will be held for the
+specified time window. If \code{r} invalidates again within that time window,
+then the timer starts over again. This means that as long as invalidations
+continually arrive from \code{r} within the time window, the debounced
+reactive will not invalidate at all. Only after the invalidations stop (or
+slow down sufficiently) will the downstream invalidation be sent.
+
+\code{ooo-oo-oo---- => -----------o-}
+
+(In this graphical depiction, each character represents a unit of time, and
+the time window is 3 characters.)
+
+Throttling, on the other hand, delays invalidation if the \emph{throttled}
+reactive recently (within the time window) invalidated. New \code{r}
+invalidations do not reset the time window. This means that if invalidations
+continually come from \code{r} within the time window, the throttled reactive
+will invalidate regularly, at a rate equal to or slower than than the time
+window.
+
+\code{ooo-oo-oo---- => o--o--o--o---}
+}
+\section{Limitations}{
+
+
+  Because R is single threaded, we can't come close to guaranteeing that the
+  timing of debounce/throttle (or any other timing-related functions in
+  Shiny) will be consistent or accurate; at the time we want to emit an
+  invalidation signal, R may be performing a different task and we have no
+  way to interrupt it (nor would we necessarily want to if we could).
+  Therefore, it's best to think of the time windows you pass to these
+  functions as minimums.
+
+  You may also see undesirable behavior if the amount of time spent doing
+  downstream processing for each change approaches or exceeds the time
+  window: in this case, debounce/throttle may not have any effect, as the
+  time each subsequent event is considered is already after the time window
+  has expired.
+}
+\examples{
+## Only run examples in interactive R sessions
+if (interactive()) {
+options(device.ask.default = FALSE)
+
+library(shiny)
+library(magrittr)
+
+ui <- fluidPage(
+  plotOutput("plot", click = clickOpts("hover")),
+  helpText("Quickly click on the plot above, while watching the result table below:"),
+  tableOutput("result")
+)
+
+server <- function(input, output, session) {
+  hover <- reactive({
+    if (is.null(input$hover))
+      list(x = NA, y = NA)
+    else
+      input$hover
+  })
+  hover_d <- hover \%>\% debounce(1000)
+  hover_t <- hover \%>\% throttle(1000)
+
+  output$plot <- renderPlot({
+    plot(cars)
+  })
+
+  output$result <- renderTable({
+    data.frame(
+      mode = c("raw", "throttle", "debounce"),
+      x = c(hover()$x, hover_t()$x, hover_d()$x),
+      y = c(hover()$y, hover_t()$y, hover_d()$y)
+    )
+  })
+}
+
+shinyApp(ui, server)
+}
+
+}
+

man/observeEvent.Rd

@@ -9,11 +9,12 @@ observeEvent(eventExpr, handlerExpr, event.env = parent.frame(),
   event.quoted = FALSE, handler.env = parent.frame(),
   handler.quoted = FALSE, label = NULL, suspended = FALSE, priority = 0,
   domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
-  ignoreNULL = TRUE)
+  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE)
 
 eventReactive(eventExpr, valueExpr, event.env = parent.frame(),
   event.quoted = FALSE, value.env = parent.frame(), value.quoted = FALSE,
-  label = NULL, domain = getDefaultReactiveDomain(), ignoreNULL = TRUE)
+  label = NULL, domain = getDefaultReactiveDomain(), ignoreNULL = TRUE,
+  ignoreInit = FALSE)
 }
 \arguments{
 \item{eventExpr}{A (quoted or unquoted) expression that represents the event;
@@ -61,6 +62,16 @@ automatically destroyed when its domain (if any) ends.}
 calculated, in the case of \code{eventReactive}) when the input is
 \code{NULL}. See Details.}
 
+\item{ignoreInit}{If \code{TRUE}, then, when this \code{observeEvent} is
+first created/initialized, ignore the \code{handlerExpr} (the second
+argument), whether it is otherwise supposed to run or not. The default is
+\code{FALSE}. See Details.}
+
+\item{once}{Whether this \code{observeEvent} should be immediately destroyed
+after the first time that the code in \code{handlerExpr} is run. This
+pattern is useful when you want to subscribe to a event that should only
+happen once.}
+
 \item{valueExpr}{The expression that produces the return value of the
 \code{eventReactive}. It will be executed within an \code{\link{isolate}}
 scope.}
@@ -108,6 +119,9 @@ updates in response to an event. This is just like a normal
 \link[=reactive]{reactive expression} except it ignores all the usual
 invalidations that come from its reactive dependencies; it only invalidates
 in response to the given event.
+}
+\section{\code{ignoreNULL} and \code{ignoreInit}}{
+
 
 Both \code{observeEvent} and \code{eventReactive} take an \code{ignoreNULL}
 parameter that affects behavior when the \code{eventExpr} evaluates to
@@ -120,34 +134,105 @@ wait for the user to initiate the action first (like a "Submit" button);
 whereas \code{ignoreNULL=FALSE} is desirable if you want to initially perform
 the action/calculation and just let the user re-initiate it (like a
 "Recalculate" button).
+
+Unlike what happens for \code{ignoreNULL}, only \code{observeEvent} takes in an
+\code{ignoreInit} argument. By default, \code{observeEvent} will run right when
+it is created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
+and \code{ignoreNULL} is \code{TRUE}). But when responding to a click of an action
+button, it may often be useful to set \code{ignoreInit} to \code{TRUE}. For
+example, if you're setting up an \code{observeEvent} for a dynamically created
+button, then \code{ignoreInit = TRUE} will guarantee that the action (in
+\code{handlerExpr}) will only be triggered when the button is actually clicked,
+instead of also being triggered when it is created/initialized.
+
+Even though \code{ignoreNULL} and \code{ignoreInit} can be used for similar
+purposes they are independent from one another. Here's the result of combining
+these:
+
+\describe{
+  \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = FALSE}}{
+     This is the default. This combination means that \code{handlerExpr} will
+     run every time that \code{eventExpr} is not \code{NULL}. If, at the time
+     of the \code{observeEvent}'s creation, \code{handleExpr} happens to
+     \emph{not} be \code{NULL}, then the code runs.
+  }
+  \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
+     This combination means that \code{handlerExpr} will run every time no
+     matter what.
+  }
+  \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = TRUE}}{
+     This combination means that \code{handlerExpr} will \emph{not} run when
+     the \code{observeEvent} is created (because \code{ignoreInit = TRUE}),
+     but it will run every other time.
+  }
+  \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = TRUE}}{
+     This combination means that \code{handlerExpr} will \emph{not} run when
+     the \code{observeEvent} is created (because \code{ignoreInit = TRUE}).
+     After that, \code{handlerExpr} will run every time that \code{eventExpr}
+     is not \code{NULL}.
+  }
+}
 }
 \examples{
 ## Only run this example in interactive R sessions
 if (interactive()) {
-  ui <- fluidPage(
-    column(4,
-      numericInput("x", "Value", 5),
-      br(),
-      actionButton("button", "Show")
+
+  ## App 1: Sample usage
+  shinyApp(
+    ui = fluidPage(
+      column(4,
+        numericInput("x", "Value", 5),
+        br(),
+        actionButton("button", "Show")
+      ),
+      column(8, tableOutput("table"))
     ),
-    column(8, tableOutput("table"))
+    server = function(input, output) {
+      # Take an action every time button is pressed;
+      # here, we just print a message to the console
+      observeEvent(input$button, {
+        cat("Showing", input$x, "rows\\n")
+      })
+      # Take a reactive dependency on input$button, but
+      # not on any of the stuff inside the function
+      df <- eventReactive(input$button, {
+        head(cars, input$x)
+      })
+      output$table <- renderTable({
+        df()
+      })
+    }
+  )
+
+  ## App 2: Using `once`
+  shinyApp(
+    ui = basicPage( actionButton("go", "Go")),
+    server = function(input, output, session) {
+      observeEvent(input$go, {
+        print(paste("This will only be printed once; all",
+              "subsequent button clicks won't do anything"))
+      }, once = TRUE)
+    }
+  )
+
+  ## App 3: Using `ignoreInit` and `once`
+  shinyApp(
+    ui = basicPage(actionButton("go", "Go")),
+    server = function(input, output, session) {
+      observeEvent(input$go, {
+        insertUI("#go", "afterEnd",
+                 actionButton("dynamic", "click to remove"))
+
+        # set up an observer that depends on the dynamic
+        # input, so that it doesn't run when the input is
+        # created, and only runs once after that (since
+        # the side effect is remove the input from the DOM)
+        observeEvent(input$dynamic, {
+          removeUI("#dynamic")
+        }, ignoreInit = TRUE, once = TRUE)
+      })
+    }
   )
-  server <- function(input, output) {
-    # Take an action every time button is pressed;
-    # here, we just print a message to the console
-    observeEvent(input$button, {
-      cat("Showing", input$x, "rows\\n")
-    })
-    # Take a reactive dependency on input$button, but
-    # not on any of the stuff inside the function
-    df <- eventReactive(input$button, {
-      head(cars, input$x)
-    })
-    output$table <- renderTable({
-      df()
-    })
-  }
-  shinyApp(ui=ui, server=server)
 }
 }
 \seealso{

man/renderImage.Rd

@@ -47,6 +47,7 @@ the CSS class name \code{shiny-image-output}.
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 ui <- fluidPage(
   sliderInput("n", "Number of observations", 2, 1000, 500),

man/runApp.Rd

@@ -74,6 +74,8 @@ runApp("myapp")
 
 ## Only run this example in interactive R sessions
 if (interactive()) {
+  options(device.ask.default = FALSE)
+
   # Apps can be run without a server.r and ui.r file
   runApp(list(
     ui = bootstrapPage(

man/shinyApp.Rd

@@ -92,6 +92,8 @@ object to \code{print()} or \code{\link{runApp}()}.
 \examples{
 ## Only run this example in interactive R sessions
 if (interactive()) {
+  options(device.ask.default = FALSE)
+
   shinyApp(
     ui = fluidPage(
       numericInput("n", "n", 1),

man/sidebarLayout.Rd

@@ -26,6 +26,7 @@ area occupies 2/3 of the horizontal width and typically contains outputs.
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 # Define UI
 ui <- fluidPage(

man/sliderInput.Rd

@@ -95,6 +95,7 @@ Constructs a slider widget to select a numeric value from a range.
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 ui <- fluidPage(
   sliderInput("obs", "Number of observations:",

man/splitLayout.Rd

@@ -25,6 +25,7 @@ equal parts (by default).
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 # Server code used for all examples
 server <- function(input, output) {

man/validate.Rd

@@ -80,6 +80,7 @@ as \code{a} does validate it.
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 ui <- fluidPage(
   checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),

man/withProgress.Rd

@@ -90,6 +90,7 @@ function.
 \examples{
 ## Only run examples in interactive R sessions
 if (interactive()) {
+options(device.ask.default = FALSE)
 
 ui <- fluidPage(
   plotOutput("plot")

srcjs/modal.js

@@ -27,6 +27,21 @@ exports.modal = {
       });
     }
 
+    $modal.on('keydown.shinymodal', function(e) {
+      // If we're listening for Esc, don't let the event propagate. See
+      // https://github.com/rstudio/shiny/issues/1453. The value of
+      // data("keyboard") needs to be checked inside the handler, because at
+      // the time that $modal.on() is called, the $("#shiny-modal") div doesn't
+      // yet exist.
+      if ($("#shiny-modal").data("keyboard") === false)
+        return;
+
+      if (e.keyCode === 27) {
+        e.stopPropagation();
+        e.preventDefault();
+      }
+    });
+
     // Set/replace contents of wrapper with html.
     exports.renderContent($modal, { html: html, deps: deps });
   },
@@ -34,6 +49,8 @@ exports.modal = {
   remove: function() {
     const $modal = $('#shiny-modal-wrapper');
 
+    $modal.off('keydown.shinymodal');
+
     // Look for a Bootstrap modal and if present, trigger hide event. This will
     // trigger the hidden.bs.modal callback that we set in show(), which unbinds
     // and removes the element.

tests/testthat/test-reactivity.r

@@ -976,3 +976,83 @@ test_that("event handling helpers take correct dependencies", {
   expect_equal(execCount(o1), 2)
   expect_equal(execCount(o2), 2)
 })
+
+run_debounce_throttle <- function(do_priming) {
+  # The changing of rv$a will be the (chatty) source of reactivity.
+  rv <- reactiveValues(a = 0)
+
+  # This observer will be what changes rv$a.
+  src <- observe({
+    invalidateLater(100)
+    rv$a <- isolate(rv$a) + 1
+  })
+  on.exit(src$destroy(), add = TRUE)
+
+  # Make a debounced reactive to test.
+  dr <- debounce(reactive(rv$a), 500)
+
+  # Make a throttled reactive to test.
+  tr <- throttle(reactive(rv$a), 500)
+
+  # Keep track of how often dr/tr are fired
+  dr_fired <- 0
+  dr_monitor <- observeEvent(dr(), {
+    dr_fired <<- dr_fired + 1
+  })
+  on.exit(dr_monitor$destroy(), add = TRUE)
+
+  tr_fired <- 0
+  tr_monitor <- observeEvent(tr(), {
+    tr_fired <<- tr_fired + 1
+  })
+  on.exit(tr_monitor$destroy(), add = TRUE)
+
+  # Starting values are both 0. Earlier I found that the tests behaved
+  # differently if I accessed the values of dr/tr before the first call to
+  # flushReact(). That bug was fixed, but to ensure that similar bugs don't
+  # appear undetected, we run this test with and without do_priming.
+  if (do_priming) {
+    expect_identical(isolate(dr()), 0)
+    expect_identical(isolate(tr()), 0)
+  }
+
+  # Pump timer and reactives for about 1.4 seconds
+  stopAt <- Sys.time() + 1.4
+  while (Sys.time() < stopAt) {
+    timerCallbacks$executeElapsed()
+    flushReact()
+    Sys.sleep(0.001)
+  }
+
+  # dr() should not have had time to fire, other than the initial run, since
+  # there haven't been long enough gaps between invalidations.
+  expect_identical(dr_fired, 1)
+  # The value of dr() should not have updated either.
+  expect_identical(isolate(dr()), 0)
+
+  # tr() however, has had time to fire multiple times and update its value.
+  expect_identical(tr_fired, 3)
+  expect_identical(isolate(tr()), 10)
+
+  # Now let some time pass without any more updates.
+  src$destroy() # No more updates
+  stopAt <- Sys.time() + 1
+  while (Sys.time() < stopAt) {
+    timerCallbacks$executeElapsed()
+    flushReact()
+    Sys.sleep(0.001)
+  }
+
+  # dr should've fired, and we should have converged on the right answer.
+  expect_identical(dr_fired, 2)
+  isolate(expect_identical(rv$a, dr()))
+  expect_identical(tr_fired, 4)
+  isolate(expect_identical(rv$a, tr()))
+}
+
+test_that("debounce/throttle work properly (with priming)", {
+  run_debounce_throttle(TRUE)
+})
+test_that("debounce/throttle work properly (without priming)", {
+  run_debounce_throttle(FALSE)
+})

tools/README.md

@@ -10,11 +10,7 @@ Shiny's JavaScript build tools use Node.js, along with [yarn](https://yarnpkg.co
 
 Installation of Node.js differs across platforms and is generally pretty easy, so I won't include instructions here.
 
-There are a number of ways to [install yarn](https://yarnpkg.com/en/docs/install), but if you already have npm installed, you can simply run:
-
-```
-sudo npm install --global yarn
-```
+Install yarn using the [official instructions](https://yarnpkg.com/en/docs/install).
 
 Then, in this directory (tools/), run the following to install the packages: