mirror of
https://github.com/rstudio/shiny.git
synced 2026-04-07 03:00:20 -04:00
Merge pull request #1209 from wch/bookmarkable-state
Bookmarkable state
This commit is contained in:
Winston Chang
@@ -86,6 +86,9 @@ BugReports: https://github.com/rstudio/shiny/issues
|
||||
VignetteBuilder: knitr
|
||||
Collate:
|
||||
'app.R'
|
||||
'bookmark-state-local.R'
|
||||
'stack.R'
|
||||
'bookmark-state.R'
|
||||
'bootstrap-layout.R'
|
||||
'conditions.R'
|
||||
'map.R'
|
||||
@@ -95,7 +98,6 @@ Collate:
|
||||
'cache.R'
|
||||
'diagnose.R'
|
||||
'fileupload.R'
|
||||
'stack.R'
|
||||
'graph.R'
|
||||
'hooks.R'
|
||||
'html-deps.R'
|
||||
@@ -132,8 +134,10 @@ Collate:
|
||||
'render-plot.R'
|
||||
'render-table.R'
|
||||
'run-url.R'
|
||||
'serializers.R'
|
||||
'server-input-handlers.R'
|
||||
'server.R'
|
||||
'shiny-options.R'
|
||||
'shiny.R'
|
||||
'shinyui.R'
|
||||
'shinywrappers.R'
|
||||
|
||||
17
NAMESPACE
17
NAMESPACE
@@ -40,6 +40,7 @@ export(addResourcePath)
|
||||
export(animationOptions)
|
||||
export(as.shiny.appobj)
|
||||
export(basicPage)
|
||||
export(bookmarkButton)
|
||||
export(bootstrapLib)
|
||||
export(bootstrapPage)
|
||||
export(br)
|
||||
@@ -67,6 +68,7 @@ export(downloadButton)
|
||||
export(downloadHandler)
|
||||
export(downloadLink)
|
||||
export(em)
|
||||
export(enableBookmarking)
|
||||
export(eventReactive)
|
||||
export(exprToFunction)
|
||||
export(extractStackTrace)
|
||||
@@ -82,6 +84,7 @@ export(fluidPage)
|
||||
export(fluidRow)
|
||||
export(formatStackTrace)
|
||||
export(getDefaultReactiveDomain)
|
||||
export(getShinyOption)
|
||||
export(h1)
|
||||
export(h2)
|
||||
export(h3)
|
||||
@@ -107,6 +110,7 @@ export(inputPanel)
|
||||
export(insertUI)
|
||||
export(installExprFunction)
|
||||
export(invalidateLater)
|
||||
export(invalidateReactiveValue)
|
||||
export(is.reactive)
|
||||
export(is.reactivevalues)
|
||||
export(is.shiny.appobj)
|
||||
@@ -133,7 +137,14 @@ export(ns.sep)
|
||||
export(numericInput)
|
||||
export(observe)
|
||||
export(observeEvent)
|
||||
export(onBookmark)
|
||||
export(onBookmarked)
|
||||
export(onFlush)
|
||||
export(onFlushed)
|
||||
export(onReactiveDomainEnded)
|
||||
export(onRestore)
|
||||
export(onRestored)
|
||||
export(onSessionEnded)
|
||||
export(outputOptions)
|
||||
export(p)
|
||||
export(pageWithSidebar)
|
||||
@@ -171,6 +182,7 @@ export(renderText)
|
||||
export(renderUI)
|
||||
export(repeatable)
|
||||
export(req)
|
||||
export(restoreInput)
|
||||
export(runApp)
|
||||
export(runExample)
|
||||
export(runGadget)
|
||||
@@ -181,12 +193,15 @@ export(safeError)
|
||||
export(selectInput)
|
||||
export(selectizeInput)
|
||||
export(serverInfo)
|
||||
export(setBookmarkExclude)
|
||||
export(setProgress)
|
||||
export(shinyApp)
|
||||
export(shinyAppDir)
|
||||
export(shinyAppFile)
|
||||
export(shinyOptions)
|
||||
export(shinyServer)
|
||||
export(shinyUI)
|
||||
export(showBookmarkUrlModal)
|
||||
export(showModal)
|
||||
export(showNotification)
|
||||
export(showReactLog)
|
||||
@@ -222,12 +237,14 @@ export(updateDateRangeInput)
|
||||
export(updateNavbarPage)
|
||||
export(updateNavlistPanel)
|
||||
export(updateNumericInput)
|
||||
export(updateQueryString)
|
||||
export(updateRadioButtons)
|
||||
export(updateSelectInput)
|
||||
export(updateSelectizeInput)
|
||||
export(updateSliderInput)
|
||||
export(updateTabsetPanel)
|
||||
export(updateTextInput)
|
||||
export(urlModal)
|
||||
export(validate)
|
||||
export(validateCssUnit)
|
||||
export(verbatimTextOutput)
|
||||
|
||||
23
R/app.R
23
R/app.R
@@ -75,12 +75,19 @@ shinyApp <- function(ui=NULL, server=NULL, onStart=NULL, options=list(),
|
||||
server
|
||||
}
|
||||
|
||||
# Store the appDir and bookmarking-related options, so that we can read them
|
||||
# from within the app.
|
||||
shinyOptions(appDir = getwd())
|
||||
appOptions <- consumeAppOptions()
|
||||
|
||||
structure(
|
||||
list(
|
||||
httpHandler = httpHandler,
|
||||
serverFuncSource = serverFuncSource,
|
||||
onStart = onStart,
|
||||
options = options),
|
||||
options = options,
|
||||
appOptions = appOptions
|
||||
),
|
||||
class = "shiny.appobj"
|
||||
)
|
||||
}
|
||||
@@ -112,7 +119,9 @@ 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)
|
||||
|
||||
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)
|
||||
@@ -177,6 +186,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
|
||||
}
|
||||
}
|
||||
|
||||
shinyOptions(appDir = appDir)
|
||||
|
||||
oldwd <- NULL
|
||||
monitorHandle <- NULL
|
||||
onStart <- function() {
|
||||
@@ -198,7 +209,8 @@ shinyAppDir_serverR <- function(appDir, options=list()) {
|
||||
serverFuncSource = serverFuncSource,
|
||||
onStart = onStart,
|
||||
onEnd = onEnd,
|
||||
options = options),
|
||||
options = options
|
||||
),
|
||||
class = "shiny.appobj"
|
||||
)
|
||||
}
|
||||
@@ -251,7 +263,8 @@ initAutoReloadMonitor <- function(dir) {
|
||||
|
||||
# This reads in an app dir for a single-file application (e.g. app.R), and
|
||||
# returns a shiny.appobj.
|
||||
shinyAppDir_appR <- function(fileName, appDir, options=list()) {
|
||||
shinyAppDir_appR <- function(fileName, appDir, options=list())
|
||||
{
|
||||
fullpath <- file.path.ci(appDir, fileName)
|
||||
|
||||
# This sources app.R and caches the content. When appObj() is called but
|
||||
@@ -264,6 +277,8 @@ shinyAppDir_appR <- function(fileName, appDir, options=list()) {
|
||||
if (!is.shiny.appobj(result))
|
||||
stop("app.R did not return a shiny.appobj object.")
|
||||
|
||||
unconsumeAppOptions(result$appOptions)
|
||||
|
||||
return(result)
|
||||
}
|
||||
)
|
||||
|
||||
28
R/bookmark-state-local.R
Normal file
28
R/bookmark-state-local.R
Normal file
@@ -0,0 +1,28 @@
|
||||
# Function wrappers for saving and restoring state to/from disk 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.
|
||||
|
||||
saveInterfaceLocal <- function(id, callback) {
|
||||
# Try to save in app directory
|
||||
appDir <- getShinyOption("appDir", default = getwd())
|
||||
|
||||
stateDir <- file.path(appDir, "shiny_bookmarks", id)
|
||||
if (!dirExists(stateDir))
|
||||
dir.create(stateDir, recursive = TRUE)
|
||||
|
||||
callback(stateDir)
|
||||
}
|
||||
|
||||
loadInterfaceLocal <- function(id, callback) {
|
||||
# Try to load from app directory
|
||||
appDir <- getShinyOption("appDir", default = getwd())
|
||||
|
||||
stateDir <- file.path(appDir, "shiny_bookmarks", id)
|
||||
callback(stateDir)
|
||||
}
|
||||
995
R/bookmark-state.R
Normal file
995
R/bookmark-state.R
Normal file
@@ -0,0 +1,995 @@
|
||||
#' @include stack.R
|
||||
NULL
|
||||
|
||||
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,
|
||||
|
||||
|
||||
initialize = function(input = NULL, exclude = NULL, onSave = NULL) {
|
||||
self$input <- input
|
||||
self$exclude <- exclude
|
||||
self$onSave <- onSave
|
||||
private$values_ <- new.env(parent = emptyenv())
|
||||
}
|
||||
),
|
||||
|
||||
active = list(
|
||||
# `values` looks to the outside world like an environment for storing
|
||||
# arbitrary values. Two things to note: (1) This is an environment (instead
|
||||
# of, say, a list) because if the onSave function represents multiple
|
||||
# callback functions (when onBookmark is called multiple times), each
|
||||
# callback can change `values`, and if we used a list, one of the callbacks
|
||||
# could easily obliterate values set by another. This can happen when using
|
||||
# modules that have an onBookmark function. (2) The purpose of the active
|
||||
# binding is to prevent replacing state$values with another arbitrary
|
||||
# object. (Simply locking the binding would prevent all changes to
|
||||
# state$values.)
|
||||
values = function(value) {
|
||||
if (missing(value))
|
||||
return(private$values_)
|
||||
|
||||
if (identical(value, private$values_)) {
|
||||
return(value)
|
||||
} else {
|
||||
stop("Items in `values` can be changed, but `values` itself cannot be replaced.")
|
||||
}
|
||||
}
|
||||
),
|
||||
|
||||
private = list(
|
||||
values_ = NULL
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
# Save a state to disk. Returns a query string which can be used to restore the
|
||||
# session.
|
||||
saveShinySaveState <- function(state) {
|
||||
id <- createUniqueId(8)
|
||||
|
||||
# A function for saving the state object to disk, given a directory to save
|
||||
# to.
|
||||
saveState <- function(stateDir) {
|
||||
state$dir <- stateDir
|
||||
|
||||
# Allow user-supplied onSave function to do things like add state$values, or
|
||||
# save data to state dir.
|
||||
if (!is.null(state$onSave))
|
||||
isolate(state$onSave(state))
|
||||
|
||||
# Serialize values, possibly saving some extra data to stateDir
|
||||
inputValues <- serializeReactiveValues(state$input, state$exclude, state$dir)
|
||||
saveRDS(inputValues, file.path(stateDir, "input.rds"))
|
||||
|
||||
# If values were added, save them also.
|
||||
if (length(state$values) != 0)
|
||||
saveRDS(state$values, file.path(stateDir, "values.rds"))
|
||||
}
|
||||
|
||||
# Pass the saveState function to the save interface function, which will
|
||||
# invoke saveState after preparing the directory.
|
||||
saveInterface <- getShinyOption("save.interface", default = saveInterfaceLocal)
|
||||
saveInterface(id, saveState)
|
||||
|
||||
paste0("_state_id_=", encodeURIComponent(id))
|
||||
}
|
||||
|
||||
# Encode the state to a URL. This does not save to disk.
|
||||
encodeShinySaveState <- function(state) {
|
||||
inputVals <- serializeReactiveValues(state$input, state$exclude, stateDir = NULL)
|
||||
|
||||
# Allow user-supplied onSave function to do things like add state$values.
|
||||
if (!is.null(state$onSave))
|
||||
isolate(state$onSave(state))
|
||||
|
||||
inputVals <- vapply(inputVals,
|
||||
function(x) toJSON(x, strict_atomic = FALSE),
|
||||
character(1),
|
||||
USE.NAMES = TRUE
|
||||
)
|
||||
|
||||
res <- paste0("_inputs_&",
|
||||
paste0(
|
||||
encodeURIComponent(names(inputVals)),
|
||||
"=",
|
||||
encodeURIComponent(inputVals),
|
||||
collapse = "&"
|
||||
)
|
||||
)
|
||||
|
||||
# If 'values' is present, add them as well.
|
||||
if (length(state$values) != 0) {
|
||||
values <- vapply(state$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 will be set to TRUE if there's actually a state to restore
|
||||
active = FALSE,
|
||||
|
||||
# This is set to an error message string in case there was an initialization
|
||||
# error. Later, after the app has started on the client, the server can send
|
||||
# this message as a notification on the client.
|
||||
initErrorMessage = NULL,
|
||||
|
||||
# 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 state that was saved to disk.
|
||||
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) {
|
||||
self$reset() # Need this to initialize self$input
|
||||
|
||||
if (!is.null(queryString) && nzchar(queryString)) {
|
||||
tryCatch(
|
||||
withLogErrors({
|
||||
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 saved state and
|
||||
# ignore other key/value pairs. If not, restore from key/value
|
||||
# pairs in the query string.
|
||||
self$active <- TRUE
|
||||
private$loadStateQueryString(queryString)
|
||||
|
||||
} else {
|
||||
# The query string contains the saved keys and values
|
||||
self$active <- TRUE
|
||||
private$decodeStateQueryString(queryString)
|
||||
}
|
||||
}),
|
||||
error = function(e) {
|
||||
# If there's an error in restoring problem, just reset these values
|
||||
self$reset()
|
||||
self$initErrorMessage <- e$message
|
||||
warning(e$message)
|
||||
}
|
||||
)
|
||||
}
|
||||
},
|
||||
|
||||
reset = function() {
|
||||
self$active <- FALSE
|
||||
self$initErrorMessage <- NULL
|
||||
self$input <- RestoreInputSet$new(list())
|
||||
self$values <- new.env(parent = emptyenv())
|
||||
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 saved state with that ID.
|
||||
loadStateQueryString = function(queryString) {
|
||||
values <- parseQueryString(queryString, nested = TRUE)
|
||||
id <- values[["_state_id_"]]
|
||||
|
||||
# Check that id has only alphanumeric chars
|
||||
if (grepl("[^a-zA-Z0-9]", id)) {
|
||||
stop("Invalid state id: ", 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
|
||||
|
||||
if (!dirExists(stateDir)) {
|
||||
stop("Bookmarked state directory does not exist.")
|
||||
}
|
||||
|
||||
tryCatch({
|
||||
inputValues <- readRDS(file.path(stateDir, "input.rds"))
|
||||
self$input <- RestoreInputSet$new(inputValues)
|
||||
},
|
||||
error = function(e) {
|
||||
stop("Error reading input values file.")
|
||||
}
|
||||
)
|
||||
|
||||
valuesFile <- file.path(stateDir, "values.rds")
|
||||
if (file.exists(valuesFile)) {
|
||||
tryCatch({
|
||||
self$values <- readRDS(valuesFile)
|
||||
},
|
||||
error = function(e) {
|
||||
stop("Error reading values file.")
|
||||
}
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
loadInterface <- getShinyOption("load.interface", default = loadInterfaceLocal)
|
||||
loadInterface(id, loadFun)
|
||||
|
||||
invisible()
|
||||
},
|
||||
|
||||
# Given a query string with values encoded in it, restore saved state
|
||||
# from those values.
|
||||
decodeStateQueryString = function(queryString) {
|
||||
# Remove leading '?'
|
||||
if (substr(queryString, 1, 1) == '?')
|
||||
queryString <- substr(queryString, 2, nchar(queryString))
|
||||
|
||||
|
||||
# Error if multiple '_inputs_' or '_values_'. This is needed because
|
||||
# strsplit won't add an entry if the search pattern is at the end of a
|
||||
# string.
|
||||
if (length(gregexpr("(^|&)_inputs_(&|$)", queryString)[[1]]) > 1)
|
||||
stop("Invalid state string: more than one '_inputs_' found")
|
||||
if (length(gregexpr("(^|&)_values_(&|$)", queryString)[[1]]) > 1)
|
||||
stop("Invalid state string: more than one '_values_' found")
|
||||
|
||||
# Look for _inputs_ and store following content in inputStr
|
||||
splitStr <- strsplit(queryString, "(^|&)_inputs_(&|$)")[[1]]
|
||||
if (length(splitStr) == 2) {
|
||||
inputStr <- splitStr[2]
|
||||
# Remove any _values_ (and content after _values_) that may come after
|
||||
# _inputs_
|
||||
inputStr <- strsplit(inputStr, "(^|&)_values_(&|$)")[[1]][1]
|
||||
|
||||
} else {
|
||||
inputStr <- ""
|
||||
}
|
||||
|
||||
# Look for _values_ and store following content in valueStr
|
||||
splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
|
||||
if (length(splitStr) == 2) {
|
||||
valueStr <- splitStr[2]
|
||||
# Remove any _inputs_ (and content after _inputs_) that may come after
|
||||
# _values_
|
||||
valueStr <- strsplit(valueStr, "(^|&)_inputs_(&|$)")[[1]][1]
|
||||
|
||||
} else {
|
||||
valueStr <- ""
|
||||
}
|
||||
|
||||
|
||||
inputs <- parseQueryString(inputStr, 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, "\"")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
inputs <- valuesFromJSON(inputs)
|
||||
self$input <- RestoreInputSet$new(inputs)
|
||||
|
||||
values <- valuesFromJSON(values)
|
||||
self$values <- list2env(values, self$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 <- list2env(values, parent = emptyenv())
|
||||
},
|
||||
|
||||
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. It should be
|
||||
#' called early on inside of input functions (like \code{\link{textInput}}).
|
||||
#'
|
||||
#' @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 (!hasCurrentRestoreContext()) {
|
||||
return(default)
|
||||
}
|
||||
|
||||
oldInputs <- getCurrentRestoreContext()$input
|
||||
if (oldInputs$available(id)) {
|
||||
oldInputs$get(id)
|
||||
} else {
|
||||
default
|
||||
}
|
||||
}
|
||||
|
||||
#' Update URL in browser's location bar
|
||||
#'
|
||||
#' This function updates the client browser's query string in the location bar.
|
||||
#' It typically is called from an observer.
|
||||
#'
|
||||
#' @param queryString The new query string to show in the location bar.
|
||||
#' @param session A Shiny session object.
|
||||
#' @export
|
||||
updateQueryString <- function(queryString, session = getDefaultReactiveDomain()) {
|
||||
session$updateQueryString(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.
|
||||
#'
|
||||
#' @param title A tooltip that is shown when the mouse cursor hovers over the
|
||||
#' button.
|
||||
#'
|
||||
#' @seealso enableBookmarking
|
||||
#' @inheritParams actionButton
|
||||
#' @export
|
||||
bookmarkButton <- function(label = "Bookmark...",
|
||||
icon = shiny::icon("link", lib = "glyphicon"),
|
||||
title = "Bookmark this application's state and get a URL for sharing.",
|
||||
...)
|
||||
{
|
||||
actionButton("._bookmark_", 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 = "Bookmarked application link", subtitle = NULL) {
|
||||
|
||||
subtitleTag <- tagList(
|
||||
br(),
|
||||
span(class = "text-muted", subtitle),
|
||||
span(id = "shiny-bookmark-copy-text", class = "text-muted")
|
||||
)
|
||||
|
||||
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();
|
||||
});
|
||||
$('#shiny-bookmark-copy-text')
|
||||
.text(function() {
|
||||
if (/Mac/i.test(navigator.userAgent)) {
|
||||
return 'Press \u2318-C to copy.';
|
||||
} else {
|
||||
return 'Press Ctrl-C to copy.';
|
||||
}
|
||||
});
|
||||
"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' Display a modal dialog for bookmarking
|
||||
#'
|
||||
#' This is a wrapper function for \code{\link{urlModal}} that is automatically
|
||||
#' called if an application is bookmarked but no other \code{\link{onBookmark}}
|
||||
#' callback was set. It displays a modal dialog with the bookmark URL, along
|
||||
#' with a subtitle that is appropriate for the type of bookmarking used ("url"
|
||||
#' or "server").
|
||||
#'
|
||||
#' @param url A URL to show in the modal dialog.
|
||||
#' @export
|
||||
showBookmarkUrlModal <- function(url) {
|
||||
store <- getShinyOption("bookmarkStore", default = "")
|
||||
if (store == "url") {
|
||||
subtitle <- "This link stores the current state of this application."
|
||||
} else if (store == "server") {
|
||||
subtitle <- "The current state of this application has been stored on the server."
|
||||
} else {
|
||||
subtitle <- NULL
|
||||
}
|
||||
|
||||
showModal(urlModal(url, subtitle = subtitle))
|
||||
}
|
||||
|
||||
#' Enable bookmarking for a Shiny application
|
||||
#'
|
||||
#' @description
|
||||
#'
|
||||
#' There are two types of bookmarking: saving an application's state to disk on
|
||||
#' the server, and encoding the application's state in a URL. For state that has
|
||||
#' been saved to disk, the state can be restored with the corresponding state
|
||||
#' ID. For URL-encoded state, the state of the application is encoded in the
|
||||
#' URL, and no server-side storage is needed.
|
||||
#'
|
||||
#' URL-encoded bookmarking is appropriate for applications where there not many
|
||||
#' input values that need to be recorded. Some browsers have a length limit for
|
||||
#' URLs of about 2000 characters, and if there are many inputs, the length of
|
||||
#' the URL can exceed that limit.
|
||||
#'
|
||||
#' Saved-on-server bookmarking is appropriate when there are many inputs, or
|
||||
#' when the bookmarked state requires storing files.
|
||||
#'
|
||||
#' @details
|
||||
#'
|
||||
#' For restoring state to work properly, the UI must be a function that takes
|
||||
#' one argument, \code{request}. In most Shiny applications, the UI is not a
|
||||
#' function; it might have the form \code{fluidPage(....)}. Converting it to a
|
||||
#' function is as simple as wrapping it in a function, as in
|
||||
#' \code{function(request) \{ fluidPage(....) \}}.
|
||||
#'
|
||||
#' By default, all input values will be bookmarked, except for the values of
|
||||
#' actionButtons and passwordInputs. fileInputs will be saved if the state is
|
||||
#' saved on a server, but not if the state is encoded in a URL.
|
||||
#'
|
||||
#' When bookmarking state, arbitrary values can be stored, by passing a function
|
||||
#' as the \code{onBookmark} argument. That function will be passed a
|
||||
#' \code{ShinySaveState} object. The \code{values} field of the object is a list
|
||||
#' which can be manipulated to save extra information. Additionally, if the
|
||||
#' state is being saved on the server, and the \code{dir} field of that object
|
||||
#' can be used to save extra information to files in that directory.
|
||||
#'
|
||||
#' For saved-to-server state, this is how the state directory is chosen:
|
||||
#' \itemize{
|
||||
#' \item If running in a hosting environment such as Shiny Server or
|
||||
#' Connect, the hosting environment will choose the directory.
|
||||
#' \item If running an app in a directory with \code{\link{runApp}()}, the
|
||||
#' saved states will be saved in a subdirectory of the app called
|
||||
#' shiny_bookmarks.
|
||||
#' \item If running a Shiny app object that is generated from code (not run
|
||||
#' from a directory), the saved states will be saved in a subdirectory of
|
||||
#' the current working directory called shiny_bookmarks.
|
||||
#' }
|
||||
#'
|
||||
#' @param store Either \code{"url"}, which encodes all of the relevant values in
|
||||
#' a URL, \code{"server"}, which saves to disk on the server, or
|
||||
#' \code{"disable"}, which disables any previously-enabled bookmarking.
|
||||
#'
|
||||
#' @seealso \code{\link{onBookmark}}, \code{\link{onRestore}}, and
|
||||
#' \code{\link{onRestored}} for registering callback functions that are
|
||||
#' invoked when the state is bookmarked or restored.
|
||||
#'
|
||||
#' @export
|
||||
#' @examples
|
||||
#' ## Only run these examples in interactive R sessions
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' # Basic example with state encoded in URL
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' textInput("txt", "Text"),
|
||||
#' checkboxInput("chk", "Checkbox"),
|
||||
#' bookmarkButton("bookmark")
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) { }
|
||||
#' enableBookmarking("url")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # Basic example with state saved to disk
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' textInput("txt", "Text"),
|
||||
#' checkboxInput("chk", "Checkbox"),
|
||||
#' bookmarkButton("bookmark")
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) { }
|
||||
#' enableBookmarking("server")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # Save/restore arbitrary values
|
||||
#' ui <- function(req) {
|
||||
#' fluidPage(
|
||||
#' textInput("txt", "Text"),
|
||||
#' checkboxInput("chk", "Checkbox"),
|
||||
#' bookmarkButton(),
|
||||
#' br(),
|
||||
#' textOutput("lastSaved")
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) {
|
||||
#' vals <- reactiveValues(savedTime = NULL)
|
||||
#' output$lastSaved <- renderText({
|
||||
#' if (!is.null(vals$savedTime))
|
||||
#' paste("Last saved at", vals$savedTime)
|
||||
#' else
|
||||
#' ""
|
||||
#' })
|
||||
#'
|
||||
#' onBookmark(function(state) {
|
||||
#' vals$savedTime <- Sys.time()
|
||||
#' # state is a mutable reference object, and we can add arbitrary values
|
||||
#' # to it.
|
||||
#' state$values$time <- vals$savedTime
|
||||
#' })
|
||||
#' onRestore(function(state) {
|
||||
#' vals$savedTime <- state$values$time
|
||||
#' })
|
||||
#' }
|
||||
#' enableBookmarking(store = "url")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # Usable with dynamic UI (set the slider, then change the text input,
|
||||
#' # click the bookmark button)
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' sliderInput("slider", "Slider", 1, 100, 50),
|
||||
#' uiOutput("ui"),
|
||||
#' bookmarkButton("bookmark")
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) {
|
||||
#' output$ui <- renderUI({
|
||||
#' textInput("txt", "Text", input$slider)
|
||||
#' })
|
||||
#' }
|
||||
#' enableBookmarking("url")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # Exclude specific inputs (The only input that will be saved in this
|
||||
#' # example is chk)
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' passwordInput("pw", "Password"), # Passwords are never saved
|
||||
#' sliderInput("slider", "Slider", 1, 100, 50), # Manually excluded below
|
||||
#' checkboxInput("chk", "Checkbox"),
|
||||
#' bookmarkButton("bookmark")
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) {
|
||||
#' setBookmarkExclude("slider")
|
||||
#' }
|
||||
#' enableBookmarking("url")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # Save/restore uploaded files
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' sidebarLayout(
|
||||
#' sidebarPanel(
|
||||
#' fileInput("file1", "Choose CSV File", multiple = TRUE,
|
||||
#' accept = c(
|
||||
#' "text/csv",
|
||||
#' "text/comma-separated-values,text/plain",
|
||||
#' ".csv"
|
||||
#' )
|
||||
#' ),
|
||||
#' tags$hr(),
|
||||
#' checkboxInput("header", "Header", TRUE),
|
||||
#' bookmarkButton("bookmark")
|
||||
#' ),
|
||||
#' mainPanel(
|
||||
#' tableOutput("contents")
|
||||
#' )
|
||||
#' )
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output) {
|
||||
#' output$contents <- renderTable({
|
||||
#' inFile <- input$file1
|
||||
#' if (is.null(inFile))
|
||||
#' return(NULL)
|
||||
#'
|
||||
#' if (nrow(inFile) == 1) {
|
||||
#' read.csv(inFile$datapath, header = input$header)
|
||||
#' } else {
|
||||
#' data.frame(x = "multiple files")
|
||||
#' }
|
||||
#' })
|
||||
#' }
|
||||
#' enableBookmarking("server")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#' }
|
||||
enableBookmarking <- function(store = c("url", "server", "disable")) {
|
||||
store <- match.arg(store)
|
||||
shinyOptions(bookmarkStore = store)
|
||||
}
|
||||
|
||||
|
||||
#' Exclude inputs from bookmarking
|
||||
#'
|
||||
#' This function tells Shiny which inputs should be excluded from bookmarking.
|
||||
#' It should be called from inside the application's server function.
|
||||
#'
|
||||
#' This function can also be called from a module's server function, in which
|
||||
#' case it will exclude inputs with the specified names, from that module. It
|
||||
#' will not affect inputs from other modules or from the top level of the Shiny
|
||||
#' application.
|
||||
#'
|
||||
#' @param names A character vector containing names of inputs to exclude from
|
||||
#' bookmarking.
|
||||
#' @param session A shiny session object.
|
||||
#' @seealso \code{\link{enableBookmarking}} for examples.
|
||||
#' @export
|
||||
setBookmarkExclude <- function(names = character(0), session = getDefaultReactiveDomain()) {
|
||||
session$setBookmarkExclude(names)
|
||||
}
|
||||
|
||||
|
||||
#' Add callbacks for Shiny session bookmarking events
|
||||
#'
|
||||
#' @description
|
||||
#'
|
||||
#' These functions are for registering callbacks on Shiny session events. They
|
||||
#' should be called within an application's server function.
|
||||
#'
|
||||
#' \itemize{
|
||||
#' \item \code{onBookmark} registers a function that will be called just
|
||||
#' before Shiny bookmarks state.
|
||||
#' \item \code{onRestore} registers a function that will be called when a
|
||||
#' session is restored, after the server function executes, but before all
|
||||
#' other reactives, observers and render functions are run.
|
||||
#' \item \code{onRestored} registers a function that will be called after a
|
||||
#' session is restored. This is similar to \code{onRestore}, but it will be
|
||||
#' called after all reactives, observers, and render functions run, and
|
||||
#' after results are sent to the client browser. \code{onRestored}
|
||||
#' callbacks can be useful for sending update messages to the client
|
||||
#' browser.
|
||||
#' }
|
||||
#'
|
||||
#' @details
|
||||
#'
|
||||
#' All of these functions return a function which can be called with no
|
||||
#' arguments to cancel the registration.
|
||||
#'
|
||||
#' The callback function that is passed to these functions should take one
|
||||
#' argument, typically named "state" (for \code{onBookmark}, \code{onRestore},
|
||||
#' and \code{onRestored}) or "url" (for \code{onBookmarked}).
|
||||
#'
|
||||
#' For \code{onBookmark}, the state object has three relevant fields. The
|
||||
#' \code{values} field is an environment which can be used to save arbitrary
|
||||
#' values (see examples). If the state is being saved to disk (as opposed to
|
||||
#' being encoded in a URL), the \code{dir} field contains the name of a
|
||||
#' directory which can be used to store extra files. Finally, the state object
|
||||
#' has an \code{input} field, which is simply the application's \code{input}
|
||||
#' object. It can be read, but not modified.
|
||||
#'
|
||||
#' For \code{onRestore} and \code{onRestored}, the state object is a list. This
|
||||
#' list contains \code{input}, which is a named list of input values to restore,
|
||||
#' \code{values}, which is an environment containing arbitrary values that were
|
||||
#' saved in \code{onBookmark}, and \code{dir}, the name of the directory that
|
||||
#' the state is being restored from, and which could have been used to save
|
||||
#' extra files.
|
||||
#'
|
||||
#' For \code{onBookmarked}, the callback function receives a string with the
|
||||
#' bookmark URL. This callback function should be used to display UI in the
|
||||
#' client browser with the bookmark URL. If no callback function is registered,
|
||||
#' then Shiny will by default display a modal dialog with the bookmark URL.
|
||||
#'
|
||||
#' @section Modules:
|
||||
#'
|
||||
#' These callbacks may also be used in Shiny modules. When used this way, the
|
||||
#' inputs and values will automatically be namespaced for the module, and the
|
||||
#' callback functions registered for the module will only be able to see the
|
||||
#' module's inputs and values.
|
||||
#'
|
||||
#' @param fun A callback function which takes one argument.
|
||||
#' @param session A shiny session object.
|
||||
#' @seealso enableBookmarking for general information on bookmarking.
|
||||
#'
|
||||
#' @examples
|
||||
#' ## Only run these examples in interactive sessions
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' # Basic use of onBookmark and onRestore: This app saves the time in its
|
||||
#' # arbitrary values, and restores that time when the app is restored.
|
||||
#' ui <- function(req) {
|
||||
#' fluidPage(
|
||||
#' textInput("txt", "Input text"),
|
||||
#' bookmarkButton()
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output) {
|
||||
#' onBookmark(function(state) {
|
||||
#' savedTime <- as.character(Sys.time())
|
||||
#' cat("Last saved at", savedTime, "\n")
|
||||
#' # state is a mutable reference object, and we can add arbitrary values to
|
||||
#' # it.
|
||||
#' state$values$time <- savedTime
|
||||
#' })
|
||||
#'
|
||||
#' onRestore(function(state) {
|
||||
#' cat("Restoring from state bookmarked at", state$values$time, "\n")
|
||||
#' })
|
||||
#' }
|
||||
#' enableBookmarking("url")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#'
|
||||
# This app illustrates two things: saving values in a file using state$dir, and
|
||||
# using an onRestored callback to call an input updater function. (In real use
|
||||
# cases, it probably makes sense to save content to a file only if it's much
|
||||
# larger.)
|
||||
#' ui <- function(req) {
|
||||
#' fluidPage(
|
||||
#' textInput("txt", "Input text"),
|
||||
#' bookmarkButton()
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) {
|
||||
#' lastUpdateTime <- NULL
|
||||
#'
|
||||
#' observeEvent(input$txt, {
|
||||
#' updateTextInput(session, "txt",
|
||||
#' label = paste0("Input text (Changed ", as.character(Sys.time()), ")")
|
||||
#' )
|
||||
#' })
|
||||
#'
|
||||
#' onBookmark(function(state) {
|
||||
#' # Save content to a file
|
||||
#' messageFile <- file.path(state$dir, "message.txt")
|
||||
#' cat(as.character(Sys.time()), file = messageFile)
|
||||
#' })
|
||||
#'
|
||||
#' onRestored(function(state) {
|
||||
#' # Read the file
|
||||
#' messageFile <- file.path(state$dir, "message.txt")
|
||||
#' timeText <- readChar(messageFile, 1000)
|
||||
#'
|
||||
#' # updateTextInput must be called in onRestored, as opposed to onRestore,
|
||||
#' # because onRestored happens after the client browser is ready.
|
||||
#' updateTextInput(session, "txt",
|
||||
#' label = paste0("Input text (Changed ", timeText, ")")
|
||||
#' )
|
||||
#' })
|
||||
#' }
|
||||
#' # "server" bookmarking is needed for writing to disk.
|
||||
#' enableBookmarking("server")
|
||||
#' shinyApp(ui, server)
|
||||
#'
|
||||
#'
|
||||
#' # This app has a module, and both the module and the main app code have
|
||||
#' # onBookmark and onRestore functions which write and read state$values$hash. The
|
||||
#' # module's version of state$values$hash does not conflict with the app's version
|
||||
#' # of state$values$hash.
|
||||
#' #
|
||||
#' # A basic module that captializes text.
|
||||
#' capitalizerUI <- function(id) {
|
||||
#' ns <- NS(id)
|
||||
#' wellPanel(
|
||||
#' h4("Text captializer module"),
|
||||
#' textInput(ns("text"), "Enter text:"),
|
||||
#' verbatimTextOutput(ns("out"))
|
||||
#' )
|
||||
#' }
|
||||
#' capitalizerServer <- function(input, output, session) {
|
||||
#' output$out <- renderText({
|
||||
#' toupper(input$text)
|
||||
#' })
|
||||
#' onBookmark(function(state) {
|
||||
#' state$values$hash <- digest::digest(input$text, "md5")
|
||||
#' })
|
||||
#' onRestore(function(state) {
|
||||
#' if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
|
||||
#' message("Module's input text matches hash ", state$values$hash)
|
||||
#' } else {
|
||||
#' message("Module's input text does not match hash ", state$values$hash)
|
||||
#' }
|
||||
#' })
|
||||
#' }
|
||||
#' # Main app code
|
||||
#' ui <- function(request) {
|
||||
#' fluidPage(
|
||||
#' sidebarLayout(
|
||||
#' sidebarPanel(
|
||||
#' capitalizerUI("tc"),
|
||||
#' textInput("text", "Enter text (not in module):"),
|
||||
#' bookmarkButton()
|
||||
#' ),
|
||||
#' mainPanel()
|
||||
#' )
|
||||
#' )
|
||||
#' }
|
||||
#' server <- function(input, output, session) {
|
||||
#' callModule(capitalizerServer, "tc")
|
||||
#' onBookmark(function(state) {
|
||||
#' state$values$hash <- digest::digest(input$text, "md5")
|
||||
#' })
|
||||
#' onRestore(function(state) {
|
||||
#' if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
|
||||
#' message("App's input text matches hash ", state$values$hash)
|
||||
#' } else {
|
||||
#' message("App's input text does not match hash ", state$values$hash)
|
||||
#' }
|
||||
#' })
|
||||
#' }
|
||||
#' enableBookmarking(store = "url")
|
||||
#' shinyApp(ui, server)
|
||||
#' }
|
||||
#' @export
|
||||
onBookmark <- function(fun, session = getDefaultReactiveDomain()) {
|
||||
session$onBookmark(fun)
|
||||
}
|
||||
|
||||
#' @rdname onBookmark
|
||||
#' @export
|
||||
onBookmarked <- function(fun, session = getDefaultReactiveDomain()) {
|
||||
session$onBookmarked(fun)
|
||||
}
|
||||
|
||||
#' @rdname onBookmark
|
||||
#' @export
|
||||
onRestore <- function(fun, session = getDefaultReactiveDomain()) {
|
||||
session$onRestore(fun)
|
||||
}
|
||||
|
||||
#' @rdname onBookmark
|
||||
#' @export
|
||||
onRestored <- function(fun, session = getDefaultReactiveDomain()) {
|
||||
session$onRestored(fun)
|
||||
}
|
||||
@@ -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"
|
||||
|
||||
@@ -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))
|
||||
|
||||
@@ -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",
|
||||
|
||||
@@ -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",
|
||||
|
||||
@@ -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",
|
||||
|
||||
@@ -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))
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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),
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
153
R/reactives.R
153
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
|
||||
}
|
||||
@@ -318,7 +364,23 @@ as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
|
||||
#' isolate(reactiveValuesToList(values))
|
||||
#' @export
|
||||
reactiveValuesToList <- function(x, all.names=FALSE) {
|
||||
.subset2(x, 'impl')$toList(all.names)
|
||||
# Default case
|
||||
res <- .subset2(x, 'impl')$toList(all.names)
|
||||
|
||||
prefix <- .subset2(x, 'ns')("")
|
||||
# Special handling for namespaces
|
||||
if (nzchar(prefix)) {
|
||||
fullNames <- names(res)
|
||||
|
||||
# Filter out items that match namespace
|
||||
fullNames <- fullNames[substring(fullNames, 1, nchar(prefix)) == prefix]
|
||||
res <- res[fullNames]
|
||||
|
||||
# Remove namespace prefix
|
||||
names(res) <- substring(fullNames, nchar(prefix) + 1)
|
||||
}
|
||||
|
||||
res
|
||||
}
|
||||
|
||||
# This function is needed because str() on a reactivevalues object will call
|
||||
@@ -332,6 +394,67 @@ 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}}
|
||||
#' @examples
|
||||
#' ## Only run this examples in interactive R sessions
|
||||
#' if (interactive()) {
|
||||
#'
|
||||
#' ui <- fluidPage(
|
||||
#' selectInput("data", "Data Set", c("mtcars", "pressure")),
|
||||
#' checkboxGroupInput("cols", "Columns (select 2)", character(0)),
|
||||
#' plotOutput("plot")
|
||||
#' )
|
||||
#'
|
||||
#' server <- function(input, output, session) {
|
||||
#' observe({
|
||||
#' data <- get(input$data)
|
||||
#' # Sets a flag on input$cols to essentially do req(FALSE) if input$cols
|
||||
#' # is accessed. Without this, an error will momentarily show whenever a
|
||||
#' # new data set is selected.
|
||||
#' invalidateReactiveValue(input, "cols")
|
||||
#' updateCheckboxGroupInput(session, "cols", choices = names(data))
|
||||
#' })
|
||||
#'
|
||||
#' output$plot <- renderPlot({
|
||||
#' # When a new data set is selected, input$cols will have been invalidated
|
||||
#' # above, and this will essentially do the same as req(FALSE), causing
|
||||
#' # this observer to stop and raise a silent exception.
|
||||
#' cols <- input$cols
|
||||
#' data <- get(input$data)
|
||||
#'
|
||||
#' if (length(cols) == 2) {
|
||||
#' plot(data[[ cols[1] ]], data[[ cols[2] ]])
|
||||
#' }
|
||||
#' })
|
||||
#' }
|
||||
#'
|
||||
#' shinyApp(ui, server)
|
||||
#' }
|
||||
#' @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(
|
||||
@@ -559,7 +682,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")
|
||||
}
|
||||
|
||||
@@ -570,7 +693,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
|
||||
@@ -914,9 +1037,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
|
||||
|
||||
72
R/serializers.R
Normal file
72
R/serializers.R
Normal file
@@ -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
|
||||
}
|
||||
@@ -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
|
||||
})
|
||||
|
||||
212
R/server.R
212
R/server.R
@@ -230,121 +230,138 @@ 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)) {
|
||||
bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
|
||||
if (bookmarkStore == "disable") {
|
||||
# If bookmarking is disabled, use empty context
|
||||
shinysession$restoreContext <- RestoreContext$new()
|
||||
} else {
|
||||
# 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 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
|
||||
})
|
||||
})
|
||||
})
|
||||
}
|
||||
@@ -569,6 +586,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'
|
||||
@@ -685,6 +707,12 @@ runApp <- function(appDir=getwd(),
|
||||
}
|
||||
|
||||
appParts <- as.shiny.appobj(appDir)
|
||||
|
||||
# Extract appOptions (which is a list) and store them as shinyOptions, for
|
||||
# this app. (This is the only place we have to store settings that are
|
||||
# accessible both the UI and server portion of the app.)
|
||||
unconsumeAppOptions(appParts$appOptions)
|
||||
|
||||
# Set up the onEnd before we call onStart, so that it gets called even if an
|
||||
# error happens in onStart.
|
||||
if (!is.null(appParts$onEnd))
|
||||
|
||||
83
R/shiny-options.R
Normal file
83
R/shiny-options.R
Normal file
@@ -0,0 +1,83 @@
|
||||
.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
|
||||
}
|
||||
|
||||
|
||||
# Get specific shiny options and put them in a list, reset those shiny options,
|
||||
# and then return the options list. This should be during the creation of a
|
||||
# shiny app object, which happens before another option frame is added to the
|
||||
# options stack (the new option frame is added when the app is run). This
|
||||
# function "consumes" the options when the shinyApp object is created, so the
|
||||
# options won't affect another app that is created later.
|
||||
consumeAppOptions <- function() {
|
||||
options <- list(
|
||||
appDir = getwd(),
|
||||
bookmarkStore = getShinyOption("bookmarkStore")
|
||||
)
|
||||
|
||||
shinyOptions(appDir = NULL, bookmarkStore = NULL)
|
||||
|
||||
options
|
||||
}
|
||||
|
||||
# Do the inverse of consumeAppOptions. This should be called once the app is
|
||||
# started.
|
||||
unconsumeAppOptions <- function(options) {
|
||||
if (!is.null(options)) {
|
||||
do.call(shinyOptions, options)
|
||||
}
|
||||
}
|
||||
377
R/shiny.R
377
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, ...)
|
||||
@@ -331,6 +335,7 @@ NS <- function(namespace, id = NULL) {
|
||||
#' @export
|
||||
ns.sep <- "-"
|
||||
|
||||
|
||||
#' @include utils.R
|
||||
ShinySession <- R6Class(
|
||||
'ShinySession',
|
||||
@@ -344,7 +349,7 @@ ShinySession <- R6Class(
|
||||
.outputs = list(), # Keeps track of all the output observer objects
|
||||
.outputOptions = list(), # Options for each of the output observer objects
|
||||
progressKeys = 'character',
|
||||
showcase = 'ANY',
|
||||
showcase = FALSE,
|
||||
fileUploadContext = 'FileUploadContext',
|
||||
.input = 'ANY', # Internal ReactiveValues object for normal input sent from client
|
||||
.clientData = 'ANY', # Internal ReactiveValues object for other data sent from the client
|
||||
@@ -353,6 +358,12 @@ ShinySession <- R6Class(
|
||||
flushCallbacks = 'Callbacks',
|
||||
flushedCallbacks = 'Callbacks',
|
||||
inputReceivedCallbacks = 'Callbacks',
|
||||
bookmarkCallbacks = 'Callbacks',
|
||||
bookmarkedCallbacks = 'Callbacks',
|
||||
restoreCallbacks = 'Callbacks',
|
||||
restoredCallbacks = 'Callbacks',
|
||||
bookmarkExclude = character(0), # Names of inputs to exclude from bookmarking
|
||||
|
||||
sendResponse = function(requestMsg, value) {
|
||||
if (is.null(requestMsg$tag)) {
|
||||
warning("Tried to send response for untagged message; method: ",
|
||||
@@ -419,9 +430,134 @@ ShinySession <- R6Class(
|
||||
|
||||
# Clear file upload directories, if present
|
||||
self$onSessionEnded(private$fileUploadContext$rmUploadDirs)
|
||||
},
|
||||
|
||||
createBookmarkObservers = function() {
|
||||
# This is to be called from the initialization. It registers observers
|
||||
# for bookmarking to work.
|
||||
|
||||
# Get bookmarking config
|
||||
store <- getShinyOption("bookmarkStore", default = "disable")
|
||||
if (store == "disable")
|
||||
return()
|
||||
|
||||
withReactiveDomain(self, {
|
||||
# To make code a little clearer
|
||||
session <- self
|
||||
|
||||
# This observer fires when the bookmark button is clicked.
|
||||
observeEvent(
|
||||
label = "bookmark",
|
||||
session$input[["._bookmark_"]],
|
||||
{
|
||||
tryCatch(
|
||||
withLogErrors({
|
||||
saveState <- ShinySaveState$new(
|
||||
input = session$input,
|
||||
exclude = session$getBookmarkExclude(),
|
||||
onSave = function(state) {
|
||||
private$bookmarkCallbacks$invoke(state)
|
||||
}
|
||||
)
|
||||
|
||||
if (store == "server") {
|
||||
url <- saveShinySaveState(saveState)
|
||||
} else if (store == "url") {
|
||||
url <- encodeShinySaveState(saveState)
|
||||
} else {
|
||||
stop("Unknown store type: ", store)
|
||||
}
|
||||
|
||||
clientData <- session$clientData
|
||||
url <- paste0(
|
||||
clientData$url_protocol, "//",
|
||||
clientData$url_hostname,
|
||||
if (nzchar(clientData$url_port)) paste0(":", clientData$url_port),
|
||||
clientData$url_pathname,
|
||||
"?", url
|
||||
)
|
||||
|
||||
|
||||
# If onBookmarked callback was provided, invoke it; if not call
|
||||
# the default.
|
||||
if (private$bookmarkedCallbacks$count() > 0) {
|
||||
private$bookmarkedCallbacks$invoke(url)
|
||||
} else {
|
||||
showBookmarkUrlModal(url)
|
||||
}
|
||||
}),
|
||||
error = function(e) {
|
||||
msg <- paste0("Error bookmarking state: ", e$message)
|
||||
showNotification(msg, duration = NULL, type = "error")
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
# If there was an error initializing the current restore context, show
|
||||
# notification in the client.
|
||||
observe({
|
||||
rc <- getCurrentRestoreContext()
|
||||
if (!is.null(rc$initErrorMessage)) {
|
||||
showNotification(
|
||||
paste("Error in RestoreContext initialization:", rc$initErrorMessage),
|
||||
duration = NULL, type = "error"
|
||||
)
|
||||
}
|
||||
})
|
||||
|
||||
# Run the onRestore function at the beginning of the flush cycle, but after
|
||||
# the server function has been executed.
|
||||
observe({
|
||||
if (private$restoreCallbacks$count() > 0) {
|
||||
tryCatch(
|
||||
withLogErrors(
|
||||
isolate({
|
||||
rc <- getCurrentRestoreContext()
|
||||
if (rc$active) {
|
||||
restoreState <- getCurrentRestoreContext()$asList()
|
||||
private$restoreCallbacks$invoke(restoreState)
|
||||
}
|
||||
})
|
||||
),
|
||||
error = function(e) {
|
||||
showNotification(
|
||||
paste0("Error calling onRestore callback: ", e$message),
|
||||
duration = NULL, type = "error"
|
||||
)
|
||||
}
|
||||
)
|
||||
}
|
||||
}, priority = -1000000)
|
||||
|
||||
# Run the onRestored function after the flush cycle completes and information
|
||||
# is sent to the client.
|
||||
session$onFlushed(function() {
|
||||
if (private$restoredCallbacks$count() > 0) {
|
||||
|
||||
tryCatch(
|
||||
withLogErrors(
|
||||
isolate({
|
||||
rc <- getCurrentRestoreContext()
|
||||
if (rc$active) {
|
||||
restoreState <- getCurrentRestoreContext()$asList()
|
||||
private$restoredCallbacks$invoke(restoreState)
|
||||
}
|
||||
})
|
||||
),
|
||||
error = function(e) {
|
||||
msg <- paste0("Error calling onRestored callback: ", e$message)
|
||||
showNotification(msg, duration = NULL, type = "error")
|
||||
}
|
||||
)
|
||||
}
|
||||
})
|
||||
|
||||
}) # withReactiveDomain
|
||||
}
|
||||
),
|
||||
public = list(
|
||||
restoreContext = 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
|
||||
@@ -464,6 +600,12 @@ ShinySession <- R6Class(
|
||||
private$.outputs <- list()
|
||||
private$.outputOptions <- list()
|
||||
|
||||
private$bookmarkCallbacks <- Callbacks$new()
|
||||
private$bookmarkedCallbacks <- Callbacks$new()
|
||||
private$restoreCallbacks <- Callbacks$new()
|
||||
private$restoredCallbacks <- Callbacks$new()
|
||||
private$createBookmarkObservers()
|
||||
|
||||
private$registerSessionEndCallbacks()
|
||||
|
||||
if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
|
||||
@@ -489,7 +631,14 @@ ShinySession <- R6Class(
|
||||
makeScope = function(namespace) {
|
||||
ns <- NS(namespace)
|
||||
|
||||
createSessionProxy(self,
|
||||
# Private items for this scope. Can't be part of the scope object because
|
||||
# `$<-.session_proxy` doesn't allow assignment on overidden names.
|
||||
bookmarkCallbacks <- Callbacks$new()
|
||||
restoreCallbacks <- Callbacks$new()
|
||||
restoredCallbacks <- Callbacks$new()
|
||||
bookmarkExclude <- character(0)
|
||||
|
||||
scope <- createSessionProxy(self,
|
||||
input = .createReactiveValues(private$.input, readonly = TRUE, ns = ns),
|
||||
output = .createOutputWriter(self, ns = ns),
|
||||
sendInputMessage = function(inputId, message) {
|
||||
@@ -501,12 +650,157 @@ ShinySession <- R6Class(
|
||||
ns = ns,
|
||||
makeScope = function(namespace) {
|
||||
self$makeScope(ns(namespace))
|
||||
},
|
||||
|
||||
setBookmarkExclude = function(names) {
|
||||
bookmarkExclude <<- names
|
||||
},
|
||||
getBookmarkExclude = function() {
|
||||
bookmarkExclude
|
||||
},
|
||||
onBookmark = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
bookmarkCallbacks$register(fun)
|
||||
},
|
||||
onBookmarked = function(fun) {
|
||||
stop("onBookmarked() can't be used in a module.")
|
||||
},
|
||||
onRestore = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
restoreCallbacks$register(fun)
|
||||
},
|
||||
onRestored = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
restoredCallbacks$register(fun)
|
||||
}
|
||||
)
|
||||
|
||||
# Given a char vector, return a logical vector indicating which of those
|
||||
# strings are names of things in the namespace.
|
||||
filterNamespace <- function(x) {
|
||||
nsString <- paste0(namespace, ns.sep)
|
||||
substr(x, 1, nchar(nsString)) == nsString
|
||||
}
|
||||
|
||||
# Given a char vector of namespaced names, return a char vector of corresponding
|
||||
# names with namespace prefix removed.
|
||||
unNamespace <- function(x) {
|
||||
if (!all(filterNamespace(x))) {
|
||||
stop("x contains strings(s) that do not have namespace prefix ", namespace)
|
||||
}
|
||||
|
||||
nsString <- paste0(namespace, ns.sep)
|
||||
substring(x, nchar(nsString) + 1)
|
||||
}
|
||||
|
||||
# Given a restore state object (a list), return a modified version that's
|
||||
# scoped to this namespace.
|
||||
scopeRestoreState <- function(state) {
|
||||
# State is a list. We need to copy and transform some things for the
|
||||
# scope.
|
||||
scopeState <- state
|
||||
# `values` is an environment and we don't want to modify the original.
|
||||
scopeState$values <- new.env(parent = emptyenv())
|
||||
|
||||
# Keep only inputs that are in the scope, and rename them
|
||||
scopeState$input <- scopeState$input[filterNamespace(names(scopeState$input))]
|
||||
names(scopeState$input) <- unNamespace(names(scopeState$input))
|
||||
|
||||
# Same for values. This is an environment so we have to handle a little
|
||||
# differently.
|
||||
origNames <- names(state$values)
|
||||
origNames <- origNames[filterNamespace(origNames)]
|
||||
lapply(origNames, function(origName) {
|
||||
scopedName <- unNamespace(origName)
|
||||
scopeState$values[[scopedName]] <- state$values[[origName]]
|
||||
})
|
||||
|
||||
if (!is.null(state$dir)) {
|
||||
dir <- file.path(state$dir, namespace)
|
||||
if (dirExists(dir))
|
||||
scopeState$dir <- dir
|
||||
}
|
||||
|
||||
scopeState
|
||||
}
|
||||
|
||||
# When scope is created, register these bookmarking callbacks on the main
|
||||
# session object. They will invoke the scope's own callbacks, if any are
|
||||
# present.
|
||||
self$onBookmark(function(state) {
|
||||
# Exit if no user-defined callbacks.
|
||||
if (bookmarkCallbacks$count() == 0)
|
||||
return()
|
||||
|
||||
scopeState <- ShinySaveState$new(scope$input, scope$getBookmarkExclude())
|
||||
|
||||
# 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)
|
||||
}
|
||||
}
|
||||
|
||||
# Invoke the callback on the scopeState object
|
||||
bookmarkCallbacks$invoke(scopeState)
|
||||
|
||||
# Copy `values` from scopeState to state, adding namespace
|
||||
if (length(scopeState$values) != 0) {
|
||||
if (anyUnnamed(scopeState$values)) {
|
||||
stop("All scope values in must be named.")
|
||||
}
|
||||
|
||||
lapply(names(scopeState$values), function(origName) {
|
||||
scopedName <- ns(origName)
|
||||
state$values[[scopedName]] <- scopeState$values[[origName]]
|
||||
})
|
||||
}
|
||||
})
|
||||
|
||||
self$onRestore(function(state) {
|
||||
# Exit if no user-defined callbacks.
|
||||
if (restoreCallbacks$count() == 0)
|
||||
return()
|
||||
|
||||
scopeState <- scopeRestoreState(state)
|
||||
# Invoke user callbacks
|
||||
restoreCallbacks$invoke(scopeState)
|
||||
})
|
||||
|
||||
self$onRestored(function(state) {
|
||||
# Exit if no user-defined callbacks.
|
||||
if (restoredCallbacks$count() == 0)
|
||||
return()
|
||||
|
||||
scopeState <- scopeRestoreState(state)
|
||||
# Invoke user callbacks
|
||||
restoredCallbacks$invoke(scopeState)
|
||||
})
|
||||
|
||||
scope
|
||||
},
|
||||
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
|
||||
@@ -777,6 +1071,38 @@ ShinySession <- R6Class(
|
||||
return(dereg)
|
||||
}
|
||||
},
|
||||
|
||||
setBookmarkExclude = function(names) {
|
||||
private$bookmarkExclude <- names
|
||||
},
|
||||
getBookmarkExclude = function() {
|
||||
private$bookmarkExclude
|
||||
},
|
||||
onBookmark = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
private$bookmarkCallbacks$register(fun)
|
||||
},
|
||||
onBookmarked = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
private$bookmarkedCallbacks$register(fun)
|
||||
},
|
||||
onRestore = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
private$restoreCallbacks$register(fun)
|
||||
},
|
||||
onRestored = function(fun) {
|
||||
if (!is.function(fun) || length(fun) != 1) {
|
||||
stop("`fun` must be a function that takes one argument")
|
||||
}
|
||||
private$restoredCallbacks$register(fun)
|
||||
},
|
||||
|
||||
reactlog = function(logEntry) {
|
||||
if (private$showcase)
|
||||
private$sendMessage(reactlog = logEntry)
|
||||
@@ -802,6 +1128,9 @@ ShinySession <- R6Class(
|
||||
)
|
||||
)
|
||||
},
|
||||
updateQueryString = function(queryString) {
|
||||
private$sendMessage(updateQueryString = list(queryString = queryString))
|
||||
},
|
||||
resetBrush = function(brushId) {
|
||||
private$sendMessage(
|
||||
resetBrush = list(
|
||||
@@ -835,6 +1164,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
|
||||
@@ -1197,3 +1529,40 @@ outputOptions <- function(x, name, ...) {
|
||||
|
||||
.subset2(x, 'impl')$outputOptions(name, ...)
|
||||
}
|
||||
|
||||
|
||||
#' Add callbacks for Shiny session events
|
||||
#'
|
||||
#' These functions are for registering callbacks on Shiny session events.
|
||||
#' \code{onFlush} registers a function that will be called before Shiny flushes
|
||||
#' the reactive system. \code{onFlushed} registers a function that will be
|
||||
#' called after Shiny flushes the reactive system. \code{onSessionEnded}
|
||||
#' registers a function to be called after the client has disconnected.
|
||||
#'
|
||||
#' These functions should be called within the application's server function.
|
||||
#'
|
||||
#' All of these functions return a function which can be called with no
|
||||
#' arguments to cancel the registration.
|
||||
#'
|
||||
#' @param fun A callback function.
|
||||
#' @param once Should the function be run once, and then cleared, or should it
|
||||
#' re-run each time the event occurs. (Only for \code{onFlush} and
|
||||
#' \code{onFlushed}.)
|
||||
#' @param session A shiny session object.
|
||||
#'
|
||||
#' @export
|
||||
onFlush <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
|
||||
session$onFlush(fun)
|
||||
}
|
||||
|
||||
#' @rdname onFlush
|
||||
#' @export
|
||||
onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
|
||||
session$onFlushed(fun)
|
||||
}
|
||||
|
||||
#' @rdname onFlush
|
||||
#' @export
|
||||
onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
|
||||
session$onSessionEnded(fun)
|
||||
}
|
||||
|
||||
35
R/shinyui.R
35
R/shinyui.R
@@ -90,17 +90,34 @@ uiHttpHandler <- function(ui, uiPattern = "^/$") {
|
||||
if (!is.null(mode))
|
||||
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())
|
||||
}
|
||||
|
||||
# Create a restore context using query string
|
||||
bookmarkStore <- getShinyOption("bookmarkStore", default = "disable")
|
||||
if (bookmarkStore == "disable") {
|
||||
# If bookmarking is disabled, use empty context
|
||||
restoreContext <- RestoreContext$new()
|
||||
} else {
|
||||
ui
|
||||
restoreContext <- RestoreContext$new(req$QUERY_STRING)
|
||||
}
|
||||
|
||||
withRestoreContext(restoreContext, {
|
||||
uiValue <- NULL
|
||||
|
||||
if (is.function(ui)) {
|
||||
if (length(formals(ui)) > 0) {
|
||||
# No corresponding ..stacktraceoff.., this is pure user code
|
||||
uiValue <- ..stacktraceon..(ui(req))
|
||||
} else {
|
||||
# No corresponding ..stacktraceoff.., this is pure user code
|
||||
uiValue <- ..stacktraceon..(ui())
|
||||
}
|
||||
} else {
|
||||
if (getCurrentRestoreContext()$active) {
|
||||
warning("Trying to restore saved app state, but UI code must be a function for this to work! See ?enableBookmarking")
|
||||
}
|
||||
uiValue <- ui
|
||||
}
|
||||
})
|
||||
if (is.null(uiValue))
|
||||
return(NULL)
|
||||
|
||||
|
||||
41
R/utils.R
41
R/utils.R
@@ -119,16 +119,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
|
||||
}
|
||||
@@ -192,6 +182,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(...) {
|
||||
@@ -234,6 +239,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.
|
||||
@@ -503,6 +514,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))
|
||||
@@ -550,13 +563,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()
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
@@ -1162,6 +1162,10 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
|
||||
});
|
||||
});
|
||||
|
||||
addMessageHandler('updateQueryString', function (message) {
|
||||
window.history.replaceState(null, null, message.queryString);
|
||||
});
|
||||
|
||||
addMessageHandler("resetBrush", function (message) {
|
||||
exports.resetBrush(message.brushId);
|
||||
});
|
||||
@@ -1177,35 +1181,24 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
|
||||
binding.showProgress(true);
|
||||
}
|
||||
},
|
||||
|
||||
// Open a page-level progress bar
|
||||
open: function open(message) {
|
||||
// Add progress container (for all progress items) if not already present
|
||||
var $container = $('.shiny-progress-container');
|
||||
if ($container.length === 0) {
|
||||
$container = $('<div class="shiny-progress-container"></div>');
|
||||
$('body').append($container);
|
||||
}
|
||||
|
||||
// Add div for just this progress ID
|
||||
var depth = $('.shiny-progress.open').length;
|
||||
var $progress = $(progressHandlers.progressHTML);
|
||||
$progress.attr('id', message.id);
|
||||
$container.append($progress);
|
||||
|
||||
// Stack bars
|
||||
var $progressBar = $progress.find('.progress');
|
||||
$progressBar.css('top', depth * $progressBar.height() + 'px');
|
||||
|
||||
// Stack text objects
|
||||
var $progressText = $progress.find('.progress-text');
|
||||
$progressText.css('top', 3 * $progressBar.height() + depth * $progressText.outerHeight() + 'px');
|
||||
|
||||
$progress.hide();
|
||||
// Progress bar starts hidden; will be made visible if a value is provided
|
||||
// during updates.
|
||||
exports.notifications.show({
|
||||
html: '<div id="shiny-progress-' + message.id + '" class="shiny-progress">' + '<div class="progress progress-striped active" style="display: none;"><div class="progress-bar"></div></div>' + '<div class="progress-text">' + '<span class="progress-message">message</span> ' + '<span class="progress-detail"></span>' + '</div>' + '</div>',
|
||||
id: message.id,
|
||||
duration: null
|
||||
});
|
||||
},
|
||||
|
||||
// Update page-level progress bar
|
||||
update: function update(message) {
|
||||
var $progress = $('#' + message.id + '.shiny-progress');
|
||||
var $progress = $('#shiny-progress-' + message.id);
|
||||
|
||||
if ($progress.length === 0) return;
|
||||
|
||||
if (typeof message.message !== 'undefined') {
|
||||
$progress.find('.progress-message').text(message.message);
|
||||
}
|
||||
@@ -1215,32 +1208,17 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol
|
||||
if (typeof message.value !== 'undefined') {
|
||||
if (message.value !== null) {
|
||||
$progress.find('.progress').show();
|
||||
$progress.find('.bar').width(message.value * 100 + '%');
|
||||
$progress.find('.progress-bar').width(message.value * 100 + '%');
|
||||
} else {
|
||||
$progress.find('.progress').hide();
|
||||
}
|
||||
}
|
||||
|
||||
$progress.fadeIn();
|
||||
},
|
||||
|
||||
// Close page-level progress bar
|
||||
close: function close(message) {
|
||||
var $progress = $('#' + message.id + '.shiny-progress');
|
||||
$progress.removeClass('open');
|
||||
|
||||
$progress.fadeOut({
|
||||
complete: function complete() {
|
||||
$progress.remove();
|
||||
|
||||
// If this was the last shiny-progress, remove container
|
||||
if ($('.shiny-progress').length === 0) $('.shiny-progress-container').remove();
|
||||
}
|
||||
});
|
||||
},
|
||||
|
||||
// The 'bar' class is needed for backward compatibility with Bootstrap 2.
|
||||
progressHTML: '<div class="shiny-progress open">' + '<div class="progress progress-striped active"><div class="progress-bar bar"></div></div>' + '<div class="progress-text">' + '<span class="progress-message">message</span>' + '<span class="progress-detail"></span>' + '</div>' + '</div>'
|
||||
exports.notifications.remove(message.id);
|
||||
}
|
||||
};
|
||||
|
||||
exports.progressHandlers = progressHandlers;
|
||||
@@ -3389,7 +3367,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;
|
||||
@@ -3444,6 +3422,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
|
||||
|
||||
@@ -4629,8 +4621,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;
|
||||
@@ -4641,12 +4633,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));
|
||||
}
|
||||
}
|
||||
|
||||
@@ -4659,11 +4662,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);
|
||||
},
|
||||
|
||||
File diff suppressed because one or more lines are too long
6
inst/www/shared/shiny.min.js
vendored
6
inst/www/shared/shiny.min.js
vendored
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
30
man/bookmarkButton.Rd
Normal file
30
man/bookmarkButton.Rd
Normal file
@@ -0,0 +1,30 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{bookmarkButton}
|
||||
\alias{bookmarkButton}
|
||||
\title{Create a button for bookmarking/sharing}
|
||||
\usage{
|
||||
bookmarkButton(label = "Bookmark...", icon = shiny::icon("link", lib =
|
||||
"glyphicon"),
|
||||
title = "Bookmark this application's state and get a URL for sharing.", ...)
|
||||
}
|
||||
\arguments{
|
||||
\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{title}{A tooltip that is shown when the mouse cursor hovers over 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{
|
||||
enableBookmarking
|
||||
}
|
||||
|
||||
202
man/enableBookmarking.Rd
Normal file
202
man/enableBookmarking.Rd
Normal file
@@ -0,0 +1,202 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{enableBookmarking}
|
||||
\alias{enableBookmarking}
|
||||
\title{Enable bookmarking for a Shiny application}
|
||||
\usage{
|
||||
enableBookmarking(store = c("url", "server", "disable"))
|
||||
}
|
||||
\arguments{
|
||||
\item{store}{Either \code{"url"}, which encodes all of the relevant values in
|
||||
a URL, \code{"server"}, which saves to disk on the server, or
|
||||
\code{"disable"}, which disables any previously-enabled bookmarking.}
|
||||
}
|
||||
\description{
|
||||
There are two types of bookmarking: saving an application's state to disk on
|
||||
the server, and encoding the application's state in a URL. For state that has
|
||||
been saved to disk, the state can be restored with the corresponding state
|
||||
ID. For URL-encoded state, the state of the application is encoded in the
|
||||
URL, and no server-side storage is needed.
|
||||
|
||||
URL-encoded bookmarking is appropriate for applications where there not many
|
||||
input values that need to be recorded. Some browsers have a length limit for
|
||||
URLs of about 2000 characters, and if there are many inputs, the length of
|
||||
the URL can exceed that limit.
|
||||
|
||||
Saved-on-server bookmarking is appropriate when there are many inputs, or
|
||||
when the bookmarked state requires storing files.
|
||||
}
|
||||
\details{
|
||||
For restoring state to work properly, the UI must be a function that takes
|
||||
one argument, \code{request}. In most Shiny applications, the UI is not a
|
||||
function; it might have the form \code{fluidPage(....)}. Converting it to a
|
||||
function is as simple as wrapping it in a function, as in
|
||||
\code{function(request) \{ fluidPage(....) \}}.
|
||||
|
||||
By default, all input values will be bookmarked, except for the values of
|
||||
actionButtons and passwordInputs. fileInputs will be saved if the state is
|
||||
saved on a server, but not if the state is encoded in a URL.
|
||||
|
||||
When bookmarking state, arbitrary values can be stored, by passing a function
|
||||
as the \code{onBookmark} argument. That function will be passed a
|
||||
\code{ShinySaveState} object. The \code{values} field of the object is a list
|
||||
which can be manipulated to save extra information. Additionally, if the
|
||||
state is being saved on the server, and the \code{dir} field of that object
|
||||
can be used to save extra information to files in that directory.
|
||||
|
||||
For saved-to-server state, this is how the state directory is chosen:
|
||||
\itemize{
|
||||
\item If running in a hosting environment such as Shiny Server or
|
||||
Connect, the hosting environment will choose the directory.
|
||||
\item If running an app in a directory with \code{\link{runApp}()}, the
|
||||
saved states will be saved in a subdirectory of the app called
|
||||
shiny_bookmarks.
|
||||
\item If running a Shiny app object that is generated from code (not run
|
||||
from a directory), the saved states will be saved in a subdirectory of
|
||||
the current working directory called shiny_bookmarks.
|
||||
}
|
||||
}
|
||||
\examples{
|
||||
## Only run these examples in interactive R sessions
|
||||
if (interactive()) {
|
||||
|
||||
# Basic example with state encoded in URL
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
textInput("txt", "Text"),
|
||||
checkboxInput("chk", "Checkbox"),
|
||||
bookmarkButton("bookmark")
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) { }
|
||||
enableBookmarking("url")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# Basic example with state saved to disk
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
textInput("txt", "Text"),
|
||||
checkboxInput("chk", "Checkbox"),
|
||||
bookmarkButton("bookmark")
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) { }
|
||||
enableBookmarking("server")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# Save/restore arbitrary values
|
||||
ui <- function(req) {
|
||||
fluidPage(
|
||||
textInput("txt", "Text"),
|
||||
checkboxInput("chk", "Checkbox"),
|
||||
bookmarkButton(),
|
||||
br(),
|
||||
textOutput("lastSaved")
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) {
|
||||
vals <- reactiveValues(savedTime = NULL)
|
||||
output$lastSaved <- renderText({
|
||||
if (!is.null(vals$savedTime))
|
||||
paste("Last saved at", vals$savedTime)
|
||||
else
|
||||
""
|
||||
})
|
||||
|
||||
onBookmark(function(state) {
|
||||
vals$savedTime <- Sys.time()
|
||||
# state is a mutable reference object, and we can add arbitrary values
|
||||
# to it.
|
||||
state$values$time <- vals$savedTime
|
||||
})
|
||||
onRestore(function(state) {
|
||||
vals$savedTime <- state$values$time
|
||||
})
|
||||
}
|
||||
enableBookmarking(store = "url")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# Usable with dynamic UI (set the slider, then change the text input,
|
||||
# click the bookmark button)
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
sliderInput("slider", "Slider", 1, 100, 50),
|
||||
uiOutput("ui"),
|
||||
bookmarkButton("bookmark")
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) {
|
||||
output$ui <- renderUI({
|
||||
textInput("txt", "Text", input$slider)
|
||||
})
|
||||
}
|
||||
enableBookmarking("url")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# Exclude specific inputs (The only input that will be saved in this
|
||||
# example is chk)
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
passwordInput("pw", "Password"), # Passwords are never saved
|
||||
sliderInput("slider", "Slider", 1, 100, 50), # Manually excluded below
|
||||
checkboxInput("chk", "Checkbox"),
|
||||
bookmarkButton("bookmark")
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) {
|
||||
setBookmarkExclude("slider")
|
||||
}
|
||||
enableBookmarking("url")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# Save/restore uploaded files
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
sidebarLayout(
|
||||
sidebarPanel(
|
||||
fileInput("file1", "Choose CSV File", multiple = TRUE,
|
||||
accept = c(
|
||||
"text/csv",
|
||||
"text/comma-separated-values,text/plain",
|
||||
".csv"
|
||||
)
|
||||
),
|
||||
tags$hr(),
|
||||
checkboxInput("header", "Header", TRUE),
|
||||
bookmarkButton("bookmark")
|
||||
),
|
||||
mainPanel(
|
||||
tableOutput("contents")
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
server <- function(input, output) {
|
||||
output$contents <- renderTable({
|
||||
inFile <- input$file1
|
||||
if (is.null(inFile))
|
||||
return(NULL)
|
||||
|
||||
if (nrow(inFile) == 1) {
|
||||
read.csv(inFile$datapath, header = input$header)
|
||||
} else {
|
||||
data.frame(x = "multiple files")
|
||||
}
|
||||
})
|
||||
}
|
||||
enableBookmarking("server")
|
||||
shinyApp(ui, server)
|
||||
|
||||
}
|
||||
}
|
||||
\seealso{
|
||||
\code{\link{onBookmark}}, \code{\link{onRestore}}, and
|
||||
\code{\link{onRestored}} for registering callback functions that are
|
||||
invoked when the state is bookmarked or restored.
|
||||
}
|
||||
|
||||
61
man/invalidateReactiveValue.Rd
Normal file
61
man/invalidateReactiveValue.Rd
Normal file
@@ -0,0 +1,61 @@
|
||||
% 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.
|
||||
}
|
||||
\examples{
|
||||
## Only run this examples in interactive R sessions
|
||||
if (interactive()) {
|
||||
|
||||
ui <- fluidPage(
|
||||
selectInput("data", "Data Set", c("mtcars", "pressure")),
|
||||
checkboxGroupInput("cols", "Columns (select 2)", character(0)),
|
||||
plotOutput("plot")
|
||||
)
|
||||
|
||||
server <- function(input, output, session) {
|
||||
observe({
|
||||
data <- get(input$data)
|
||||
# Sets a flag on input$cols to essentially do req(FALSE) if input$cols
|
||||
# is accessed. Without this, an error will momentarily show whenever a
|
||||
# new data set is selected.
|
||||
invalidateReactiveValue(input, "cols")
|
||||
updateCheckboxGroupInput(session, "cols", choices = names(data))
|
||||
})
|
||||
|
||||
output$plot <- renderPlot({
|
||||
# When a new data set is selected, input$cols will have been invalidated
|
||||
# above, and this will essentially do the same as req(FALSE), causing
|
||||
# this observer to stop and raise a silent exception.
|
||||
cols <- input$cols
|
||||
data <- get(input$data)
|
||||
|
||||
if (length(cols) == 2) {
|
||||
plot(data[[ cols[1] ]], data[[ cols[2] ]])
|
||||
}
|
||||
})
|
||||
}
|
||||
|
||||
shinyApp(ui, server)
|
||||
}
|
||||
}
|
||||
\seealso{
|
||||
\code{\link{req}}
|
||||
}
|
||||
|
||||
207
man/onBookmark.Rd
Normal file
207
man/onBookmark.Rd
Normal file
@@ -0,0 +1,207 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{onBookmark}
|
||||
\alias{onBookmark}
|
||||
\alias{onBookmarked}
|
||||
\alias{onRestore}
|
||||
\alias{onRestored}
|
||||
\title{Add callbacks for Shiny session bookmarking events}
|
||||
\usage{
|
||||
onBookmark(fun, session = getDefaultReactiveDomain())
|
||||
|
||||
onBookmarked(fun, session = getDefaultReactiveDomain())
|
||||
|
||||
onRestore(fun, session = getDefaultReactiveDomain())
|
||||
|
||||
onRestored(fun, session = getDefaultReactiveDomain())
|
||||
}
|
||||
\arguments{
|
||||
\item{fun}{A callback function which takes one argument.}
|
||||
|
||||
\item{session}{A shiny session object.}
|
||||
}
|
||||
\description{
|
||||
These functions are for registering callbacks on Shiny session events. They
|
||||
should be called within an application's server function.
|
||||
|
||||
\itemize{
|
||||
\item \code{onBookmark} registers a function that will be called just
|
||||
before Shiny bookmarks state.
|
||||
\item \code{onRestore} registers a function that will be called when a
|
||||
session is restored, after the server function executes, but before all
|
||||
other reactives, observers and render functions are run.
|
||||
\item \code{onRestored} registers a function that will be called after a
|
||||
session is restored. This is similar to \code{onRestore}, but it will be
|
||||
called after all reactives, observers, and render functions run, and
|
||||
after results are sent to the client browser. \code{onRestored}
|
||||
callbacks can be useful for sending update messages to the client
|
||||
browser.
|
||||
}
|
||||
}
|
||||
\details{
|
||||
All of these functions return a function which can be called with no
|
||||
arguments to cancel the registration.
|
||||
|
||||
The callback function that is passed to these functions should take one
|
||||
argument, typically named "state" (for \code{onBookmark}, \code{onRestore},
|
||||
and \code{onRestored}) or "url" (for \code{onBookmarked}).
|
||||
|
||||
For \code{onBookmark}, the state object has three relevant fields. The
|
||||
\code{values} field is an environment which can be used to save arbitrary
|
||||
values (see examples). If the state is being saved to disk (as opposed to
|
||||
being encoded in a URL), the \code{dir} field contains the name of a
|
||||
directory which can be used to store extra files. Finally, the state object
|
||||
has an \code{input} field, which is simply the application's \code{input}
|
||||
object. It can be read, but not modified.
|
||||
|
||||
For \code{onRestore} and \code{onRestored}, the state object is a list. This
|
||||
list contains \code{input}, which is a named list of input values to restore,
|
||||
\code{values}, which is an environment containing arbitrary values that were
|
||||
saved in \code{onBookmark}, and \code{dir}, the name of the directory that
|
||||
the state is being restored from, and which could have been used to save
|
||||
extra files.
|
||||
|
||||
For \code{onBookmarked}, the callback function receives a string with the
|
||||
bookmark URL. This callback function should be used to display UI in the
|
||||
client browser with the bookmark URL. If no callback function is registered,
|
||||
then Shiny will by default display a modal dialog with the bookmark URL.
|
||||
}
|
||||
\section{Modules}{
|
||||
|
||||
|
||||
These callbacks may also be used in Shiny modules. When used this way, the
|
||||
inputs and values will automatically be namespaced for the module, and the
|
||||
callback functions registered for the module will only be able to see the
|
||||
module's inputs and values.
|
||||
}
|
||||
\examples{
|
||||
## Only run these examples in interactive sessions
|
||||
if (interactive()) {
|
||||
|
||||
# Basic use of onBookmark and onRestore: This app saves the time in its
|
||||
# arbitrary values, and restores that time when the app is restored.
|
||||
ui <- function(req) {
|
||||
fluidPage(
|
||||
textInput("txt", "Input text"),
|
||||
bookmarkButton()
|
||||
)
|
||||
}
|
||||
server <- function(input, output) {
|
||||
onBookmark(function(state) {
|
||||
savedTime <- as.character(Sys.time())
|
||||
cat("Last saved at", savedTime, "\\n")
|
||||
# state is a mutable reference object, and we can add arbitrary values to
|
||||
# it.
|
||||
state$values$time <- savedTime
|
||||
})
|
||||
|
||||
onRestore(function(state) {
|
||||
cat("Restoring from state bookmarked at", state$values$time, "\\n")
|
||||
})
|
||||
}
|
||||
enableBookmarking("url")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
|
||||
ui <- function(req) {
|
||||
fluidPage(
|
||||
textInput("txt", "Input text"),
|
||||
bookmarkButton()
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) {
|
||||
lastUpdateTime <- NULL
|
||||
|
||||
observeEvent(input$txt, {
|
||||
updateTextInput(session, "txt",
|
||||
label = paste0("Input text (Changed ", as.character(Sys.time()), ")")
|
||||
)
|
||||
})
|
||||
|
||||
onBookmark(function(state) {
|
||||
# Save content to a file
|
||||
messageFile <- file.path(state$dir, "message.txt")
|
||||
cat(as.character(Sys.time()), file = messageFile)
|
||||
})
|
||||
|
||||
onRestored(function(state) {
|
||||
# Read the file
|
||||
messageFile <- file.path(state$dir, "message.txt")
|
||||
timeText <- readChar(messageFile, 1000)
|
||||
|
||||
# updateTextInput must be called in onRestored, as opposed to onRestore,
|
||||
# because onRestored happens after the client browser is ready.
|
||||
updateTextInput(session, "txt",
|
||||
label = paste0("Input text (Changed ", timeText, ")")
|
||||
)
|
||||
})
|
||||
}
|
||||
# "server" bookmarking is needed for writing to disk.
|
||||
enableBookmarking("server")
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
# This app has a module, and both the module and the main app code have
|
||||
# onBookmark and onRestore functions which write and read state$values$hash. The
|
||||
# module's version of state$values$hash does not conflict with the app's version
|
||||
# of state$values$hash.
|
||||
#
|
||||
# A basic module that captializes text.
|
||||
capitalizerUI <- function(id) {
|
||||
ns <- NS(id)
|
||||
wellPanel(
|
||||
h4("Text captializer module"),
|
||||
textInput(ns("text"), "Enter text:"),
|
||||
verbatimTextOutput(ns("out"))
|
||||
)
|
||||
}
|
||||
capitalizerServer <- function(input, output, session) {
|
||||
output$out <- renderText({
|
||||
toupper(input$text)
|
||||
})
|
||||
onBookmark(function(state) {
|
||||
state$values$hash <- digest::digest(input$text, "md5")
|
||||
})
|
||||
onRestore(function(state) {
|
||||
if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
|
||||
message("Module's input text matches hash ", state$values$hash)
|
||||
} else {
|
||||
message("Module's input text does not match hash ", state$values$hash)
|
||||
}
|
||||
})
|
||||
}
|
||||
# Main app code
|
||||
ui <- function(request) {
|
||||
fluidPage(
|
||||
sidebarLayout(
|
||||
sidebarPanel(
|
||||
capitalizerUI("tc"),
|
||||
textInput("text", "Enter text (not in module):"),
|
||||
bookmarkButton()
|
||||
),
|
||||
mainPanel()
|
||||
)
|
||||
)
|
||||
}
|
||||
server <- function(input, output, session) {
|
||||
callModule(capitalizerServer, "tc")
|
||||
onBookmark(function(state) {
|
||||
state$values$hash <- digest::digest(input$text, "md5")
|
||||
})
|
||||
onRestore(function(state) {
|
||||
if (identical(digest::digest(input$text, "md5"), state$values$hash)) {
|
||||
message("App's input text matches hash ", state$values$hash)
|
||||
} else {
|
||||
message("App's input text does not match hash ", state$values$hash)
|
||||
}
|
||||
})
|
||||
}
|
||||
enableBookmarking(store = "url")
|
||||
shinyApp(ui, server)
|
||||
}
|
||||
}
|
||||
\seealso{
|
||||
enableBookmarking for general information on bookmarking.
|
||||
}
|
||||
|
||||
37
man/onFlush.Rd
Normal file
37
man/onFlush.Rd
Normal file
@@ -0,0 +1,37 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/shiny.R
|
||||
\name{onFlush}
|
||||
\alias{onFlush}
|
||||
\alias{onFlushed}
|
||||
\alias{onSessionEnded}
|
||||
\title{Add callbacks for Shiny session events}
|
||||
\usage{
|
||||
onFlush(fun, once = TRUE, session = getDefaultReactiveDomain())
|
||||
|
||||
onFlushed(fun, once = TRUE, session = getDefaultReactiveDomain())
|
||||
|
||||
onSessionEnded(fun, session = getDefaultReactiveDomain())
|
||||
}
|
||||
\arguments{
|
||||
\item{fun}{A callback function.}
|
||||
|
||||
\item{once}{Should the function be run once, and then cleared, or should it
|
||||
re-run each time the event occurs. (Only for \code{onFlush} and
|
||||
\code{onFlushed}.)}
|
||||
|
||||
\item{session}{A shiny session object.}
|
||||
}
|
||||
\description{
|
||||
These functions are for registering callbacks on Shiny session events.
|
||||
\code{onFlush} registers a function that will be called before Shiny flushes
|
||||
the reactive system. \code{onFlushed} registers a function that will be
|
||||
called after Shiny flushes the reactive system. \code{onSessionEnded}
|
||||
registers a function to be called after the client has disconnected.
|
||||
}
|
||||
\details{
|
||||
These functions should be called within the application's server function.
|
||||
|
||||
All of these functions return a function which can be called with no
|
||||
arguments to cancel the registration.
|
||||
}
|
||||
|
||||
18
man/restoreInput.Rd
Normal file
18
man/restoreInput.Rd
Normal file
@@ -0,0 +1,18 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-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. It should be
|
||||
called early on inside of input functions (like \code{\link{textInput}}).
|
||||
}
|
||||
|
||||
29
man/setBookmarkExclude.Rd
Normal file
29
man/setBookmarkExclude.Rd
Normal file
@@ -0,0 +1,29 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{setBookmarkExclude}
|
||||
\alias{setBookmarkExclude}
|
||||
\title{Exclude inputs from bookmarking}
|
||||
\usage{
|
||||
setBookmarkExclude(names = character(0),
|
||||
session = getDefaultReactiveDomain())
|
||||
}
|
||||
\arguments{
|
||||
\item{names}{A character vector containing names of inputs to exclude from
|
||||
bookmarking.}
|
||||
|
||||
\item{session}{A shiny session object.}
|
||||
}
|
||||
\description{
|
||||
This function tells Shiny which inputs should be excluded from bookmarking.
|
||||
It should be called from inside the application's server function.
|
||||
}
|
||||
\details{
|
||||
This function can also be called from a module's server function, in which
|
||||
case it will exclude inputs with the specified names, from that module. It
|
||||
will not affect inputs from other modules or from the top level of the Shiny
|
||||
application.
|
||||
}
|
||||
\seealso{
|
||||
\code{\link{enableBookmarking}} for examples.
|
||||
}
|
||||
|
||||
39
man/shinyOptions.Rd
Normal file
39
man/shinyOptions.Rd
Normal file
@@ -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")
|
||||
}
|
||||
}
|
||||
|
||||
19
man/showBookmarkUrlModal.Rd
Normal file
19
man/showBookmarkUrlModal.Rd
Normal file
@@ -0,0 +1,19 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{showBookmarkUrlModal}
|
||||
\alias{showBookmarkUrlModal}
|
||||
\title{Display a modal dialog for bookmarking}
|
||||
\usage{
|
||||
showBookmarkUrlModal(url)
|
||||
}
|
||||
\arguments{
|
||||
\item{url}{A URL to show in the modal dialog.}
|
||||
}
|
||||
\description{
|
||||
This is a wrapper function for \code{\link{urlModal}} that is automatically
|
||||
called if an application is bookmarked but no other \code{\link{onBookmark}}
|
||||
callback was set. It displays a modal dialog with the bookmark URL, along
|
||||
with a subtitle that is appropriate for the type of bookmarking used ("url"
|
||||
or "server").
|
||||
}
|
||||
|
||||
18
man/updateQueryString.Rd
Normal file
18
man/updateQueryString.Rd
Normal file
@@ -0,0 +1,18 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{updateQueryString}
|
||||
\alias{updateQueryString}
|
||||
\title{Update URL in browser's location bar}
|
||||
\usage{
|
||||
updateQueryString(queryString, session = getDefaultReactiveDomain())
|
||||
}
|
||||
\arguments{
|
||||
\item{queryString}{The new query string to show in the location bar.}
|
||||
|
||||
\item{session}{A Shiny session object.}
|
||||
}
|
||||
\description{
|
||||
This function updates the client browser's query string in the location bar.
|
||||
It typically is called from an observer.
|
||||
}
|
||||
|
||||
22
man/urlModal.Rd
Normal file
22
man/urlModal.Rd
Normal file
@@ -0,0 +1,22 @@
|
||||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/bookmark-state.R
|
||||
\name{urlModal}
|
||||
\alias{urlModal}
|
||||
\title{Generate a modal dialog that displays a URL}
|
||||
\usage{
|
||||
urlModal(url, title = "Bookmarked 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.
|
||||
}
|
||||
|
||||
@@ -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);
|
||||
},
|
||||
|
||||
10
srcjs/input_binding_password.js
Normal file
10
srcjs/input_binding_password.js
Normal file
@@ -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');
|
||||
@@ -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;
|
||||
|
||||
@@ -667,6 +667,10 @@ var ShinyApp = function() {
|
||||
});
|
||||
});
|
||||
|
||||
addMessageHandler('updateQueryString', function(message) {
|
||||
window.history.replaceState(null, null, message.queryString);
|
||||
});
|
||||
|
||||
addMessageHandler("resetBrush", function(message) {
|
||||
exports.resetBrush(message.brushId);
|
||||
});
|
||||
|
||||
50
tests/testthat/helper.R
Normal file
50
tests/testthat/helper.R
Normal file
@@ -0,0 +1,50 @@
|
||||
# Helper function for checking that vectors have same contents, regardless of
|
||||
# order. Can be removed once something similar is incorporated into testthat
|
||||
# package. See
|
||||
# https://github.com/hadley/testthat/issues/473
|
||||
contents_identical <- function(a, b) {
|
||||
# Convert to named vectors - needed for sorting later.
|
||||
if (is.null(names(a))) {
|
||||
names(a) <- rep("", length(a))
|
||||
}
|
||||
if (is.null(names(b))) {
|
||||
names(b) <- rep("", length(b))
|
||||
}
|
||||
|
||||
# Fast path for atomic vectors
|
||||
if (is.atomic(a) && is.atomic(b)) {
|
||||
# Sort first by names, then contents. This is so that the comparison can
|
||||
# handle duplicated names.
|
||||
a <- a[order(names(a), a)]
|
||||
b <- b[order(names(b), b)]
|
||||
|
||||
return(identical(a, b))
|
||||
}
|
||||
|
||||
# If we get here, we're on the slower path for lists
|
||||
|
||||
# Check if names are the same. If there are duplicated names, make sure
|
||||
# there's the same number of duplicates of each.
|
||||
if (!identical(sort(names(a)), sort(names(b)))) {
|
||||
return(FALSE)
|
||||
}
|
||||
|
||||
# Group each vector by names
|
||||
by_names_a <- tapply(a, names(a), function(x) x)
|
||||
by_names_b <- tapply(b, names(b), function(x) x)
|
||||
|
||||
# Compare each group
|
||||
for (i in seq_along(by_names_a)) {
|
||||
subset_a <- by_names_a[[i]]
|
||||
subset_b <- by_names_b[[i]]
|
||||
|
||||
unique_subset_a <- unique(subset_a)
|
||||
idx_a <- sort(match(subset_a, unique_subset_a))
|
||||
idx_b <- sort(match(subset_b, unique_subset_a))
|
||||
if (!identical(idx_a, idx_b)) {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
TRUE
|
||||
}
|
||||
54
tests/testthat/test-bookmarking.R
Normal file
54
tests/testthat/test-bookmarking.R
Normal file
@@ -0,0 +1,54 @@
|
||||
context("bookmarking")
|
||||
|
||||
test_that("Inputs and values in query string", {
|
||||
# Normal format
|
||||
vals <- RestoreContext$new("?_inputs_&a=1&b=2&_values_&x=3")$asList()
|
||||
expect_true(contents_identical(vals$input, list(a=1L, b=2L)))
|
||||
expect_identical(as.list(vals$values), list(x=3L))
|
||||
|
||||
# No leading '?', trailing '&', and values before inputs
|
||||
vals <- RestoreContext$new("_values_&x=3&_inputs_&a=1&b=2&")$asList()
|
||||
expect_true(contents_identical(vals$input, list(a=1L, b=2L)))
|
||||
expect_identical(as.list(vals$values), list(x=3L))
|
||||
|
||||
# Just inputs, no values, and leading '&'
|
||||
vals <- RestoreContext$new("&_inputs_&a=1&b=2")$asList()
|
||||
expect_true(contents_identical(vals$input, list(a=1L, b=2L)))
|
||||
expect_identical(as.list(vals$values), list())
|
||||
|
||||
# No inputs, just values
|
||||
vals <- RestoreContext$new("?_values_&x=3")$asList()
|
||||
expect_identical(vals$input, list())
|
||||
expect_identical(as.list(vals$values), list(x=3L))
|
||||
|
||||
# Empty query string
|
||||
vals <- RestoreContext$new("")$asList()
|
||||
expect_identical(vals$input, list())
|
||||
expect_identical(as.list(vals$values), list())
|
||||
|
||||
# Other items (not inputs and not values)
|
||||
vals <- RestoreContext$new("?c=3&d=4")$asList()
|
||||
expect_identical(vals$input, list())
|
||||
expect_identical(as.list(vals$values), list())
|
||||
|
||||
# Multiple instances of _inputs_ or _values_
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_")))
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_&")))
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_inputs_&b=2")))
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_values_&b=2&_inputs_&")))
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_values_&a=1&_values_")))
|
||||
expect_warning(suppressMessages(RestoreContext$new("?_inputs_&a=1&_values_&_values&b=2")))
|
||||
|
||||
# If there's an error in the conversion from query string, should have
|
||||
# blank values.
|
||||
expect_warning(suppressMessages(rc <- RestoreContext$new("?_inputs_&a=[x&b=1")))
|
||||
expect_identical(rc$input$asList(), list())
|
||||
expect_identical(as.list(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(as.list(rc$values), list())
|
||||
expect_identical(rc$dir, NULL)
|
||||
})
|
||||
55
tests/testthat/test-options.R
Normal file
55
tests/testthat/test-options.R
Normal file
@@ -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)
|
||||
})
|
||||
@@ -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(
|
||||
|
||||
@@ -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',
|
||||
|
||||
Reference in New Issue
Block a user