Do equivalent of "mkdir -p" when making state dir

DESCRIPTION

@@ -132,8 +132,12 @@ Collate:
     'render-plot.R'
     'render-table.R'
     'run-url.R'
+    'save-state-local.R'
+    'save-state.R'
+    'serializers.R'
     'server-input-handlers.R'
     'server.R'
+    'shiny-options.R'
     'shiny.R'
     'shinyui.R'
     'shinywrappers.R'

NAMESPACE

@@ -55,6 +55,7 @@ export(code)
 export(column)
 export(conditionStackTrace)
 export(conditionalPanel)
+export(configureBookmarking)
 export(createWebDependency)
 export(dataTableOutput)
 export(dateInput)
@@ -81,6 +82,7 @@ export(fluidPage)
 export(fluidRow)
 export(formatStackTrace)
 export(getDefaultReactiveDomain)
+export(getShinyOption)
 export(h1)
 export(h2)
 export(h3)
@@ -106,6 +108,7 @@ export(inputPanel)
 export(insertUI)
 export(installExprFunction)
 export(invalidateLater)
+export(invalidateReactiveValue)
 export(is.reactive)
 export(is.reactivevalues)
 export(is.shiny.appobj)
@@ -170,6 +173,7 @@ export(renderText)
 export(renderUI)
 export(repeatable)
 export(req)
+export(restoreInput)
 export(runApp)
 export(runExample)
 export(runGadget)
@@ -177,6 +181,7 @@ export(runGist)
 export(runGitHub)
 export(runUrl)
 export(safeError)
+export(saveStateButton)
 export(selectInput)
 export(selectizeInput)
 export(serverInfo)
@@ -184,6 +189,7 @@ export(setProgress)
 export(shinyApp)
 export(shinyAppDir)
 export(shinyAppFile)
+export(shinyOptions)
 export(shinyServer)
 export(shinyUI)
 export(showModal)
@@ -218,6 +224,7 @@ export(updateCheckboxGroupInput)
 export(updateCheckboxInput)
 export(updateDateInput)
 export(updateDateRangeInput)
+export(updateLocationBar)
 export(updateNavbarPage)
 export(updateNavlistPanel)
 export(updateNumericInput)
@@ -227,6 +234,7 @@ export(updateSelectizeInput)
 export(updateSliderInput)
 export(updateTabsetPanel)
 export(updateTextInput)
+export(urlModal)
 export(validate)
 export(validateCssUnit)
 export(verbatimTextOutput)

R/app.R

