Check for existence of bookmark scope directory before creating

Use xxhash64 instead of sha256 for hash algorithm

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: shiny
 Type: Package
 Title: Web Application Framework for R
-Version: 1.1.0
+Version: 1.1.0.9001
 Authors@R: c(
     person("Winston", "Chang", role = c("aut", "cre"), email = "winston@rstudio.com"),
     person("Joe", "Cheng", role = "aut", email = "joe@rstudio.com"),
@@ -65,7 +65,7 @@ Depends:
 Imports:
     utils,
     grDevices,
-    httpuv (>= 1.4.3),
+    httpuv (>= 1.4.3.9001),
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
@@ -89,7 +89,10 @@ Suggests:
     magrittr
 URL: http://shiny.rstudio.com
 BugReports: https://github.com/rstudio/shiny/issues
-Collate: 
+Remotes:
+    tidyverse/ggplot2,
+    rstudio/httpuv
+Collate:
     'app.R'
     'bookmark-state-local.R'
     'stack.R'
@@ -100,7 +103,10 @@ Collate:
     'map.R'
     'utils.R'
     'bootstrap.R'
-    'cache.R'
+    'cache-context.R'
+    'cache-disk.R'
+    'cache-memory.R'
+    'cache-utils.R'
     'diagnose.R'
     'fileupload.R'
     'graph.R'
@@ -139,6 +145,7 @@ Collate:
     'priorityqueue.R'
     'progress.R'
     'react.R'
+    'render-cached-plot.R'
     'render-plot.R'
     'render-table.R'
     'run-url.R'
@@ -155,4 +162,4 @@ Collate:
     'test-export.R'
     'timer.R'
     'update-input.R'
-RoxygenNote: 6.0.1.9000
+RoxygenNote: 6.1.0

NAMESPACE

@@ -25,6 +25,7 @@ S3method(as.tags,shiny.render.function)
 S3method(format,reactiveExpr)
 S3method(format,reactiveVal)
 S3method(names,reactivevalues)
+S3method(print,key_missing)
 S3method(print,reactive)
 S3method(print,shiny.appobj)
 S3method(str,reactivevalues)
@@ -67,6 +68,7 @@ export(dateRangeInput)
 export(dblclickOpts)
 export(debounce)
 export(dialogViewer)
+export(diskCache)
 export(div)
 export(downloadButton)
 export(downloadHandler)
@@ -90,6 +92,7 @@ export(fluidRow)
 export(formatStackTrace)
 export(freezeReactiveVal)
 export(freezeReactiveValue)
+export(getCurrentOutputInfo)
 export(getDefaultReactiveDomain)
 export(getQueryString)
 export(getShinyOption)
@@ -121,6 +124,7 @@ export(insertTab)
 export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
+export(is.key_missing)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
@@ -128,6 +132,7 @@ export(is.singleton)
 export(isRunning)
 export(isTruthy)
 export(isolate)
+export(key_missing)
 export(knit_print.html)
 export(knit_print.reactive)
 export(knit_print.shiny.appobj)
@@ -138,6 +143,7 @@ export(mainPanel)
 export(makeReactiveBinding)
 export(markRenderFunction)
 export(maskReactiveContext)
+export(memoryCache)
 export(modalButton)
 export(modalDialog)
 export(navbarMenu)
@@ -189,6 +195,7 @@ export(removeModal)
 export(removeNotification)
 export(removeTab)
 export(removeUI)
+export(renderCachedPlot)
 export(renderDataTable)
 export(renderImage)
 export(renderPlot)
@@ -226,6 +233,7 @@ export(showTab)
 export(sidebarLayout)
 export(sidebarPanel)
 export(singleton)
+export(sizeGrowthRatio)
 export(sliderInput)
 export(snapshotExclude)
 export(snapshotPreprocessInput)
@@ -268,9 +276,13 @@ export(updateSliderInput)
 export(updateTabsetPanel)
 export(updateTextAreaInput)
 export(updateTextInput)
+export(updateVarSelectInput)
+export(updateVarSelectizeInput)
 export(urlModal)
 export(validate)
 export(validateCssUnit)
+export(varSelectInput)
+export(varSelectizeInput)
 export(verbatimTextOutput)
 export(verticalLayout)
 export(wellPanel)

NEWS.md

@@ -1,3 +1,35 @@
+shiny 1.1.0.9001
+===========
+
+## Full changelog
+
+### Minor new features and improvements
+
+* 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))
+
+* Support for selecting variables of a data frame with the output values to be used within tidy evaluation.  Added functions: `varSelectInput`, `varSelectizeInput`, `updateVarSelectInput`, `updateVarSelectizeInput`. ([#2091](https://github.com/rstudio/shiny/pull/2091))
+
+* Addressed [#2042](https://github.com/rstudio/shiny/issues/2042): dates outside of `min`/`max` date range are now a lighter shade of grey to highlight the allowed range. ([#2087](https://github.com/rstudio/shiny/pull/2087))
+
+* Added support for plot interaction when the plot is scaled. ([#2125](https://github.com/rstudio/shiny/pull/2125))
+
+* Fixed [#1933](https://github.com/rstudio/shiny/issues/1933): extended server-side selectize to lists and optgroups. ([#2102](https://github.com/rstudio/shiny/pull/2102))
+
+* Fixed [#1935](https://github.com/rstudio/shiny/issues/1935): correctly returns plot coordinates when using outer margins. ([#2108](https://github.com/rstudio/shiny/pull/2108))
+
+* Resolved [#2019](https://github.com/rstudio/shiny/issues/2019): `updateSliderInput` now changes the slider formatting if the input type changes. ([#2099](https://github.com/rstudio/shiny/pull/2099))
+
+* Added namespace support when freezing reactiveValue keys. [#2080](https://github.com/rstudio/shiny/pull/2080)
+
+* Fixed [#2138](https://github.com/rstudio/shiny/issues/2138): Inputs that are part of a `renderUI` were no longer restoring correctly from bookmarked state. [#2139](https://github.com/rstudio/shiny/pull/2139)
+
+* Fixed [#2093](https://github.com/rstudio/shiny/issues/2093): Make sure bookmark scope directory does not exist before trying to create it. [#2168](https://github.com/rstudio/shiny/pull/2168)
+
+### Documentation Updates
+
+* Addressed [#1864](https://github.com/rstudio/shiny/issues/1864) by changing `optgroup` documentation to use `list` instead of `c`. ([#2084](https://github.com/rstudio/shiny/pull/2084))
+
+
 shiny 1.1.0
 ===========
 
@@ -282,7 +314,7 @@ Now there's an official way to slow down reactive values and expressions that in
 ### Minor new features and improvements
 
 * Addressed [#1486](https://github.com/rstudio/shiny/issues/1486) by adding a new argument to `observeEvent` and `eventReactive`, called `ignoreInit` (defaults to `FALSE` for backwards compatibility). When set to `TRUE`, the action (i.e. the second argument: `handlerExpr` and `valueExpr`, respectively) will not be triggered when the observer/reactive is first created/initialized. In other words, `ignoreInit = TRUE` ensures that the `observeEvent` (or `eventReactive`) is *never* run right away. For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
-    
+
 * Added a new argument to `observeEvent` called `once`. When set to `TRUE`, it results in the observer being destroyed (stop observing) after the first time that `handlerExpr` is run (i.e. `once = TRUE` guarantees that the observer only runs, at most, once). For more info, see the documentation (`?observeEvent`). ([#1494](https://github.com/rstudio/shiny/pull/1494))
 
 * Addressed [#1358](https://github.com/rstudio/shiny/issues/1358): more informative error message when calling `runApp()` inside of an app's app.R (or inside ui.R or server.R). ([#1482](https://github.com/rstudio/shiny/pull/1482))
@@ -681,7 +713,7 @@ shiny 0.12.1
 shiny 0.12.0
 ============
 
-In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps. 
+In addition to the changes listed below (in the *Full Changelog* section), there is an infrastructure change that could affect existing Shiny apps.
 
 ### JSON serialization
 
@@ -772,13 +804,13 @@ Shiny 0.11 switches away from the Bootstrap 2 web framework to the next version,
 ### Known issues for migration
 
 *    In Bootstrap 3, images in `<img>` tags are no longer automatically scaled to the width of their container. If you use `img()` in your UI code, or `<img>` tags in your raw HTML source, it's possible that they will be too large in the new version of Shiny. To address this you can add the `img-responsive` class:
-    
+
     ```r
     img(src = "picture.png", class = "img-responsive")
     ```
-    
+
     The R code above will generate the following HTML:
-    
+
     ```html
     <img src="picture.png" class="img-responsive">
     ```

R/bookmark-state.R

@@ -448,7 +448,13 @@ withRestoreContext <- function(ctx, expr) {
 
 # Is there a current restore context?
 hasCurrentRestoreContext <- function() {
-  restoreCtxStack$size() > 0
+  if (restoreCtxStack$size() > 0)
+    return(TRUE)
+  domain <- getDefaultReactiveDomain()
+  if (!is.null(domain) && !is.null(domain$restoreContext))
+    return(TRUE)
+  
+  return(FALSE)
 }
 
 # Call to access the current restore context. First look on the restore

R/cache-disk.R

@@ -0,0 +1,561 @@
+#' Create a disk cache object
+#'
+#' A disk cache object is a key-value store that saves the values as files in a
+#' directory on disk. Objects can be stored and retrieved using the \code{get()}
+#' and \code{set()} methods. Objects are automatically pruned from the cache
+#' according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+#' and \code{evict}.
+#'
+#'
+#' @section Missing Keys:
+#'
+#'   The \code{missing} and \code{exec_missing} parameters controls what happens
+#'   when \code{get()} is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a \code{\link{key_missing}}
+#'   object. This is a \emph{sentinel value} that indicates that the key was not
+#'   present in the cache. You can test if the returned value represents a
+#'   missing key by using the \code{\link{is.key_missing}} function. You can
+#'   also have \code{get()} return a different sentinel value, like \code{NULL}.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for \code{missing} that takes one argument, the key, and also use
+#'   \code{exec_missing=TRUE}.
+#'
+#'   When the cache is created, you can supply a value for \code{missing}, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when \code{get()} is called, by supplying a \code{missing}
+#'   argument. For example, if you use \code{cache$get("mykey", missing =
+#'   NULL)}, it will return \code{NULL} if the key is not in the cache.
+#'
+#'   If your cache is configured so that \code{get()} returns a sentinel value
+#'   to represent a cache miss, then \code{set} will also not allow you to store
+#'   the sentinel value in the cache. It will throw an error if you attempt to
+#'   do so.
+#'
+#'   Instead of returning the same sentinel value each time there is cache miss,
+#'   the cache can execute a function each time \code{get()} encounters missing
+#'   key. If the function returns a value, then \code{get()} will in turn return
+#'   that value. However, a more common use is for the function to throw an
+#'   error. If an error is thrown, then \code{get()} will not return a value.
+#'
+#'   To do this, pass a one-argument function to \code{missing}, and use
+#'   \code{exec_missing=TRUE}. For example, if you want to throw an error that
+#'   prints the missing key, you could do this:
+#'
+#'   \preformatted{
+#'   diskCache(
+#'     missing = function(key) {
+#'       stop("Attempted to get missing key: ", key)
+#'     },
+#'     exec_missing = TRUE
+#'   )
+#'   }
+#'
+#'   If you use this, the code that calls \code{get()} should be wrapped with
+#'   \code{\link{tryCatch}()} to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when \code{set()} is called, or it can be invoked
+#'   manually by calling \code{prune()}.
+#'
+#'   The disk cache will throttle the pruning so that it does not happen on
+#'   every call to \code{set()}, because the filesystem operations for checking
+#'   the status of files can be slow. Instead, it will prune once in every 20
+#'   calls to \code{set()}, or if at least 5 seconds have elapsed since the last
+#'   prune occurred, whichever is first. These parameters are currently not
+#'   customizable, but may be in the future.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   \code{max_age}, they will be removed.
+#'
+#'   The \code{max_size} and \code{max_n} parameters are applied to the cache as
+#'   a whole, in contrast to \code{max_age}, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds \code{max_n}, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the \code{evict} parameter. Objects will be removed so that the
+#'   number of items is \code{max_n}.
+#'
+#'   If the size of the objects in the cache exceeds \code{max_size}, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under \code{max_size}. Note that the
+#'   size is calculated using the size of the files, not the size of disk space
+#'   used by the files -- these two values can differ because of files are
+#'   stored in blocks on disk. For example, if the block size is 4096 bytes,
+#'   then a file that is one byte in size will take 4096 bytes on disk.
+#'
+#'   Another time that objects can be removed from the cache is when
+#'   \code{get()} is called. If the target object is older than \code{max_age},
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If \code{max_n} or \code{max_size} are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{\code{"lru"}}{
+#'       Least Recently Used. The least recently used objects will be removed.
+#'       This uses the filesystem's mtime property. When "lru" is used, each
+#'       \code{get()} is called, it will update the file's mtime.
+#'     }
+#'     \item{\code{"fifo"}}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' Both of these policies use files' mtime. Note that some filesystems (notably
+#' FAT) have poor mtime resolution. (atime is not used because support for
+#' atime is worse than mtime.)
+#'
+#'
+#' @section Sharing among multiple processes:
+#'
+#' The directory for a DiskCache can be shared among multiple R processes. To
+#' do this, each R process should have a DiskCache object that uses the same
+#' directory. Each DiskCache will do pruning independently of the others, so if
+#' they have different pruning parameters, then one DiskCache may remove cached
+#' objects before another DiskCache would do so.
+#'
+#' Even though it is possible for multiple processes to share a DiskCache
+#' directory, this should not be done on networked file systems, because of
+#' slow performance of networked file systems can cause problems. If you need
+#' a high-performance shared cache, you can use one built on a database like
+#' Redis, SQLite, mySQL, or similar.
+#'
+#' When multiple processes share a cache directory, there are some potential
+#' race conditions. For example, if your code calls \code{exists(key)} to check
+#' if an object is in the cache, and then call \code{get(key)}, the object may
+#' be removed from the cache in between those two calls, and \code{get(key)}
+#' will throw an error. Instead of calling the two functions, it is better to
+#' simply call \code{get(key)}, and use \code{tryCatch()} to handle the error
+#' that is thrown if the object is not in the cache. This effectively tests for
+#' existence and gets the object in one operation.
+#'
+#' It is also possible for one processes to prune objects at the same time that
+#' another processes is trying to prune objects. If this happens, you may see
+#' a warning from \code{file.remove()} failing to remove a file that has
+#' already been deleted.
+#'
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{\code{get(key, missing, exec_missing)}}{
+#'       Returns the value associated with \code{key}. If the key is not in the
+#'       cache, then it returns the value specified by \code{missing} or,
+#'       \code{missing} is a function and \code{exec_missing=TRUE}, then
+#'       executes \code{missing}. The function can throw an error or return the
+#'       value. If either of these parameters are specified here, then they
+#'       will override the defaults that were set when the DiskCache object was
+#'       created. See section Missing Keys for more information.
+#'     }
+#'     \item{\code{set(key, value)}}{
+#'       Stores the \code{key}-\code{value} pair in the cache.
+#'     }
+#'     \item{\code{exists(key)}}{
+#'       Returns \code{TRUE} if the cache contains the key, otherwise
+#'       \code{FALSE}.
+#'     }
+#'     \item{\code{size()}}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{\code{keys()}}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{\code{reset()}}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{\code{destroy()}}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{\code{prune()}}{
+#'       Prunes the cache, using the parameters specified by \code{max_size},
+#'       \code{max_age}, \code{max_n}, and \code{evict}.
+#'     }
+#'   }
+#'
+#' @param dir Directory to store files for the cache. If \code{NULL} (the
+#'   default) it will create and use a temporary directory.
+#' @param max_age Maximum age of files in cache before they are evicted, in
+#'   seconds. Use \code{Inf} for no age limit.
+#' @param max_size Maximum size of the cache, in bytes. If the cache exceeds
+#'   this size, cached objects will be removed according to the value of the
+#'   \code{evict}. Use \code{Inf} for no size limit.
+#' @param max_n Maximum number of objects in the cache. If the number of objects
+#'   exceeds this value, then cached objects will be removed according to the
+#'   value of \code{evict}. Use \code{Inf} for no limit of number of items.
+#' @param evict The eviction policy to use to decide which objects are removed
+#'   when a cache pruning occurs. Currently, \code{"lru"} and \code{"fifo"} are
+#'   supported.
+#' @param destroy_on_finalize If \code{TRUE}, then when the DiskCache object is
+#'   garbage collected, the cache directory and all objects inside of it will be
+#'   deleted from disk. If \code{FALSE} (the default), it will do nothing when
+#'   finalized.
+#' @param missing A value to return or a function to execute when
+#'   \code{get(key)} is called but the key is not present in the cache. The
+#'   default is a \code{\link{key_missing}} object. If it is a function to
+#'   execute, the function must take one argument (the key), and you must also
+#'   use \code{exec_missing = TRUE}. If it is a function, it is useful in most
+#'   cases for it to throw an error, although another option is to return a
+#'   value. If a value is returned, that value will in turn be returned by
+#'   \code{get()}. See section Missing keys for more information.
+#' @param exec_missing If \code{FALSE} (the default), then treat \code{missing}
+#'   as a value to return when \code{get()} results in a cache miss. If
+#'   \code{TRUE}, treat \code{missing} as a function to execute when
+#'   \code{get()} results in a cache miss.
+#' @param logfile An optional filename or connection object to where logging
+#'   information will be written. To log to the console, use \code{stdout()}.
+#'
+#' @export
+diskCache <- function(
+  dir = NULL,
+  max_size = 10 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  destroy_on_finalize = FALSE,
+  missing = key_missing(),
+  exec_missing = FALSE,
+  logfile = NULL)
+{
+  DiskCache$new(dir, max_size, max_age, max_n, evict, destroy_on_finalize,
+                missing, exec_missing, logfile)
+}
+
+
+DiskCache <- R6Class("DiskCache",
+  public = list(
+    initialize = function(
+      dir = NULL,
+      max_size = 10 * 1024 ^ 2,
+      max_age = Inf,
+      max_n = Inf,
+      evict = c("lru", "fifo"),
+      destroy_on_finalize = FALSE,
+      missing = key_missing(),
+      exec_missing = FALSE,
+      logfile = NULL)
+    {
+      if (exec_missing && (!is.function(missing) || length(formals(missing)) == 0)) {
+        stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+      }
+      if (is.null(dir)) {
+        dir <- tempfile("DiskCache-")
+      }
+      if (!is.numeric(max_size)) stop("max_size must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_age))  stop("max_age must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_n))    stop("max_n must be a number. Use `Inf` for no limit.")
+
+      if (!dirExists(dir)) {
+        private$log(paste0("initialize: Creating ", dir))
+        dir.create(dir, recursive = TRUE)
+      }
+
+      private$dir                 <- normalizePath(dir)
+      private$max_size            <- max_size
+      private$max_age             <- max_age
+      private$max_n               <- max_n
+      private$evict               <- match.arg(evict)
+      private$destroy_on_finalize <- destroy_on_finalize
+      private$missing             <- missing
+      private$exec_missing        <- exec_missing
+      private$logfile             <- logfile
+
+      private$prune_last_time     <- as.numeric(Sys.time())
+    },
+
+    get = function(key, missing = private$missing, exec_missing = private$exec_missing) {
+      private$log(paste0('get: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+
+      private$maybe_prune_single(key)
+
+      filename <- private$key_to_filename(key)
+
+      # Instead of calling exists() before fetching the value, just try to
+      # fetch the value. This reduces the risk of a race condition when
+      # multiple processes share a cache.
+      read_error <- FALSE
+      tryCatch(
+        {
+          value <- suppressWarnings(readRDS(filename))
+          if (private$evict == "lru"){
+            Sys.setFileTime(filename, Sys.time())
+          }
+        },
+        error = function(e) {
+          read_error <<- TRUE
+        }
+      )
+      if (read_error) {
+        private$log(paste0('get: key "', key, '" is missing'))
+
+        if (exec_missing) {
+          if (!is.function(missing) || length(formals(missing)) == 0) {
+            stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+          }
+          return(missing(key))
+        } else {
+          return(missing)
+        }
+      }
+
+      private$log(paste0('get: key "', key, '" found'))
+      value
+    },
+
+    set = function(key, value) {
+      private$log(paste0('set: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+
+      file <- private$key_to_filename(key)
+      temp_file <- paste0(file, "-temp-", createUniqueId(8))
+
+      save_error <- FALSE
+      ref_object <- FALSE
+      tryCatch(
+        {
+          saveRDS(value, file = temp_file,
+            refhook = function(x) {
+              ref_object <<- TRUE
+              NULL
+            }
+          )
+          file.rename(temp_file, file)
+        },
+        error = function(e) {
+          save_error <<- TRUE
+          # Unlike file.remove(), unlink() does not raise warning if file does
+          # not exist.
+          unlink(temp_file)
+        }
+      )
+      if (save_error) {
+        private$log(paste0('set: key "', key, '" error'))
+        stop('Error setting value for key "', key, '".')
+      }
+      if (ref_object) {
+        private$log(paste0('set: value is a reference object'))
+        warning("A reference object was cached in a serialized format. The restored object may not work as expected.")
+      }
+
+      private$prune_throttled()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+      file.exists(private$key_to_filename(key))
+    },
+
+    # Return all keys in the cache
+    keys = function() {
+      self$is_destroyed(throw = TRUE)
+      files <- dir(private$dir, "\\.rds$")
+      sub("\\.rds$", "", files)
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      self$is_destroyed(throw = TRUE)
+      validate_key(key)
+      file.remove(private$key_to_filename(key))
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      self$is_destroyed(throw = TRUE)
+      file.remove(dir(private$dir, "\\.rds$", full.names = TRUE))
+      invisible(self)
+    },
+
+    prune = function() {
+      # TODO: It would be good to add parameters `n` and `size`, so that the
+      # cache can be pruned to `max_n - n` and `max_size - size` before adding
+      # an object. Right now we prune after adding the object, so the cache
+      # can temporarily grow past the limits. The reason we don't do this now
+      # is because it is expensive to find the size of the serialized object
+      # before adding it.
+
+      private$log(paste0('prune'))
+      self$is_destroyed(throw = TRUE)
+
+      current_time <- Sys.time()
+
+      filenames <- dir(private$dir, "\\.rds$", full.names = TRUE)
+      info <- file.info(filenames)
+      info <- info[info$isdir == FALSE, ]
+      info$name <- rownames(info)
+      rownames(info) <- NULL
+      # Files could be removed between the dir() and file.info() calls. The
+      # entire row for such files will have NA values. Remove those rows.
+      info <- info[!is.na(info$size), ]
+
+      # 1. Remove any files where the age exceeds max age.
+      if (is.finite(private$max_age)) {
+        timediff <- as.numeric(current_time - info$mtime, units = "secs")
+        rm_idx <- timediff > private$max_age
+        if (any(rm_idx)) {
+          private$log(paste0("prune max_age: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+          file.remove(info$name[rm_idx])
+          info <- info[!rm_idx, ]
+        }
+      }
+
+      # Sort objects by priority. The sorting is done in a function which can be
+      # called multiple times but only does the work the first time.
+      info_is_sorted <- FALSE
+      ensure_info_is_sorted <- function() {
+        if (info_is_sorted) return()
+
+        info <<- info[order(info$mtime, decreasing = TRUE), ]
+        info_is_sorted <<- TRUE
+      }
+
+      # 2. Remove files if there are too many.
+      if (is.finite(private$max_n) && nrow(info) > private$max_n) {
+        ensure_info_is_sorted()
+        rm_idx <- seq_len(nrow(info)) > private$max_n
+        private$log(paste0("prune max_n: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+        rm_success <- file.remove(info$name[rm_idx])
+        info <- info[!rm_success, ]
+      }
+
+      # 3. Remove files if cache is too large.
+      if (is.finite(private$max_size) && sum(info$size) > private$max_size) {
+        ensure_info_is_sorted()
+        cum_size <- cumsum(info$size)
+        rm_idx <- cum_size > private$max_size
+        private$log(paste0("prune max_size: Removing ", paste(info$name[rm_idx], collapse = ", ")))
+        rm_success <- file.remove(info$name[rm_idx])
+        info <- info[!rm_success, ]
+      }
+
+      private$prune_last_time <- as.numeric(current_time)
+
+      invisible(self)
+    },
+
+    size = function() {
+      self$is_destroyed(throw = TRUE)
+      length(dir(private$dir, "\\.rds$"))
+    },
+
+    destroy = function() {
+      if (self$is_destroyed()) {
+        return(invisible(self))
+      }
+
+      private$log(paste0("destroy: Removing ", private$dir))
+      # First create a sentinel file so that other processes sharing this
+      # cache know that the cache is to be destroyed. This is needed because
+      # the recursive unlink is not atomic: another process can add a file to
+      # the directory after unlink starts removing files but before it removes
+      # the directory, and when that happens, the directory removal will fail.
+      file.create(file.path(private$dir, "__destroyed__"))
+      # Remove all the .rds files. This will not remove the setinel file.
+      file.remove(dir(private$dir, "\\.rds$", full.names = TRUE))
+      # Next remove dir recursively, including sentinel file.
+      unlink(private$dir, recursive = TRUE)
+      private$destroyed <- TRUE
+      invisible(self)
+    },
+
+    is_destroyed = function(throw = FALSE) {
+      if (!dirExists(private$dir) ||
+          file.exists(file.path(private$dir, "__destroyed__")))
+      {
+        # It's possible for another process to destroy a shared cache directory
+        private$destroyed <- TRUE
+      }
+
+      if (throw) {
+        if (private$destroyed) {
+          stop("Attempted to use cache which has been destroyed:\n  ", private$dir)
+        }
+
+      } else {
+        private$destroyed
+      }
+    },
+
+    finalize = function() {
+      if (private$destroy_on_finalize) {
+        self$destroy()
+      }
+    }
+  ),
+
+  private = list(
+    dir = NULL,
+    max_age = NULL,
+    max_size = NULL,
+    max_n = NULL,
+    evict = NULL,
+    destroy_on_finalize = NULL,
+    destroyed = FALSE,
+    missing = NULL,
+    exec_missing = FALSE,
+    logfile = NULL,
+
+    prune_throttle_counter = 0,
+    prune_last_time = NULL,
+
+    key_to_filename = function(key) {
+      validate_key(key)
+      # Additional validation. This 80-char limit is arbitrary, and is
+      # intended to avoid hitting a filename length limit on Windows.
+      if (nchar(key) > 80) {
+        stop("Invalid key: key must have fewer than 80 characters.")
+      }
+      file.path(private$dir, paste0(key, ".rds"))
+    },
+
+    # A wrapper for prune() that throttles it, because prune() can be
+    # expensive due to filesystem operations. This function will prune only
+    # once every 20 times it is called, or if it has been more than 5 seconds
+    # since the last time the cache was actually pruned, whichever is first.
+    # In the future, the behavior may be customizable.
+    prune_throttled = function() {
+      # Count the number of times prune() has been called.
+      private$prune_throttle_counter <- private$prune_throttle_counter + 1
+
+      if (private$prune_throttle_counter > 20 ||
+          private$prune_last_time - as.numeric(Sys.time()) > 5)
+      {
+        self$prune()
+        private$prune_throttle_counter <- 0
+      }
+    },
+
+    # Prunes a single object if it exceeds max_age. If the object does not
+    # exceed max_age, or if the object doesn't exist, do nothing.
+    maybe_prune_single = function(key) {
+      obj <- private$cache[[key]]
+      if (is.null(obj)) return()
+
+      timediff <- as.numeric(Sys.time()) - obj$mtime
+      if (timediff > private$max_age) {
+        private$log(paste0("pruning single object exceeding max_age: Removing ", key))
+        rm(list = key, envir = private$cache)
+      }
+    },
+
+    log = function(text) {
+      if (is.null(private$logfile)) return()
+
+      text <- paste0(format(Sys.time(), "[%Y-%m-%d %H:%M:%OS3] DiskCache "), text)
+      writeLines(text, private$logfile)
+    }
+  )
+)

R/cache-memory.R

@@ -0,0 +1,366 @@
+#' Create a memory cache object
+#'
+#' A memory cache object is a key-value store that saves the values in an
+#' environment. Objects can be stored and retrieved using the \code{get()} and
+#' \code{set()} methods. Objects are automatically pruned from the cache
+#' according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+#' and \code{evict}.
+#'
+#' In a \code{MemoryCache}, R objects are stored directly in the cache; they are
+#' not \emph{not} serialized before being stored in the cache. This contrasts
+#' with other cache types, like \code{\link{diskCache}}, where objects are
+#' serialized, and the serialized object is cached. This can result in some
+#' differences of behavior. For example, as long as an object is stored in a
+#' MemoryCache, it will not be garbage collected.
+#'
+#'
+#' @section Missing keys:
+#'   The \code{missing} and \code{exec_missing} parameters controls what happens
+#'   when \code{get()} is called with a key that is not in the cache (a cache
+#'   miss). The default behavior is to return a \code{\link{key_missing}}
+#'   object. This is a \emph{sentinel value} that indicates that the key was not
+#'   present in the cache. You can test if the returned value represents a
+#'   missing key by using the \code{\link{is.key_missing}} function. You can
+#'   also have \code{get()} return a different sentinel value, like \code{NULL}.
+#'   If you want to throw an error on a cache miss, you can do so by providing a
+#'   function for \code{missing} that takes one argument, the key, and also use
+#'   \code{exec_missing=TRUE}.
+#'
+#'   When the cache is created, you can supply a value for \code{missing}, which
+#'   sets the default value to be returned for missing values. It can also be
+#'   overridden when \code{get()} is called, by supplying a \code{missing}
+#'   argument. For example, if you use \code{cache$get("mykey", missing =
+#'   NULL)}, it will return \code{NULL} if the key is not in the cache.
+#'
+#'   If your cache is configured so that \code{get()} returns a sentinel value
+#'   to represent a cache miss, then \code{set} will also not allow you to store
+#'   the sentinel value in the cache. It will throw an error if you attempt to
+#'   do so.
+#'
+#'   Instead of returning the same sentinel value each time there is cache miss,
+#'   the cache can execute a function each time \code{get()} encounters missing
+#'   key. If the function returns a value, then \code{get()} will in turn return
+#'   that value. However, a more common use is for the function to throw an
+#'   error. If an error is thrown, then \code{get()} will not return a value.
+#'
+#'   To do this, pass a one-argument function to \code{missing}, and use
+#'   \code{exec_missing=TRUE}. For example, if you want to throw an error that
+#'   prints the missing key, you could do this:
+#'
+#'   \preformatted{
+#'   diskCache(
+#'     missing = function(key) {
+#'       stop("Attempted to get missing key: ", key)
+#'     },
+#'     exec_missing = TRUE
+#'   )
+#'   }
+#'
+#'   If you use this, the code that calls \code{get()} should be wrapped with
+#'   \code{\link{tryCatch}()} to gracefully handle missing keys.
+#'
+#' @section Cache pruning:
+#'
+#'   Cache pruning occurs when \code{set()} is called, or it can be invoked
+#'   manually by calling \code{prune()}.
+#'
+#'   When a pruning occurs, if there are any objects that are older than
+#'   \code{max_age}, they will be removed.
+#'
+#'   The \code{max_size} and \code{max_n} parameters are applied to the cache as
+#'   a whole, in contrast to \code{max_age}, which is applied to each object
+#'   individually.
+#'
+#'   If the number of objects in the cache exceeds \code{max_n}, then objects
+#'   will be removed from the cache according to the eviction policy, which is
+#'   set with the \code{evict} parameter. Objects will be removed so that the
+#'   number of items is \code{max_n}.
+#'
+#'   If the size of the objects in the cache exceeds \code{max_size}, then
+#'   objects will be removed from the cache. Objects will be removed from the
+#'   cache so that the total size remains under \code{max_size}. Note that the
+#'   size is calculated using the size of the files, not the size of disk space
+#'   used by the files -- these two values can differ because of files are
+#'   stored in blocks on disk. For example, if the block size is 4096 bytes,
+#'   then a file that is one byte in size will take 4096 bytes on disk.
+#'
+#'   Another time that objects can be removed from the cache is when
+#'   \code{get()} is called. If the target object is older than \code{max_age},
+#'   it will be removed and the cache will report it as a missing value.
+#'
+#' @section Eviction policies:
+#'
+#' If \code{max_n} or \code{max_size} are used, then objects will be removed
+#' from the cache according to an eviction policy. The available eviction
+#' policies are:
+#'
+#'   \describe{
+#'     \item{\code{"lru"}}{
+#'       Least Recently Used. The least recently used objects will be removed.
+#'       This uses the filesystem's atime property. Some filesystems do not
+#'       support atime, or have a very low atime resolution. The DiskCache will
+#'       check for atime support, and if the filesystem does not support atime,
+#'       a warning will be issued and the "fifo" policy will be used instead.
+#'     }
+#'     \item{\code{"fifo"}}{
+#'       First-in-first-out. The oldest objects will be removed.
+#'     }
+#'   }
+#'
+#' @section Methods:
+#'
+#'  A disk cache object has the following methods:
+#'
+#'   \describe{
+#'     \item{\code{get(key, missing, exec_missing)}}{
+#'       Returns the value associated with \code{key}. If the key is not in the
+#'       cache, then it returns the value specified by \code{missing} or,
+#'       \code{missing} is a function and \code{exec_missing=TRUE}, then
+#'       executes \code{missing}. The function can throw an error or return the
+#'       value. If either of these parameters are specified here, then they
+#'       will override the defaults that were set when the DiskCache object was
+#'       created. See section Missing Keys for more information.
+#'     }
+#'     \item{\code{set(key, value)}}{
+#'       Stores the \code{key}-\code{value} pair in the cache.
+#'     }
+#'     \item{\code{exists(key)}}{
+#'       Returns \code{TRUE} if the cache contains the key, otherwise
+#'       \code{FALSE}.
+#'     }
+#'     \item{\code{size()}}{
+#'       Returns the number of items currently in the cache.
+#'     }
+#'     \item{\code{keys()}}{
+#'       Returns a character vector of all keys currently in the cache.
+#'     }
+#'     \item{\code{reset()}}{
+#'       Clears all objects from the cache.
+#'     }
+#'     \item{\code{destroy()}}{
+#'       Clears all objects in the cache, and removes the cache directory from
+#'       disk.
+#'     }
+#'     \item{\code{prune()}}{
+#'       Prunes the cache, using the parameters specified by \code{max_size},
+#'       \code{max_age}, \code{max_n}, and \code{evict}.
+#'     }
+#'   }
+#'
+#' @inheritParams diskCache
+#'
+#' @export
+memoryCache <- function(
+  max_size = 10 * 1024 ^ 2,
+  max_age = Inf,
+  max_n = Inf,
+  evict = c("lru", "fifo"),
+  missing = key_missing(),
+  exec_missing = FALSE,
+  logfile = NULL)
+{
+  MemoryCache$new(max_size, max_age, max_n, evict, missing, exec_missing, logfile)
+}
+
+MemoryCache <- R6Class("MemoryCache",
+  public = list(
+    initialize = function(
+      max_size = 10 * 1024 ^ 2,
+      max_age = Inf,
+      max_n = Inf,
+      evict = c("lru", "fifo"),
+      missing = key_missing(),
+      exec_missing = FALSE,
+      logfile = NULL)
+    {
+      if (exec_missing && (!is.function(missing) || length(formals(missing)) == 0)) {
+        stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+      }
+      if (!is.numeric(max_size)) stop("max_size must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_age))  stop("max_age must be a number. Use `Inf` for no limit.")
+      if (!is.numeric(max_n))    stop("max_n must be a number. Use `Inf` for no limit.")
+      private$cache        <- new.env(parent = emptyenv())
+      private$max_size     <- max_size
+      private$max_age      <- max_age
+      private$max_n        <- max_n
+      private$evict        <- match.arg(evict)
+      private$missing      <- missing
+      private$exec_missing <- exec_missing
+      private$logfile      <- logfile
+    },
+
+    get = function(key, missing = private$missing, exec_missing = private$exec_missing) {
+      private$log(paste0('get: key "', key, '"'))
+      validate_key(key)
+
+      private$maybe_prune_single(key)
+
+      if (!self$exists(key)) {
+        private$log(paste0('get: key "', key, '" is missing'))
+        if (exec_missing) {
+          if (!is.function(missing) || length(formals(missing)) == 0) {
+            stop("When `exec_missing` is true, `missing` must be a function that takes one argument.")
+          }
+          return(missing(key))
+        } else {
+          return(missing)
+        }
+      }
+
+      private$log(paste0('get: key "', key, '" found'))
+      value <- private$cache[[key]]$value
+      value
+    },
+
+    set = function(key, value) {
+      private$log(paste0('set: key "', key, '"'))
+      validate_key(key)
+
+      time <- as.numeric(Sys.time())
+
+      # Only record size if we're actually using max_size for pruning.
+      if (is.finite(private$max_size)) {
+        # Reported size is rough! See ?object.size.
+        size <- as.numeric(object.size(value))
+      } else {
+        size <- NULL
+      }
+
+      private$cache[[key]] <- list(
+        key = key,
+        value = value,
+        size = size,
+        mtime = time,
+        atime = time
+      )
+      self$prune()
+      invisible(self)
+    },
+
+    exists = function(key) {
+      validate_key(key)
+      # Faster than `exists(key, envir = private$cache, inherits = FALSE)
+      !is.null(private$cache[[key]])
+    },
+
+    keys = function() {
+      ls(private$cache, sorted = FALSE)  # Faster with sorted=FALSE
+    },
+
+    remove = function(key) {
+      private$log(paste0('remove: key "', key, '"'))
+      validate_key(key)
+      rm(list = key, envir = private$cache)
+      invisible(self)
+    },
+
+    reset = function() {
+      private$log(paste0('reset'))
+      rm(list = self$keys(), envir = private$cache)
+      invisible(self)
+    },
+
+    prune = function() {
+      private$log(paste0('prune'))
+      info <- private$object_info()
+
+      # 1. Remove any objects where the age exceeds max age.
+      if (is.finite(private$max_age)) {
+        time <- as.numeric(Sys.time())
+        timediff <- time - info$mtime
+        rm_idx <- timediff > private$max_age
+        if (any(rm_idx)) {
+          private$log(paste0("prune max_age: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+          rm(list = info$key[rm_idx], envir = private$cache)
+          info <- info[!rm_idx, ]
+        }
+      }
+
+      # Sort objects by priority, according to eviction policy. The sorting is
+      # done in a function which can be called multiple times but only does
+      # the work the first time.
+      info_is_sorted <- FALSE
+      ensure_info_is_sorted <- function() {
+        if (info_is_sorted) return()
+
+        if (private$evict == "lru") {
+          info <<- info[order(info$atime, decreasing = TRUE), ]
+        } else if (private$evict == "fifo") {
+          info <<- info[order(info$mtime, decreasing = TRUE), ]
+        } else {
+          stop('Unknown eviction policy "', private$evict, '"')
+        }
+        info_is_sorted <<- TRUE
+      }
+
+      # 2. Remove objects if there are too many.
+      if (is.finite(private$max_n) && nrow(info) > private$max_n) {
+        ensure_info_is_sorted()
+        rm_idx <- seq_len(nrow(info)) > private$max_n
+        private$log(paste0("prune max_n: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        info <- info[!rm_idx, ]
+      }
+
+      # 3. Remove objects if cache is too large.
+      if (is.finite(private$max_size) && sum(info$size) > private$max_size) {
+        ensure_info_is_sorted()
+        cum_size <- cumsum(info$size)
+        rm_idx <- cum_size > private$max_size
+        private$log(paste0("prune max_size: Removing ", paste(info$key[rm_idx], collapse = ", ")))
+        rm(list = info$key[rm_idx], envir = private$cache)
+        info <- info[!rm_idx, ]
+      }
+
+      invisible(self)
+    },
+
+    size = function() {
+      length(self$keys())
+    }
+  ),
+
+  private = list(
+    cache = NULL,
+    max_age = NULL,
+    max_size = NULL,
+    max_n = NULL,
+    evict = NULL,
+    missing = NULL,
+    exec_missing = NULL,
+    logfile = NULL,
+
+    # Prunes a single object if it exceeds max_age. If the object does not
+    # exceed max_age, or if the object doesn't exist, do nothing.
+    maybe_prune_single = function(key) {
+      if (!is.finite(private$max_age)) return()
+
+      obj <- private$cache[[key]]
+      if (is.null(obj)) return()
+
+      timediff <- as.numeric(Sys.time()) - obj$mtime
+      if (timediff > private$max_age) {
+        private$log(paste0("pruning single object exceeding max_age: Removing ", key))
+        rm(list = key, envir = private$cache)
+      }
+    },
+
+    object_info = function() {
+      keys <- ls(private$cache, sorted = FALSE)
+      data.frame(
+        key   = keys,
+        size  = vapply(keys, function(key) private$cache[[key]]$size,  0),
+        mtime = vapply(keys, function(key) private$cache[[key]]$mtime, 0),
+        atime = vapply(keys, function(key) private$cache[[key]]$atime, 0),
+        stringsAsFactors = FALSE
+      )
+    },
+
+    log = function(text) {
+      if (is.null(private$logfile)) return()
+
+      text <- paste0(format(Sys.time(), "[%Y-%m-%d %H:%M:%OS3] MemoryCache "), text)
+      writeLines(text, private$logfile)
+    }
+  )
+)

R/cache-utils.R

@@ -0,0 +1,33 @@
+#' A Key Missing object
+#'
+#' A \code{key_missing} object represents a cache miss.
+#'
+#' @param x An object to test.
+#'
+#' @seealso \code{\link{diskCache}}, \code{\link{memoryCache}}.
+#'
+#' @export
+key_missing <- function() {
+  structure(list(), class = "key_missing")
+}
+
+#' @rdname key_missing
+#' @export
+is.key_missing <- function(x) {
+  inherits(x, "key_missing")
+}
+
+#' @export
+print.key_missing <- function(x, ...) {
+  cat("<Key Missing>\n")
+}
+
+
+validate_key <- function(key) {
+  if (!is.character(key) || length(key) != 1 || nchar(key) == 0) {
+    stop("Invalid key: key must be single non-empty string.")
+  }
+  if (grepl("[^a-z0-9]", key)) {
+    stop("Invalid key: ", key, ". Only lowercase letters and numbers are allowed.")
+  }
+}

R/image-interact.R

@@ -249,14 +249,20 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
   x <- asNumber(df[[xvar]])
   y <- asNumber(df[[yvar]])
 
-  # Get the pixel coordinates of the point
-  coordPx <- scaleCoords(coordinfo$x, coordinfo$y, coordinfo)
+  # Get the coordinates of the point (in img pixel coordinates)
+  point_img <- scaleCoords(coordinfo$x, coordinfo$y, coordinfo)
 
-  # Get pixel coordinates of data points
-  dataPx <- scaleCoords(x, y, coordinfo)
+  # Get coordinates of data points (in img pixel coordinates)
+  data_img <- scaleCoords(x, y, coordinfo)
 
-  # Distances of data points to coordPx
-  dists <- sqrt((dataPx$x - coordPx$x) ^ 2 + (dataPx$y - coordPx$y) ^ 2)
+  # Get x/y distances (in css coordinates)
+  dist_css <- list(
+    x = (data_img$x - point_img$x) / coordinfo$pixelratio$x,
+    y = (data_img$y - point_img$y) / coordinfo$pixelratio$y
+  )
+
+  # Distances of data points to the target point, in css pixels.
+  dists <- sqrt(dist_css$x^2 + dist_css$y^2)
 
   if (addDist)
     df$dist_ <- dists
@@ -298,50 +304,56 @@ nearPoints <- function(df, coordinfo, xvar = NULL, yvar = NULL,
 # The coordinfo data structure will look something like the examples below.
 # For base graphics, `mapping` is empty, and there are no panelvars:
 # List of 7
-#  $ x      : num 4.37
-#  $ y      : num 12
-#  $ mapping: Named list()
-#  $ domain :List of 4
+#  $ x         : num 4.37
+#  $ y         : num 12
+#  $ pixelratio:List of 2
+#  ..$ x: num 2
+#  ..$ y: num 2
+#  $ mapping   : Named list()
+#  $ domain    :List of 4
 #   ..$ left  : num 1.36
 #   ..$ right : num 5.58
 #   ..$ bottom: num 9.46
 #   ..$ top   : num 34.8
-#  $ range  :List of 4
+#  $ range     :List of 4
 #   ..$ left  : num 58
 #   ..$ right : num 429
 #   ..$ bottom: num 226
 #   ..$ top   : num 58
-#  $ log    :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce : num 0.343
+#  $ .nonce    : num 0.343
 #
 # For ggplot2, the mapping vars usually will be included, and if faceting is
 # used, they will be listed as panelvars:
 # List of 9
-#  $ x        : num 3.78
-#  $ y        : num 17.1
-#  $ panelvar1: int 6
-#  $ panelvar2: int 0
-#  $ mapping  :List of 4
+#  $ x         : num 3.78
+#  $ y         : num 17.1
+#  $ pixelratio:List of 2
+#  ..$ x: num 2
+#  ..$ y: num 2
+#  $ panelvar1 : int 6
+#  $ panelvar2 : int 0
+#  $ mapping   :List of 4
 #   ..$ x        : chr "wt"
 #   ..$ y        : chr "mpg"
 #   ..$ panelvar1: chr "cyl"
 #   ..$ panelvar2: chr "am"
-#  $ domain   :List of 4
+#  $ domain    :List of 4
 #   ..$ left  : num 1.32
 #   ..$ right : num 5.62
 #   ..$ bottom: num 9.22
 #   ..$ top   : num 35.1
-#  $ range    :List of 4
+#  $ range     :List of 4
 #   ..$ left  : num 172
 #   ..$ right : num 300
 #   ..$ bottom: num 144
 #   ..$ top   : num 28.5
-#  $ log      :List of 2
+#  $ log       :List of 2
 #   ..$ x: NULL
 #   ..$ y: NULL
-#  $ .nonce   : num 0.603
+#  $ .nonce    : num 0.603
 
 
 

R/input-select.R

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

R/input-slider.R

@@ -86,24 +86,10 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
-  if (inherits(min, "Date")) {
-    if (!inherits(max, "Date") || !inherits(value, "Date"))
-      stop("`min`, `max`, and `value must all be Date or non-Date objects")
-    dataType <- "date"
+  dataType <- getSliderType(min, max, value)
 
-    if (is.null(timeFormat))
-      timeFormat <- "%F"
-
-  } else if (inherits(min, "POSIXt")) {
-    if (!inherits(max, "POSIXt") || !inherits(value, "POSIXt"))
-      stop("`min`, `max`, and `value must all be POSIXt or non-POSIXt objects")
-    dataType <- "datetime"
-
-    if (is.null(timeFormat))
-      timeFormat <- "%F %T"
-
-  } else {
-    dataType <- "number"
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
   # Restore bookmarked values here, after doing the type checking, because the
@@ -250,7 +236,7 @@ findStepSize <- function(min, max, step) {
     # values to calculate the step size.
     pretty_steps <- pretty(c(min, max), n = 100)
     n_steps <- length(pretty_steps) - 1
-    
+
     # Fix for #2061: Windows has low-significance digits (like 17 digits out)
     # even at the boundaries of pretty()'s output. Use signif(digits = 10),
     # which should be way way less significant than any data we'd want to keep.

R/render-cached-plot.R

@@ -0,0 +1,588 @@
+#' Plot output with cached images
+#'
+#' Renders a reactive plot, with plot images cached to disk.
+#'
+#' \code{expr} is an expression that generates a plot, similar to that in
+#' \code{renderPlot}. Unlike with \code{renderPlot}, this expression does not
+#' take reactive dependencies. It is re-executed only when the cache key
+#' changes.
+#'
+#' \code{cacheKeyExpr} is an expression which, when evaluated, returns an object
+#' which will be serialized and hashed using the \code{\link[digest]{digest}}
+#' function to generate a string that will be used as a cache key. This key is
+#' used to identify the contents of the plot: if the cache key is the same as a
+#' previous time, it assumes that the plot is the same and can be retrieved from
+#' the cache.
+#'
+#' This \code{cacheKeyExpr} is reactive, and so it will be re-evaluated when any
+#' upstream reactives are invalidated. This will also trigger re-execution of
+#' the plotting expression, \code{expr}.
+#'
+#' The key should consist of "normal" R objects, like vectors and lists. Lists
+#' should in turn contain other normal R objects. If the key contains
+#' environments, external pointers, or reference objects -- or even if it has
+#' such objects attached as attributes -- then it is possible that it will
+#' change unpredictably even when you do not expect it to. Additionally, because
+#' the entire key is serialized and hashed, if it contains a very large object
+#' -- a large data set, for example -- there may be a noticeable performance
+#' penalty.
+#'
+#' If you face these issues with the cache key, you can work around them by
+#' extracting out the important parts of the objects, and/or by converting them
+#' to normal R objects before returning them. Your expression could even
+#' serialize and hash that information in an efficient way and return a string,
+#' which will in turn be hashed (very quickly) by the
+#' \code{\link[digest]{digest}} function.
+#'
+#' Internally, the result from \code{cacheKeyExpr} is combined with the name of
+#' the output (if you assign it to \code{output$plot1}, it will be combined
+#' with \code{"plot1"}) to form the actual key that is used. As a result, even
+#' if there are multiple plots that have the same \code{cacheKeyExpr}, they
+#' will not have cache key collisions.
+#'
+#' @section Cache scoping:
+#'
+#'   There are a number of different ways you may want to scope the cache. For
+#'   example, you may want each user session to have their own plot cache, or
+#'   you may want each run of the application to have a cache (shared among
+#'   possibly multiple simultaneous user sessions), or you may want to have a
+#'   cache that persists even after the application is shut down and started
+#'   again.
+#'
+#'   To control the scope of the cache, use the \code{cache} parameter. There
+#'   are two ways of having Shiny automatically create and clean up the disk
+#'   cache.
+#'
+#' \describe{
+#'   \item{1}{To scope the cache to one run of a Shiny application (shared
+#'     among possibly multiple user sessions), use \code{cache="app"}. This
+#'     is the default. The cache will be shared across multiple sessions, so
+#'     there is potentially a large performance benefit if there are many users
+#'     of the application. When the application stops running, the cache will
+#'     be deleted. If plots cannot be safely shared across users, this should
+#'     not be used.}
+#'   \item{2}{To scope the cache to one session, use \code{cache="session"}.
+#'     When a new user session starts -- in other words, when a web browser
+#'     visits the Shiny application -- a new cache will be created on disk
+#'     for that session. When the session ends, the cache will be deleted.
+#'     The cache will not be shared across multiple sessions.}
+#'  }
+#'
+#'   If either \code{"app"} or \code{"session"} is used, the cache will be 10 MB
+#'   in size, and will be stored stored in memory, using a
+#'   \code{\link{memoryCache}} object. Note that the cache space will be shared
+#'   among all cached plots within a single application or session.
+#'
+#'   In some cases, you may want more control over the caching behavior. For
+#'   example, you may want to use a larger or smaller cache, share a cache
+#'   among multiple R processes, or you may want the cache to persist across
+#'   multiple runs of an application, or even across multiple R processes.
+#'
+#'   To use different settings for an application-scoped cache, you can call
+#'   \code{\link{shinyOptions}()} at the top of your app.R, server.R, or
+#'   global.R. For example, this will create a cache with 20 MB of space
+#'   instead of the default 10 MB:
+#'   \preformatted{
+#'   shinyOptions(cache = memoryCache(size = 20e6))
+#'   }
+#'
+#'   To use different settings for a session-scoped cache, you can call
+#'   \code{\link{shinyOptions}()} at the top of your server function. To use
+#'   the session-scoped cache, you must also call \code{renderCachedPlot} with
+#'   \code{cache="session"}. This will create a 20 MB cache for the session:
+#'   \preformatted{
+#'   function(input, output, session) {
+#'     shinyOptions(cache = memoryCache(size = 20e6))
+#'
+#'     output$plot <- renderCachedPlot(
+#'       ...,
+#'       cache = "session"
+#'     )
+#'   }
+#'   }
+#'
+#'   If you want to create a cache that is shared across multiple concurrent
+#'   R processes, you can use a \code{\link{diskCache}}. You can create an
+#'   application-level shared cache by putting this at the top of your app.R,
+#'   server.R, or global.R:
+#'   \preformatted{
+#'   shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+#'   }
+#'
+#'   This will create a subdirectory in your system temp directory named
+#'   \code{myapp-cache} (replace \code{myapp-cache} with a unique name of
+#'   your choosing). On most platforms, this directory will be removed when
+#'   your system reboots. This cache will persist across multiple starts and
+#'   stops of the R process, as long as you do not reboot.
+#'
+#'   To have the cache persist even across multiple reboots, you can create the
+#'   cache in a location outside of the temp directory. For example, it could
+#'   be a subdirectory of the application:
+#'   \preformatted{
+#'   shinyOptions(cache = diskCache("./myapp-cache"))
+#'   }
+#'
+#'   In this case, resetting the cache will have to be done manually, by deleting
+#'   the directory.
+#'
+#'   You can also scope a cache to just one plot, or selected plots. To do that,
+#'   create a \code{\link{memoryCache}} or \code{\link{diskCache}}, and pass it
+#'   as the \code{cache} argument of \code{renderCachedPlot}.
+#'
+#' @section Interactive plots:
+#'
+#'   \code{renderCachedPlot} can be used to create interactive plots. See
+#'   \code{\link{plotOutput}} for more information and examples.
+#'
+#'
+#' @inheritParams renderPlot
+#' @param cacheKeyExpr An expression that returns a cache key. This key should
+#'   be a unique identifier for a plot: the assumption is that if the cache key
+#'   is the same, then the plot will be the same.
+#' @param sizePolicy A function that takes two arguments, \code{width} and
+#'   \code{height}, and returns a list with \code{width} and \code{height}. The
+#'   purpose is to round the actual pixel dimensions from the browser to some
+#'   other dimensions, so that this will not generate and cache images of every
+#'   possible pixel dimension. See \code{\link{sizeGrowthRatio}} for more
+#'   information on the default sizing policy.
+#' @param res The resolution of the PNG, in pixels per inch.
+#' @param cache The scope of the cache, or a cache object. This can be
+#'   \code{"app"} (the default), \code{"session"}, or a cache object like
+#'   a \code{\link{diskCache}}. See the Cache Scoping section for more
+#'   information.
+#'
+#' @seealso See \code{\link{renderPlot}} for the regular, non-cached version of
+#'   this function. For more about configuring caches, see
+#'   \code{\link{memoryCache}} and \code{\link{diskCache}}.
+#'
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#' # A basic example that uses the default app-scoped memory cache.
+#' # The cache will be shared among all simultaneous users of the application.
+#' shinyApp(
+#'   fluidPage(
+#'     sidebarLayout(
+#'       sidebarPanel(
+#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+#'       ),
+#'       mainPanel(plotOutput("plot"))
+#'     )
+#'   ),
+#'   function(input, output, session) {
+#'     output$plot <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) }
+#'     )
+#'   }
+#' )
+#'
+#'
+#'
+#' # An example uses a data object shared across sessions. mydata() is part of
+#' # the cache key, so when its value changes, plots that were previously
+#' # stored in the cache will no longer be used (unless mydata() changes back
+#' # to its previous value).
+#' mydata <- reactiveVal(data.frame(x = rnorm(400), y = rnorm(400)))
+#'
+#' ui <- fluidPage(
+#'   sidebarLayout(
+#'     sidebarPanel(
+#'       sliderInput("n", "Number of points", 50, 400, 100, step = 50),
+#'       actionButton("newdata", "New data")
+#'     ),
+#'     mainPanel(
+#'       plotOutput("plot")
+#'     )
+#'   )
+#' )
+#'
+#' server <- function(input, output, session) {
+#'   observeEvent(input$newdata, {
+#'     mydata(data.frame(x = rnorm(400), y = rnorm(400)))
+#'   })
+#'
+#'   output$plot <- renderCachedPlot(
+#'     {
+#'       Sys.sleep(2)
+#'       d <- mydata()
+#'       seqn <- seq_len(input$n)
+#'       plot(d$x[seqn], d$y[seqn], xlim = range(d$x), ylim = range(d$y))
+#'     },
+#'     cacheKeyExpr = { list(input$n, mydata()) },
+#'   )
+#' }
+#'
+#' shinyApp(ui, server)
+#'
+#'
+#' # A basic application with two plots, where each plot in each session has
+#' # a separate cache.
+#' shinyApp(
+#'   fluidPage(
+#'     sidebarLayout(
+#'       sidebarPanel(
+#'         sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+#'       ),
+#'       mainPanel(
+#'         plotOutput("plot1"),
+#'         plotOutput("plot2")
+#'       )
+#'     )
+#'   ),
+#'   function(input, output, session) {
+#'     output$plot1 <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) },
+#'       cache = memoryCache()
+#'     )
+#'     output$plot2 <- renderCachedPlot({
+#'         Sys.sleep(2)  # Add an artificial delay
+#'         seqn <- seq_len(input$n)
+#'         plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+#'              xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+#'       },
+#'       cacheKeyExpr = { list(input$n) },
+#'       cache = memoryCache()
+#'     )
+#'   }
+#' )
+#'
+#' }
+#'
+#' \dontrun{
+#' # At the top of app.R, this set the application-scoped cache to be a memory
+#' # cache that is 20 MB in size, and where cached objects expire after one
+#' # hour.
+#' shinyOptions(cache = memoryCache(max_size = 20e6, max_age = 3600))
+#'
+#' # At the top of app.R, this set the application-scoped cache to be a disk
+#' # cache that can be shared among multiple concurrent R processes, and is
+#' # deleted when the system reboots.
+#' shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+#'
+#' # At the top of app.R, this set the application-scoped cache to be a disk
+#' # cache that can be shared among multiple concurrent R processes, and
+#' # persists on disk across reboots.
+#' shinyOptions(cache = diskCache("./myapp-cache"))
+#'
+#' # At the top of the server function, this set the session-scoped cache to be
+#' # a memory cache that is 5 MB in size.
+#' server <- function(input, output, session) {
+#'   shinyOptions(cache = memoryCache(max_size = 5e6))
+#'
+#'   output$plot <- renderCachedPlot(
+#'     ...,
+#'     cache = "session"
+#'   )
+#' }
+#'
+#' }
+#' @export
+renderCachedPlot <- function(expr,
+  cacheKeyExpr,
+  sizePolicy = sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2),
+  res = 72,
+  cache = "app",
+  ...,
+  outputArgs = list()
+) {
+
+  # This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
+  # is called
+  installExprFunction(expr, "func", parent.frame(), quoted = FALSE, ..stacktraceon = TRUE)
+  # This is so that the expr doesn't re-execute by itself; it needs to be
+  # triggered by the cache key (or width/height) changing.
+  isolatedFunc <- function() isolate(func())
+
+  args <- list(...)
+
+  cacheKeyExpr <- substitute(cacheKeyExpr)
+  # The real cache key we'll use also includes width, height, res, pixelratio.
+  # This is just the part supplied by the user.
+  userCacheKey <- reactive(cacheKeyExpr, env = parent.frame(), quoted = TRUE, label = "userCacheKey")
+
+  ensureCacheSetup <- function() {
+    # For our purposes, cache objects must support these methods.
+    isCacheObject <- function(x) {
+      # Use tryCatch in case the object does not support `$`.
+      tryCatch(
+        is.function(x$get) && is.function(x$set),
+        error = function(e) FALSE
+      )
+    }
+
+    if (isCacheObject(cache)) {
+      # If `cache` is already a cache object, do nothing
+      return()
+
+    } else if (identical(cache, "app")) {
+      cache <<- getShinyOption("cache")
+
+    } else if (identical(cache, "session")) {
+      cache <<- session$cache
+
+    } else {
+      stop('`cache` must either be "app", "session", or a cache object with methods, `$get`, and `$set`.')
+    }
+  }
+
+  # The width and height of the plot to draw, given from sizePolicy. These
+  # values get filled by an observer below.
+  fitDims <- reactiveValues(width = NULL, height = NULL)
+
+  resizeObserver <- NULL
+  ensureResizeObserver <- function() {
+    if (!is.null(resizeObserver))
+      return()
+
+    # Given the actual width/height of the image in the browser, this gets the
+    # width/height from sizePolicy() and pushes those values into `fitDims`.
+    # It's done this way so that the `fitDims` only change (and cause
+    # invalidations) when the rendered image size changes, and not every time
+    # the browser's <img> tag changes size.
+    doResizeCheck <- function() {
+      width  <- session$clientData[[paste0('output_', outputName, '_width')]]
+      height <- session$clientData[[paste0('output_', outputName, '_height')]]
+
+      if (is.null(width)) width <- 0
+      if (is.null(height)) height <- 0
+
+      rect <- sizePolicy(c(width, height))
+      fitDims$width  <- rect[1]
+      fitDims$height <- rect[2]
+    }
+
+    # Run it once immediately, then set up the observer
+    isolate(doResizeCheck())
+
+    resizeObserver <<- observe(doResizeCheck())
+  }
+
+  # Vars to store session and output, so that they can be accessed from
+  # the plotObj() reactive.
+  session <- NULL
+  outputName <- NULL
+
+
+  drawReactive <- reactive(label = "plotObj", {
+    hybrid_chain(
+      # Depend on the user cache key, even though we don't use the value. When
+      # it changes, it can cause the drawReactive to re-execute. (Though
+      # drawReactive will not necessarily re-execute -- it must be called from
+      # renderFunc, which happens only if there's a cache miss.)
+      userCacheKey(),
+      function(userCacheKeyValue) {
+        # Get width/height, but don't depend on them.
+        isolate({
+          width  <- fitDims$width
+          height <- fitDims$height
+        })
+
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        do.call("drawPlot", c(
+          list(
+            name = outputName,
+            session = session,
+            func = isolatedFunc,
+            width = width,
+            height = height,
+            pixelratio = pixelratio,
+            res = res
+          ),
+          args
+        ))
+      },
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        fitDims$width
+        fitDims$height
+
+        # Propagate the error
+        stop(reason)
+      }
+    )
+  })
+
+
+  # This function is the one that's returned from renderPlot(), and gets
+  # wrapped in an observer when the output value is assigned.
+  renderFunc <- function(shinysession, name, ...) {
+    outputName <<- name
+    session <<- shinysession
+    ensureCacheSetup()
+    ensureResizeObserver()
+
+    hybrid_chain(
+      # This use of the userCacheKey() sets up the reactive dependency that
+      # causes plot re-draw events. These may involve pulling from the cache,
+      # replaying a display list, or re-executing user code.
+      userCacheKey(),
+      function(userCacheKeyResult) {
+        width  <- fitDims$width
+        height <- fitDims$height
+        pixelratio <- session$clientData$pixelratio %OR% 1
+
+        key <- digest::digest(list(outputName, userCacheKeyResult, width, height, res, pixelratio), "xxhash64")
+
+        plotObj <- cache$get(key)
+
+        # First look in cache.
+        # Case 1. cache hit.
+        if (!is.key_missing(plotObj)) {
+          return(list(
+            cacheHit = TRUE,
+            key = key,
+            plotObj = plotObj,
+            width = width,
+            height = height,
+            pixelratio = pixelratio
+          ))
+        }
+
+        # If not in cache, hybrid_chain call to drawReactive
+        #
+        # Two more possible cases:
+        #   2. drawReactive will re-execute and return a plot that's the
+        #      correct size.
+        #   3. It will not re-execute, but it will return the previous value,
+        #      which is the wrong size. It will include a valid display list
+        #      which can be used by resizeSavedPlot.
+        hybrid_chain(
+          drawReactive(),
+          function(drawReactiveResult) {
+            # Pass along the key for caching in the next stage
+            list(
+              cacheHit = FALSE,
+              key = key,
+              plotObj = drawReactiveResult,
+              width = width,
+              height = height,
+              pixelratio = pixelratio
+            )
+          }
+        )
+      },
+      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
+          ))
+
+          # 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
+      }
+    )
+  }
+
+  # If renderPlot isn't going to adapt to the height of the div, then the
+  # div needs to adapt to the height of renderPlot. By default, plotOutput
+  # sets the height to 400px, so to make it adapt we need to override it
+  # with NULL.
+  outputFunc <- plotOutput
+  formals(outputFunc)['height'] <- list(NULL)
+
+  markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
+}
+
+
+#' Create a sizing function that grows at a given ratio
+#'
+#' Returns a function which takes a two-element vector representing an input
+#' width and height, and returns a two-element vector of width and height. The
+#' possible widths are the base width times the growthRate to any integer power.
+#' For example, with a base width of 500 and growth rate of 1.25, the possible
+#' widths include 320, 400, 500, 625, 782, and so on, both smaller and larger.
+#' Sizes are rounded up to the next pixel. Heights are computed the same way as
+#' widths.
+#'
+#' @param width,height Base width and height.
+#' @param growthRate Growth rate multiplier.
+#'
+#' @seealso This is to be used with \code{\link{renderCachedPlot}}.
+#'
+#' @examples
+#' f <- sizeGrowthRatio(500, 500, 1.25)
+#' f(c(400, 400))
+#' f(c(500, 500))
+#' f(c(530, 550))
+#' f(c(625, 700))
+#'
+#' @export
+sizeGrowthRatio <- function(width = 400, height = 400, growthRate = 1.2) {
+  round_dim_up <- function(x, base, rate) {
+    power <- ceiling(log(x / base, rate))
+    ceiling(base * rate^power)
+  }
+
+  function(dims) {
+    if (length(dims) != 2) {
+      stop("dims must be a vector with two numbers, for width and height.")
+    }
+    c(
+      round_dim_up(dims[1], width,  growthRate),
+      round_dim_up(dims[2], height, growthRate)
+    )
+  }
+}

R/render-plot.R

@@ -133,10 +133,12 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
       function(result) {
         dims <- getDims()
         pixelratio <- session$clientData$pixelratio %OR% 1
-        do.call("resizeSavedPlot", c(
+        result <- do.call("resizeSavedPlot", c(
           list(name, shinysession, result, dims$width, dims$height, pixelratio, res),
           args
         ))
+
+        result$img
       }
     )
   }
@@ -154,23 +156,25 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
 resizeSavedPlot <- function(name, session, result, width, height, pixelratio, res, ...) {
   if (result$img$width == width && result$img$height == height &&
       result$pixelratio == pixelratio && result$res == res) {
-    return(result$img)
+    return(result)
   }
 
   coordmap <- NULL
   outfile <- plotPNG(function() {
     grDevices::replayPlot(result$recordedPlot)
-    coordmap <<- getCoordmap(result$plotResult, width, height, pixelratio, res)
+    coordmap <<- getCoordmap(result$plotResult, width*pixelratio, height*pixelratio, res*pixelratio)
   }, width = width*pixelratio, height = height*pixelratio, res = res*pixelratio, ...)
   on.exit(unlink(outfile), add = TRUE)
 
-  img <- list(
+  result$img <- list(
     src = session$fileUrl(name, outfile, contentType = "image/png"),
     width = width,
     height = height,
     coordmap = coordmap,
     error = attr(coordmap, "error", exact = TRUE)
   )
+
+  result
 }
 
 drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
@@ -227,7 +231,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
             list(
               plotResult = value,
               recordedPlot = grDevices::recordPlot(),
-              coordmap = getCoordmap(value, width, height, pixelratio, res),
+              coordmap = getCoordmap(value, width*pixelratio, height*pixelratio, res*pixelratio),
               pixelratio = pixelratio,
               res = res
             )
@@ -247,6 +251,7 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
         # Get coordmap error message if present
         error = attr(result$coordmap, "error", exact = TRUE)
       ))
+
       result
     },
     finally = function() {
@@ -279,22 +284,26 @@ custom_print.ggplot <- function(x) {
 # below. For base graphics:
 # plot(mtcars$wt, mtcars$mpg)
 # str(getPrevPlotCoordmap(400, 300))
-# List of 1
-#  $ :List of 4
-#   ..$ domain :List of 4
-#   .. ..$ left  : num 1.36
-#   .. ..$ right : num 5.58
-#   .. ..$ bottom: num 9.46
-#   .. ..$ top   : num 34.8
-#   ..$ range  :List of 4
-#   .. ..$ left  : num 50.4
-#   .. ..$ right : num 373
-#   .. ..$ bottom: num 199
-#   .. ..$ top   : num 79.6
-#   ..$ log    :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ mapping: Named list()
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 4
+#   .. ..$ domain :List of 4
+#   .. .. ..$ left  : num 1.36
+#   .. .. ..$ right : num 5.58
+#   .. .. ..$ bottom: num 9.46
+#   .. .. ..$ top   : num 34.8
+#   .. ..$ range  :List of 4
+#   .. .. ..$ left  : num 65.6
+#   .. .. ..$ right : num 366
+#   .. .. ..$ bottom: num 238
+#   .. .. ..$ top   : num 48.2
+#   .. ..$ log    :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ mapping: Named list()
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 #
 # For ggplot2, first you need to define the print.ggplot function from inside
 # renderPlot, then use it to print the plot:
@@ -313,29 +322,33 @@ custom_print.ggplot <- function(x) {
 # }
 #
 # p <- print(ggplot(mtcars, aes(wt, mpg)) + geom_point())
-# str(getGgplotCoordmap(p, 1, 72))
-# List of 1
-#  $ :List of 10
-#   ..$ panel     : int 1
-#   ..$ row       : int 1
-#   ..$ col       : int 1
-#   ..$ panel_vars: Named list()
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 2
-#   .. ..$ x: chr "wt"
-#   .. ..$ y: chr "mpg"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 40.8
-#   .. ..$ right : num 446
-#   .. ..$ bottom: num 263
-#   .. ..$ top   : num 14.4
+# str(getGgplotCoordmap(p, 400, 300, 72))
+# List of 2
+#  $ panels:List of 1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : num 1
+#   .. ..$ col       : num 1
+#   .. ..$ panel_vars: Named list()
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 2
+#   .. .. ..$ x: chr "wt"
+#   .. .. ..$ y: chr "mpg"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 5.48
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 #
 # With a faceted ggplot2 plot, the outer list contains two objects, each of
 # which represents one panel. In this example, there is one panelvar, but there
@@ -343,59 +356,63 @@ custom_print.ggplot <- function(x) {
 # mtc <- mtcars
 # mtc$am <- factor(mtc$am)
 # p <- print(ggplot(mtc, aes(wt, mpg)) + geom_point() + facet_wrap(~ am))
-# str(getGgplotCoordmap(p, 1, 72))
+# str(getGgplotCoordmap(p, 400, 300, 72))
 # List of 2
-#  $ :List of 10
-#   ..$ panel     : int 1
-#   ..$ row       : int 1
-#   ..$ col       : int 1
-#   ..$ panel_vars:List of 1
-#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 3
-#   .. ..$ x        : chr "wt"
-#   .. ..$ y        : chr "mpg"
-#   .. ..$ panelvar1: chr "am"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 45.6
-#   .. ..$ right : num 317
-#   .. ..$ bottom: num 251
-#   .. ..$ top   : num 35.7
-#  $ :List of 10
-#   ..$ panel     : int 2
-#   ..$ row       : int 1
-#   ..$ col       : int 2
-#   ..$ panel_vars:List of 1
-#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
-#   ..$ log       :List of 2
-#   .. ..$ x: NULL
-#   .. ..$ y: NULL
-#   ..$ domain    :List of 4
-#   .. ..$ left  : num 1.32
-#   .. ..$ right : num 5.62
-#   .. ..$ bottom: num 9.22
-#   .. ..$ top   : num 35.1
-#   ..$ mapping   :List of 3
-#   .. ..$ x        : chr "wt"
-#   .. ..$ y        : chr "mpg"
-#   .. ..$ panelvar1: chr "am"
-#   ..$ range     :List of 4
-#   .. ..$ left  : num 322
-#   .. ..$ right : num 594
-#   .. ..$ bottom: num 251
-#   .. ..$ top   : num 35.7
+#  $ panels:List of 2
+#   ..$ :List of 8
+#   .. ..$ panel     : num 1
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 1
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 33.3
+#   .. .. ..$ right : num 191
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#   ..$ :List of 8
+#   .. ..$ panel     : num 2
+#   .. ..$ row       : int 1
+#   .. ..$ col       : int 2
+#   .. ..$ panel_vars:List of 1
+#   .. .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
+#   .. ..$ log       :List of 2
+#   .. .. ..$ x: NULL
+#   .. .. ..$ y: NULL
+#   .. ..$ domain    :List of 4
+#   .. .. ..$ left  : num 1.32
+#   .. .. ..$ right : num 5.62
+#   .. .. ..$ bottom: num 9.22
+#   .. .. ..$ top   : num 35.1
+#   .. ..$ mapping   :List of 3
+#   .. .. ..$ x        : chr "wt"
+#   .. .. ..$ y        : chr "mpg"
+#   .. .. ..$ panelvar1: chr "am"
+#   .. ..$ range     :List of 4
+#   .. .. ..$ left  : num 197
+#   .. .. ..$ right : num 355
+#   .. .. ..$ bottom: num 328
+#   .. .. ..$ top   : num 23.1
+#  $ dims  :List of 2
+#   ..$ width : num 400
+#   ..$ height: num 300
 
 
-getCoordmap <- function(x, width, height, pixelratio, res) {
+getCoordmap <- function(x, width, height, res) {
   if (inherits(x, "ggplot_build_gtable")) {
-    getGgplotCoordmap(x, pixelratio, res)
+    getGgplotCoordmap(x, width, height, res)
   } else {
     getPrevPlotCoordmap(width, height)
   }
@@ -415,7 +432,7 @@ getPrevPlotCoordmap <- function(width, height) {
   }
 
   # Wrapped in double list because other types of plots can have multiple panels.
-  list(list(
+  panel_info <- list(list(
     # Bounds of the plot area, in data space
     domain = list(
       left = usrCoords[1],
@@ -425,10 +442,10 @@ getPrevPlotCoordmap <- function(width, height) {
     ),
     # The bounds of the plot area, in DOM pixels
     range = list(
-      left = graphics::grconvertX(usrBounds[1], 'user', 'nfc') * width,
-      right = graphics::grconvertX(usrBounds[2], 'user', 'nfc') * width,
-      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'nfc')) * height - 1,
-      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'nfc')) * height - 1
+      left = graphics::grconvertX(usrBounds[1], 'user', 'ndc') * width,
+      right = graphics::grconvertX(usrBounds[2], 'user', 'ndc') * width,
+      bottom = (1-graphics::grconvertY(usrBounds[3], 'user', 'ndc')) * height - 1,
+      top = (1-graphics::grconvertY(usrBounds[4], 'user', 'ndc')) * height - 1
     ),
     log = list(
       x = if (graphics::par('xlog')) 10 else NULL,
@@ -439,27 +456,43 @@ getPrevPlotCoordmap <- function(width, height) {
     # (not an array) in JSON.
     mapping = list(x = NULL)[0]
   ))
+
+  list(
+    panels = panel_info,
+    dims = list(
+      width = width,
+      height =height
+    )
+  )
 }
 
 # Given a ggplot_build_gtable object, return a coordmap for it.
-getGgplotCoordmap <- function(p, pixelratio, res) {
+getGgplotCoordmap <- function(p, width, height, res) {
   if (!inherits(p, "ggplot_build_gtable"))
     return(NULL)
 
   tryCatch({
     # Get info from built ggplot object
-    info <- find_panel_info(p$build)
+    panel_info <- find_panel_info(p$build)
 
     # Get ranges from gtable - it's possible for this to return more elements than
     # info, because it calculates positions even for panels that aren't present.
     # This can happen with facet_wrap.
-    ranges <- find_panel_ranges(p$gtable, pixelratio, res)
+    ranges <- find_panel_ranges(p$gtable, res)
 
-    for (i in seq_along(info)) {
-      info[[i]]$range <- ranges[[i]]
+    for (i in seq_along(panel_info)) {
+      panel_info[[i]]$range <- ranges[[i]]
     }
 
-    return(info)
+    return(
+      list(
+        panels = panel_info,
+        dims = list(
+          width = width,
+          height = height
+        )
+      )
+    )
 
   }, error = function(e) {
     # If there was an error extracting info from the ggplot object, just return
@@ -486,13 +519,11 @@ find_panel_info <- function(b) {
 # This is for ggplot2>2.2.1, after an API was introduced for extracting
 # information about the plot object.
 find_panel_info_api <- function(b) {
-  # Workaround for check NOTE, until ggplot2 >2.2.1 is released
-  colon_colon <- `::`
   # Given a built ggplot object, return x and y domains (data space coords) for
   # each panel.
-  layout <- colon_colon("ggplot2", "summarise_layout")(b)
-  coord  <- colon_colon("ggplot2", "summarise_coord")(b)
-  layers <- colon_colon("ggplot2", "summarise_layers")(b)
+  layout <- ggplot2::summarise_layout(b)
+  coord  <- ggplot2::summarise_coord(b)
+  layers <- ggplot2::summarise_layers(b)
 
   # Given x and y scale objects and a coord object, return a list that has
   # the bases of log transformations for x and y, or NULL if it's not a
@@ -822,7 +853,7 @@ find_panel_info_non_api <- function(b, ggplot_format) {
 
 
 # Given a gtable object, return the x and y ranges (in pixel dimensions)
-find_panel_ranges <- function(g, pixelratio, res) {
+find_panel_ranges <- function(g, res) {
   # Given a vector of unit objects, return logical vector indicating which ones
   # are "null" units. These units use the remaining available width/height --
   # that is, the space not occupied by elements that have an absolute size.
@@ -952,26 +983,15 @@ find_panel_ranges <- function(g, pixelratio, res) {
   layout <- layout[order(layout$t, layout$l), ]
   layout$panel <- seq_len(nrow(layout))
 
-  # When using a HiDPI client on a Linux server, the pixel
-  # dimensions are doubled, so we have to divide the dimensions by
-  # `pixelratio`. When a HiDPI client is used on a Mac server (with
-  # the quartz device), the pixel dimensions _aren't_ doubled, even though
-  # the image has double size. In the latter case we don't have to scale the
-  # numbers down.
-  pix_ratio <- 1
-  if (!grepl("^quartz", names(grDevices::dev.cur()))) {
-    pix_ratio <- pixelratio
-  }
-
   # Return list of lists, where each inner list has left, right, top, bottom
   # values for a panel
   lapply(seq_len(nrow(layout)), function(i) {
     p <- layout[i, , drop = FALSE]
     list(
-      left   = x_pos[p$l - 1] / pix_ratio,
-      right  = x_pos[p$r] / pix_ratio,
-      bottom = y_pos[p$b] / pix_ratio,
-      top    = y_pos[p$t - 1] / pix_ratio
+      left   = x_pos[p$l - 1],
+      right  = x_pos[p$r],
+      bottom = y_pos[p$b],
+      top    = y_pos[p$t - 1]
     )
   })
 }

R/server-input-handlers.R

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

R/server.R

@@ -419,7 +419,10 @@ startApp <- function(appObj, port, host, quiet) {
 
   if (is.numeric(port) || is.integer(port)) {
     if (!quiet) {
-      message('\n', 'Listening on http://', host, ':', port)
+      hostString <- host
+      if (httpuv::ipFamily(host) == 6L)
+        hostString <- paste0("[", hostString, "]")
+      message('\n', 'Listening on http://', hostString, ':', port)
     }
     return(startServer(host, port, handlerManager$createHttpuvApp()))
   } else if (is.character(port)) {
@@ -576,12 +579,16 @@ runApp <- function(appDir=getwd(),
     .globals$running <- FALSE
   }, add = TRUE)
 
-  # Enable per-app Shiny options
+  # Enable per-app Shiny options, for shinyOptions() and getShinyOption().
   oldOptionSet <- .globals$options
   on.exit({
     .globals$options <- oldOptionSet
   },add = TRUE)
 
+  # A unique identifier associated with this run of this application. It is
+  # shared across sessions.
+  shinyOptions(appToken = createUniqueId(8))
+
   # Make warnings print immediately
   # Set pool.scheduler to support pool package
   ops <- options(
@@ -591,6 +598,11 @@ runApp <- function(appDir=getwd(),
   )
   on.exit(options(ops), add = TRUE)
 
+  # Set up default cache for app.
+  if (is.null(getShinyOption("cache"))) {
+    shinyOptions(cache = MemoryCache$new())
+  }
+
   appParts <- as.shiny.appobj(appDir)
 
   # The lines below set some of the app's running options, which
@@ -770,8 +782,17 @@ runApp <- function(appDir=getwd(),
   }, add = TRUE)
 
   if (!is.character(port)) {
-    # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
-    browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
+    browseHost <- host
+    if (identical(host, "0.0.0.0")) {
+      # http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
+      browseHost <- "127.0.0.1"
+    } else if (identical(host, "::")) {
+      browseHost <- "::1"
+    }
+
+    if (httpuv::ipFamily(browseHost) == 6L) {
+      browseHost <- paste0("[", browseHost, "]")
+    }
 
     appUrl <- paste("http://", browseHost, ":", port, sep="")
     if (is.function(launch.browser))

R/shiny.R

@@ -445,6 +445,8 @@ ShinySession <- R6Class(
     testMode = FALSE,                # Are we running in test mode?
     testExportExprs = list(),
     outputValues = list(),           # Saved output values (for testing mode)
+    currentOutputName = NULL,        # Name of the currently-running output
+    outputInfo = list(),             # List of information for each output
     testSnapshotUrl = character(0),
 
     sendResponse = function(requestMsg, value) {
@@ -491,6 +493,16 @@ ShinySession <- R6Class(
         return(defaultValue)
       return(result)
     },
+    withCurrentOutput = function(name, expr) {
+      if (!is.null(private$currentOutputName)) {
+        stop("Nested calls to withCurrentOutput() are not allowed.")
+      }
+
+      promises::with_promise_domain(
+        createVarPromiseDomain(private, "currentOutputName", name),
+        expr
+      )
+    },
     shouldSuspend = function(name) {
       # Find corresponding hidden state clientData variable, with the format
       # "output_foo_hidden". (It comes from .clientdata_output_foo_hidden
@@ -691,6 +703,7 @@ ShinySession <- R6Class(
     request = 'ANY',      # Websocket request object
     singletons = character(0),  # Tracks singleton HTML fragments sent to the page
     userData = 'environment',
+    cache = NULL,         # A cache object used in the session
     user = NULL,
     groups = NULL,
 
@@ -725,6 +738,8 @@ ShinySession <- R6Class(
       private$.outputs <- list()
       private$.outputOptions <- list()
 
+      self$cache <- MemoryCache$new()
+
       private$bookmarkCallbacks <- Callbacks$new()
       private$bookmarkedCallbacks <- Callbacks$new()
       private$restoreCallbacks <- Callbacks$new()
@@ -901,9 +916,11 @@ ShinySession <- R6Class(
         # Create subdir for this scope
         if (!is.null(state$dir)) {
           scopeState$dir <- file.path(state$dir, namespace)
-          res <- dir.create(scopeState$dir)
-          if (res == FALSE) {
-            stop("Error creating subdirectory for scope ", namespace)
+          if (!dirExists(scopeState$dir)) {
+            res <- dir.create(scopeState$dir)
+            if (res == FALSE) {
+              stop("Error creating subdirectory for scope ", namespace)
+            }
           }
         }
 
@@ -961,8 +978,9 @@ ShinySession <- R6Class(
         stop("x must be a reactivevalues object")
 
       impl <- .subset2(x, 'impl')
-      impl$freeze(name)
-      self$onFlushed(function() impl$thaw(name))
+      key <- .subset2(x, 'ns')(name)
+      impl$freeze(key)
+      self$onFlushed(function() impl$thaw(key))
     },
 
     onSessionEnded = function(sessionEndedCallback) {
@@ -1070,7 +1088,11 @@ ShinySession <- R6Class(
           # to include the $then/$catch calls below?
           hybrid_chain(
             hybrid_chain(
-              shinyCallingHandlers(func()),
+              {
+                private$withCurrentOutput(name, {
+                  shinyCallingHandlers(func())
+                })
+              },
               catch = function(cond) {
                 if (inherits(cond, "shiny.custom.error")) {
                   if (isTRUE(getOption("show.error.messages"))) printError(cond)
@@ -1313,6 +1335,47 @@ ShinySession <- R6Class(
       }
     },
 
+    getCurrentOutputInfo = function() {
+      name <- private$currentOutputName
+
+      tmp_info <- private$outputInfo[[name]] %OR% list(name = name)
+
+      # cd_names() returns names of all items in clientData, without taking a
+      # reactive dependency. It is a function and it's memoized, so that we do
+      # the (relatively) expensive isolate(names(...)) call only when needed,
+      # and at most one time in this function.
+      .cd_names <- NULL
+      cd_names <- function() {
+        if (is.null(.cd_names)) {
+          .cd_names <<- isolate(names(self$clientData))
+        }
+        .cd_names
+      }
+
+      # If we don't already have width for this output info, see if it's
+      # present, and if so, add it.
+      if (! ("width" %in% names(tmp_info)) ) {
+        width_name  <- paste0("output_", name, "_width")
+        if (width_name %in% cd_names()) {
+          tmp_info$width <- reactive({
+            self$clientData[[width_name]]
+          })
+        }
+      }
+
+      if (! ("height" %in% names(tmp_info)) ) {
+        height_name  <- paste0("output_", name, "_height")
+        if (height_name %in% cd_names()) {
+          tmp_info$height <- reactive({
+            self$clientData[[height_name]]
+          })
+        }
+      }
+
+      private$outputInfo[[name]] <- tmp_info
+      private$outputInfo[[name]]
+    },
+
     createBookmarkObservers = function() {
       # This registers observers for bookmarking to work.
 
@@ -2056,6 +2119,16 @@ outputOptions <- function(x, name, ...) {
   .subset2(x, 'impl')$outputOptions(name, ...)
 }
 
+
+#' Get information about the output that is currently being executed.
+#'
+#' @param session The current Shiny session.
+#'
+#' @export
+getCurrentOutputInfo <- function(session = getDefaultReactiveDomain()) {
+  session$getCurrentOutputInfo()
+}
+
 #' Add callbacks for Shiny session events
 #'
 #' These functions are for registering callbacks on Shiny session events.
@@ -2124,7 +2197,9 @@ flushPendingSessions <- function() {
 #'   called from within the server function, this will default to the current
 #'   session, and the callback will be invoked when the current session ends. If
 #'   \code{onStop} is called outside a server function, then the callback will
-#'   be invoked with the application exits.
+#'   be invoked with the application exits. If \code{NULL}, it is the same as
+#'   calling \code{onStop} outside of the server function, and the callback will
+#'   be invoked when the application exits.
 #'
 #'
 #' @seealso \code{\link{onSessionEnded}()} for the same functionality, but at
@@ -2184,7 +2259,7 @@ flushPendingSessions <- function() {
 #' }
 #' @export
 onStop <- function(fun, session = getDefaultReactiveDomain()) {
-  if (is.null(getDefaultReactiveDomain())) {
+  if (is.null(session)) {
     return(.globals$onStopCallbacks$register(fun))
   } else {
     # Note: In the future if we allow scoping the onStop() callback to modules

R/shinywrappers.R

@@ -1,4 +1,4 @@
-globalVariables('func')
+utils::globalVariables('func')
 
 #' Mark a function as a render function
 #'
@@ -118,7 +118,7 @@ useRenderFunction <- function(renderFunc, inline = FALSE) {
     # If there's a namespace, we must respect it
     id <- getDefaultReactiveDomain()$ns(id)
   }
-  
+
   # Make the id the first positional argument
   outputArgs <- c(list(id), outputArgs)
 
@@ -451,7 +451,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
 #'   call to \code{\link{uiOutput}} when \code{renderUI} is used in an
 #'   interactive R Markdown document.
 #'
-#' @seealso \code{\link{uiOutput}} 
+#' @seealso \code{\link{uiOutput}}
 #' @export
 #' @examples
 #' ## Only run examples in interactive R sessions

R/update-input.R

@@ -383,13 +383,17 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
   session$sendInputMessage(inputId, message)
 }
 
-#' Change the value of a slider input on the client
+#' Update Slider Input Widget
+#'
+#' Change the value of a slider input on the client.
 #'
 #' @template update-input
 #' @param value The value to set for the input object.
 #' @param min Minimum value.
 #' @param max Maximum value.
 #' @param step Step size.
+#' @param timeFormat Date and POSIXt formatting.
+#' @param timezone The timezone offset for POSIXt objects.
 #'
 #' @seealso \code{\link{sliderInput}}
 #'
@@ -422,22 +426,15 @@ updateNumericInput <- function(session, inputId, label = NULL, value = NULL,
 #' }
 #' @export
 updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
-  min = NULL, max = NULL, step = NULL)
+  min = NULL, max = NULL, step = NULL, timeFormat = NULL, timezone = NULL)
 {
-  # Make sure that value, min, max all have the same type, because we need
-  # special handling for dates and datetimes.
-  vals <- dropNulls(list(value, min, max))
+  dataType <- getSliderType(min, max, value)
 
-  type <- unique(lapply(vals, function(x) {
-    if      (inherits(x, "Date"))   "date"
-    else if (inherits(x, "POSIXt")) "datetime"
-    else                            "number"
-  }))
-  if (length(type) > 1) {
-    stop("Type mismatch for value, min, and max")
+  if (is.null(timeFormat)) {
+    timeFormat <- switch(dataType, date = "%F", datetime = "%F %T", number = NULL)
   }
 
-  if ((length(type) == 1) && (type == "date" || type == "datetime")) {
+  if (dataType == "date" || dataType == "datetime") {
     to_ms <- function(x) 1000 * as.numeric(as.POSIXct(x))
     if (!is.null(min))   min   <- to_ms(min)
     if (!is.null(max))   max   <- to_ms(max)
@@ -449,7 +446,10 @@ updateSliderInput <- function(session, inputId, label = NULL, value = NULL,
     value = formatNoSci(value),
     min = formatNoSci(min),
     max = formatNoSci(max),
-    step = formatNoSci(step)
+    step = formatNoSci(step),
+    `data-type` = dataType,
+    `time-format` = timeFormat,
+    timezone = timezone
   ))
   session$sendInputMessage(inputId, message)
 }
@@ -576,7 +576,7 @@ updateRadioButtons <- function(session, inputId, label = NULL, choices = NULL,
 #' @template update-input
 #' @inheritParams selectInput
 #'
-#' @seealso \code{\link{selectInput}}
+#' @seealso \code{\link{selectInput}} \code{\link{varSelectInput}}
 #'
 #' @examples
 #' ## Only run examples in interactive R sessions
@@ -643,10 +643,22 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     return(updateSelectInput(session, inputId, label, choices, selected))
   }
 
-  # convert a single vector to a data frame so it returns {label: , value: }
-  # other objects return arbitrary JSON {x: , y: , foo: , ...}
-  choices <- if (is.atomic(choices)) {
-    # fast path
+  noOptGroup <- TRUE
+  if (is.list(choices)) {
+    # check if list is nested
+    for (i in seq_along(choices)) {
+      if (is.list(choices[[i]]) || length(choices[[i]]) > 1) {
+        noOptGroup <- FALSE
+        break()
+      }
+    }
+  }
+  # convert choices to a data frame so it returns [{label: , value: , group: },...]
+  choices <- if (is.atomic(choices) || noOptGroup) {
+    # fast path for vectors and flat lists
+    if (is.list(choices)) {
+      choices <- unlist(choices)
+    }
     if (is.null(names(choices))) {
       lab <- as.character(choices)
     } else {
@@ -659,8 +671,52 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
     }
     data.frame(label = lab, value = choices, stringsAsFactors = FALSE)
   } else {
-    # slow path
-    as.data.frame(choices, stringsAsFactors = FALSE)
+    # slow path for nested lists/optgroups
+    list_names <- names(choices)
+    if (is.null(list_names)) {
+      list_names <- rep("", length(choices))
+    }
+
+    choice_list <- mapply(choices, list_names, FUN = function (choice, name) {
+      group <- ""
+      lab <- name
+      if (lab == "") lab <- as.character(choice)
+
+      if (is.list(choice) || length(choice) > 1) {
+        group <- rep(name, length(choice))
+        choice <- unlist(choice)
+
+        if (is.null(names(choice))) {
+          lab <- as.character(choice)
+        } else {
+          lab <- names(choice)
+          # replace empty names like: choices = c(a = 1, 2)
+          # in this case: names(choices) = c("a", "")
+          # with replacement below choices will be: lab = c("a", "2")
+          empty_names_indices <- lab == ""
+          lab[empty_names_indices] <- as.character(choice[empty_names_indices])
+        }
+      }
+
+      list(
+        label = lab,
+        value = as.character(choice),
+        group = group
+      )
+    }, SIMPLIFY = FALSE)
+
+
+    extract_vector <- function(x, name) {
+      vecs <- lapply(x, `[[`, name)
+      do.call(c, vecs)
+    }
+
+    data.frame(
+      label = extract_vector(choice_list, "label"),
+      value = extract_vector(choice_list, "value"),
+      group = extract_vector(choice_list, "group"),
+      stringsAsFactors = FALSE, row.names = NULL
+    )
   }
 
   value <- unname(selected)
@@ -673,6 +729,43 @@ updateSelectizeInput <- function(session, inputId, label = NULL, choices = NULL,
   ))
   session$sendInputMessage(inputId, message)
 }
+#' @rdname updateSelectInput
+#' @inheritParams varSelectInput
+#' @export
+updateVarSelectInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected
+  )
+}
+#' @rdname updateSelectInput
+#' @export
+updateVarSelectizeInput <- function(session, inputId, label = NULL, data = NULL, selected = NULL, options = list(), server = FALSE) {
+  if (is.null(data)) {
+    choices <- NULL
+  } else {
+    choices <- colnames(data)
+  }
+  updateSelectizeInput(
+    session = session,
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    options = options,
+    server = server
+  )
+}
+
+
 
 selectizeJSON <- function(data, req) {
   query <- parseQueryString(req$QUERY_STRING)

R/utils.R

@@ -269,6 +269,25 @@ dirExists <- function(paths) {
   file.exists(paths) & file.info(paths)$isdir
 }
 
+# Removes empty directory (vectorized). This is needed because file.remove()
+# on Unix will remove empty directories, but on Windows, it will not. On
+# Windows, you would need to use unlink(recursive=TRUE), which is not very
+# safe. This function does it safely on Unix and Windows.
+dirRemove <- function(path) {
+  for (p in path) {
+    if (!dirExists(p)) {
+      stop("Cannot remove non-existent directory ", p, ".")
+    }
+    if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) {
+      stop("Cannot remove non-empty directory ", p, ".")
+    }
+    result <- unlink(p, recursive = TRUE)
+    if (result == 1) {
+      stop("Error removing directory ", p, ".")
+    }
+  }
+}
+
 # Attempt to join a path and relative path, and turn the result into a
 # (normalized) absolute path. The result will only be returned if it is an
 # existing file/directory and is a descendant of dir.
@@ -1679,14 +1698,14 @@ createVarPromiseDomain <- function(env, name, value) {
   force(env)
   force(name)
   force(value)
-  
+
   promises::new_promise_domain(
     wrapOnFulfilled = function(onFulfilled) {
       function(...) {
         orig <- env[[name]]
         env[[name]] <- value
         on.exit(env[[name]] <- orig)
-        
+
         onFulfilled(...)
       }
     },
@@ -1695,7 +1714,7 @@ createVarPromiseDomain <- function(env, name, value) {
         orig <- env[[name]]
         env[[name]] <- value
         on.exit(env[[name]] <- orig)
-        
+
         onRejected(...)
       }
     },
@@ -1707,4 +1726,17 @@ createVarPromiseDomain <- function(env, name, value) {
       force(expr)
     }
   )
-}
+}
+
+getSliderType <- function(min, max, value) {
+  vals <- dropNulls(list(value, min, max))
+  type <- unique(lapply(vals, function(x) {
+    if      (inherits(x, "Date"))   "date"
+    else if (inherits(x, "POSIXt")) "datetime"
+    else                            "number"
+  }))
+  if (length(type) > 1) {
+    stop("Type mismatch for `min`, `max`, and `value`. Each must be Date, POSIXt, or number.")
+  }
+  type[[1]]
+}

inst/staticdocs/index.r

@@ -41,6 +41,7 @@ sd_section("UI Inputs",
     "numericInput",
     "radioButtons",
     "selectInput",
+    "varSelectInput",
     "sliderInput",
     "submitButton",
     "textInput",
@@ -104,6 +105,7 @@ sd_section("Rendering functions",
   "Functions that you use in your application's server side code, assigning them to outputs that appear in your user interface.",
   c(
     "renderPlot",
+    "renderCachedPlot",
     "renderText",
     "renderPrint",
     "renderDataTable",
@@ -195,7 +197,9 @@ sd_section("Utility functions",
     "exprToFunction",
     "installExprFunction",
     "parseQueryString",
+    "getCurrentOutputInfo",
     "plotPNG",
+    "sizeGrowthRatio",
     "exportTestValues",
     "setSerializer",
     "snapshotExclude",
@@ -206,7 +210,10 @@ sd_section("Utility functions",
     "shinyDeprecated",
     "serverInfo",
     "shiny-options",
-    "onStop"
+    "onStop",
+    "diskCache",
+    "memoryCache",
+    "key_missing"
   )
 )
 sd_section("Plot interaction",

inst/www/shared/shiny.css

@@ -12,6 +12,11 @@ pre.shiny-text-output.noplaceholder:empty {
   height: 0;
 }
 
+.shiny-image-output img.shiny-scalable, .shiny-plot-output img.shiny-scalable {
+  max-width: 100%;
+  max-height: 100%;
+}
+
 #shiny-disconnected-overlay {
   position: fixed;
   top: 0;
@@ -381,3 +386,10 @@ pre.shiny-text-output.noplaceholder:empty {
 .shiny-file-input-over {
   box-shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px rgba(76, 174, 76, .6);
 }
+
+/* Overrides bootstrap-datepicker3.css styling for invalid date ranges.
+   See https://github.com/rstudio/shiny/issues/2042 for details. */
+.datepicker table tbody tr td.disabled,
+.datepicker table tbody tr td.disabled:hover {
+  color: #aaa;
+}

man/absolutePanel.Rd

@@ -5,13 +5,13 @@
 \alias{fixedPanel}
 \title{Panel with absolute positioning}
 \usage{
-absolutePanel(..., top = NULL, left = NULL, right = NULL, bottom = NULL,
-  width = NULL, height = NULL, draggable = FALSE, fixed = FALSE,
-  cursor = c("auto", "move", "default", "inherit"))
+absolutePanel(..., top = NULL, left = NULL, right = NULL,
+  bottom = NULL, width = NULL, height = NULL, draggable = FALSE,
+  fixed = FALSE, cursor = c("auto", "move", "default", "inherit"))
 
-fixedPanel(..., top = NULL, left = NULL, right = NULL, bottom = NULL,
-  width = NULL, height = NULL, draggable = FALSE, cursor = c("auto",
-  "move", "default", "inherit"))
+fixedPanel(..., top = NULL, left = NULL, right = NULL,
+  bottom = NULL, width = NULL, height = NULL, draggable = FALSE,
+  cursor = c("auto", "move", "default", "inherit"))
 }
 \arguments{
 \item{...}{Attributes (named arguments) or children (unnamed arguments) that

man/actionButton.Rd

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

man/bookmarkButton.Rd

@@ -6,8 +6,8 @@
 \usage{
 bookmarkButton(label = "Bookmark...", icon = shiny::icon("link", lib =
   "glyphicon"),
-  title = "Bookmark this application's state and get a URL for sharing.", ...,
-  id = "._bookmark_")
+  title = "Bookmark this application's state and get a URL for sharing.",
+  ..., id = "._bookmark_")
 }
 \arguments{
 \item{label}{The contents of the button or link--usually a text label, but

man/brushOpts.Rd

@@ -4,9 +4,9 @@
 \alias{brushOpts}
 \title{Create an object representing brushing options}
 \usage{
-brushOpts(id = NULL, fill = "#9cf", stroke = "#036", opacity = 0.25,
-  delay = 300, delayType = c("debounce", "throttle"), clip = TRUE,
-  direction = c("xy", "x", "y"), resetOnNew = FALSE)
+brushOpts(id = NULL, fill = "#9cf", stroke = "#036",
+  opacity = 0.25, delay = 300, delayType = c("debounce", "throttle"),
+  clip = TRUE, direction = c("xy", "x", "y"), resetOnNew = FALSE)
 }
 \arguments{
 \item{id}{Input value name. For example, if the value is \code{"plot_brush"},

man/checkboxGroupInput.Rd

@@ -5,7 +5,8 @@
 \title{Checkbox Group Input Control}
 \usage{
 checkboxGroupInput(inputId, label, choices = NULL, selected = NULL,
-  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL)
+  inline = FALSE, width = NULL, choiceNames = NULL,
+  choiceValues = NULL)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -93,6 +94,7 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}, \code{\link{textInput}}
+  \code{\link{textAreaInput}}, \code{\link{textInput}},
+  \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/checkboxInput.Rd

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

man/createRenderFunction.Rd

@@ -4,8 +4,8 @@
 \alias{createRenderFunction}
 \title{Implement render functions}
 \usage{
-createRenderFunction(func, transform = function(value, session, name, ...)
-  value, outputFunc = NULL, outputArgs = NULL)
+createRenderFunction(func, transform = function(value, session, name,
+  ...) value, outputFunc = NULL, outputArgs = NULL)
 }
 \arguments{
 \item{func}{A function without parameters, that returns user data. If the

man/dateInput.Rd

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

man/dateRangeInput.Rd

@@ -5,8 +5,9 @@
 \title{Create date range input}
 \usage{
 dateRangeInput(inputId, label, start = NULL, end = NULL, min = NULL,
-  max = NULL, format = "yyyy-mm-dd", startview = "month", weekstart = 0,
-  language = "en", separator = " to ", width = NULL, autoclose = TRUE)
+  max = NULL, format = "yyyy-mm-dd", startview = "month",
+  weekstart = 0, language = "en", separator = " to ", width = NULL,
+  autoclose = TRUE)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -124,6 +125,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/debounce.Rd

@@ -5,9 +5,11 @@
 \alias{throttle}
 \title{Slow down a reactive expression with debounce/throttle}
 \usage{
-debounce(r, millis, priority = 100, domain = getDefaultReactiveDomain())
+debounce(r, millis, priority = 100,
+  domain = getDefaultReactiveDomain())
 
-throttle(r, millis, priority = 100, domain = getDefaultReactiveDomain())
+throttle(r, millis, priority = 100,
+  domain = getDefaultReactiveDomain())
 }
 \arguments{
 \item{r}{A reactive expression (that invalidates too often).}

man/diskCache.Rd

@@ -0,0 +1,239 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cache-disk.R
+\name{diskCache}
+\alias{diskCache}
+\title{Create a disk cache object}
+\usage{
+diskCache(dir = NULL, max_size = 10 * 1024^2, max_age = Inf,
+  max_n = Inf, evict = c("lru", "fifo"), destroy_on_finalize = FALSE,
+  missing = key_missing(), exec_missing = FALSE, logfile = NULL)
+}
+\arguments{
+\item{dir}{Directory to store files for the cache. If \code{NULL} (the
+default) it will create and use a temporary directory.}
+
+\item{max_size}{Maximum size of the cache, in bytes. If the cache exceeds
+this size, cached objects will be removed according to the value of the
+\code{evict}. Use \code{Inf} for no size limit.}
+
+\item{max_age}{Maximum age of files in cache before they are evicted, in
+seconds. Use \code{Inf} for no age limit.}
+
+\item{max_n}{Maximum number of objects in the cache. If the number of objects
+exceeds this value, then cached objects will be removed according to the
+value of \code{evict}. Use \code{Inf} for no limit of number of items.}
+
+\item{evict}{The eviction policy to use to decide which objects are removed
+when a cache pruning occurs. Currently, \code{"lru"} and \code{"fifo"} are
+supported.}
+
+\item{destroy_on_finalize}{If \code{TRUE}, then when the DiskCache object is
+garbage collected, the cache directory and all objects inside of it will be
+deleted from disk. If \code{FALSE} (the default), it will do nothing when
+finalized.}
+
+\item{missing}{A value to return or a function to execute when
+\code{get(key)} is called but the key is not present in the cache. The
+default is a \code{\link{key_missing}} object. If it is a function to
+execute, the function must take one argument (the key), and you must also
+use \code{exec_missing = TRUE}. If it is a function, it is useful in most
+cases for it to throw an error, although another option is to return a
+value. If a value is returned, that value will in turn be returned by
+\code{get()}. See section Missing keys for more information.}
+
+\item{exec_missing}{If \code{FALSE} (the default), then treat \code{missing}
+as a value to return when \code{get()} results in a cache miss. If
+\code{TRUE}, treat \code{missing} as a function to execute when
+\code{get()} results in a cache miss.}
+
+\item{logfile}{An optional filename or connection object to where logging
+information will be written. To log to the console, use \code{stdout()}.}
+}
+\description{
+A disk cache object is a key-value store that saves the values as files in a
+directory on disk. Objects can be stored and retrieved using the \code{get()}
+and \code{set()} methods. Objects are automatically pruned from the cache
+according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+and \code{evict}.
+}
+\section{Missing Keys}{
+
+
+  The \code{missing} and \code{exec_missing} parameters controls what happens
+  when \code{get()} is called with a key that is not in the cache (a cache
+  miss). The default behavior is to return a \code{\link{key_missing}}
+  object. This is a \emph{sentinel value} that indicates that the key was not
+  present in the cache. You can test if the returned value represents a
+  missing key by using the \code{\link{is.key_missing}} function. You can
+  also have \code{get()} return a different sentinel value, like \code{NULL}.
+  If you want to throw an error on a cache miss, you can do so by providing a
+  function for \code{missing} that takes one argument, the key, and also use
+  \code{exec_missing=TRUE}.
+
+  When the cache is created, you can supply a value for \code{missing}, which
+  sets the default value to be returned for missing values. It can also be
+  overridden when \code{get()} is called, by supplying a \code{missing}
+  argument. For example, if you use \code{cache$get("mykey", missing =
+  NULL)}, it will return \code{NULL} if the key is not in the cache.
+
+  If your cache is configured so that \code{get()} returns a sentinel value
+  to represent a cache miss, then \code{set} will also not allow you to store
+  the sentinel value in the cache. It will throw an error if you attempt to
+  do so.
+
+  Instead of returning the same sentinel value each time there is cache miss,
+  the cache can execute a function each time \code{get()} encounters missing
+  key. If the function returns a value, then \code{get()} will in turn return
+  that value. However, a more common use is for the function to throw an
+  error. If an error is thrown, then \code{get()} will not return a value.
+
+  To do this, pass a one-argument function to \code{missing}, and use
+  \code{exec_missing=TRUE}. For example, if you want to throw an error that
+  prints the missing key, you could do this:
+
+  \preformatted{
+  diskCache(
+    missing = function(key) {
+      stop("Attempted to get missing key: ", key)
+    },
+    exec_missing = TRUE
+  )
+  }
+
+  If you use this, the code that calls \code{get()} should be wrapped with
+  \code{\link{tryCatch}()} to gracefully handle missing keys.
+}
+
+\section{Cache pruning}{
+
+
+  Cache pruning occurs when \code{set()} is called, or it can be invoked
+  manually by calling \code{prune()}.
+
+  The disk cache will throttle the pruning so that it does not happen on
+  every call to \code{set()}, because the filesystem operations for checking
+  the status of files can be slow. Instead, it will prune once in every 20
+  calls to \code{set()}, or if at least 5 seconds have elapsed since the last
+  prune occurred, whichever is first. These parameters are currently not
+  customizable, but may be in the future.
+
+  When a pruning occurs, if there are any objects that are older than
+  \code{max_age}, they will be removed.
+
+  The \code{max_size} and \code{max_n} parameters are applied to the cache as
+  a whole, in contrast to \code{max_age}, which is applied to each object
+  individually.
+
+  If the number of objects in the cache exceeds \code{max_n}, then objects
+  will be removed from the cache according to the eviction policy, which is
+  set with the \code{evict} parameter. Objects will be removed so that the
+  number of items is \code{max_n}.
+
+  If the size of the objects in the cache exceeds \code{max_size}, then
+  objects will be removed from the cache. Objects will be removed from the
+  cache so that the total size remains under \code{max_size}. Note that the
+  size is calculated using the size of the files, not the size of disk space
+  used by the files -- these two values can differ because of files are
+  stored in blocks on disk. For example, if the block size is 4096 bytes,
+  then a file that is one byte in size will take 4096 bytes on disk.
+
+  Another time that objects can be removed from the cache is when
+  \code{get()} is called. If the target object is older than \code{max_age},
+  it will be removed and the cache will report it as a missing value.
+}
+
+\section{Eviction policies}{
+
+
+If \code{max_n} or \code{max_size} are used, then objects will be removed
+from the cache according to an eviction policy. The available eviction
+policies are:
+
+  \describe{
+    \item{\code{"lru"}}{
+      Least Recently Used. The least recently used objects will be removed.
+      This uses the filesystem's mtime property. When "lru" is used, each
+      \code{get()} is called, it will update the file's mtime.
+    }
+    \item{\code{"fifo"}}{
+      First-in-first-out. The oldest objects will be removed.
+    }
+  }
+
+Both of these policies use files' mtime. Note that some filesystems (notably
+FAT) have poor mtime resolution. (atime is not used because support for
+atime is worse than mtime.)
+}
+
+\section{Sharing among multiple processes}{
+
+
+The directory for a DiskCache can be shared among multiple R processes. To
+do this, each R process should have a DiskCache object that uses the same
+directory. Each DiskCache will do pruning independently of the others, so if
+they have different pruning parameters, then one DiskCache may remove cached
+objects before another DiskCache would do so.
+
+Even though it is possible for multiple processes to share a DiskCache
+directory, this should not be done on networked file systems, because of
+slow performance of networked file systems can cause problems. If you need
+a high-performance shared cache, you can use one built on a database like
+Redis, SQLite, mySQL, or similar.
+
+When multiple processes share a cache directory, there are some potential
+race conditions. For example, if your code calls \code{exists(key)} to check
+if an object is in the cache, and then call \code{get(key)}, the object may
+be removed from the cache in between those two calls, and \code{get(key)}
+will throw an error. Instead of calling the two functions, it is better to
+simply call \code{get(key)}, and use \code{tryCatch()} to handle the error
+that is thrown if the object is not in the cache. This effectively tests for
+existence and gets the object in one operation.
+
+It is also possible for one processes to prune objects at the same time that
+another processes is trying to prune objects. If this happens, you may see
+a warning from \code{file.remove()} failing to remove a file that has
+already been deleted.
+}
+
+\section{Methods}{
+
+
+ A disk cache object has the following methods:
+
+  \describe{
+    \item{\code{get(key, missing, exec_missing)}}{
+      Returns the value associated with \code{key}. If the key is not in the
+      cache, then it returns the value specified by \code{missing} or,
+      \code{missing} is a function and \code{exec_missing=TRUE}, then
+      executes \code{missing}. The function can throw an error or return the
+      value. If either of these parameters are specified here, then they
+      will override the defaults that were set when the DiskCache object was
+      created. See section Missing Keys for more information.
+    }
+    \item{\code{set(key, value)}}{
+      Stores the \code{key}-\code{value} pair in the cache.
+    }
+    \item{\code{exists(key)}}{
+      Returns \code{TRUE} if the cache contains the key, otherwise
+      \code{FALSE}.
+    }
+    \item{\code{size()}}{
+      Returns the number of items currently in the cache.
+    }
+    \item{\code{keys()}}{
+      Returns a character vector of all keys currently in the cache.
+    }
+    \item{\code{reset()}}{
+      Clears all objects from the cache.
+    }
+    \item{\code{destroy()}}{
+      Clears all objects in the cache, and removes the cache directory from
+      disk.
+    }
+    \item{\code{prune()}}{
+      Prunes the cache, using the parameters specified by \code{max_size},
+      \code{max_age}, \code{max_n}, and \code{evict}.
+    }
+  }
+}
+

man/downloadHandler.Rd

@@ -4,7 +4,8 @@
 \alias{downloadHandler}
 \title{File Downloads}
 \usage{
-downloadHandler(filename, content, contentType = NA, outputArgs = list())
+downloadHandler(filename, content, contentType = NA,
+  outputArgs = list())
 }
 \arguments{
 \item{filename}{A string of the filename, including extension, that the

man/fileInput.Rd

@@ -4,8 +4,9 @@
 \alias{fileInput}
 \title{File Upload Control}
 \usage{
-fileInput(inputId, label, multiple = FALSE, accept = NULL, width = NULL,
-  buttonLabel = "Browse...", placeholder = "No file selected")
+fileInput(inputId, label, multiple = FALSE, accept = NULL,
+  width = NULL, buttonLabel = "Browse...",
+  placeholder = "No file selected")
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -97,6 +98,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{passwordInput}}, \code{\link{radioButtons}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/fillPage.Rd

@@ -4,7 +4,8 @@
 \alias{fillPage}
 \title{Create a page that fills the window}
 \usage{
-fillPage(..., padding = 0, title = NULL, bootstrap = TRUE, theme = NULL)
+fillPage(..., padding = 0, title = NULL, bootstrap = TRUE,
+  theme = NULL)
 }
 \arguments{
 \item{...}{Elements to include within the page.}

man/getCurrentOutputInfo.Rd

@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny.R
+\name{getCurrentOutputInfo}
+\alias{getCurrentOutputInfo}
+\title{Get information about the output that is currently being executed.}
+\usage{
+getCurrentOutputInfo(session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{session}{The current Shiny session.}
+}
+\description{
+Get information about the output that is currently being executed.
+}

man/hoverOpts.Rd

@@ -4,8 +4,8 @@
 \alias{hoverOpts}
 \title{Create an object representing hover options}
 \usage{
-hoverOpts(id = NULL, delay = 300, delayType = c("debounce", "throttle"),
-  clip = TRUE, nullOutside = TRUE)
+hoverOpts(id = NULL, delay = 300, delayType = c("debounce",
+  "throttle"), clip = TRUE, nullOutside = TRUE)
 }
 \arguments{
 \item{id}{Input value name. For example, if the value is \code{"plot_hover"},

man/htmlOutput.Rd

@@ -5,11 +5,11 @@
 \alias{uiOutput}
 \title{Create an HTML output element}
 \usage{
-htmlOutput(outputId, inline = FALSE, container = if (inline) span else div,
-  ...)
+htmlOutput(outputId, inline = FALSE, container = if (inline) span else
+  div, ...)
 
-uiOutput(outputId, inline = FALSE, container = if (inline) span else div,
-  ...)
+uiOutput(outputId, inline = FALSE, container = if (inline) span else
+  div, ...)
 }
 \arguments{
 \item{outputId}{output variable to read the value from}

man/installExprFunction.Rd

@@ -4,9 +4,10 @@
 \alias{installExprFunction}
 \title{Install an expression as a function}
 \usage{
-installExprFunction(expr, name, eval.env = parent.frame(2), quoted = FALSE,
-  assign.env = parent.frame(1), label = deparse(sys.call(-1)[[1]]),
-  wrappedWithLabel = TRUE, ..stacktraceon = FALSE)
+installExprFunction(expr, name, eval.env = parent.frame(2),
+  quoted = FALSE, assign.env = parent.frame(1),
+  label = deparse(sys.call(-1)[[1]]), wrappedWithLabel = TRUE,
+  ..stacktraceon = FALSE)
 }
 \arguments{
 \item{expr}{A quoted or unquoted expression}

man/key_missing.Rd

@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cache-utils.R
+\name{key_missing}
+\alias{key_missing}
+\alias{is.key_missing}
+\title{A Key Missing object}
+\usage{
+key_missing()
+
+is.key_missing(x)
+}
+\arguments{
+\item{x}{An object to test.}
+}
+\description{
+A \code{key_missing} object represents a cache miss.
+}
+\seealso{
+\code{\link{diskCache}}, \code{\link{memoryCache}}.
+}

man/memoryCache.Rd

@@ -0,0 +1,199 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cache-memory.R
+\name{memoryCache}
+\alias{memoryCache}
+\title{Create a memory cache object}
+\usage{
+memoryCache(max_size = 10 * 1024^2, max_age = Inf, max_n = Inf,
+  evict = c("lru", "fifo"), missing = key_missing(),
+  exec_missing = FALSE, logfile = NULL)
+}
+\arguments{
+\item{max_size}{Maximum size of the cache, in bytes. If the cache exceeds
+this size, cached objects will be removed according to the value of the
+\code{evict}. Use \code{Inf} for no size limit.}
+
+\item{max_age}{Maximum age of files in cache before they are evicted, in
+seconds. Use \code{Inf} for no age limit.}
+
+\item{max_n}{Maximum number of objects in the cache. If the number of objects
+exceeds this value, then cached objects will be removed according to the
+value of \code{evict}. Use \code{Inf} for no limit of number of items.}
+
+\item{evict}{The eviction policy to use to decide which objects are removed
+when a cache pruning occurs. Currently, \code{"lru"} and \code{"fifo"} are
+supported.}
+
+\item{missing}{A value to return or a function to execute when
+\code{get(key)} is called but the key is not present in the cache. The
+default is a \code{\link{key_missing}} object. If it is a function to
+execute, the function must take one argument (the key), and you must also
+use \code{exec_missing = TRUE}. If it is a function, it is useful in most
+cases for it to throw an error, although another option is to return a
+value. If a value is returned, that value will in turn be returned by
+\code{get()}. See section Missing keys for more information.}
+
+\item{exec_missing}{If \code{FALSE} (the default), then treat \code{missing}
+as a value to return when \code{get()} results in a cache miss. If
+\code{TRUE}, treat \code{missing} as a function to execute when
+\code{get()} results in a cache miss.}
+
+\item{logfile}{An optional filename or connection object to where logging
+information will be written. To log to the console, use \code{stdout()}.}
+}
+\description{
+A memory cache object is a key-value store that saves the values in an
+environment. Objects can be stored and retrieved using the \code{get()} and
+\code{set()} methods. Objects are automatically pruned from the cache
+according to the parameters \code{max_size}, \code{max_age}, \code{max_n},
+and \code{evict}.
+}
+\details{
+In a \code{MemoryCache}, R objects are stored directly in the cache; they are
+not \emph{not} serialized before being stored in the cache. This contrasts
+with other cache types, like \code{\link{diskCache}}, where objects are
+serialized, and the serialized object is cached. This can result in some
+differences of behavior. For example, as long as an object is stored in a
+MemoryCache, it will not be garbage collected.
+}
+\section{Missing keys}{
+
+  The \code{missing} and \code{exec_missing} parameters controls what happens
+  when \code{get()} is called with a key that is not in the cache (a cache
+  miss). The default behavior is to return a \code{\link{key_missing}}
+  object. This is a \emph{sentinel value} that indicates that the key was not
+  present in the cache. You can test if the returned value represents a
+  missing key by using the \code{\link{is.key_missing}} function. You can
+  also have \code{get()} return a different sentinel value, like \code{NULL}.
+  If you want to throw an error on a cache miss, you can do so by providing a
+  function for \code{missing} that takes one argument, the key, and also use
+  \code{exec_missing=TRUE}.
+
+  When the cache is created, you can supply a value for \code{missing}, which
+  sets the default value to be returned for missing values. It can also be
+  overridden when \code{get()} is called, by supplying a \code{missing}
+  argument. For example, if you use \code{cache$get("mykey", missing =
+  NULL)}, it will return \code{NULL} if the key is not in the cache.
+
+  If your cache is configured so that \code{get()} returns a sentinel value
+  to represent a cache miss, then \code{set} will also not allow you to store
+  the sentinel value in the cache. It will throw an error if you attempt to
+  do so.
+
+  Instead of returning the same sentinel value each time there is cache miss,
+  the cache can execute a function each time \code{get()} encounters missing
+  key. If the function returns a value, then \code{get()} will in turn return
+  that value. However, a more common use is for the function to throw an
+  error. If an error is thrown, then \code{get()} will not return a value.
+
+  To do this, pass a one-argument function to \code{missing}, and use
+  \code{exec_missing=TRUE}. For example, if you want to throw an error that
+  prints the missing key, you could do this:
+
+  \preformatted{
+  diskCache(
+    missing = function(key) {
+      stop("Attempted to get missing key: ", key)
+    },
+    exec_missing = TRUE
+  )
+  }
+
+  If you use this, the code that calls \code{get()} should be wrapped with
+  \code{\link{tryCatch}()} to gracefully handle missing keys.
+}
+
+\section{Cache pruning}{
+
+
+  Cache pruning occurs when \code{set()} is called, or it can be invoked
+  manually by calling \code{prune()}.
+
+  When a pruning occurs, if there are any objects that are older than
+  \code{max_age}, they will be removed.
+
+  The \code{max_size} and \code{max_n} parameters are applied to the cache as
+  a whole, in contrast to \code{max_age}, which is applied to each object
+  individually.
+
+  If the number of objects in the cache exceeds \code{max_n}, then objects
+  will be removed from the cache according to the eviction policy, which is
+  set with the \code{evict} parameter. Objects will be removed so that the
+  number of items is \code{max_n}.
+
+  If the size of the objects in the cache exceeds \code{max_size}, then
+  objects will be removed from the cache. Objects will be removed from the
+  cache so that the total size remains under \code{max_size}. Note that the
+  size is calculated using the size of the files, not the size of disk space
+  used by the files -- these two values can differ because of files are
+  stored in blocks on disk. For example, if the block size is 4096 bytes,
+  then a file that is one byte in size will take 4096 bytes on disk.
+
+  Another time that objects can be removed from the cache is when
+  \code{get()} is called. If the target object is older than \code{max_age},
+  it will be removed and the cache will report it as a missing value.
+}
+
+\section{Eviction policies}{
+
+
+If \code{max_n} or \code{max_size} are used, then objects will be removed
+from the cache according to an eviction policy. The available eviction
+policies are:
+
+  \describe{
+    \item{\code{"lru"}}{
+      Least Recently Used. The least recently used objects will be removed.
+      This uses the filesystem's atime property. Some filesystems do not
+      support atime, or have a very low atime resolution. The DiskCache will
+      check for atime support, and if the filesystem does not support atime,
+      a warning will be issued and the "fifo" policy will be used instead.
+    }
+    \item{\code{"fifo"}}{
+      First-in-first-out. The oldest objects will be removed.
+    }
+  }
+}
+
+\section{Methods}{
+
+
+ A disk cache object has the following methods:
+
+  \describe{
+    \item{\code{get(key, missing, exec_missing)}}{
+      Returns the value associated with \code{key}. If the key is not in the
+      cache, then it returns the value specified by \code{missing} or,
+      \code{missing} is a function and \code{exec_missing=TRUE}, then
+      executes \code{missing}. The function can throw an error or return the
+      value. If either of these parameters are specified here, then they
+      will override the defaults that were set when the DiskCache object was
+      created. See section Missing Keys for more information.
+    }
+    \item{\code{set(key, value)}}{
+      Stores the \code{key}-\code{value} pair in the cache.
+    }
+    \item{\code{exists(key)}}{
+      Returns \code{TRUE} if the cache contains the key, otherwise
+      \code{FALSE}.
+    }
+    \item{\code{size()}}{
+      Returns the number of items currently in the cache.
+    }
+    \item{\code{keys()}}{
+      Returns a character vector of all keys currently in the cache.
+    }
+    \item{\code{reset()}}{
+      Clears all objects from the cache.
+    }
+    \item{\code{destroy()}}{
+      Clears all objects in the cache, and removes the cache directory from
+      disk.
+    }
+    \item{\code{prune()}}{
+      Prunes the cache, using the parameters specified by \code{max_size},
+      \code{max_age}, \code{max_n}, and \code{evict}.
+    }
+  }
+}
+

man/navbarPage.Rd

@@ -6,9 +6,10 @@
 \title{Create a page with a top level navigation bar}
 \usage{
 navbarPage(title, ..., id = NULL, selected = NULL,
-  position = c("static-top", "fixed-top", "fixed-bottom"), header = NULL,
-  footer = NULL, inverse = FALSE, collapsible = FALSE, collapsable,
-  fluid = TRUE, responsive = NULL, theme = NULL, windowTitle = title)
+  position = c("static-top", "fixed-top", "fixed-bottom"),
+  header = NULL, footer = NULL, inverse = FALSE,
+  collapsible = FALSE, collapsable, fluid = TRUE, responsive = NULL,
+  theme = NULL, windowTitle = title)
 
 navbarMenu(title, ..., menuName = title, icon = NULL)
 }

man/navlistPanel.Rd

@@ -4,8 +4,8 @@
 \alias{navlistPanel}
 \title{Create a navigation list panel}
 \usage{
-navlistPanel(..., id = NULL, selected = NULL, well = TRUE, fluid = TRUE,
-  widths = c(4, 8))
+navlistPanel(..., id = NULL, selected = NULL, well = TRUE,
+  fluid = TRUE, widths = c(4, 8))
 }
 \arguments{
 \item{...}{\code{\link{tabPanel}} elements to include in the navlist}

man/nearPoints.Rd

@@ -5,8 +5,8 @@
 \title{Find rows of data that are near a click/hover/double-click}
 \usage{
 nearPoints(df, coordinfo, xvar = NULL, yvar = NULL, panelvar1 = NULL,
-  panelvar2 = NULL, threshold = 5, maxpoints = NULL, addDist = FALSE,
-  allRows = FALSE)
+  panelvar2 = NULL, threshold = 5, maxpoints = NULL,
+  addDist = FALSE, allRows = FALSE)
 }
 \arguments{
 \item{df}{A data frame from which to select rows.}

man/numericInput.Rd

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

man/observe.Rd

@@ -5,8 +5,9 @@
 \title{Create a reactive observer}
 \usage{
 observe(x, env = parent.frame(), quoted = FALSE, label = NULL,
-  suspended = FALSE, priority = 0, domain = getDefaultReactiveDomain(),
-  autoDestroy = TRUE, ..stacktraceon = TRUE)
+  suspended = FALSE, priority = 0,
+  domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
+  ..stacktraceon = TRUE)
 }
 \arguments{
 \item{x}{An expression (quoted or unquoted). Any return value will be

man/observeEvent.Rd

@@ -7,13 +7,15 @@
 \usage{
 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, ignoreInit = FALSE, once = FALSE)
+  handler.quoted = FALSE, label = NULL, suspended = FALSE,
+  priority = 0, domain = getDefaultReactiveDomain(),
+  autoDestroy = 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,
+  event.quoted = FALSE, value.env = parent.frame(),
+  value.quoted = FALSE, label = NULL,
+  domain = getDefaultReactiveDomain(), ignoreNULL = TRUE,
   ignoreInit = FALSE)
 }
 \arguments{

man/onStop.Rd

@@ -13,7 +13,9 @@ onStop(fun, session = getDefaultReactiveDomain())
 called from within the server function, this will default to the current
 session, and the callback will be invoked when the current session ends. If
 \code{onStop} is called outside a server function, then the callback will
-be invoked with the application exits.}
+be invoked with the application exits. If \code{NULL}, it is the same as
+calling \code{onStop} outside of the server function, and the callback will
+be invoked when the application exits.}
 }
 \value{
 A function which, if invoked, will cancel the callback.

man/passwordInput.Rd

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

man/plotOutput.Rd

@@ -5,15 +5,15 @@
 \alias{imageOutput}
 \title{Create an plot or image output element}
 \usage{
-imageOutput(outputId, width = "100\%", height = "400px", click = NULL,
-  dblclick = NULL, hover = NULL, hoverDelay = NULL,
-  hoverDelayType = NULL, brush = NULL, clickId = NULL, hoverId = NULL,
-  inline = FALSE)
+imageOutput(outputId, width = "100\%", height = "400px",
+  click = NULL, dblclick = NULL, hover = NULL, hoverDelay = NULL,
+  hoverDelayType = NULL, brush = NULL, clickId = NULL,
+  hoverId = NULL, inline = FALSE)
 
 plotOutput(outputId, width = "100\%", height = "400px", click = NULL,
   dblclick = NULL, hover = NULL, hoverDelay = NULL,
-  hoverDelayType = NULL, brush = NULL, clickId = NULL, hoverId = NULL,
-  inline = FALSE)
+  hoverDelayType = NULL, brush = NULL, clickId = NULL,
+  hoverId = NULL, inline = FALSE)
 }
 \arguments{
 \item{outputId}{output variable to read the plot/image from.}

man/radioButtons.Rd

@@ -5,7 +5,8 @@
 \title{Create radio buttons}
 \usage{
 radioButtons(inputId, label, choices = NULL, selected = NULL,
-  inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL)
+  inline = FALSE, width = NULL, choiceNames = NULL,
+  choiceValues = NULL)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -109,6 +110,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{selectInput}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/renderCachedPlot.Rd

@@ -0,0 +1,316 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/render-cached-plot.R
+\name{renderCachedPlot}
+\alias{renderCachedPlot}
+\title{Plot output with cached images}
+\usage{
+renderCachedPlot(expr, cacheKeyExpr, sizePolicy = sizeGrowthRatio(width =
+  400, height = 400, growthRate = 1.2), res = 72, cache = "app", ...,
+  outputArgs = list())
+}
+\arguments{
+\item{expr}{An expression that generates a plot.}
+
+\item{cacheKeyExpr}{An expression that returns a cache key. This key should
+be a unique identifier for a plot: the assumption is that if the cache key
+is the same, then the plot will be the same.}
+
+\item{sizePolicy}{A function that takes two arguments, \code{width} and
+\code{height}, and returns a list with \code{width} and \code{height}. The
+purpose is to round the actual pixel dimensions from the browser to some
+other dimensions, so that this will not generate and cache images of every
+possible pixel dimension. See \code{\link{sizeGrowthRatio}} for more
+information on the default sizing policy.}
+
+\item{res}{The resolution of the PNG, in pixels per inch.}
+
+\item{cache}{The scope of the cache, or a cache object. This can be
+\code{"app"} (the default), \code{"session"}, or a cache object like
+a \code{\link{diskCache}}. See the Cache Scoping section for more
+information.}
+
+\item{...}{Arguments to be passed through to \code{\link[grDevices]{png}}.
+These can be used to set the width, height, background color, etc.}
+
+\item{outputArgs}{A list of arguments to be passed through to the implicit
+call to \code{\link{plotOutput}} when \code{renderPlot} is used in an
+interactive R Markdown document.}
+}
+\description{
+Renders a reactive plot, with plot images cached to disk.
+}
+\details{
+\code{expr} is an expression that generates a plot, similar to that in
+\code{renderPlot}. Unlike with \code{renderPlot}, this expression does not
+take reactive dependencies. It is re-executed only when the cache key
+changes.
+
+\code{cacheKeyExpr} is an expression which, when evaluated, returns an object
+which will be serialized and hashed using the \code{\link[digest]{digest}}
+function to generate a string that will be used as a cache key. This key is
+used to identify the contents of the plot: if the cache key is the same as a
+previous time, it assumes that the plot is the same and can be retrieved from
+the cache.
+
+This \code{cacheKeyExpr} is reactive, and so it will be re-evaluated when any
+upstream reactives are invalidated. This will also trigger re-execution of
+the plotting expression, \code{expr}.
+
+The key should consist of "normal" R objects, like vectors and lists. Lists
+should in turn contain other normal R objects. If the key contains
+environments, external pointers, or reference objects -- or even if it has
+such objects attached as attributes -- then it is possible that it will
+change unpredictably even when you do not expect it to. Additionally, because
+the entire key is serialized and hashed, if it contains a very large object
+-- a large data set, for example -- there may be a noticeable performance
+penalty.
+
+If you face these issues with the cache key, you can work around them by
+extracting out the important parts of the objects, and/or by converting them
+to normal R objects before returning them. Your expression could even
+serialize and hash that information in an efficient way and return a string,
+which will in turn be hashed (very quickly) by the
+\code{\link[digest]{digest}} function.
+
+Internally, the result from \code{cacheKeyExpr} is combined with the name of
+the output (if you assign it to \code{output$plot1}, it will be combined
+with \code{"plot1"}) to form the actual key that is used. As a result, even
+if there are multiple plots that have the same \code{cacheKeyExpr}, they
+will not have cache key collisions.
+}
+\section{Cache scoping}{
+
+
+  There are a number of different ways you may want to scope the cache. For
+  example, you may want each user session to have their own plot cache, or
+  you may want each run of the application to have a cache (shared among
+  possibly multiple simultaneous user sessions), or you may want to have a
+  cache that persists even after the application is shut down and started
+  again.
+
+  To control the scope of the cache, use the \code{cache} parameter. There
+  are two ways of having Shiny automatically create and clean up the disk
+  cache.
+
+\describe{
+  \item{1}{To scope the cache to one run of a Shiny application (shared
+    among possibly multiple user sessions), use \code{cache="app"}. This
+    is the default. The cache will be shared across multiple sessions, so
+    there is potentially a large performance benefit if there are many users
+    of the application. When the application stops running, the cache will
+    be deleted. If plots cannot be safely shared across users, this should
+    not be used.}
+  \item{2}{To scope the cache to one session, use \code{cache="session"}.
+    When a new user session starts -- in other words, when a web browser
+    visits the Shiny application -- a new cache will be created on disk
+    for that session. When the session ends, the cache will be deleted.
+    The cache will not be shared across multiple sessions.}
+ }
+
+  If either \code{"app"} or \code{"session"} is used, the cache will be 10 MB
+  in size, and will be stored stored in memory, using a
+  \code{\link{memoryCache}} object. Note that the cache space will be shared
+  among all cached plots within a single application or session.
+
+  In some cases, you may want more control over the caching behavior. For
+  example, you may want to use a larger or smaller cache, share a cache
+  among multiple R processes, or you may want the cache to persist across
+  multiple runs of an application, or even across multiple R processes.
+
+  To use different settings for an application-scoped cache, you can call
+  \code{\link{shinyOptions}()} at the top of your app.R, server.R, or
+  global.R. For example, this will create a cache with 20 MB of space
+  instead of the default 10 MB:
+  \preformatted{
+  shinyOptions(cache = memoryCache(size = 20e6))
+  }
+
+  To use different settings for a session-scoped cache, you can call
+  \code{\link{shinyOptions}()} at the top of your server function. To use
+  the session-scoped cache, you must also call \code{renderCachedPlot} with
+  \code{cache="session"}. This will create a 20 MB cache for the session:
+  \preformatted{
+  function(input, output, session) {
+    shinyOptions(cache = memoryCache(size = 20e6))
+
+    output$plot <- renderCachedPlot(
+      ...,
+      cache = "session"
+    )
+  }
+  }
+
+  If you want to create a cache that is shared across multiple concurrent
+  R processes, you can use a \code{\link{diskCache}}. You can create an
+  application-level shared cache by putting this at the top of your app.R,
+  server.R, or global.R:
+  \preformatted{
+  shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+  }
+
+  This will create a subdirectory in your system temp directory named
+  \code{myapp-cache} (replace \code{myapp-cache} with a unique name of
+  your choosing). On most platforms, this directory will be removed when
+  your system reboots. This cache will persist across multiple starts and
+  stops of the R process, as long as you do not reboot.
+
+  To have the cache persist even across multiple reboots, you can create the
+  cache in a location outside of the temp directory. For example, it could
+  be a subdirectory of the application:
+  \preformatted{
+  shinyOptions(cache = diskCache("./myapp-cache"))
+  }
+
+  In this case, resetting the cache will have to be done manually, by deleting
+  the directory.
+
+  You can also scope a cache to just one plot, or selected plots. To do that,
+  create a \code{\link{memoryCache}} or \code{\link{diskCache}}, and pass it
+  as the \code{cache} argument of \code{renderCachedPlot}.
+}
+
+\section{Interactive plots}{
+
+
+  \code{renderCachedPlot} can be used to create interactive plots. See
+  \code{\link{plotOutput}} for more information and examples.
+}
+
+\examples{
+## Only run examples in interactive R sessions
+if (interactive()) {
+
+# A basic example that uses the default app-scoped memory cache.
+# The cache will be shared among all simultaneous users of the application.
+shinyApp(
+  fluidPage(
+    sidebarLayout(
+      sidebarPanel(
+        sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+      ),
+      mainPanel(plotOutput("plot"))
+    )
+  ),
+  function(input, output, session) {
+    output$plot <- renderCachedPlot({
+        Sys.sleep(2)  # Add an artificial delay
+        seqn <- seq_len(input$n)
+        plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+             xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+      },
+      cacheKeyExpr = { list(input$n) }
+    )
+  }
+)
+
+
+
+# An example uses a data object shared across sessions. mydata() is part of
+# the cache key, so when its value changes, plots that were previously
+# stored in the cache will no longer be used (unless mydata() changes back
+# to its previous value).
+mydata <- reactiveVal(data.frame(x = rnorm(400), y = rnorm(400)))
+
+ui <- fluidPage(
+  sidebarLayout(
+    sidebarPanel(
+      sliderInput("n", "Number of points", 50, 400, 100, step = 50),
+      actionButton("newdata", "New data")
+    ),
+    mainPanel(
+      plotOutput("plot")
+    )
+  )
+)
+
+server <- function(input, output, session) {
+  observeEvent(input$newdata, {
+    mydata(data.frame(x = rnorm(400), y = rnorm(400)))
+  })
+
+  output$plot <- renderCachedPlot(
+    {
+      Sys.sleep(2)
+      d <- mydata()
+      seqn <- seq_len(input$n)
+      plot(d$x[seqn], d$y[seqn], xlim = range(d$x), ylim = range(d$y))
+    },
+    cacheKeyExpr = { list(input$n, mydata()) },
+  )
+}
+
+shinyApp(ui, server)
+
+
+# A basic application with two plots, where each plot in each session has
+# a separate cache.
+shinyApp(
+  fluidPage(
+    sidebarLayout(
+      sidebarPanel(
+        sliderInput("n", "Number of points", 4, 32, value = 8, step = 4)
+      ),
+      mainPanel(
+        plotOutput("plot1"),
+        plotOutput("plot2")
+      )
+    )
+  ),
+  function(input, output, session) {
+    output$plot1 <- renderCachedPlot({
+        Sys.sleep(2)  # Add an artificial delay
+        seqn <- seq_len(input$n)
+        plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+             xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+      },
+      cacheKeyExpr = { list(input$n) },
+      cache = memoryCache()
+    )
+    output$plot2 <- renderCachedPlot({
+        Sys.sleep(2)  # Add an artificial delay
+        seqn <- seq_len(input$n)
+        plot(mtcars$wt[seqn], mtcars$mpg[seqn],
+             xlim = range(mtcars$wt), ylim = range(mtcars$mpg))
+      },
+      cacheKeyExpr = { list(input$n) },
+      cache = memoryCache()
+    )
+  }
+)
+
+}
+
+\dontrun{
+# At the top of app.R, this set the application-scoped cache to be a memory
+# cache that is 20 MB in size, and where cached objects expire after one
+# hour.
+shinyOptions(cache = memoryCache(max_size = 20e6, max_age = 3600))
+
+# At the top of app.R, this set the application-scoped cache to be a disk
+# cache that can be shared among multiple concurrent R processes, and is
+# deleted when the system reboots.
+shinyOptions(cache = diskCache(file.path(dirname(tempdir()), "myapp-cache"))
+
+# At the top of app.R, this set the application-scoped cache to be a disk
+# cache that can be shared among multiple concurrent R processes, and
+# persists on disk across reboots.
+shinyOptions(cache = diskCache("./myapp-cache"))
+
+# At the top of the server function, this set the session-scoped cache to be
+# a memory cache that is 5 MB in size.
+server <- function(input, output, session) {
+  shinyOptions(cache = memoryCache(max_size = 5e6))
+
+  output$plot <- renderCachedPlot(
+    ...,
+    cache = "session"
+  )
+}
+
+}
+}
+\seealso{
+See \code{\link{renderPlot}} for the regular, non-cached version of
+  this function. For more about configuring caches, see
+  \code{\link{memoryCache}} and \code{\link{diskCache}}.
+}

man/renderDataTable.Rd

@@ -5,8 +5,8 @@
 \title{Table output with the JavaScript library DataTables}
 \usage{
 renderDataTable(expr, options = NULL, searchDelay = 500,
-  callback = "function(oTable) {}", escape = TRUE, env = parent.frame(),
-  quoted = FALSE, outputArgs = list())
+  callback = "function(oTable) {}", escape = TRUE,
+  env = parent.frame(), quoted = FALSE, outputArgs = list())
 }
 \arguments{
 \item{expr}{An expression that returns a data frame or a matrix.}

man/renderImage.Rd

@@ -4,8 +4,8 @@
 \alias{renderImage}
 \title{Image file output}
 \usage{
-renderImage(expr, env = parent.frame(), quoted = FALSE, deleteFile = TRUE,
-  outputArgs = list())
+renderImage(expr, env = parent.frame(), quoted = FALSE,
+  deleteFile = TRUE, outputArgs = list())
 }
 \arguments{
 \item{expr}{An expression that returns a list.}

man/renderUI.Rd

@@ -4,7 +4,8 @@
 \alias{renderUI}
 \title{UI Output}
 \usage{
-renderUI(expr, env = parent.frame(), quoted = FALSE, outputArgs = list())
+renderUI(expr, env = parent.frame(), quoted = FALSE,
+  outputArgs = list())
 }
 \arguments{
 \item{expr}{An expression that returns a Shiny tag object, \code{\link{HTML}},

man/selectInput.Rd

@@ -98,9 +98,9 @@ shinyApp(
 shinyApp(
   ui = fluidPage(
     selectInput("state", "Choose a state:",
-      list(`East Coast` = c("NY", "NJ", "CT"),
-           `West Coast` = c("WA", "OR", "CA"),
-           `Midwest` = c("MN", "WI", "IA"))
+      list(`East Coast` = list("NY", "NJ", "CT"),
+           `West Coast` = list("WA", "OR", "CA"),
+           `Midwest` = list("MN", "WI", "IA"))
     ),
     textOutput("result")
   ),
@@ -113,7 +113,7 @@ shinyApp(
 }
 }
 \seealso{
-\code{\link{updateSelectInput}}
+\code{\link{updateSelectInput}} \code{\link{varSelectInput}}
 
 Other input elements: \code{\link{actionButton}},
   \code{\link{checkboxGroupInput}},
@@ -122,6 +122,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{sliderInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/shinyApp.Rd

@@ -13,8 +13,8 @@
 \alias{as.tags.shiny.appobj}
 \title{Create a Shiny app object}
 \usage{
-shinyApp(ui = NULL, server = NULL, onStart = NULL, options = list(),
-  uiPattern = "/", enableBookmarking = NULL)
+shinyApp(ui = NULL, server = NULL, onStart = NULL,
+  options = list(), uiPattern = "/", enableBookmarking = NULL)
 
 shinyAppDir(appDir, options = list())
 

man/sizeGrowthRatio.Rd

@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/render-cached-plot.R
+\name{sizeGrowthRatio}
+\alias{sizeGrowthRatio}
+\title{Create a sizing function that grows at a given ratio}
+\usage{
+sizeGrowthRatio(width = 400, height = 400, growthRate = 1.2)
+}
+\arguments{
+\item{width, height}{Base width and height.}
+
+\item{growthRate}{Growth rate multiplier.}
+}
+\description{
+Returns a function which takes a two-element vector representing an input
+width and height, and returns a two-element vector of width and height. The
+possible widths are the base width times the growthRate to any integer power.
+For example, with a base width of 500 and growth rate of 1.25, the possible
+widths include 320, 400, 500, 625, 782, and so on, both smaller and larger.
+Sizes are rounded up to the next pixel. Heights are computed the same way as
+widths.
+}
+\examples{
+f <- sizeGrowthRatio(500, 500, 1.25)
+f(c(400, 400))
+f(c(500, 500))
+f(c(530, 550))
+f(c(625, 700))
+
+}
+\seealso{
+This is to be used with \code{\link{renderCachedPlot}}.
+}

man/sliderInput.Rd

@@ -5,10 +5,11 @@
 \alias{animationOptions}
 \title{Slider Input Widget}
 \usage{
-sliderInput(inputId, label, min, max, value, step = NULL, round = FALSE,
-  format = NULL, locale = NULL, ticks = TRUE, animate = FALSE,
-  width = NULL, sep = ",", pre = NULL, post = NULL, timeFormat = NULL,
-  timezone = NULL, dragRange = TRUE)
+sliderInput(inputId, label, min, max, value, step = NULL,
+  round = FALSE, format = NULL, locale = NULL, ticks = TRUE,
+  animate = FALSE, width = NULL, sep = ",", pre = NULL,
+  post = NULL, timeFormat = NULL, timezone = NULL,
+  dragRange = TRUE)
 
 animationOptions(interval = 1000, loop = FALSE, playButton = NULL,
   pauseButton = NULL)
@@ -125,6 +126,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{submitButton}}, \code{\link{textAreaInput}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/snapshotPreprocessInput.Rd

@@ -4,7 +4,8 @@
 \alias{snapshotPreprocessInput}
 \title{Add a function for preprocessing an input before taking a test snapshot}
 \usage{
-snapshotPreprocessInput(inputId, fun, session = getDefaultReactiveDomain())
+snapshotPreprocessInput(inputId, fun,
+  session = getDefaultReactiveDomain())
 }
 \arguments{
 \item{inputId}{Name of the input value.}

man/submitButton.Rd

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

man/tabsetPanel.Rd

@@ -4,8 +4,8 @@
 \alias{tabsetPanel}
 \title{Create a tabset panel}
 \usage{
-tabsetPanel(..., id = NULL, selected = NULL, type = c("tabs", "pills"),
-  position = NULL)
+tabsetPanel(..., id = NULL, selected = NULL, type = c("tabs",
+  "pills"), position = NULL)
 }
 \arguments{
 \item{...}{\code{\link{tabPanel}} elements to include in the tabset}

man/textAreaInput.Rd

@@ -4,8 +4,9 @@
 \alias{textAreaInput}
 \title{Create a textarea input control}
 \usage{
-textAreaInput(inputId, label, value = "", width = NULL, height = NULL,
-  cols = NULL, rows = NULL, placeholder = NULL, resize = NULL)
+textAreaInput(inputId, label, value = "", width = NULL,
+  height = NULL, cols = NULL, rows = NULL, placeholder = NULL,
+  resize = NULL)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -68,6 +69,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textInput}}
+  \code{\link{textInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/textInput.Rd

@@ -4,7 +4,8 @@
 \alias{textInput}
 \title{Create a text input control}
 \usage{
-textInput(inputId, label, value = "", width = NULL, placeholder = NULL)
+textInput(inputId, label, value = "", width = NULL,
+  placeholder = NULL)
 }
 \arguments{
 \item{inputId}{The \code{input} slot that will be used to access the value.}
@@ -50,6 +51,6 @@ Other input elements: \code{\link{actionButton}},
   \code{\link{numericInput}}, \code{\link{passwordInput}},
   \code{\link{radioButtons}}, \code{\link{selectInput}},
   \code{\link{sliderInput}}, \code{\link{submitButton}},
-  \code{\link{textAreaInput}}
+  \code{\link{textAreaInput}}, \code{\link{varSelectInput}}
 }
 \concept{input elements}

man/textOutput.Rd

@@ -4,7 +4,8 @@
 \alias{textOutput}
 \title{Create a text output element}
 \usage{
-textOutput(outputId, container = if (inline) span else div, inline = FALSE)
+textOutput(outputId, container = if (inline) span else div,
+  inline = FALSE)
 }
 \arguments{
 \item{outputId}{output variable to read the value from}

man/updateCheckboxGroupInput.Rd

@@ -4,9 +4,9 @@
 \alias{updateCheckboxGroupInput}
 \title{Change the value of a checkbox group input on the client}
 \usage{
-updateCheckboxGroupInput(session, inputId, label = NULL, choices = NULL,
-  selected = NULL, inline = FALSE, choiceNames = NULL,
-  choiceValues = NULL)
+updateCheckboxGroupInput(session, inputId, label = NULL,
+  choices = NULL, selected = NULL, inline = FALSE,
+  choiceNames = NULL, choiceValues = NULL)
 }
 \arguments{
 \item{session}{The \code{session} object passed to function given to

man/updateDateInput.Rd

@@ -4,8 +4,8 @@
 \alias{updateDateInput}
 \title{Change the value of a date input on the client}
 \usage{
-updateDateInput(session, inputId, label = NULL, value = NULL, min = NULL,
-  max = NULL)
+updateDateInput(session, inputId, label = NULL, value = NULL,
+  min = NULL, max = NULL)
 }
 \arguments{
 \item{session}{The \code{session} object passed to function given to

man/updateSelectInput.Rd

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

man/updateSliderInput.Rd

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

man/varSelectInput.Rd

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

man/withProgress.Rd

@@ -7,9 +7,10 @@
 \title{Reporting progress (functional API)}
 \usage{
 withProgress(expr, min = 0, max = 1, value = min + (max - min) * 0.1,
-  message = NULL, detail = NULL, style = getShinyOption("progress.style",
-  default = "notification"), session = getDefaultReactiveDomain(),
-  env = parent.frame(), quoted = FALSE)
+  message = NULL, detail = NULL,
+  style = getShinyOption("progress.style", default = "notification"),
+  session = getDefaultReactiveDomain(), env = parent.frame(),
+  quoted = FALSE)
 
 setProgress(value = NULL, message = NULL, detail = NULL,
   session = getDefaultReactiveDomain())

srcjs/input_binding_select.js

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

srcjs/input_binding_slider.js

@@ -6,6 +6,38 @@ function forceIonSliderUpdate(slider) {
     console.log("Couldn't force ion slider to update");
 }
 
+function getTypePrettifyer(dataType, timeFormat, timezone) {
+  var timeFormatter;
+  var prettify;
+  if (dataType === 'date') {
+    timeFormatter = strftime.utc();
+    prettify = function(num) {
+      return timeFormatter(timeFormat, new Date(num));
+    };
+
+  } else if (dataType === 'datetime') {
+    if (timezone)
+      timeFormatter = strftime.timezone(timezone);
+    else
+      timeFormatter = strftime;
+
+    prettify = function(num) {
+      return timeFormatter(timeFormat, new Date(num));
+    };
+
+  } else {
+    // The default prettify function for ion.rangeSlider adds thousands
+    // separators after the decimal mark, so we have our own version here.
+    // (#1958)
+    prettify = function(num) {
+      // When executed, `this` will refer to the `IonRangeSlider.options`
+      // object.
+      return formatNumber(num, this.prettify_separator);
+    };
+  }
+  return prettify;
+}
+
 var sliderInputBinding = {};
 $.extend(sliderInputBinding, textInputBinding, {
   find: function(scope) {
@@ -90,13 +122,31 @@ $.extend(sliderInputBinding, textInputBinding, {
         msg.from = data.value;
       }
     }
-    if (data.hasOwnProperty('min'))  msg.min   = data.min;
-    if (data.hasOwnProperty('max'))  msg.max   = data.max;
-    if (data.hasOwnProperty('step')) msg.step  = data.step;
+    var sliderFeatures = ['min', 'max', 'step'];
+    for (var i = 0; i < sliderFeatures.length; i++) {
+      var feats = sliderFeatures[i];
+      if (data.hasOwnProperty(feats)) {
+        msg[feats] = data[feats];
+      }
+    }
 
     if (data.hasOwnProperty('label'))
       $el.parent().find('label[for="' + $escape(el.id) + '"]').text(data.label);
 
+    var domElements = ['data-type', 'time-format', 'timezone'];
+    for (var i = 0; i < domElements.length; i++) {
+      var elem = domElements[i];
+      if (data.hasOwnProperty(elem)) {
+        $el.data(elem, data[elem]);
+      }
+    }
+
+    var dataType = $el.data('data-type');
+    var timeFormat = $el.data('time-format');
+    var timezone = $el.data('timezone');
+
+    msg.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
+
     $el.data('immediate', true);
     try {
       slider.update(msg);
@@ -118,36 +168,9 @@ $.extend(sliderInputBinding, textInputBinding, {
     var $el = $(el);
     var dataType = $el.data('data-type');
     var timeFormat = $el.data('time-format');
-    var timeFormatter;
+    var timezone = $el.data('timezone');
 
-    // Set up formatting functions
-    if (dataType === 'date') {
-      timeFormatter = strftime.utc();
-      opts.prettify = function(num) {
-        return timeFormatter(timeFormat, new Date(num));
-      };
-
-    } else if (dataType === 'datetime') {
-      var timezone = $el.data('timezone');
-      if (timezone)
-        timeFormatter = strftime.timezone(timezone);
-      else
-        timeFormatter = strftime;
-
-      opts.prettify = function(num) {
-        return timeFormatter(timeFormat, new Date(num));
-      };
-
-    } else {
-      // The default prettify function for ion.rangeSlider adds thousands
-      // separators after the decimal mark, so we have our own version here.
-      // (#1958)
-      opts.prettify = function(num) {
-        // When executed, `this` will refer to the `IonRangeSlider.options`
-        // object.
-        return formatNumber(num, this.prettify_separator);
-      };
-    }
+    opts.prettify = getTypePrettifyer(dataType, timeFormat, timezone);
 
     $el.ionRangeSlider(opts);
   },

srcjs/utils.js

@@ -249,11 +249,17 @@ function mapValues(obj, f) {
   const newObj = {};
   for (let key in obj) {
     if (obj.hasOwnProperty(key))
-      newObj[key] = f(obj[key]);
+      newObj[key] = f(obj[key], key, obj);
   }
   return newObj;
 }
 
+// This is does the same as Number.isNaN, but that function unfortunately does
+// not exist in any version of IE.
+function isnan(x) {
+  return typeof(x) === 'number' && isNaN(x);
+}
+
 // Binary equality function used by the equal function.
 function _equal(x, y) {
   if ($.type(x) === "object" && $.type(y) === "object") {

tests/testthat/test-cache.R

@@ -0,0 +1,84 @@
+context("Cache")
+
+test_that("DiskCache: handling missing values", {
+  d <- diskCache()
+  expect_true(is.key_missing(d$get("abcd")))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = NULL), NULL)
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key: ", key), exec_missing = TRUE),
+    "^Missing key: y$",
+  )
+
+  d <- diskCache(missing = NULL)
+  expect_true(is.null(d$get("abcd")))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = -1), -1)
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key: ", key), exec_missing = TRUE),
+    "^Missing key: y$",
+  )
+
+
+  d <- diskCache(missing = function(key) stop("Missing key: ", key), exec_missing = TRUE)
+  expect_error(d$get("abcd"), "^Missing key: abcd$")
+  # When exec_missing=TRUE, should be able to set a value that's identical to
+  # missing. Need to suppress warnings, because it will warn about reference
+  # object (the environment captured by the function)
+  d$set("x", NULL)
+  suppressWarnings(d$set("x", function(key) stop("Missing key: ", key)))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = NULL, exec_missing = FALSE), NULL)
+  expect_true(is.key_missing(d$get("y", missing = key_missing(), exec_missing = FALSE)))
+  expect_identical(d$get("y", exec_missing = FALSE), function(key) stop("Missing key: ", key))
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key 2: ", key), exec_missing = TRUE),
+    "^Missing key 2: y$",
+  )
+
+  # Can't use exec_missing when missing is not a function
+  expect_error(diskCache(missing = 1, exec_missing = TRUE))
+})
+
+test_that("MemoryCache: handling missing values", {
+  d <- memoryCache()
+  expect_true(is.key_missing(d$get("abcd")))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = NULL), NULL)
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key: ", key), exec_missing = TRUE),
+    "^Missing key: y$",
+  )
+
+  d <- memoryCache(missing = NULL)
+  expect_true(is.null(d$get("abcd")))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = -1), -1)
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key: ", key), exec_missing = TRUE),
+    "^Missing key: y$",
+  )
+
+  d <- memoryCache(missing = function(key) stop("Missing key: ", key), exec_missing = TRUE)
+  expect_error(d$get("abcd"), "^Missing key: abcd$")
+  # When exec_missing==TRUE, should be able to set a value that's identical to
+  # missing.
+  d$set("x", NULL)
+  d$set("x", function(key) stop("Missing key: ", key))
+  d$set("a", 100)
+  expect_identical(d$get("a"), 100)
+  expect_identical(d$get("y", missing = NULL, exec_missing = FALSE), NULL)
+  expect_true(is.key_missing(d$get("y", missing = key_missing(), exec_missing = FALSE)))
+  expect_error(
+    d$get("y", missing = function(key) stop("Missing key 2: ", key), exec_missing = TRUE),
+    "^Missing key 2: y$",
+  )
+
+  # Can't create a cache with both missing and missing_f
+  expect_error(memoryCache(missing = 1, exec_missing = TRUE))
+})

tests/testthat/test-input-handler.R

@@ -48,3 +48,34 @@ test_that("Nulls are not converted to NAs in parsing", {
     list(method="init", data=list(obs=500L, nullObs=NULL))
   )
 })
+
+
+test_that("characters turn into symbols", {
+  handler <- inputHandlers$get("shiny.symbol")
+  x <- "mpg"
+  expect_identical(
+    handler(x),
+    as.symbol(x)
+  )
+  expect_identical(
+    handler(NULL),
+    NULL
+  )
+})
+test_that("character vectors turn into symbol lists", {
+  handler <- inputHandlers$get("shiny.symbolList")
+  x <- list("mpg")
+  expect_identical(
+    handler(x),
+    list(as.symbol(x[[1]]))
+  )
+  x <- list("mpg", "cyl", "disp")
+  expect_identical(
+    handler(x),
+    list(as.symbol(x[[1]]), as.symbol(x[[2]]), as.symbol(x[[3]]))
+  )
+  expect_identical(
+    handler(NULL),
+    list()
+  )
+})

tests/testthat/test-js-version.R

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

tests/testthat/test-plot-coordmap.R

@@ -21,50 +21,52 @@ test_that("ggplot coordmap", {
     scale_x_continuous(expand = c(0, 0)) +
     scale_y_continuous(expand = c(0, 0))
   png(tmpfile, width = 500, height = 500)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 500, 72)
   dev.off()
 
+  expect_equal(m$dims, list(width = 500, height = 500))
+
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar"))
+  expect_equal(m$panels[[1]]$mapping, list(x = "xvar", y = "yvar"))
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=5, bottom=10, top=20))
   )
   # Check for no log bases
   expect_equal(
-    sortList(m[[1]]$log),
+    sortList(m$panels[[1]]$log),
     sortList(list(x=NULL, y=NULL))
   )
   # panel_vars should be an empty named list
-  expect_identical(m[[1]]$panel_vars, list(a=1)[0])
+  expect_identical(m$panels[[1]]$panel_vars, list(a=1)[0])
   # Sanity check for ranges. Checking exact range values isn't feasible due to
   # variations in graphics devices, and possible changes to positioning in
   # ggplot2.
-  expect_true(m[[1]]$range$left    >  20 && m[[1]]$range$left   <  70)
-  expect_true(m[[1]]$range$right   > 480 && m[[1]]$range$right  < 499)
-  expect_true(m[[1]]$range$bottom  > 450 && m[[1]]$range$bottom < 490)
-  expect_true(m[[1]]$range$top     > 1   && m[[1]]$range$top    <  20)
+  expect_true(m$panels[[1]]$range$left    >  20 && m$panels[[1]]$range$left   <  70)
+  expect_true(m$panels[[1]]$range$right   > 480 && m$panels[[1]]$range$right  < 499)
+  expect_true(m$panels[[1]]$range$bottom  > 450 && m$panels[[1]]$range$bottom < 490)
+  expect_true(m$panels[[1]]$range$top     > 1   && m$panels[[1]]$range$top    <  20)
 
 
   # Scatterplot where aes() is declared in geom
   p <- ggplot(dat, aes(xvar)) + geom_point(aes(y=yvar))
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 500, 72)
   dev.off()
 
   # Check mapping vars
-  expect_equal(sortList(m[[1]]$mapping), list(x = "xvar", y = "yvar"))
+  expect_equal(sortList(m$panels[[1]]$mapping), list(x = "xvar", y = "yvar"))
 
 
   # Plot with an expression in aes, and a computed variable (histogram)
   p <- ggplot(dat, aes(xvar/2)) + geom_histogram(binwidth=1)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 500, 72)
   dev.off()
 
   # Check mapping vars - no value for y
-  expect_equal(sortList(m[[1]]$mapping), list(x = "xvar/2", y = NULL))
+  expect_equal(sortList(m$panels[[1]]$mapping), list(x = "xvar/2", y = NULL))
 })
 
 
@@ -81,38 +83,38 @@ test_that("ggplot coordmap with facet_wrap", {
     scale_y_continuous(expand = c(0, 0)) +
     facet_wrap(~ g, ncol = 2)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Should have 3 panels
-  expect_equal(length(m), 3)
-  expect_equal(m[[1]]$panel, 1)
-  expect_equal(m[[1]]$row, 1)
-  expect_equal(m[[1]]$col, 1)
-  expect_equal(m[[2]]$panel, 2)
-  expect_equal(m[[2]]$row, 1)
-  expect_equal(m[[2]]$col, 2)
-  expect_equal(m[[3]]$panel, 3)
-  expect_equal(m[[3]]$row, 2)
-  expect_equal(m[[3]]$col, 1)
+  expect_equal(length(m$panels), 3)
+  expect_equal(m$panels[[1]]$panel, 1)
+  expect_equal(m$panels[[1]]$row, 1)
+  expect_equal(m$panels[[1]]$col, 1)
+  expect_equal(m$panels[[2]]$panel, 2)
+  expect_equal(m$panels[[2]]$row, 1)
+  expect_equal(m$panels[[2]]$col, 2)
+  expect_equal(m$panels[[3]]$panel, 3)
+  expect_equal(m$panels[[3]]$row, 2)
+  expect_equal(m$panels[[3]]$col, 1)
 
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
-  expect_equal(m[[1]]$mapping, m[[2]]$mapping)
-  expect_equal(m[[2]]$mapping, m[[3]]$mapping)
+  expect_equal(m$panels[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
+  expect_equal(m$panels[[1]]$mapping, m$panels[[2]]$mapping)
+  expect_equal(m$panels[[2]]$mapping, m$panels[[3]]$mapping)
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=10, bottom=10, top=30))
   )
-  expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
-  expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
+  expect_equal(sortList(m$panels[[1]]$domain), sortList(m$panels[[2]]$domain))
+  expect_equal(sortList(m$panels[[2]]$domain), sortList(m$panels[[3]]$domain))
 
   # Check panel vars
   factor_vals <- dat$g
-  expect_equal(m[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
-  expect_equal(m[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
-  expect_equal(m[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
+  expect_equal(m$panels[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
+  expect_equal(m$panels[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
+  expect_equal(m$panels[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
 })
 
 
@@ -130,75 +132,75 @@ test_that("ggplot coordmap with facet_grid", {
   # facet_grid horizontal
   p1 <- p + facet_grid(. ~ g)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(print(p1), 500, 400, 72)
   dev.off()
 
   # Should have 3 panels
-  expect_equal(length(m), 3)
-  expect_equal(m[[1]]$panel, 1)
-  expect_equal(m[[1]]$row, 1)
-  expect_equal(m[[1]]$col, 1)
-  expect_equal(m[[2]]$panel, 2)
-  expect_equal(m[[2]]$row, 1)
-  expect_equal(m[[2]]$col, 2)
-  expect_equal(m[[3]]$panel, 3)
-  expect_equal(m[[3]]$row, 1)
-  expect_equal(m[[3]]$col, 3)
+  expect_equal(length(m$panels), 3)
+  expect_equal(m$panels[[1]]$panel, 1)
+  expect_equal(m$panels[[1]]$row, 1)
+  expect_equal(m$panels[[1]]$col, 1)
+  expect_equal(m$panels[[2]]$panel, 2)
+  expect_equal(m$panels[[2]]$row, 1)
+  expect_equal(m$panels[[2]]$col, 2)
+  expect_equal(m$panels[[3]]$panel, 3)
+  expect_equal(m$panels[[3]]$row, 1)
+  expect_equal(m$panels[[3]]$col, 3)
 
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
-  expect_equal(m[[1]]$mapping, m[[2]]$mapping)
-  expect_equal(m[[2]]$mapping, m[[3]]$mapping)
+  expect_equal(m$panels[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
+  expect_equal(m$panels[[1]]$mapping, m$panels[[2]]$mapping)
+  expect_equal(m$panels[[2]]$mapping, m$panels[[3]]$mapping)
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=10, bottom=10, top=30))
   )
-  expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
-  expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
+  expect_equal(sortList(m$panels[[1]]$domain), sortList(m$panels[[2]]$domain))
+  expect_equal(sortList(m$panels[[2]]$domain), sortList(m$panels[[3]]$domain))
 
   # Check panel vars
   factor_vals <- dat$g
-  expect_equal(m[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
-  expect_equal(m[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
-  expect_equal(m[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
+  expect_equal(m$panels[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
+  expect_equal(m$panels[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
+  expect_equal(m$panels[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
 
 
   # facet_grid vertical
   p1 <- p + facet_grid(g ~ .)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(print(p1), 500, 400, 72)
   dev.off()
 
   # Should have 3 panels
-  expect_equal(length(m), 3)
-  expect_equal(m[[1]]$panel, 1)
-  expect_equal(m[[1]]$row, 1)
-  expect_equal(m[[1]]$col, 1)
-  expect_equal(m[[2]]$panel, 2)
-  expect_equal(m[[2]]$row, 2)
-  expect_equal(m[[2]]$col, 1)
-  expect_equal(m[[3]]$panel, 3)
-  expect_equal(m[[3]]$row, 3)
-  expect_equal(m[[3]]$col, 1)
+  expect_equal(length(m$panels), 3)
+  expect_equal(m$panels[[1]]$panel, 1)
+  expect_equal(m$panels[[1]]$row, 1)
+  expect_equal(m$panels[[1]]$col, 1)
+  expect_equal(m$panels[[2]]$panel, 2)
+  expect_equal(m$panels[[2]]$row, 2)
+  expect_equal(m$panels[[2]]$col, 1)
+  expect_equal(m$panels[[3]]$panel, 3)
+  expect_equal(m$panels[[3]]$row, 3)
+  expect_equal(m$panels[[3]]$col, 1)
 
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
-  expect_equal(m[[1]]$mapping, m[[2]]$mapping)
-  expect_equal(m[[2]]$mapping, m[[3]]$mapping)
+  expect_equal(m$panels[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "g"))
+  expect_equal(m$panels[[1]]$mapping, m$panels[[2]]$mapping)
+  expect_equal(m$panels[[2]]$mapping, m$panels[[3]]$mapping)
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=10, bottom=10, top=30))
   )
-  expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
-  expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
+  expect_equal(sortList(m$panels[[1]]$domain), sortList(m$panels[[2]]$domain))
+  expect_equal(sortList(m$panels[[2]]$domain), sortList(m$panels[[3]]$domain))
 
   # Check panel vars
   factor_vals <- dat$g
-  expect_equal(m[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
-  expect_equal(m[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
-  expect_equal(m[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
+  expect_equal(m$panels[[1]]$panel_vars, list(panelvar1 = factor_vals[1]))
+  expect_equal(m$panels[[2]]$panel_vars, list(panelvar1 = factor_vals[2]))
+  expect_equal(m$panels[[3]]$panel_vars, list(panelvar1 = factor_vals[3]))
 })
 
 
@@ -215,43 +217,43 @@ test_that("ggplot coordmap with 2D facet_grid", {
 
   p1 <- p + facet_grid(g ~ h)
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p1), 1, 72)
+  m <- getGgplotCoordmap(print(p1), 500, 400, 72)
   dev.off()
 
   # Should have 4 panels
-  expect_equal(length(m), 4)
-  expect_equal(m[[1]]$panel, 1)
-  expect_equal(m[[1]]$row, 1)
-  expect_equal(m[[1]]$col, 1)
-  expect_equal(m[[2]]$panel, 2)
-  expect_equal(m[[2]]$row, 1)
-  expect_equal(m[[2]]$col, 2)
-  expect_equal(m[[3]]$panel, 3)
-  expect_equal(m[[3]]$row, 2)
-  expect_equal(m[[3]]$col, 1)
-  expect_equal(m[[4]]$panel, 4)
-  expect_equal(m[[4]]$row, 2)
-  expect_equal(m[[4]]$col, 2)
+  expect_equal(length(m$panels), 4)
+  expect_equal(m$panels[[1]]$panel, 1)
+  expect_equal(m$panels[[1]]$row, 1)
+  expect_equal(m$panels[[1]]$col, 1)
+  expect_equal(m$panels[[2]]$panel, 2)
+  expect_equal(m$panels[[2]]$row, 1)
+  expect_equal(m$panels[[2]]$col, 2)
+  expect_equal(m$panels[[3]]$panel, 3)
+  expect_equal(m$panels[[3]]$row, 2)
+  expect_equal(m$panels[[3]]$col, 1)
+  expect_equal(m$panels[[4]]$panel, 4)
+  expect_equal(m$panels[[4]]$row, 2)
+  expect_equal(m$panels[[4]]$col, 2)
 
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "h", panelvar2 = "g"))
-  expect_equal(m[[1]]$mapping, m[[2]]$mapping)
-  expect_equal(m[[2]]$mapping, m[[3]]$mapping)
-  expect_equal(m[[4]]$mapping, m[[4]]$mapping)
+  expect_equal(m$panels[[1]]$mapping, list(x = "xvar", y = "yvar", panelvar1 = "h", panelvar2 = "g"))
+  expect_equal(m$panels[[1]]$mapping, m$panels[[2]]$mapping)
+  expect_equal(m$panels[[2]]$mapping, m$panels[[3]]$mapping)
+  expect_equal(m$panels[[4]]$mapping, m$panels[[4]]$mapping)
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=15, bottom=10, top=40))
   )
-  expect_equal(sortList(m[[1]]$domain), sortList(m[[2]]$domain))
-  expect_equal(sortList(m[[2]]$domain), sortList(m[[3]]$domain))
-  expect_equal(sortList(m[[3]]$domain), sortList(m[[4]]$domain))
+  expect_equal(sortList(m$panels[[1]]$domain), sortList(m$panels[[2]]$domain))
+  expect_equal(sortList(m$panels[[2]]$domain), sortList(m$panels[[3]]$domain))
+  expect_equal(sortList(m$panels[[3]]$domain), sortList(m$panels[[4]]$domain))
 
   # Check panel vars
-  expect_equal(m[[1]]$panel_vars, list(panelvar1 = dat$h[1], panelvar2 = dat$g[1]))
-  expect_equal(m[[2]]$panel_vars, list(panelvar1 = dat$h[2], panelvar2 = dat$g[1]))
-  expect_equal(m[[3]]$panel_vars, list(panelvar1 = dat$h[1], panelvar2 = dat$g[2]))
-  expect_equal(m[[4]]$panel_vars, list(panelvar1 = dat$h[2], panelvar2 = dat$g[2]))
+  expect_equal(m$panels[[1]]$panel_vars, list(panelvar1 = dat$h[1], panelvar2 = dat$g[1]))
+  expect_equal(m$panels[[2]]$panel_vars, list(panelvar1 = dat$h[2], panelvar2 = dat$g[1]))
+  expect_equal(m$panels[[3]]$panel_vars, list(panelvar1 = dat$h[1], panelvar2 = dat$g[2]))
+  expect_equal(m$panels[[4]]$panel_vars, list(panelvar1 = dat$h[2], panelvar2 = dat$g[2]))
 })
 
 
@@ -265,12 +267,12 @@ test_that("ggplot coordmap with various data types", {
     scale_x_discrete(expand = c(0 ,0)) +
     scale_y_discrete(expand = c(0, 0))
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=1, right=3, bottom=1, top=4))
   )
 
@@ -283,12 +285,12 @@ test_that("ggplot coordmap with various data types", {
     scale_x_date(expand = c(0 ,0)) +
     scale_y_datetime(expand = c(0, 0))
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Check domain
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(
       left   = as.numeric(dat$xvar[1]),
       right  = as.numeric(dat$xvar[2]),
@@ -308,12 +310,12 @@ test_that("ggplot coordmap with various scales and coords", {
     scale_x_continuous(expand = c(0 ,0)) +
     scale_y_reverse(expand = c(0, 0))
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Check domain (y reversed)
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=0, right=5, bottom=20, top=10))
   )
 
@@ -323,14 +325,14 @@ test_that("ggplot coordmap with various scales and coords", {
     scale_y_continuous(expand = c(0 ,0)) +
     coord_flip()
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Check mapping vars
-  expect_equal(m[[1]]$mapping, list(x = "yvar", y = "xvar"))
+  expect_equal(m$panels[[1]]$mapping, list(x = "yvar", y = "xvar"))
   # Check domain (y reversed)
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=10, right=20, bottom=0, top=5))
   )
 
@@ -341,17 +343,17 @@ test_that("ggplot coordmap with various scales and coords", {
     scale_y_continuous(expand = c(0, 0)) +
     coord_trans(y = "log2")
   png(tmpfile)
-  m <- getGgplotCoordmap(print(p), 1, 72)
+  m <- getGgplotCoordmap(print(p), 500, 400, 72)
   dev.off()
 
   # Check log bases
   expect_equal(
-    sortList(m[[1]]$log),
+    sortList(m$panels[[1]]$log),
     sortList(list(x=10, y=2))
   )
   # Check domains
   expect_equal(
-    sortList(m[[1]]$domain),
+    sortList(m$panels[[1]]$domain),
     sortList(list(left=-1, right=3, bottom=-2, top=4))
   )
 })

tests/testthat/test-ui.R

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

tools/Gruntfile.js

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