@@ -99,6 +99,10 @@ shinyAppDir <- function(appDir, options=list()) {
   # affected by future changes to the path)
   appDir <- normalizePath(appDir, mustWork = TRUE)
 
+  # Store appDir in options so that we can find out where we are from within the
+  # app.
+  shinyOptions(appDir = appDir)
+
   if (file.exists.ci(appDir, "server.R")) {
     shinyAppDir_serverR(appDir, options = options)
   } else if (file.exists.ci(appDir, "app.R")) {
@@ -113,7 +117,12 @@ shinyAppDir <- function(appDir, options=list()) {
 #' @export
 shinyAppFile <- function(appFile, options=list()) {
   appFile <- normalizePath(appFile, mustWork = TRUE)
-  shinyAppDir_appR(basename(appFile), dirname(appFile), options = options)
+  appDir <- dirname(appFile)
+
+  # Store appDir in options so that we can find out where we are
+  shinyOptions(appDir = appDir)
+
+  shinyAppDir_appR(basename(appFile), appDir, options = options)
 }
 
 # This reads in an app dir in the case that there's a server.R (and ui.R/www)

R/input-checkbox.R

@@ -24,6 +24,9 @@
 #' }
 #' @export
 checkboxInput <- function(inputId, label, value = FALSE, width = NULL) {
+
+  value <- restoreInput(id = inputId, default = value)
+
   inputTag <- tags$input(id = inputId, type="checkbox")
   if (!is.null(value) && value)
     inputTag$attribs$checked <- "checked"

R/input-checkboxgroup.R

@@ -38,6 +38,8 @@
 checkboxGroupInput <- function(inputId, label, choices, selected = NULL,
   inline = FALSE, width = NULL) {
 
+  selected <- restoreInput(id = inputId, default = selected)
+
   # resolve names
   choices <- choicesWithNames(choices)
   if (!is.null(selected))

R/input-date.R

@@ -81,6 +81,8 @@ dateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
+  value <- restoreInput(id = inputId, default = value)
+
   attachDependencies(
     tags$div(id = inputId,
       class = "shiny-date-input form-group shiny-input-container",

R/input-daterange.R

@@ -82,6 +82,10 @@ dateRangeInput <- function(inputId, label, start = NULL, end = NULL,
   if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
   if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")
 
+  restored <- restoreInput(id = inputId, default = list(start, end))
+  start <- restored[[1]]
+  end <- restored[[2]]
+
   attachDependencies(
     div(id = inputId,
       class = "shiny-date-range-input form-group shiny-input-container",

R/input-file.R

@@ -72,16 +72,48 @@
 fileInput <- function(inputId, label, multiple = FALSE, accept = NULL,
   width = NULL) {
 
-  inputTag <- tags$input(id = inputId, name = inputId, type = "file")
+  restoredValue <- restoreInput(id = inputId, default = NULL)
+
+  # Catch potential edge case - ensure that it's either NULL or a data frame.
+  if (!is.null(restoredValue) && !is.data.frame(restoredValue)) {
+    warning("Restored value for ", inputId, " has incorrect format.")
+    restoredValue <- NULL
+  }
+
+  if (!is.null(restoredValue)) {
+    restoredValue <- toJSON(restoredValue, strict_atomic = FALSE)
+  }
+
+  inputTag <- tags$input(
+    id = inputId,
+    name = inputId,
+    type = "file",
+    style = "display: none;",
+    `data-restore` = restoredValue
+  )
+
   if (multiple)
     inputTag$attribs$multiple <- "multiple"
   if (length(accept) > 0)
     inputTag$attribs$accept <- paste(accept, collapse=',')
 
+
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label),
-    inputTag,
+
+    div(class = "input-group",
+      tags$label(class = "input-group-btn",
+        span(class = "btn btn-default btn-file",
+          "Browse...",
+          inputTag
+        )
+      ),
+      tags$input(type = "text", class = "form-control",
+        placeholder = "No file selected", readonly = "readonly"
+      )
+    ),
+
     tags$div(
       id=paste(inputId, "_progress", sep=""),
       class="progress progress-striped active shiny-file-input-progress",

R/input-numeric.R

@@ -1,4 +1,3 @@
-
 #' Create a numeric input control
 #'
 #' Create an input control for entry of numeric values
@@ -29,6 +28,8 @@
 numericInput <- function(inputId, label, value, min = NA, max = NA, step = NA,
   width = NULL) {
 
+  value <- restoreInput(id = inputId, default = value)
+
   # build input tag
   inputTag <- tags$input(id = inputId, type = "number", class="form-control",
                          value = formatNoSci(value))

R/input-radiobuttons.R

@@ -55,6 +55,8 @@ radioButtons <- function(inputId, label, choices, selected = NULL,
   # resolve names
   choices <- choicesWithNames(choices)
 
+  selected <- restoreInput(id = inputId, default = selected)
+
   # default value if it's not specified
   selected <- if (is.null(selected)) choices[[1]] else {
     validateSelected(selected, choices, inputId)

R/input-select.R

@@ -54,6 +54,9 @@
 selectInput <- function(inputId, label, choices, selected = NULL,
                         multiple = FALSE, selectize = TRUE, width = NULL,
                         size = NULL) {
+
+  selected <- restoreInput(id = inputId, default = selected)
+
   # resolve names
   choices <- choicesWithNames(choices)
 

R/input-slider.R

@@ -85,6 +85,8 @@ sliderInput <- function(inputId, label, min, max, value, step = NULL,
                     version = "0.10.2.2")
   }
 
+  value <- restoreInput(id = inputId, default = value)
+
   # If step is NULL, use heuristic to set the step size.
   findStepSize <- function(min, max, step) {
     if (!is.null(step)) return(step)

R/input-text.R

@@ -32,6 +32,8 @@
 textInput <- function(inputId, label, value = "", width = NULL,
   placeholder = NULL) {
 
+  value <- restoreInput(id = inputId, default = value)
+
   div(class = "form-group shiny-input-container",
     style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),
     label %AND% tags$label(label, `for` = inputId),

R/notifications.R

@@ -75,7 +75,7 @@ showNotification <- function(ui, action = NULL, duration = 5,
 {
 
   if (is.null(id))
-    id <- randomID()
+    id <- createUniqueId(8)
 
   res <- processDeps(ui, session)
   actionRes <- processDeps(action, session)

R/progress.R

@@ -94,7 +94,7 @@ Progress <- R6Class(
         stop("'session' is not a ShinySession object.")
 
       private$session <- session
-      private$id <- randomID()
+      private$id <- createUniqueId(8)
       private$min <- min
       private$max <- max
       private$value <- NULL

R/reactives.R

@@ -47,6 +47,7 @@ ReactiveValues <- R6Class(
     # For debug purposes
     .label = character(0),
     .values = 'environment',
+    .metadata = 'environment',
     .dependents = 'environment',
     # Dependents for the list of all names, including hidden
     .namesDeps = 'Dependents',
@@ -60,32 +61,40 @@ ReactiveValues <- R6Class(
                        p_randomInt(1000, 10000),
                        sep="")
       .values <<- new.env(parent=emptyenv())
+      .metadata <<- new.env(parent=emptyenv())
       .dependents <<- new.env(parent=emptyenv())
       .namesDeps <<- Dependents$new()
       .allValuesDeps <<- Dependents$new()
       .valuesDeps <<- Dependents$new()
     },
+
     get = function(key) {
+      # Register the "downstream" reactive which is accessing this value, so
+      # that we know to invalidate them when this value changes.
       ctx <- .getReactiveEnvironment()$currentContext()
       dep.key <- paste(key, ':', ctx$id, sep='')
-      if (!exists(dep.key, where=.dependents, inherits=FALSE)) {
+      if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
         .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
-        assign(dep.key, ctx, pos=.dependents, inherits=FALSE)
+        .dependents[[dep.key]] <- ctx
         ctx$onInvalidate(function() {
-          rm(list=dep.key, pos=.dependents, inherits=FALSE)
+          rm(list=dep.key, envir=.dependents, inherits=FALSE)
         })
       }
 
-      if (!exists(key, where=.values, inherits=FALSE))
+      if (isInvalid(key))
+        stopWithCondition(c("validation", "shiny.silent.error"), "")
+
+      if (!exists(key, envir=.values, inherits=FALSE))
         NULL
       else
-        base::get(key, pos=.values, inherits=FALSE)
+        .values[[key]]
     },
+
     set = function(key, value) {
       hidden <- substr(key, 1, 1) == "."
 
-      if (exists(key, where=.values, inherits=FALSE)) {
-        if (identical(base::get(key, pos=.values, inherits=FALSE), value)) {
+      if (exists(key, envir=.values, inherits=FALSE)) {
+        if (identical(.values[[key]], value)) {
           return(invisible())
         }
       }
@@ -98,14 +107,14 @@ ReactiveValues <- R6Class(
       else
         .valuesDeps$invalidate()
 
-      assign(key, value, pos=.values, inherits=FALSE)
+      .values[[key]] <- value
 
       .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
       .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
       .graphValueChange(sprintf('%s$%s', .label, key), value)
 
       dep.keys <- objects(
-        pos=.dependents,
+        envir=.dependents,
         pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
         all.names=TRUE
       )
@@ -118,18 +127,54 @@ ReactiveValues <- R6Class(
       )
       invisible()
     },
+
     mset = function(lst) {
       lapply(base::names(lst),
              function(name) {
                self$set(name, lst[[name]])
              })
     },
+
     names = function() {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('names(%s)', .label))
       .namesDeps$register()
       return(ls(.values, all.names=TRUE))
     },
+
+    # Get a metadata value. Does not trigger reactivity.
+    getMeta = function(key, metaKey) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+      .metadata[[key]][[metaKey]]
+    },
+
+    # Set a metadata value. Does not trigger reactivity.
+    setMeta = function(key, metaKey, value) {
+      # Make sure to use named (not numeric) indexing into list.
+      metaKey <- as.character(metaKey)
+
+      if (!exists(key, envir = .metadata, inherits = FALSE)) {
+        .metadata[[key]] <<- list()
+      }
+
+      .metadata[[key]][[metaKey]] <<- value
+    },
+
+    # Mark a value as invalid. If accessed while invalid, a shiny.silent.error
+    # will be thrown.
+    invalidate = function(key) {
+      setMeta(key, "invalid", TRUE)
+    },
+
+    unInvalidate = function(key) {
+      setMeta(key, "invalid", NULL)
+    },
+
+    isInvalid = function(key) {
+      isTRUE(getMeta(key, "invalid"))
+    },
+
     toList = function(all.names=FALSE) {
       .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                       sprintf('%s (all)', .label))
@@ -140,6 +185,7 @@ ReactiveValues <- R6Class(
 
       return(as.list(.values, all.names=all.names))
     },
+
     .setLabel = function(label) {
       .label <<- label
     }
@@ -334,6 +380,32 @@ str.reactivevalues <- function(object, indent.str = " ", ...) {
   utils::str(class(object))
 }
 
+
+#' Invalidate a reactive value
+#'
+#' This invalidates a reactive value. If the value is accessed while invalid, a
+#' "silent" exception is raised and the operation is stopped. This is the same
+#' thing that happens if \code{req(FALSE)} is called. The value is
+#' un-invalidated (accessing it will no longer raise an exception) when the
+#' current reactive domain is flushed; in a Shiny application, this occurs after
+#' all of the observers are executed.
+#'
+#' @param x A \code{\link{reactiveValues}} object (like \code{input}).
+#' @param name The name of a value in the \code{\link{reactiveValues}} object.
+#'
+#' @seealso \code{\link{req}}
+#' @export
+invalidateReactiveValue <- function(x, name) {
+  domain <- getDefaultReactiveDomain()
+  if (is.null(getDefaultReactiveDomain)) {
+    stop("invalidateReactiveValue() must be called when a default reactive domain is active.")
+  }
+
+  domain$invalidateValue(x, name)
+  invisible()
+}
+
+
 # Observable ----------------------------------------------------------------
 
 Observable <- R6Class(
@@ -562,7 +634,7 @@ srcrefToLabel <- function(srcref, defaultLabel) {
 
 #' @export
 print.reactive <- function(x, ...) {
-  label <- attr(x, "observable")$.label
+  label <- attr(x, "observable", exact = TRUE)$.label
   cat(label, "\n")
 }
 
@@ -573,7 +645,7 @@ is.reactive <- function(x) inherits(x, "reactive")
 # Return the number of times that a reactive expression or observer has been run
 execCount <- function(x) {
   if (is.reactive(x))
-    return(attr(x, "observable")$.execCount)
+    return(attr(x, "observable", exact = TRUE)$.execCount)
   else if (inherits(x, 'Observer'))
     return(x$.execCount)
   else
@@ -865,9 +937,9 @@ observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
 #' }
 #' @export
 makeReactiveBinding <- function(symbol, env = parent.frame()) {
-  if (exists(symbol, where = env, inherits = FALSE)) {
-    initialValue <- get(symbol, pos = env, inherits = FALSE)
-    rm(list = symbol, pos = env, inherits = FALSE)
+  if (exists(symbol, envir = env, inherits = FALSE)) {
+    initialValue <- env[[symbol]]
+    rm(list = symbol, envir = env, inherits = FALSE)
   }
   else
     initialValue <- NULL

R/save-state-local.R

@@ -0,0 +1,29 @@
+# Function wrappers for persisting or restoring state when running Shiny locally
+#
+# These functions provide a directory to the callback function.
+#
+# @param id A session ID to save.
+# @param callback A callback function that saves state to or restores state from
+#   a directory. It must take one argument, \code{stateDir}, which is a
+#   directory to which it writes/reads.
+
+persistInterfaceLocal <- function(id, callback) {
+  # Try to save in app directory, or, if that's not available, in the current
+  # directory.
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_persist", id)
+  if (!dirExists(stateDir))
+    dir.create(stateDir, recursive = TRUE)
+
+  callback(stateDir)
+}
+
+loadInterfaceLocal <- function(id, callback) {
+  # Try to save in app directory, or, if that's not available, in the current
+  # directory.
+  appDir <- getShinyOption("appDir", default = getwd())
+
+  stateDir <- file.path(appDir, "shiny_persist", id)
+  callback(stateDir)
+}

R/save-state.R

@@ -0,0 +1,525 @@
+ShinySaveState <- R6Class("ShinySaveState",
+  public = list(
+    input = NULL,
+    exclude = NULL,
+    onSave = NULL, # A callback to invoke during the saving process.
+
+    # These are set not in initialize(), but by external functions that modify
+    # the ShinySaveState object.
+    dir = NULL,
+    values = NULL,
+
+    initialize = function(input = NULL, exclude = NULL, onSave = NULL)
+    {
+      self$input   <- input
+      self$exclude <- exclude
+      self$onSave  <- onSave
+    },
+
+    # Persist this state object to disk. Returns a query string which can be
+    # used to restore the session.
+    persist = function() {
+      id <- createUniqueId(8)
+
+      persistInterface <- getShinyOption("persist.interface",
+                                         default = persistInterfaceLocal)
+
+      persistInterface(id, function(stateDir) {
+        # Directory is provided by the persistInterface function.
+        self$dir <- stateDir
+
+        # Allow user-supplied onSave function to do things like add self$values, or
+        # save data to state dir.
+        if (!is.null(self$onSave))
+          isolate(self$onSave(self))
+
+        # Serialize values, possibly saving some extra data to stateDir
+        inputValues <- serializeReactiveValues(self$input, self$exclude, self$dir)
+        saveRDS(inputValues, file.path(stateDir, "input.rds"))
+
+        # If there values passed in, save them also
+        if (!is.null(self$values))
+          saveRDS(self$values, file.path(stateDir, "values.rds"))
+      })
+
+      paste0("__state_id__=", encodeURIComponent(id))
+    },
+
+    # Encode the state to a URL. This does not save to disk.
+    encode = function() {
+      inputVals <- serializeReactiveValues(self$input, self$exclude, stateDir = NULL)
+
+      # Allow user-supplied onSave function to do things like add self$values.
+      if (!is.null(self$onSave))
+        self$onSave(self)
+
+      inputVals <- vapply(inputVals,
+        function(x) toJSON(x, strict_atomic = FALSE),
+        character(1),
+        USE.NAMES = TRUE
+      )
+
+      res <- paste0(
+        encodeURIComponent(names(inputVals)),
+        "=",
+        encodeURIComponent(inputVals),
+        collapse = "&"
+      )
+
+      # If 'values' is present, add them as well.
+      if (length(self$values) != 0) {
+        values <- vapply(self$values,
+          function(x) toJSON(x, strict_atomic = FALSE),
+          character(1),
+          USE.NAMES = TRUE
+        )
+
+        res <- paste0(res, "&_values_&",
+          paste0(
+            encodeURIComponent(names(values)),
+            "=",
+            encodeURIComponent(values),
+            collapse = "&"
+          )
+        )
+      }
+
+      res
+    }
+  )
+)
+
+
+RestoreContext <- R6Class("RestoreContext",
+  public = list(
+    # This is a RestoreInputSet for input values. This is a key-value store with
+    # some special handling.
+    input = NULL,
+
+    # Directory for extra files, if restoring from persisted state
+    dir = NULL,
+
+    # For values other than input values. These values don't need the special
+    # phandling that's needed for input values, because they're only accessed
+    # from the onRestore function.
+    values = NULL,
+
+    initialize = function(queryString = NULL) {
+      if (!is.null(queryString)) {
+        tryCatch(
+          {
+            qsValues <- parseQueryString(queryString, nested = TRUE)
+
+            if (!is.null(qsValues[["__subapp__"]]) && qsValues[["__subapp__"]] == 1) {
+              # Ignore subapps in shiny docs
+              self$reset()
+
+            } else if (!is.null(qsValues[["__state_id__"]]) && nzchar(qsValues[["__state_id__"]])) {
+              # If we have a "__state_id__" key, restore from persisted state and ignore
+              # other key/value pairs. If not, restore from key/value pairs in the
+              # query string.
+              private$loadStateQueryString(queryString)
+
+            } else {
+              # The query string contains the saved keys and values
+              private$decodeStateQueryString(queryString)
+            }
+          },
+          error = function(e) {
+            # If there's an error in restoring problem, just reset these values
+            self$reset()
+            warning(e$message)
+          }
+        )
+      }
+    },
+
+    reset = function() {
+      self$input <- RestoreInputSet$new(list())
+      self$values <- list()
+      self$dir <- NULL
+    },
+
+    # This should be called before a restore context is popped off the stack.
+    flushPending = function() {
+      self$input$flushPending()
+    },
+
+
+    # Returns a list representation of the RestoreContext object. This is passed
+    # to the app author's onRestore function. An important difference between
+    # the RestoreContext object and the list is that the former's `input` field
+    # is a RestoreInputSet object, while the latter's `input` field is just a
+    # list.
+    asList = function() {
+      list(
+        input = self$input$asList(),
+        dir = self$dir,
+        values = self$values
+      )
+    }
+  ),
+
+  private = list(
+    # Given a query string with a __state_id__, load persisted state with that ID.
+    loadStateQueryString = function(queryString) {
+      values <- parseQueryString(queryString, nested = TRUE)
+      id <- values[["__state_id__"]]
+
+      # This function is passed to the loadInterface function; given a
+      # directory, it will load state from that directory
+      loadFun <- function(stateDir) {
+        self$dir <- stateDir
+
+        inputValues <- readRDS(file.path(stateDir, "input.rds"))
+        self$input <- RestoreInputSet$new(inputValues)
+
+        valuesFile <- file.path(stateDir, "values.rds")
+        if (file.exists(valuesFile)) {
+          self$values <- readRDS(valuesFile)
+        } else {
+          self$values <- list()
+        }
+      }
+
+      loadInterface <- getShinyOption("load.interface", default = loadInterfaceLocal)
+      loadInterface(id, loadFun)
+
+      invisible()
+    },
+
+    # Given a query string with values encoded in it, restore persisted state
+    # from those values.
+    decodeStateQueryString = function(queryString) {
+      # Remove leading '?'
+      if (substr(queryString, 1, 1) == '?')
+        queryString <- substr(queryString, 2, nchar(queryString))
+
+      if (grepl("(^|&)_values_(&|$)", queryString)) {
+        splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
+        inputValueStr <- splitStr[1]
+        valueStr <- splitStr[2]
+        if (is.na(valueStr))
+          valueStr <- ""
+
+      } else {
+        inputValueStr <- queryString
+        valueStr <- ""
+      }
+
+      inputValues <- parseQueryString(inputValueStr, nested = TRUE)
+      values <- parseQueryString(valueStr, nested = TRUE)
+
+      valuesFromJSON <- function(vals) {
+        mapply(names(vals), vals, SIMPLIFY = FALSE,
+          FUN = function(name, value) {
+            tryCatch(
+              jsonlite::fromJSON(value),
+              error = function(e) {
+                stop("Failed to parse URL parameter \"", name, "\"")
+              }
+            )
+          }
+        )
+      }
+
+      inputValues <- valuesFromJSON(inputValues)
+      self$input <- RestoreInputSet$new(inputValues)
+
+      self$values <- valuesFromJSON(values)
+    }
+  )
+)
+
+
+# Restore input set. This is basically a key-value store, except for one
+# important difference: When the user `get()`s a value, the value is marked as
+# pending; when `flushPending()` is called, those pending values are marked as
+# used. When a value is marked as used, `get()` will not return it, unless
+# called with `force=TRUE`. This is to make sure that a particular value can be
+# restored only within a single call to `withRestoreContext()`. Without this, if
+# a value is restored in a dynamic UI, it could completely prevent any other
+# (non- restored) kvalue from being used.
+RestoreInputSet <- R6Class("RestoreInputSet",
+  private = list(
+    values = NULL,
+    pending = character(0),
+    used = character(0)     # Names of values which have been used
+  ),
+
+  public = list(
+    initialize = function(values) {
+      private$values <- new.env(parent = emptyenv())
+      list2env(values, private$values)
+    },
+
+    exists = function(name) {
+      exists(name, envir = private$values)
+    },
+
+    # Return TRUE if the value exists and has not been marked as used.
+    available = function(name) {
+      self$exists(name) && !self$isUsed(name)
+    },
+
+    isPending = function(name) {
+      name %in% private$pending
+    },
+
+    isUsed = function(name) {
+      name %in% private$used
+    },
+
+    # Get a value. If `force` is TRUE, get the value without checking whether
+    # has been used, and without marking it as pending.
+    get = function(name, force = FALSE) {
+      if (force)
+        return(private$values[[name]])
+
+      if (!self$available(name))
+        return(NULL)
+
+      # Mark this name as pending. Use unique so that it's not added twice.
+      private$pending <- unique(c(private$pending, name))
+      private$values[[name]]
+    },
+
+    # Take pending names and mark them as used, then clear pending list.
+    flushPending = function() {
+      private$used <- unique(c(private$used, private$pending))
+      private$pending <- character(0)
+    },
+
+    asList = function() {
+      as.list.environment(private$values)
+    }
+  )
+)
+
+
+restoreCtxStack <- Stack$new()
+
+withRestoreContext <- function(ctx, expr) {
+  restoreCtxStack$push(ctx)
+
+  on.exit({
+    # Mark pending names as used
+    restoreCtxStack$peek()$flushPending()
+    restoreCtxStack$pop()
+  }, add = TRUE)
+
+  force(expr)
+}
+
+# Is there a current restore context?
+hasCurrentRestoreContext <- function() {
+  restoreCtxStack$size() > 0
+}
+
+# Call to access the current restore context
+getCurrentRestoreContext <- function() {
+  ctx <- restoreCtxStack$peek()
+  if (is.null(ctx)) {
+    stop("No restore context found")
+  }
+  ctx
+}
+
+#' Restore an input value
+#'
+#' This restores an input value from the current restore context..
+#'
+#' @param id Name of the input value to restore.
+#' @param default A default value to use, if there's no value to restore.
+#'
+#' @export
+restoreInput <- function(id, default) {
+  # Need to evaluate `default` in case it contains reactives like input$x. If we
+  # don't, then the calling code won't take a reactive dependency on input$x
+  # when restoring a value.
+  force(default)
+
+  if (identical(getShinyOption("restorable"), FALSE) || !hasCurrentRestoreContext())
+    return(default)
+
+  oldInputs <- getCurrentRestoreContext()$input
+  if (oldInputs$available(id)) {
+    oldInputs$get(id)
+  } else {
+    default
+  }
+}
+
+#' Update URL in browser's location bar
+#'
+#' @param queryString The new query string to show in the location bar.
+#' @param session A Shiny session object.
+#' @export
+updateLocationBar <- function(queryString, session = getDefaultReactiveDomain()) {
+  session$updateLocationBar(queryString)
+}
+
+#' Create a button for bookmarking/sharing
+#'
+#' A \code{bookmarkButton} is a \code{\link{actionButton}} with a default label
+#' that consists of a link icon and the text "Share...". It is meant to be used
+#' for bookmarking state.
+#'
+#' @seealso configureBookmarking
+#' @inheritParams actionButton
+#' @export
+saveStateButton <- function(inputId, label = "Save and share...",
+  icon = shiny::icon("link", lib = "glyphicon"),
+  title = "Save this application's current state and get a URL for sharing.",
+  ...)
+{
+  actionButton(inputId, label, icon, title = title, ...)
+}
+
+
+#' Generate a modal dialog that displays a URL
+#'
+#' The modal dialog generated by \code{urlModal} will display the URL in a
+#' textarea input, and the URL text will be selected so that it can be easily
+#' copied. The result from \code{urlModal} should be passed to the
+#' \code{\link{showModal}} function to display it in the browser.
+#'
+#' @param url A URL to display in the dialog box.
+#' @param title A title for the dialog box.
+#' @param subtitle Text to display underneath URL.
+#' @export
+urlModal <- function(url, title = "Saved application link", subtitle = NULL) {
+
+  subtitleTag <- NULL
+  if (!is.null(subtitle)) {
+    subtitleTag <- tagList(
+      br(),
+      span(class = "text-muted", subtitle)
+    )
+  }
+
+  modalDialog(
+    title = title,
+    easyClose = TRUE,
+    footer = NULL,
+    tags$textarea(class = "form-control", rows = "1", style = "resize: none;",
+      readonly = "readonly",
+      url
+    ),
+    subtitleTag,
+    # Need separate show and shown listeners. The show listener sizes the
+    # textarea just as the modal starts to fade in. The 200ms delay is needed
+    # because if we try to resize earlier, it can't calculate the text height
+    # (scrollHeight will be reported as zero). The shown listener selects the
+    # text; it's needed because because selection has to be done after the fade-
+    # in is completed.
+    tags$script(
+      "$('#shiny-modal').
+        one('show.bs.modal', function() {
+          setTimeout(function() {
+            var $textarea = $('#shiny-modal textarea');
+            $textarea.innerHeight($textarea[0].scrollHeight);
+          }, 200);
+        });
+      $('#shiny-modal')
+        .one('shown.bs.modal', function() {
+          $('#shiny-modal textarea').select().focus();
+        });"
+    )
+  )
+}
+
+
+#' Configure bookmarking for the current session
+#'
+#' There are two types of bookmarking: saving state, and encoding state.
+#'
+#' @param eventExpr An expression to listen for, similar to
+#'   \code{\link{observeEvent}}.
+#' @param type Either \code{"encode"}, which encodes all of the relevant values
+#'   in a URL, \code{"persist"}, which saves to disk, or \code{"disable"}, which
+#'   disables any previously-enabled bookmarking.
+#' @param exclude Input values to exclude from bookmarking.
+#' @param onBookmark A function to call before saving state. This function
+#'   should return a list, which will be saved as \code{values}.
+#' @param onRestore A function to call when a session is restored. It will be
+#'   passed one argument, a restoreContext object.
+#' @param onBookmarked A callback function to invoke after the bookmarking has
+#'   been done.
+#' @param session A Shiny session object.
+#' @export
+configureBookmarking <- function(eventExpr,
+  type = c("encode", "persist", "disable"), exclude = NULL,
+  onBookmark = NULL, onRestore = NULL, onBookmarked = NULL,
+  session = getDefaultReactiveDomain())
+{
+
+  eventExpr <- substitute(eventExpr)
+  type <- match.arg(type)
+
+  # If there's an existing onBookmarked observer, destroy it before creating a
+  # new one.
+  if (!is.null(session$bookmarkObserver)) {
+    session$bookmarkObserver$destroy()
+    session$bookmarkObserver <- NULL
+  }
+
+  if (type == "disable") {
+    return(invisible())
+  }
+
+  # If no onBookmarked function is provided, use one of these defaults.
+  if (is.null(onBookmarked)) {
+    if (type == "persist") {
+      onBookmarked <- function(url) {
+        showModal(urlModal(
+          url,
+          subtitle = "The current state of this application has been persisted."
+        ))
+      }
+    } else if (type == "encode") {
+      onBookmarked <- function(url) {
+        showModal(urlModal(
+          url,
+          subtitle = "This link encodes the current state of this application."
+        ))
+      }
+    }
+  } else if (!is.function(onBookmarked)) {
+    stop("onBookmarked must be a function.")
+  }
+
+  session$bookmarkObserver <- observeEvent(
+    eventExpr,
+    event.env = parent.frame(),
+    event.quoted = TRUE,
+    {
+      saveState <- ShinySaveState$new(session$input, exclude, onBookmark)
+
+      if (type == "persist") {
+        url <- saveState$persist()
+      } else {
+        url <- saveState$encode()
+      }
+
+      clientData <- session$clientData
+      url <- paste0(
+        clientData$url_protocol, "//",
+        clientData$url_hostname,
+        if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
+        clientData$url_pathname,
+        "?", url
+      )
+
+      onBookmarked(url)
+    }
+  )
+
+  # Run the onRestore function immediately
+  if (!is.null(onRestore)) {
+    restoreState <- getCurrentRestoreContext()$asList()
+    onRestore(restoreState)
+  }
+
+  invisible()
+}

R/serializers.R

@@ -0,0 +1,72 @@
+# For most types of values, simply return the value unchanged.
+serializerDefault <- function(value, stateDir) {
+  value
+}
+
+
+serializerFileInput <- function(value, stateDir = NULL) {
+  # File inputs can be serialized only if there's a stateDir
+  if (is.null(stateDir)) {
+    return(serializerUnserializable())
+  }
+
+  # value is a data frame. When persisting files, we need to copy the file to
+  # the persistent dir and then strip the original path before saving.
+  newpaths <- file.path(stateDir, basename(value$datapath))
+  file.copy(value$datapath, newpaths, overwrite = TRUE)
+  value$datapath <- basename(newpaths)
+
+  value
+}
+
+
+# Return a sentinel value that represents "unserializable". This is applied to
+# for example, passwords and actionButtons.
+serializerUnserializable <- function(value, stateDir) {
+  structure(
+    list(),
+    serializable = FALSE
+  )
+}
+
+# Is this an "unserializable" sentinel value?
+isUnserializable <- function(x) {
+  identical(
+    attr(x, "serializable", exact = TRUE),
+    FALSE
+  )
+}
+
+
+# Given a reactiveValues object and optional directory for saving state, apply
+# serializer function to each of the values, and return a list of the returned
+# values. This function passes stateDir to the serializer functions, so if
+# stateDir is non-NULL, it can have a side effect of writing values to disk (in
+# stateDir).
+serializeReactiveValues <- function(values, exclude, stateDir = NULL) {
+  impl <- .subset2(values, "impl")
+
+  # Get named list where keys and values are the names of inputs; we'll retrieve
+  # actual values later.
+  vals <- isolate(impl$names())
+  vals <- setdiff(vals, exclude)
+  names(vals) <- vals
+
+  # Get values and apply serializer functions
+  vals <- lapply(vals, function(name) {
+    val <- impl$get(name)
+
+    # Get the serializer function for this input value. If none specified, use
+    # the default.
+    serializer <- impl$getMeta(name, "shiny.serializer")
+    if (is.null(serializer))
+      serializer <- serializerDefault
+
+    # Apply serializer function.
+    serializer(val, stateDir)
+  })
+
+  # Filter out any values that were marked as unserializable.
+  vals <- Filter(Negate(isUnserializable), vals)
+  vals
+}

R/server-input-handlers.R

@@ -89,6 +89,12 @@ registerInputHandler("shiny.number", function(val, ...){
   ifelse(is.null(val), NA, val)
 })
 
+registerInputHandler("shiny.password", function(val, shinysession, name) {
+  # Mark passwords as not serializable
+  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+  val
+})
+
 registerInputHandler("shiny.date", function(val, ...){
   # First replace NULLs with NA, then convert to Date vector
   datelist <- ifelse(lapply(val, is.null), NA, val)
@@ -104,8 +110,33 @@ registerInputHandler("shiny.datetime", function(val, ...){
   as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
 })
 
-registerInputHandler("shiny.action", function(val, ...) {
+registerInputHandler("shiny.action", function(val, shinysession, name) {
+  # Mark as not serializable
+  .subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
+
   # mark up the action button value with a special class so we can recognize it later
   class(val) <- c(class(val), "shinyActionButtonValue")
   val
 })
+
+registerInputHandler("shiny.file", function(val, shinysession, name) {
+  # This function is only used when restoring a Shiny fileInput. When a file is
+  # uploaded the usual way, it takes a different code path and won't hit this
+  # function.
+  if (is.null(val))
+    return(NULL)
+
+  # The data will be a named list of lists; convert to a data frame.
+  val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
+
+  # Make sure that the paths don't go up the directory tree, for security
+  # reasons.
+  if (any(grepl("..", val$datapath, fixed = TRUE))) {
+    stop("Invalid '..' found in file input path.")
+  }
+
+  # Prepend the persistent dir
+  val$datapath <- file.path(getCurrentRestoreContext()$dir, val$datapath)
+
+  val
+})

R/server.R

@@ -232,121 +232,132 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
 
           msg <- decodeMessage(msg)
 
-          # Do our own list simplifying here. sapply/simplify2array give names to
-          # character vectors, which is rarely what we want.
-          if (!is.null(msg$data)) {
-            for (name in names(msg$data)) {
-              val <- msg$data[[name]]
+          # Set up a restore context from .clientdata_url_search before
+          # handling all the input values, because the restore context may be
+          # used by an input handler (like the one for "shiny.file"). This
+          # should only happen once, when the app starts.
+          if (is.null(shinysession$restoreContext)) {
+            # If there's bookmarked state, save it on the session object
+            shinysession$restoreContext <- RestoreContext$new(msg$data$.clientdata_url_search)
+          }
 
+          withRestoreContext(shinysession$restoreContext, {
+
+            unpackInput <- function(name, val) {
               splitName <- strsplit(name, ':')[[1]]
               if (length(splitName) > 1) {
-                msg$data[[name]] <- NULL
-
-                if (!inputHandlers$containsKey(splitName[[2]])){
+                if (!inputHandlers$containsKey(splitName[[2]])) {
                   # No input handler registered for this type
                   stop("No handler registered for for type ", name)
                 }
 
-                msg$data[[ splitName[[1]] ]] <-
-                  inputHandlers$get(splitName[[2]])(
-                    val,
-                    shinysession,
-                    splitName[[1]] )
-              }
-              else if (is.list(val) && is.null(names(val))) {
-                val_flat <- unlist(val, recursive = TRUE)
+                inputName <- splitName[[1]]
 
-                if (is.null(val_flat)) {
-                  # This is to assign NULL instead of deleting the item
-                  msg$data[name] <- list(NULL)
-                } else {
-                  msg$data[[name]] <- val_flat
-                }
+                # Get the function for processing this type of input
+                inputHandler <- inputHandlers$get(splitName[[2]])
+
+                return(inputHandler(val, shinysession, inputName))
+
+              } else if (is.list(val) && is.null(names(val))) {
+                return(unlist(val, recursive = TRUE))
+              } else {
+                return(val)
               }
             }
-          }
 
-          switch(
-            msg$method,
-            init = {
+            msg$data <- mapply(unpackInput, names(msg$data), msg$data,
+                               SIMPLIFY = FALSE)
 
-              serverFunc <- withReactiveDomain(NULL, serverFuncSource())
-              if (!identicalFunctionBodies(serverFunc, appvars$server)) {
-                appvars$server <- serverFunc
-                if (!is.null(appvars$server))
-                {
-                  # Tag this function as the Shiny server function. A debugger may use this
-                  # tag to give this function special treatment.
-                  # It's very important that it's appvars$server itself and NOT a copy that
-                  # is invoked, otherwise new breakpoints won't be picked up.
-                  attr(appvars$server, "shinyServerFunction") <- TRUE
-                  registerDebugHook("server", appvars, "Server Function")
+            # Convert names like "button1:shiny.action" to "button1"
+            names(msg$data) <- vapply(
+              names(msg$data),
+              function(name) { strsplit(name, ":")[[1]][1] },
+              FUN.VALUE = character(1)
+            )
+
+
+            switch(
+              msg$method,
+              init = {
+
+                serverFunc <- withReactiveDomain(NULL, serverFuncSource())
+                if (!identicalFunctionBodies(serverFunc, appvars$server)) {
+                  appvars$server <- serverFunc
+                  if (!is.null(appvars$server))
+                  {
+                    # Tag this function as the Shiny server function. A debugger may use this
+                    # tag to give this function special treatment.
+                    # It's very important that it's appvars$server itself and NOT a copy that
+                    # is invoked, otherwise new breakpoints won't be picked up.
+                    attr(appvars$server, "shinyServerFunction") <- TRUE
+                    registerDebugHook("server", appvars, "Server Function")
+                  }
                 }
-              }
 
-              # Check for switching into/out of showcase mode
-              if (.globals$showcaseOverride &&
-                  exists(".clientdata_url_search", where = msg$data)) {
-                mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
-                if (!is.null(mode))
-                  shinysession$setShowcase(mode)
-              }
+                # Check for switching into/out of showcase mode
+                if (.globals$showcaseOverride &&
+                    exists(".clientdata_url_search", where = msg$data)) {
+                  mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
+                  if (!is.null(mode))
+                    shinysession$setShowcase(mode)
+                }
 
-              shinysession$manageInputs(msg$data)
+                shinysession$manageInputs(msg$data)
 
-              # The client tells us what singletons were rendered into
-              # the initial page
-              if (!is.null(msg$data$.clientdata_singletons)) {
-                shinysession$singletons <- strsplit(
-                  msg$data$.clientdata_singletons, ',')[[1]]
-              }
+                # The client tells us what singletons were rendered into
+                # the initial page
+                if (!is.null(msg$data$.clientdata_singletons)) {
+                  shinysession$singletons <- strsplit(
+                    msg$data$.clientdata_singletons, ',')[[1]]
+                }
 
-              local({
-                args <- argsForServerFunc(serverFunc, shinysession)
+                local({
+                  args <- argsForServerFunc(serverFunc, shinysession)
 
-                withReactiveDomain(shinysession, {
-                  do.call(
-                    # No corresponding ..stacktraceoff; the server func is pure
-                    # user code
-                    wrapFunctionLabel(appvars$server, "server",
-                      ..stacktraceon = TRUE
-                    ),
-                    args
-                  )
+                  withReactiveDomain(shinysession, {
+                    do.call(
+                      # No corresponding ..stacktraceoff; the server func is pure
+                      # user code
+                      wrapFunctionLabel(appvars$server, "server",
+                        ..stacktraceon = TRUE
+                      ),
+                      args
+                    )
+                  })
                 })
-              })
-            },
-            update = {
-              shinysession$manageInputs(msg$data)
-            },
-            shinysession$dispatch(msg)
-          )
-          shinysession$manageHiddenOutputs()
+              },
+              update = {
+                shinysession$manageInputs(msg$data)
+              },
+              shinysession$dispatch(msg)
+            )
+            shinysession$manageHiddenOutputs()
 
-          if (exists(".shiny__stdout", globalenv()) &&
-              exists("HTTP_GUID", ws$request)) {
-            # safe to assume we're in shiny-server
-            shiny_stdout <- get(".shiny__stdout", globalenv())
+            if (exists(".shiny__stdout", globalenv()) &&
+                exists("HTTP_GUID", ws$request)) {
+              # safe to assume we're in shiny-server
+              shiny_stdout <- get(".shiny__stdout", globalenv())
 
-            # eNter a flushReact
-            writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
-              " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-              sep=""), con=shiny_stdout)
-            flush(shiny_stdout)
+              # eNter a flushReact
+              writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
+                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                sep=""), con=shiny_stdout)
+              flush(shiny_stdout)
 
-            flushReact()
+              flushReact()
 
-            # eXit a flushReact
-            writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
-              " @ ", sprintf("%.3f", as.numeric(Sys.time())),
-              sep=""), con=shiny_stdout)
-            flush(shiny_stdout)
-          } else {
-            flushReact()
-          }
-          lapply(appsByToken$values(), function(shinysession) {
-            shinysession$flushOutput()
-            NULL
+              # eXit a flushReact
+              writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
+                " @ ", sprintf("%.3f", as.numeric(Sys.time())),
+                sep=""), con=shiny_stdout)
+              flush(shiny_stdout)
+            } else {
+              flushReact()
+            }
+            lapply(appsByToken$values(), function(shinysession) {
+              shinysession$flushOutput()
+              NULL
+            })
           })
         })
       }
@@ -565,6 +576,11 @@ runApp <- function(appDir=getwd(),
     handlerManager$clear()
   }, add = TRUE)
 
+  # Enable per-app Shiny options
+  oldOptionSet <- .globals$options
+  on.exit({
+    .globals$options <- oldOptionSet
+  },add = TRUE)
 
   if (is.null(host) || is.na(host))
     host <- '0.0.0.0'

R/shiny-options.R

@@ -0,0 +1,57 @@
+.globals$options <- list()
+
+#' @param name Name of an option to get.
+#' @param default Value to be returned if the option is not currently set.
+#' @rdname shinyOptions
+#' @export
+getShinyOption <- function(name, default = NULL) {
+  # Make sure to use named (not numeric) indexing
+  name <- as.character(name)
+
+  if (name %in% names(.globals$options))
+    .globals$options[[name]]
+  else
+    default
+}
+
+#' Get or set Shiny options
+#'
+#' \code{getShinyOption} retrieves the value of a Shiny option.
+#' \code{shinyOptions} sets the value of Shiny options; it can also be used to
+#' return a list of all currently-set Shiny options.
+#'
+#' There is a global option set, which is available by default. When a Shiny
+#' application is run with \code{\link{runApp}}, that option set is duplicated
+#' and the new option set is available for getting or setting values. If options
+#' are set from global.R, app.R, ui.R, or server.R, or if they are set from
+#' inside the server function, then the options will be scoped to the
+#' application. When the application exits, the new option set is discarded and
+#' the global option set is restored.
+#'
+#' @param ... Options to set, with the form \code{name = value}.
+#'
+#' @examples
+#' \dontrun{
+#' shinyOptions(myOption = 10)
+#' getShinyOption("myOption")
+#' }
+#' @export
+shinyOptions <- function(...) {
+  newOpts <- list(...)
+
+  if (length(newOpts) > 0) {
+    .globals$options <- mergeVectors(.globals$options, newOpts)
+    invisible(.globals$options)
+  } else {
+    .globals$options
+  }
+}
+
+
+# Eval an expression with a new option set
+withLocalOptions <- function(expr) {
+  oldOptionSet <- .globals$options
+  on.exit(.globals$options <- oldOptionSet)
+
+  expr
+}

R/shiny.R

@@ -123,10 +123,14 @@ createUniqueId <- function(bytes, prefix = "", suffix = "") {
 toJSON <- function(x, ...,  dataframe = "columns", null = "null", na = "null",
   auto_unbox = TRUE, digits = getOption("shiny.json.digits", 16),
   use_signif = TRUE, force = TRUE, POSIXt = "ISO8601", UTC = TRUE,
-  rownames = FALSE, keep_vec_names = TRUE) {
+  rownames = FALSE, keep_vec_names = TRUE, strict_atomic = TRUE) {
+
+  if (strict_atomic) {
+    x <- I(x)
+  }
 
   # I(x) is so that length-1 atomic vectors get put in [].
-  jsonlite::toJSON(I(x), dataframe = dataframe, null = null, na = na,
+  jsonlite::toJSON(x, dataframe = dataframe, null = null, na = na,
    auto_unbox = auto_unbox, digits = digits, use_signif = use_signif,
    force = force, POSIXt = POSIXt, UTC = UTC, rownames = rownames,
    keep_vec_names = keep_vec_names, json_verbatim = TRUE, ...)
@@ -423,6 +427,8 @@ ShinySession <- R6Class(
     }
   ),
   public = list(
+    restoreContext = NULL,
+    bookmarkObserver = NULL,
     progressStack = 'Stack', # Stack of progress objects
     input       = 'reactivevalues', # Externally-usable S3 wrapper object for .input
     output      = 'ANY',    # Externally-usable S3 wrapper object for .outputs
@@ -508,6 +514,17 @@ ShinySession <- R6Class(
     ns = function(id) {
       NS(NULL, id)
     },
+
+    # Invalidate a value until the flush cycle completes
+    invalidateValue = function(x, name) {
+      if (!is.reactivevalues(x))
+        stop("x must be a reactivevalues object")
+
+      impl <- .subset2(x, 'impl')
+      impl$invalidate(name)
+      self$onFlushed(function() impl$unInvalidate(name))
+    },
+
     onSessionEnded = function(sessionEndedCallback) {
       "Registers the given callback to be invoked when the session is closed
       (i.e. the connection to the client has been severed). The return value
@@ -810,6 +827,9 @@ ShinySession <- R6Class(
         )
       )
     },
+    updateLocationBar = function(url) {
+      private$sendMessage(updateLocationBar = list(url = url))
+    },
 
     # Public RPC methods
     `@uploadieFinish` = function() {
@@ -836,6 +856,9 @@ ShinySession <- R6Class(
     `@uploadEnd` = function(jobId, inputId) {
       fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
       private$.input$set(inputId, fileData)
+
+      private$.input$setMeta(inputId, "shiny.serializer", serializerFileInput)
+
       invisible()
     },
     # Provides a mechanism for handling direct HTTP requests that are posted

R/shinyui.R

@@ -92,13 +92,15 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
         showcaseMode <- mode
     }
     uiValue <- if (is.function(ui)) {
-      if (length(formals(ui)) > 0) {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui(req))
-      } else {
-        # No corresponding ..stacktraceoff.., this is pure user code
-        ..stacktraceon..(ui())
-      }
+      withRestoreContext(RestoreContext$new(req$QUERY_STRING), {
+        if (length(formals(ui)) > 0) {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui(req))
+        } else {
+          # No corresponding ..stacktraceoff.., this is pure user code
+          ..stacktraceon..(ui())
+        }
+      })
     } else {
       ui
     }

R/utils.R

@@ -120,16 +120,6 @@ p_randomInt <- function(...) {
   withPrivateSeed(randomInt(...))
 }
 
-# Return a random hexadecimal string with `length` digits.
-randomID <- function(length = 16) {
-  paste(sample(
-    c("0", "1", "2", "3", "4", "5", "6", "7", "8","9",
-      "a", "b", "c", "d", "e", "f"),
-    length,
-    replace = TRUE
-  ), collapse = '')
-}
-
 isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
   abs(x - round(x)) < tol
 }
@@ -193,6 +183,21 @@ anyUnnamed <- function(x) {
   any(!nzchar(nms))
 }
 
+# Given two named vectors, join them together, and keep only the last element
+# with a given name in the resulting vector. If b has any elements with the same
+# name as elements in a, the element in a is dropped. Also, if there are any
+# duplicated names in a or b, only the last one with that name is kept.
+mergeVectors <- function(a, b) {
+  if (anyUnnamed(a) || anyUnnamed(b)) {
+    stop("Vectors must be either NULL or have names for all elements")
+  }
+
+  x <- c(a, b)
+  drop_idx <- duplicated(names(x), fromLast = TRUE)
+  x[!drop_idx]
+}
+
+
 # Combine dir and (file)name into a file path. If a file already exists with a
 # name differing only by case, then use it instead.
 file.path.ci <- function(...) {
@@ -235,6 +240,12 @@ find.file.ci <- function(...) {
   return(matches[1])
 }
 
+# The function base::dir.exists was added in R 3.2.0, but for backward
+# compatibility we need to add this function
+dirExists <- function(paths) {
+  file.exists(paths) & file.info(paths)$isdir
+}
+
 # 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.
@@ -506,6 +517,8 @@ parseQueryString <- function(str, nested = FALSE) {
     str <- substr(str, 2, nchar(str))
 
   pairs <- strsplit(str, '&', fixed = TRUE)[[1]]
+  # Drop any empty items (if there's leading/trailing/consecutive '&' chars)
+  pairs <- pairs[pairs != ""]
   pairs <- strsplit(pairs, '=', fixed = TRUE)
 
   keys   <- vapply(pairs, function(x) x[1], FUN.VALUE = character(1))
@@ -553,13 +566,7 @@ shinyCallingHandlers <- function(expr) {
         return()
 
       handle <- getOption('shiny.error')
-      if (is.function(handle)) {
-        if ("condition" %in% names(formals(handle))) {
-          handle(condition = e)
-        } else {
-          handle()
-        }
-      }
+      if (is.function(handle)) handle()
     }
   )
 }

inst/www/shared/shiny.js

@@ -1165,6 +1165,9 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
     addMessageHandler("resetBrush", function (message) {
       exports.resetBrush(message.brushId);
     });
+    addMessageHandler('updateLocationBar', function (message) {
+      window.history.replaceState(null, null, message.url);
+    });
 
     // Progress reporting ====================================================
 
@@ -3386,7 +3389,7 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
   var textInputBinding = new InputBinding();
   $.extend(textInputBinding, {
     find: function find(scope) {
-      return $(scope).find('input[type="text"], input[type="password"], input[type="search"], input[type="url"], input[type="email"]');
+      return $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
     },
     getId: function getId(el) {
       return InputBinding.prototype.getId.call(this, el) || el.name;
@@ -3441,6 +3444,20 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
   });
   inputBindings.register(textareaInputBinding, 'shiny.textareaInput');
 
+  //---------------------------------------------------------------------
+  // Source file: ../srcjs/input_binding_password.js
+
+  var passwordInputBinding = {};
+  $.extend(passwordInputBinding, textInputBinding, {
+    find: function find(scope) {
+      return $(scope).find('input[type="password"]');
+    },
+    getType: function getType(el) {
+      return "shiny.password";
+    }
+  });
+  inputBindings.register(passwordInputBinding, 'shiny.passwordInput');
+
   //---------------------------------------------------------------------
   // Source file: ../srcjs/input_binding_number.js
 
@@ -4626,8 +4643,8 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
 
   function uploadFiles(evt) {
     // If previously selected files are uploading, abort that.
-    var el = $(evt.target);
-    var uploader = el.data('currentUploader');
+    var $el = $(evt.target);
+    var uploader = $el.data('currentUploader');
     if (uploader) uploader.abort();
 
     var files = evt.target.files;
@@ -4638,12 +4655,23 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
 
     if (!IE8 && files.length === 0) return;
 
+    // Clear data-restore attribute if present.
+    $el.removeAttr('data-restore');
+
+    // Set the label in the text box
+    var $fileText = $el.closest('div.input-group').find('input[type=text]');
+    if (files.length === 1) {
+      $fileText.val(files[0].name);
+    } else {
+      $fileText.val(files.length + " files");
+    }
+
     // Start the new upload and put the uploader in 'currentUploader'.
     if (IE8) {
       /*jshint nonew:false */
       new IE8FileUploader(exports.shinyapp, id, evt.target);
     } else {
-      el.data('currentUploader', new FileUploader(exports.shinyapp, id, files));
+      $el.data('currentUploader', new FileUploader(exports.shinyapp, id, files));
     }
   }
 
@@ -4656,11 +4684,41 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
       return InputBinding.prototype.getId.call(this, el) || el.name;
     },
     getValue: function getValue(el) {
-      return null;
+      // This returns a non-undefined value only when there's a 'data-restore'
+      // attribute, which is set only when restoring Shiny state. If a file is
+      // uploaded through the browser, 'data-restore' gets cleared.
+      var data = $(el).attr('data-restore');
+      if (data) {
+        data = JSON.parse(data);
+
+        // Set the label in the text box
+        var $fileText = $(el).closest('div.input-group').find('input[type=text]');
+        if (data.name.length === 1) {
+          $fileText.val(data.name[0]);
+        } else {
+          $fileText.val(data.name.length + " files");
+        }
+
+        // Manually set up progress bar. A bit inelegant because it duplicates
+        // code from FileUploader, but duplication is less bad than alternatives.
+        var $progress = $(el).closest('div.form-group').find('.progress');
+        var $bar = $progress.find('.progress-bar');
+        $progress.removeClass('active');
+        $bar.width('100%');
+        $bar.css('visibility', 'visible');
+
+        return data;
+      } else {
+        return null;
+      }
     },
     setValue: function setValue(el, value) {
       // Not implemented
     },
+    getType: function getType(el) {
+      // This will be used only when restoring a file from a saved state.
+      return 'shiny.file';
+    },
     subscribe: function subscribe(el, callback) {
       $(el).on('change.fileInputBinding', uploadFiles);
     },

man/configureBookmarking.Rd

@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{configureBookmarking}
+\alias{configureBookmarking}
+\title{Configure bookmarking for the current session}
+\usage{
+configureBookmarking(eventExpr, type = c("encode", "persist", "disable"),
+  exclude = NULL, onBookmark = NULL, onRestore = NULL,
+  onBookmarked = NULL, session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{eventExpr}{An expression to listen for, similar to
+\code{\link{observeEvent}}.}
+
+\item{type}{Either \code{"encode"}, which encodes all of the relevant values
+in a URL, \code{"persist"}, which saves to disk, or \code{"disable"}, which
+disables any previously-enabled bookmarking.}
+
+\item{exclude}{Input values to exclude from bookmarking.}
+
+\item{onBookmark}{A function to call before saving state. This function
+should return a list, which will be saved as \code{values}.}
+
+\item{onRestore}{A function to call when a session is restored. It will be
+passed one argument, a restoreContext object.}
+
+\item{onBookmarked}{A callback function to invoke after the bookmarking has
+been done.}
+
+\item{session}{A Shiny session object.}
+}
+\description{
+There are two types of bookmarking: saving state, and encoding state.
+}
+

man/invalidateReactiveValue.Rd

@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/reactives.R
+\name{invalidateReactiveValue}
+\alias{invalidateReactiveValue}
+\title{Invalidate a reactive value}
+\usage{
+invalidateReactiveValue(x, name)
+}
+\arguments{
+\item{x}{A \code{\link{reactiveValues}} object (like \code{input}).}
+
+\item{name}{The name of a value in the \code{\link{reactiveValues}} object.}
+}
+\description{
+This invalidates a reactive value. If the value is accessed while invalid, a
+"silent" exception is raised and the operation is stopped. This is the same
+thing that happens if \code{req(FALSE)} is called. The value is
+un-invalidated (accessing it will no longer raise an exception) when the
+current reactive domain is flushed; in a Shiny application, this occurs after
+all of the observers are executed.
+}
+\seealso{
+\code{\link{req}}
+}
+

man/restoreInput.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{restoreInput}
+\alias{restoreInput}
+\title{Restore an input value}
+\usage{
+restoreInput(id, default)
+}
+\arguments{
+\item{id}{Name of the input value to restore.}
+
+\item{default}{A default value to use, if there's no value to restore.}
+}
+\description{
+This restores an input value from the current restore context..
+}
+

man/saveStateButton.Rd

@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{saveStateButton}
+\alias{saveStateButton}
+\title{Create a button for bookmarking/sharing}
+\usage{
+saveStateButton(inputId, label = "Save and share...",
+  icon = shiny::icon("link", lib = "glyphicon"),
+  title = "Save this application's current state and get a URL for sharing.",
+  ...)
+}
+\arguments{
+\item{inputId}{The \code{input} slot that will be used to access the value.}
+
+\item{label}{The contents of the button or link--usually a text label, but
+you could also use any other HTML, like an image.}
+
+\item{icon}{An optional \code{\link{icon}} to appear on the button.}
+
+\item{...}{Named attributes to be applied to the button or link.}
+}
+\description{
+A \code{bookmarkButton} is a \code{\link{actionButton}} with a default label
+that consists of a link icon and the text "Share...". It is meant to be used
+for bookmarking state.
+}
+\seealso{
+configureBookmarking
+}
+

man/shinyOptions.Rd

@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/shiny-options.R
+\name{getShinyOption}
+\alias{getShinyOption}
+\alias{shinyOptions}
+\title{Get or set Shiny options}
+\usage{
+getShinyOption(name, default = NULL)
+
+shinyOptions(...)
+}
+\arguments{
+\item{name}{Name of an option to get.}
+
+\item{default}{Value to be returned if the option is not currently set.}
+
+\item{...}{Options to set, with the form \code{name = value}.}
+}
+\description{
+\code{getShinyOption} retrieves the value of a Shiny option.
+\code{shinyOptions} sets the value of Shiny options; it can also be used to
+return a list of all currently-set Shiny options.
+}
+\details{
+There is a global option set, which is available by default. When a Shiny
+application is run with \code{\link{runApp}}, that option set is duplicated
+and the new option set is available for getting or setting values. If options
+are set from global.R, app.R, ui.R, or server.R, or if they are set from
+inside the server function, then the options will be scoped to the
+application. When the application exits, the new option set is discarded and
+the global option set is restored.
+}
+\examples{
+\dontrun{
+shinyOptions(myOption = 10)
+getShinyOption("myOption")
+}
+}
+

man/updateLocationBar.Rd

@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{updateLocationBar}
+\alias{updateLocationBar}
+\title{Update URL in browser's location bar}
+\usage{
+updateLocationBar(queryString, session = getDefaultReactiveDomain())
+}
+\arguments{
+\item{queryString}{The new query string to show in the location bar.}
+
+\item{session}{A Shiny session object.}
+}
+\description{
+Update URL in browser's location bar
+}
+

man/urlModal.Rd

@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/save-state.R
+\name{urlModal}
+\alias{urlModal}
+\title{Generate a modal dialog that displays a URL}
+\usage{
+urlModal(url, title = "Saved application link", subtitle = NULL)
+}
+\arguments{
+\item{url}{A URL to display in the dialog box.}
+
+\item{title}{A title for the dialog box.}
+
+\item{subtitle}{Text to display underneath URL.}
+}
+\description{
+The modal dialog generated by \code{urlModal} will display the URL in a
+textarea input, and the URL text will be selected so that it can be easily
+copied. The result from \code{urlModal} should be passed to the
+\code{\link{showModal}} function to display it in the browser.
+}
+

srcjs/input_binding_fileinput.js

@@ -162,8 +162,8 @@ $.extend(FileUploader.prototype, FileProcessor.prototype);
 
 function uploadFiles(evt) {
   // If previously selected files are uploading, abort that.
-  var el = $(evt.target);
-  var uploader = el.data('currentUploader');
+  var $el = $(evt.target);
+  var uploader = $el.data('currentUploader');
   if (uploader)
     uploader.abort();
 
@@ -176,12 +176,23 @@ function uploadFiles(evt) {
   if (!IE8 && files.length === 0)
     return;
 
+  // Clear data-restore attribute if present.
+  $el.removeAttr('data-restore');
+
+  // Set the label in the text box
+  var $fileText = $el.closest('div.input-group').find('input[type=text]');
+  if (files.length === 1) {
+    $fileText.val(files[0].name);
+  } else {
+    $fileText.val(files.length + " files");
+  }
+
   // Start the new upload and put the uploader in 'currentUploader'.
   if (IE8) {
     /*jshint nonew:false */
     new IE8FileUploader(exports.shinyapp, id, evt.target);
   } else {
-    el.data('currentUploader', new FileUploader(exports.shinyapp, id, files));
+    $el.data('currentUploader', new FileUploader(exports.shinyapp, id, files));
   }
 }
 
@@ -194,11 +205,42 @@ $.extend(fileInputBinding, {
     return InputBinding.prototype.getId.call(this, el) || el.name;
   },
   getValue: function(el) {
-    return null;
+    // This returns a non-undefined value only when there's a 'data-restore'
+    // attribute, which is set only when restoring Shiny state. If a file is
+    // uploaded through the browser, 'data-restore' gets cleared.
+    var data = $(el).attr('data-restore');
+    if (data) {
+      data = JSON.parse(data);
+
+      // Set the label in the text box
+      var $fileText = $(el).closest('div.input-group').find('input[type=text]');
+      if (data.name.length === 1) {
+        $fileText.val(data.name[0]);
+      } else {
+        $fileText.val(data.name.length + " files");
+      }
+
+      // Manually set up progress bar. A bit inelegant because it duplicates
+      // code from FileUploader, but duplication is less bad than alternatives.
+      var $progress = $(el).closest('div.form-group').find('.progress');
+      var $bar = $progress.find('.progress-bar');
+      $progress.removeClass('active');
+      $bar.width('100%');
+      $bar.css('visibility', 'visible');
+
+      return data;
+
+    } else {
+      return null;
+    }
   },
   setValue: function(el, value) {
     // Not implemented
   },
+  getType: function(el) {
+    // This will be used only when restoring a file from a saved state.
+    return 'shiny.file';
+  },
   subscribe: function(el, callback) {
     $(el).on('change.fileInputBinding', uploadFiles);
   },

srcjs/input_binding_password.js

@@ -0,0 +1,10 @@
+var passwordInputBinding = {};
+$.extend(passwordInputBinding, textInputBinding, {
+  find: function(scope) {
+    return $(scope).find('input[type="password"]');
+  },
+  getType: function(el) {
+    return "shiny.password";
+  }
+});
+inputBindings.register(passwordInputBinding, 'shiny.passwordInput');

srcjs/input_binding_text.js

@@ -1,7 +1,7 @@
 var textInputBinding = new InputBinding();
 $.extend(textInputBinding, {
   find: function(scope) {
-    return $(scope).find('input[type="text"], input[type="password"], input[type="search"], input[type="url"], input[type="email"]');
+    return $(scope).find('input[type="text"], input[type="search"], input[type="url"], input[type="email"]');
   },
   getId: function(el) {
     return InputBinding.prototype.getId.call(this, el) || el.name;

srcjs/shinyapp.js

@@ -670,6 +670,10 @@ var ShinyApp = function() {
   addMessageHandler("resetBrush", function(message) {
     exports.resetBrush(message.brushId);
   });
+  addMessageHandler('updateLocationBar', function(message) {
+    window.history.replaceState(null, null, message.url);
+  });
+
 
   // Progress reporting ====================================================
 

tests/testthat/test-options.R

@@ -0,0 +1,55 @@
+context("options")
+
+sortByName <- function(x) {
+  if (anyUnnamed(x))
+    stop("Can't sort by name because there are unnamed items")
+
+  if (any(duplicated(names(x))))
+    stop("Can't sort by name because there are duplicate names")
+
+  x[sort(names(x))]
+}
+
+test_that("Local options", {
+  # Basic options
+  shinyOptions(a = 1, b = 2)
+
+  expect_identical(sortByName(shinyOptions()), sortByName(list(a = 1, b = 2)))
+  expect_identical(getShinyOption('a'), 1)
+  expect_identical(getShinyOption('b'), 2)
+
+  # Options that haven't been set
+  expect_identical(getShinyOption('c'), NULL)
+  expect_identical(getShinyOption('c', default = 10), 10)
+
+  withLocalOptions({
+    # No changes yet
+    expect_identical(sortByName(shinyOptions()), sortByName(list(a = 1, b = 2)))
+    expect_identical(getShinyOption('a'), 1)
+    expect_identical(getShinyOption('b'), 2)
+
+    # Override an option
+    shinyOptions(a = 3)
+    expect_identical(sortByName(shinyOptions()), sortByName(list(b = 2, a = 3)))
+    expect_identical(getShinyOption('a'), 3)
+    expect_identical(getShinyOption('b'), 2)
+
+    # Options that haven't been set
+    expect_identical(getShinyOption('c'), NULL)
+    expect_identical(getShinyOption('c', default = 10), 10)
+
+    # Another local option set
+    withLocalOptions({
+      # Override an option
+      shinyOptions(a = 4)
+      expect_identical(sortByName(shinyOptions()), sortByName(list(b = 2, a = 4)))
+      expect_identical(getShinyOption('a'), 4)
+      expect_identical(getShinyOption('b'), 2)
+    })
+  })
+
+  # Should be back to original state
+  expect_identical(shinyOptions(), list(a = 1, b = 2))
+  expect_identical(getShinyOption('a'), 1)
+  expect_identical(getShinyOption('b'), 2)
+})

tests/testthat/test-save-state.R

@@ -0,0 +1,37 @@
+context("save-state")
+
+test_that("decoding state query string", {
+  rc <- RestoreContext$new("?a=1&b=2")
+  expect_identical(rc$input$asList(), list(a=1L, b=2L))
+  expect_identical(rc$values, list())
+
+  rc <- RestoreContext$new("?a=1&b=2&_values_&c=3")
+  expect_identical(rc$input$asList(), list(a=1L, b=2L))
+  expect_identical(rc$values, list(c=3L))
+
+  rc <- RestoreContext$new("?_values_&c=3")
+  expect_identical(rc$input$asList(), list())
+  expect_identical(rc$values, list(c=3L))
+
+  rc <- RestoreContext$new("?a=1&b=2&_values_")
+  expect_identical(rc$input$asList(), list(a=1L, b=2L))
+  expect_identical(rc$values, list())
+
+  rc <- RestoreContext$new("?_values_")
+  expect_identical(rc$input$asList(), list())
+  expect_identical(rc$values, list())
+
+  # If there's an error in the conversion from query string, should have
+  # blank values.
+  expect_warning(rc <- RestoreContext$new("?a=[x&b=1"))
+  expect_identical(rc$input$asList(), list())
+  expect_identical(rc$values, list())
+  expect_identical(rc$dir, NULL)
+
+  # Ignore query string if it's a subapp
+  rc <- RestoreContext$new("?w=&__subapp__=1")
+  expect_identical(rc$input$asList(), list())
+  expect_identical(rc$values, list())
+  expect_identical(rc$dir, NULL)
+
+})

tests/testthat/test-url.R

@@ -18,6 +18,8 @@ test_that("Query string parsing", {
   # Should be the same with or without leading question mark
   expect_identical(parseQueryString("?foo=1&bar=b"), parseQueryString("foo=1&bar=b"))
 
+  # Leading/trailing/consecutive ampersands are ignored
+  expect_identical(parseQueryString("?&a=1&&b=2&"), parseQueryString("?a=1&b=2"))
 
   # Nested and non-nested query strings
   expect_identical(

tools/Gruntfile.js

@@ -47,6 +47,7 @@ module.exports = function(grunt) {
           js_srcdir + 'input_binding.js',
           js_srcdir + 'input_binding_text.js',
           js_srcdir + 'input_binding_textarea.js',
+          js_srcdir + 'input_binding_password.js',
           js_srcdir + 'input_binding_number.js',
           js_srcdir + 'input_binding_checkbox.js',
           js_srcdir + 'input_binding_slider.js',