github/shiny
1
1
Fork 0
mirror of https://github.com/rstudio/shiny.git synced 2026-02-07 21:26:08 -05:00
Code Issues Packages Projects Releases Wiki Activity
Files
07b223dcb0d90d7634fca224e3960ceb02772bfc
shiny/R/shiny.R
Joe Cheng 3ccf2937b4 Fix #928: allow inputs to trigger reactive flow even if the value of input hasn't changed 
We already had an `immediate` input option, which was used to override client side rate
limiting mechanisms (debounce/throttle). This commit extends the semantics of that option
to also mean that duplicate values should not be ignored on the client side.

Previous to this commit, circumventing the client side dedupe logic was not enough. The
server side ReactiveValues object was also subject to deduping. With this commit, the
low-level ReactiveValues class's constructor now has a `dedupe` option, which defaults
to TRUE; the ReactiveValues used for a session's input has it turned to FALSE. I figure
if I had to work this hard to get the client to stop sending duplicates, and the input
values are only expected to ever be updated by the client, then there's really no reason
for server side deduping to be performed for this particular ReactiveValues object.

It would make sense as a future feature to also make deduping optional for user-created
reactiveValues and reactiveVal objects.
2018-04-16 18:37:47 -07:00

2228 lines
82 KiB
R
Raw Blame History

#' @include utils.R stack.R
NULL
#' Web Application Framework for R
#'
#' Shiny makes it incredibly easy to build interactive web applications with R.
#' Automatic "reactive" binding between inputs and outputs and extensive
#' prebuilt widgets make it possible to build beautiful, responsive, and
#' powerful applications with minimal effort.
#'
#' The Shiny tutorial at \url{http://shiny.rstudio.com/tutorial/} explains
#' the framework in depth, walks you through building a simple application, and
#' includes extensive annotated examples.
#'
#' @seealso \link{shiny-options} for documentation about global options.
#'
#' @name shiny-package
#' @aliases shiny
#' @docType package
#' @import htmltools httpuv xtable digest R6 mime
NULL
# It's necessary to Depend on methods so Rscript doesn't fail. It's necessary
# to import(methods) in NAMESPACE so R CMD check doesn't complain. This
# approach isn't foolproof because Rscript -e pkgname::func() doesn't actually
# cause methods to be attached, but it's not a problem for shiny::runApp()
# since we call require(shiny) as part of loading the app.
#' @import methods
NULL
#' Global options for Shiny
#'
#' There are a number of global options that affect Shiny's behavior. These can
#' be set with (for example) \code{options(shiny.trace=TRUE)}.
#'
#' \describe{
#' \item{shiny.launch.browser}{A boolean which controls the default behavior
#' when an app is run. See \code{\link{runApp}} for more information.}
#' \item{shiny.port}{A port number that Shiny will listen on. See
#' \code{\link{runApp}} for more information.}
#' \item{shiny.trace}{Print messages sent between the R server and the web
#' browser client to the R console. This is useful for debugging. Possible
#' values are \code{"send"} (only print messages sent to the client),
#' \code{"recv"} (only print messages received by the server), \code{TRUE}
#' (print all messages), or \code{FALSE} (default; don't print any of these
#' messages).}
#' \item{shiny.autoreload}{If \code{TRUE} when a Shiny app is launched, the
#' app directory will be continually monitored for changes to files that
#' have the extensions: r, htm, html, js, css, png, jpg, jpeg, gif. If any
#' changes are detected, all connected Shiny sessions are reloaded. This
#' allows for fast feedback loops when tweaking Shiny UI.
#'
#' Since monitoring for changes is expensive (we simply poll for last
#' modified times), this feature is intended only for development.
#'
#' You can customize the file patterns Shiny will monitor by setting the
#' shiny.autoreload.pattern option. For example, to monitor only ui.R:
#' \code{options(shiny.autoreload.pattern = glob2rx("ui.R"))}
#'
#' The default polling interval is 500 milliseconds. You can change this
#' by setting e.g. \code{options(shiny.autoreload.interval = 2000)} (every
#' two seconds).}
#' \item{shiny.reactlog}{If \code{TRUE}, enable logging of reactive events,
#' which can be viewed later with the \code{\link{showReactLog}} function.
#' This incurs a substantial performance penalty and should not be used in
#' production.}
#' \item{shiny.usecairo}{This is used to disable graphical rendering by the
#' Cairo package, if it is installed. See \code{\link{plotPNG}} for more
#' information.}
#' \item{shiny.maxRequestSize}{This is a number which specifies the maximum
#' web request size, which serves as a size limit for file uploads. If
#' unset, the maximum request size defaults to 5MB.}
#' \item{shiny.suppressMissingContextError}{Normally, invoking a reactive
#' outside of a reactive context (or \code{\link{isolate}()}) results in
#' an error. If this is \code{TRUE}, don't error in these cases. This
#' should only be used for debugging or demonstrations of reactivity at the
#' console.}
#' \item{shiny.host}{The IP address that Shiny should listen on. See
#' \code{\link{runApp}} for more information.}
#' \item{shiny.json.digits}{The number of digits to use when converting
#' numbers to JSON format to send to the client web browser.}
#' \item{shiny.minified}{If this is \code{TRUE} or unset (the default), then
#' Shiny will use minified JavaScript (\code{shiny.min.js}). If
#' \code{FALSE}, then Shiny will use the un-minified JavaScript
#' (\code{shiny.js}); this can be useful during development.}
#' \item{shiny.error}{This can be a function which is called when an error
#' occurs. For example, \code{options(shiny.error=recover)} will result a
#' the debugger prompt when an error occurs.}
#' \item{shiny.table.class}{CSS class names to use for tables.}
#' \item{shiny.deprecation.messages}{This controls whether messages for
#' deprecated functions in Shiny will be printed. See
#' \code{\link{shinyDeprecated}} for more information.}
#' \item{shiny.fullstacktrace}{Controls whether "pretty" or full stack traces
#' are dumped to the console when errors occur during Shiny app execution.
#' The default is \code{FALSE} (pretty stack traces).}
#' \item{shiny.stacktraceoffset}{If \code{TRUE}, then Shiny's printed stack
#' traces will display srcrefs one line above their usual location. This is
#' an arguably more intuitive arrangement for casual R users, as the name
#' of a function appears next to the srcref where it is defined, rather than
#' where it is currently being called from.}
#' \item{shiny.sanitize.errors}{If \code{TRUE}, then normal errors (i.e.
#' errors not wrapped in \code{safeError}) won't show up in the app; a simple
#' generic error message is printed instead (the error and strack trace printed
#' to the console remain unchanged). The default is \code{FALSE} (unsanitized
#' errors).If you want to sanitize errors in general, but you DO want a
#' particular error \code{e} to get displayed to the user, then set this option
#' to \code{TRUE} and use \code{stop(safeError(e))} for errors you want the
#' user to see.}
#' \item{shiny.testmode}{If \code{TRUE}, then enable features for testing Shiny
#' applications. If \code{FALSE} (the default), do not enable those features.
#' }
#' }
#' @name shiny-options
NULL
createUniqueId <- function(bytes, prefix = "", suffix = "") {
withPrivateSeed({
paste(
prefix,
paste(
format(as.hexmode(sample(256, bytes, replace = TRUE)-1), width=2),
collapse = ""),
suffix,
sep = ""
)
})
}
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, strict_atomic = TRUE) {
if (strict_atomic) {
x <- I(x)
}
# I(x) is so that length-1 atomic vectors get put in [].
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, ...)
}
# If the input to jsonlite::fromJSON is not valid JSON, it will try to fetch a
# URL or read a file from disk. We don't want to allow that.
safeFromJSON <- function(txt, ...) {
if (!jsonlite::validate(txt)) {
stop("Argument 'txt' is not a valid JSON string.")
}
jsonlite::fromJSON(txt, ...)
}
# Call the workerId func with no args to get the worker id, and with an arg to
# set it.
#
# A worker ID is an opaque string that is passed in by the caller. The ID is
# added as a URL parameter (?w=<worker_id>) to any URLs that need to refer back
# to the app. This can be used as a hint for load balancers to direct requests
# to this particular process. Since the worker refers to a process, it's
# inherently global, and should never need to change.
workerId <- local({
.workerId <- NULL
function(value) {
if (missing(value)) {
.workerId
} else {
if (!is.null(.workerId)) {
if (!identical(value, .workerId)) {
warning("Ignoring workerId value--",
"it's already been set to a different value")
}
} else {
.workerId <<- value
}
}
}
})
#' Session object
#'
#' Shiny server functions can optionally include \code{session} as a parameter
#' (e.g. \code{function(input, output, session)}). The session object is an
#' environment that can be used to access information and functionality
#' relating to the session. The following list describes the items available
#' in the environment; they can be accessed using the \code{$} operator (for
#' example, \code{session$clientData$url_search}).
#'
#' @return
#' \item{allowReconnect(value)}{
#' If \code{value} is \code{TRUE} and run in a hosting environment (Shiny
#' Server or Connect) with reconnections enabled, then when the session ends
#' due to the network connection closing, the client will attempt to
#' reconnect to the server. If a reconnection is successful, the browser will
#' send all the current input values to the new session on the server, and
#' the server will recalculate any outputs and send them back to the client.
#' If \code{value} is \code{FALSE}, reconnections will be disabled (this is
#' the default state). If \code{"force"}, then the client browser will always
#' attempt to reconnect. The only reason to use \code{"force"} is for testing
#' on a local connection (without Shiny Server or Connect).
#' }
#' \item{clientData}{
#' A \code{\link{reactiveValues}} object that contains information about the client.
#' \itemize{
#' \item{\code{allowDataUriScheme} is a logical value that indicates whether
#' the browser is able to handle URIs that use the \code{data:} scheme.
#' }
#' \item{\code{pixelratio} reports the "device pixel ratio" from the web browser,
#' or 1 if none is reported. The value is 2 for Apple Retina displays.
#' }
#' \item{\code{singletons} - for internal use}
#' \item{\code{url_protocol}, \code{url_hostname}, \code{url_port},
#' \code{url_pathname}, \code{url_search}, \code{url_hash_initial}
#' and \code{url_hash} can be used to get the components of the URL
#' that was requested by the browser to load the Shiny app page.
#' These values are from the browser's perspective, so neither HTTP
#' proxies nor Shiny Server will affect these values. The
#' \code{url_search} value may be used with \code{\link{parseQueryString}}
#' to access query string parameters.
#' }
#' }
#' \code{clientData} also contains information about each output.
#' \code{output_\var{outputId}_width} and \code{output_\var{outputId}_height}
#' give the dimensions (using \code{offsetWidth} and \code{offsetHeight}) of
#' the DOM element that is bound to \code{\var{outputId}}, and
#' \code{output_\var{outputId}_hidden} is a logical that indicates whether
#' the element is hidden. These values may be \code{NULL} if the output is
#' not bound.
#' }
#' \item{input}{
#' The session's \code{input} object (the same as is passed into the Shiny
#' server function as an argument).
#' }
#' \item{isClosed()}{A function that returns \code{TRUE} if the client has
#' disconnected.
#' }
#' \item{ns(id)}{
#' Server-side version of \code{ns <- \link{NS}(id)}. If bare IDs need to be
#' explicitly namespaced for the current module, \code{session$ns("name")}
#' will return the fully-qualified ID.
#' }
#' \item{onEnded(callback)}{
#' Synonym for \code{onSessionEnded}.
#' }
#' \item{onFlush(func, once=TRUE)}{
#' Registers a function to be called before the next time (if \code{once=TRUE})
#' or every time (if \code{once=FALSE}) Shiny flushes the reactive system.
#' Returns a function that can be called with no arguments to cancel the
#' registration.
#' }
#' \item{onFlushed(func, once=TRUE)}{
#' Registers a function to be called after the next time (if \code{once=TRUE})
#' or every time (if \code{once=FALSE}) Shiny flushes the reactive system.
#' Returns a function that can be called with no arguments to cancel the
#' registration.
#' }
#' \item{onSessionEnded(callback)}{
#' Registers a function to be called after the client has disconnected.
#' Returns a function that can be called with no arguments to cancel the
#' registration.
#' }
#' \item{output}{
#' The session's \code{output} object (the same as is passed into the Shiny
#' server function as an argument).
#' }
#' \item{reactlog}{
#' For internal use.
#' }
#' \item{registerDataObj(name, data, filterFunc)}{
#' Publishes any R object as a URL endpoint that is unique to this session.
#' \code{name} must be a single element character vector; it will be used
#' to form part of the URL. \code{filterFunc} must be a function that takes
#' two arguments: \code{data} (the value that was passed into
#' \code{registerDataObj}) and \code{req} (an environment that implements
#' the Rook specification for HTTP requests). \code{filterFunc} will be
#' called with these values whenever an HTTP request is made to the URL
#' endpoint. The return value of \code{filterFunc} should be a Rook-style
#' response.
#' }
#' \item{reload()}{
#' The equivalent of hitting the browser's Reload button. Only works if the
#' session is actually connected.
#' }
#' \item{request}{
#' An environment that implements the Rook specification for HTTP requests.
#' This is the request that was used to initiate the websocket connection
#' (as opposed to the request that downloaded the web page for the app).
#' }
#' \item{userData}{
#' An environment for app authors and module/package authors to store whatever
#' session-specific data they want.
#' }
#' \item{resetBrush(brushId)}{
#' Resets/clears the brush with the given \code{brushId}, if it exists on
#' any \code{imageOutput} or \code{plotOutput} in the app.
#' }
#' \item{sendCustomMessage(type, message)}{
#' Sends a custom message to the web page. \code{type} must be a
#' single-element character vector giving the type of message, while
#' \code{message} can be any jsonlite-encodable value. Custom messages
#' have no meaning to Shiny itself; they are used soley to convey information
#' to custom JavaScript logic in the browser. You can do this by adding
#' JavaScript code to the browser that calls
#' \code{Shiny.addCustomMessageHandler(type, function(message){...})}
#' as the page loads; the function you provide to
#' \code{addCustomMessageHandler} will be invoked each time
#' \code{sendCustomMessage} is called on the server.
#' }
#' \item{sendBinaryMessage(type, message)}{
#' Similar to \code{sendCustomMessage}, but the message must be a raw vector
#' and the registration method on the client is
#' \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
#' message argument on the client will be a
#' \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
#' }
#' \item{sendInputMessage(inputId, message)}{
#' Sends a message to an input on the session's client web page; if the input
#' is present and bound on the page at the time the message is received, then
#' the input binding object's \code{receiveMessage(el, message)} method will
#' be called. \code{sendInputMessage} should generally not be called directly
#' from Shiny apps, but through friendlier wrapper functions like
#' \code{\link{updateTextInput}}.
#' }
#' \item{setBookmarkExclude(names)}{
#' Set input names to be excluded from bookmarking.
#' }
#' \item{getBookmarkExclude()}{
#' Returns the set of input names to be excluded from bookmarking.
#' }
#' \item{onBookmark(fun)}{
#' Registers a function that will be called just before bookmarking state.
#' }
#' \item{onBookmarked(fun)}{
#' Registers a function that will be called just after bookmarking state.
#' }
#' \item{onRestore(fun)}{
#' Registers a function that will be called when a session is restored, before
#' all other reactives, observers, and render functions are run.
#' }
#' \item{onRestored(fun)}{
#' Registers a function that will be called when a session is restored, after
#' all other reactives, observers, and render functions are run.
#' }
#' \item{doBookmark()}{
#' Do bookmarking and invoke the onBookmark and onBookmarked callback functions.
#' }
#' \item{exportTestValues()}{
#' Registers expressions for export in test mode, available at the test
#' snapshot URL.
#' }
#' \item{getTestSnapshotUrl(input=TRUE, output=TRUE, export=TRUE,
#' format="json")}{
#' Returns a URL for the test snapshots. Only has an effect when the
#' \code{shiny.testmode} option is set to TRUE. For the input, output, and
#' export arguments, TRUE means to return all of these values. It is also
#' possible to specify by name which values to return by providing a
#' character vector, as in \code{input=c("x", "y")}. The format can be
#' "rds" or "json".
#' }
#'
#' @name session
NULL
#' Namespaced IDs for inputs/outputs
#'
#' The \code{NS} function creates namespaced IDs out of bare IDs, by joining
#' them using \code{ns.sep} as the delimiter. It is intended for use in Shiny
#' modules. See \url{http://shiny.rstudio.com/articles/modules.html}.
#'
#' Shiny applications use IDs to identify inputs and outputs. These IDs must be
#' unique within an application, as accidentally using the same input/output ID
#' more than once will result in unexpected behavior. The traditional solution
#' for preventing name collisions is \emph{namespaces}; a namespace is to an ID
#' as a directory is to a file. Use the \code{NS} function to turn a bare ID
#' into a namespaced one, by combining them with \code{ns.sep} in between.
#'
#' @param namespace The character vector to use for the namespace. This can have
#' any length, though a single element is most common. Length 0 will cause the
#' \code{id} to be returned without a namespace, and length 2 will be
#' interpreted as multiple namespaces, in increasing order of specificity
#' (i.e. starting with the top-level namespace).
#' @param id The id string to be namespaced (optional).
#' @return If \code{id} is missing, returns a function that expects an id string
#' as its only argument and returns that id with the namespace prepended.
#' @seealso \url{http://shiny.rstudio.com/articles/modules.html}
#' @export
NS <- function(namespace, id = NULL) {
if (length(namespace) == 0)
ns_prefix <- character(0)
else
ns_prefix <- paste(namespace, collapse = ns.sep)
f <- function(id) {
if (length(id) == 0)
return(ns_prefix)
if (length(ns_prefix) == 0)
return(id)
paste(ns_prefix, id, sep = ns.sep)
}
if (missing(id)) {
f
} else {
f(id)
}
}
#' @rdname NS
#' @export
ns.sep <- "-"
#' @include utils.R
ShinySession <- R6Class(
'ShinySession',
private = list(
# There are some private items with a leading "."; except for the dot, these
# items share a name with a public item.
websocket = 'ANY',
invalidatedOutputValues = 'Map',
invalidatedOutputErrors = 'Map',
inputMessageQueue = list(), # A list of inputMessages to send when flushed
cycleStartActionQueue = list(), # A list of actions to perform to start a cycle
.outputs = list(), # Keeps track of all the output observer objects
.outputOptions = list(), # Options for each of the output observer objects
progressKeys = 'character',
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
busyCount = 0L, # Number of observer callbacks that are pending. When 0, we are idle
closedCallbacks = 'Callbacks',
flushCallbacks = 'Callbacks',
flushedCallbacks = 'Callbacks',
inputReceivedCallbacks = 'Callbacks',
bookmarkCallbacks = 'Callbacks',
bookmarkedCallbacks = 'Callbacks',
restoreCallbacks = 'Callbacks',
restoredCallbacks = 'Callbacks',
bookmarkExclude = character(0), # Names of inputs to exclude from bookmarking
getBookmarkExcludeFuns = list(),
timingRecorder = 'ShinyServerTimingRecorder',
testMode = FALSE, # Are we running in test mode?
testExportExprs = list(),
outputValues = list(), # Saved output values (for testing mode)
testSnapshotUrl = character(0),
sendResponse = function(requestMsg, value) {
if (is.null(requestMsg$tag)) {
warning("Tried to send response for untagged message; method: ",
requestMsg$method)
return()
}
private$sendMessage(
response = list(tag = requestMsg$tag, value = value)
)
},
sendErrorResponse = function(requestMsg, error) {
if (is.null(requestMsg$tag))
return()
private$sendMessage(
response = list(tag = requestMsg$tag, error = error)
)
},
write = function(json) {
if (self$closed){
return()
}
traceOption <- getOption('shiny.trace', FALSE)
if (isTRUE(traceOption) || traceOption == "send")
message('SEND ',
gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE))
private$websocket$send(json)
},
sendMessage = function(...) {
# This function is a wrapper for $write
msg <- list(...)
if (anyUnnamed(msg)) {
stop("All arguments to sendMessage must be named.")
}
private$write(toJSON(msg))
},
getOutputOption = function(outputName, propertyName, defaultValue) {
opts <- private$.outputOptions[[outputName]]
if (is.null(opts))
return(defaultValue)
result <- opts[[propertyName]]
if (is.null(result))
return(defaultValue)
return(result)
},
shouldSuspend = function(name) {
# Find corresponding hidden state clientData variable, with the format
# "output_foo_hidden". (It comes from .clientdata_output_foo_hidden
# on the JS side)
# Some tricky stuff: instead of accessing names using input$names(),
# get the names directly via input$.values, to avoid triggering reactivity.
# Need to handle cases where the output object isn't actually used
# in the web page; in these cases, there's no output_foo_hidden flag,
# and hidden should be TRUE. In other words, NULL and TRUE should map to
# TRUE, FALSE should map to FALSE.
hidden <- private$.clientData$.values[[paste("output_", name, "_hidden",
sep="")]]
if (is.null(hidden)) hidden <- TRUE
return(hidden && private$getOutputOption(name, 'suspendWhenHidden', TRUE))
},
registerSessionEndCallbacks = function() {
# This is to be called from the initialization. It registers functions
# that are called when a session ends.
# Clear file upload directories, if present
self$onSessionEnded(private$fileUploadContext$rmUploadDirs)
},
# Modules (scopes) call this to register a function that returns a vector
# of names to exclude from bookmarking. The function should return
# something like c("scope1-x", "scope1-y"). This doesn't use a Callback
# object because the return values of the functions are needed, but
# Callback$invoke() discards return values.
registerBookmarkExclude = function(fun) {
len <- length(private$getBookmarkExcludeFuns) + 1
private$getBookmarkExcludeFuns[[len]] <- fun
},
# Save output values and errors. This is only used for testing mode.
storeOutputValues = function(values = NULL) {
private$outputValues <- mergeVectors(private$outputValues, values)
},
enableTestSnapshot = function() {
private$testSnapshotUrl <- self$registerDataObj("shinytest", NULL,
function(data, req) {
if (!isTRUE(private$testMode)) {
return()
}
params <- parseQueryString(req$QUERY_STRING)
# The format of the response that will be sent back. Defaults to
# "json" unless requested otherwise. The only other valid value is
# "rds".
format <- params$format %OR% "json"
values <- list()
if (!is.null(params$input)) {
allInputs <- isolate(
reactiveValuesToList(self$input, all.names = TRUE)
)
# If params$input is "1", return all; otherwise return just the
# inputs that are named in params$input, like "x,y,z".
if (params$input == "1") {
values$input <- allInputs
} else {
items <- strsplit(params$input, ",")[[1]]
items <- intersect(items, names(allInputs))
values$input <- allInputs[items]
}
# Apply preprocessor functions for inputs that have them.
values$input <- lapply(
setNames(names(values$input), names(values$input)),
function(name) {
preprocess <- private$getSnapshotPreprocessInput(name)
preprocess(values$input[[name]])
}
)
values$input <- sortByName(values$input)
}
if (!is.null(params$output)) {
if (params$output == "1") {
values$output <- private$outputValues
} else {
items <- strsplit(params$output, ",")[[1]]
items <- intersect(items, names(private$outputValues))
values$output <- private$outputValues[items]
}
# Filter out those outputs that have the snapshotExclude attribute.
exclude_idx <- vapply(names(values$output), function(name) {
isTRUE(attr(private$.outputs[[name]], "snapshotExclude", TRUE))
}, logical(1))
values$output <- values$output[!exclude_idx]
# Apply snapshotPreprocess functions for outputs that have them.
values$output <- lapply(
setNames(names(values$output), names(values$output)),
function(name) {
preprocess <- private$getSnapshotPreprocessOutput(name)
preprocess(values$output[[name]])
}
)
values$output <- sortByName(values$output)
}
if (!is.null(params$export)) {
if (params$export == "1") {
values$export <- isolate(
lapply(private$testExportExprs, function(item) {
eval(item$expr, envir = item$env)
})
)
} else {
items <- strsplit(params$export, ",")[[1]]
items <- intersect(items, names(private$testExportExprs))
values$export <- isolate(
lapply(private$testExportExprs[items], function(item) {
eval(item$expr, envir = item$env)
})
)
}
values$export <- sortByName(values$export)
}
# Make sure input, output, and export are all named lists (at this
# point, they could be unnamed if they are empty lists). This is so
# that the resulting object is represented as an object in JSON
# instead of an array, and so that the RDS data structure is of a
# consistent type.
values <- lapply(values, asNamedVector)
if (length(values) == 0) {
return(httpResponse(400, "text/plain",
"None of export, input, or output requested."
))
}
if (identical(format, "json")) {
content <- toJSON(values, pretty = TRUE)
httpResponse(200, "application/json", content)
} else if (identical(format, "rds")) {
tmpfile <- tempfile("shinytest", fileext = ".rds")
saveRDS(values, tmpfile)
on.exit(unlink(tmpfile), add = TRUE)
content <- readBin(tmpfile, "raw", n = file.info(tmpfile)$size)
httpResponse(200, "application/octet-stream", content)
} else {
httpResponse(400, "text/plain", paste("Invalid format requested:", format))
}
}
)
},
# Get the snapshotPreprocessOutput function for an output name. If no preprocess
# function has been set, return the identity function.
getSnapshotPreprocessOutput = function(name) {
fun <- attr(private$.outputs[[name]], "snapshotPreprocess", exact = TRUE)
fun %OR% identity
},
# Get the snapshotPreprocessInput function for an input name. If no preprocess
# function has been set, return the identity function.
getSnapshotPreprocessInput = function(name) {
fun <- private$.input$getMeta(name, "shiny.snapshot.preprocess")
fun %OR% identity
},
# See cycleStartAction
startCycle = function() {
if (length(private$cycleStartActionQueue) > 0) {
head <- private$cycleStartActionQueue[[1L]]
private$cycleStartActionQueue <- private$cycleStartActionQueue[-1L]
head()
}
}
),
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
clientData = 'reactivevalues', # Externally-usable S3 wrapper object for .clientData
token = 'character', # Used to identify this instance in URLs
files = 'Map', # For keeping track of files sent to client
downloads = 'Map',
closed = logical(0),
request = 'ANY', # Websocket request object
singletons = character(0), # Tracks singleton HTML fragments sent to the page
userData = 'environment',
user = NULL,
groups = NULL,
initialize = function(websocket) {
private$websocket <- websocket
self$closed <- FALSE
# TODO: Put file upload context in user/app-specific dir if possible
private$invalidatedOutputValues <- Map$new()
private$invalidatedOutputErrors <- Map$new()
private$fileUploadContext <- FileUploadContext$new()
private$closedCallbacks <- Callbacks$new()
private$flushCallbacks <- Callbacks$new()
private$flushedCallbacks <- Callbacks$new()
private$inputReceivedCallbacks <- Callbacks$new()
private$.input <- ReactiveValues$new(dedupe = FALSE)
private$.clientData <- ReactiveValues$new(dedupe = TRUE)
private$timingRecorder <- ShinyServerTimingRecorder$new()
self$progressStack <- Stack$new()
self$files <- Map$new()
self$downloads <- Map$new()
self$userData <- new.env(parent = emptyenv())
self$input <- .createReactiveValues(private$.input, readonly=TRUE)
.setLabel(self$input, 'input')
self$clientData <- .createReactiveValues(private$.clientData, readonly=TRUE)
.setLabel(self$clientData, 'clientData')
self$output <- .createOutputWriter(self)
self$token <- createUniqueId(16)
private$.outputs <- list()
private$.outputOptions <- list()
private$bookmarkCallbacks <- Callbacks$new()
private$bookmarkedCallbacks <- Callbacks$new()
private$restoreCallbacks <- Callbacks$new()
private$restoredCallbacks <- Callbacks$new()
private$testMode <- .globals$testMode
private$enableTestSnapshot()
private$registerSessionEndCallbacks()
if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
try({
creds <- safeFromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
self$user <- creds$user
self$groups <- creds$groups
}, silent=FALSE)
}
# session$request should throw an error if httpuv doesn't have
# websocket$request, but don't throw it until a caller actually
# tries to access session$request
delayedAssign('request', websocket$request, assign.env = self)
private$sendMessage(
config = list(
workerId = workerId(),
sessionId = self$token,
user = self$user
)
)
},
startTiming = function(guid) {
if (!is.null(guid)) {
private$timingRecorder$start(guid)
self$onFlush(private$timingRecorder$stop)
}
},
requestFlush = function() {
appsNeedingFlush$set(self$token, self)
},
rootScope = function() {
self
},
makeScope = function(namespace) {
ns <- NS(namespace)
# 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) {
.subset2(self, "sendInputMessage")(ns(inputId), message)
},
registerDataObj = function(name, data, filterFunc) {
.subset2(self, "registerDataObj")(ns(name), data, filterFunc)
},
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)
},
exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) {
if (quoted_) {
dots <- list(...)
} else {
dots <- eval(substitute(alist(...)))
}
if (anyUnnamed(dots))
stop("exportTestValues: all arguments must be named.")
names(dots) <- ns(names(dots))
do.call(
.subset2(self, "exportTestValues"),
c(dots, quoted_ = TRUE, env_ = env_),
quote = TRUE
)
}
)
# 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)
})
# Returns the excluded names with the scope's ns prefix on them.
private$registerBookmarkExclude(function() {
excluded <- scope$getBookmarkExclude()
ns(excluded)
})
scope
},
ns = function(id) {
NS(NULL, id)
},
# Freeze a value until the flush cycle completes
freezeValue = function(x, name) {
if (!is.reactivevalues(x))
stop("x must be a reactivevalues object")
impl <- .subset2(x, 'impl')
impl$freeze(name)
self$onFlushed(function() impl$thaw(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
is a function which unregisters the callback. If multiple callbacks are
registered, the order in which they are invoked is not guaranteed."
return(private$closedCallbacks$register(sessionEndedCallback))
},
onEnded = function(endedCallback) {
"Synonym for onSessionEnded"
return(self$onSessionEnded(endedCallback))
},
onInputReceived = function(callback) {
"Registers the given callback to be invoked when the session receives
new data from the client."
return(private$inputReceivedCallbacks$register(callback))
},
unhandledError = function(e) {
self$close()
},
close = function() {
if (!self$closed) {
private$websocket$close()
}
},
wsClosed = function() {
self$closed <- TRUE
for (output in private$.outputs) {
output$suspend()
}
# ..stacktraceon matches with the top-level ..stacktraceoff..
private$closedCallbacks$invoke(onError = printError, ..stacktraceon = TRUE)
},
isClosed = function() {
return(self$closed)
},
isEnded = function() {
return(self$isClosed())
},
setShowcase = function(value) {
private$showcase <- !is.null(value) && as.logical(value)
},
allowReconnect = function(value) {
if (!(identical(value, TRUE) || identical(value, FALSE) || identical(value, "force"))) {
stop('value must be TRUE, FALSE, or "force"')
}
private$write(toJSON(list(allowReconnect = value)))
},
defineOutput = function(name, func, label) {
"Binds an output generating function to this name. The function can either
take no parameters, or have named parameters for \\code{name} and
\\code{shinysession} (in the future this list may expand, so it is a good idea
to also include \\code{...} in your function signature)."
# jcheng 08/31/2012: User submitted an example of a dynamically calculated
# name not working unless name was eagerly evaluated. Yikes!
force(name)
# If overwriting an output object, destroy the previous copy of it
if (!is.null(private$.outputs[[name]])) {
private$.outputs[[name]]$destroy()
}
if (is.null(func)) {
# If func is null, give it an "empty" output function so it can go
# through the logic below. If we simply returned at this point, the
# previous output (if any) would continue to show in the client.
func <- missingOutput
}
if (is.function(func)) {
# Extract any output attributes attached to the render function. These
# will be attached to the observer after it's created.
outputAttrs <- attr(func, "outputAttrs", TRUE)
funcFormals <- formals(func)
# ..stacktraceon matches with the top-level ..stacktraceoff.., because
# the observer we set up below has ..stacktraceon=FALSE
func <- wrapFunctionLabel(func, paste0("output$", name), ..stacktraceon = TRUE)
if (length(funcFormals) != 0) {
orig <- func
func <- function() {
orig(name=name, shinysession=self)
}
}
# Preserve source reference and file information when formatting the
# label for display in the reactive graph
srcref <- attr(label, "srcref")
srcfile <- attr(label, "srcfile")
label <- sprintf('output$%s', name)
attr(label, "srcref") <- srcref
attr(label, "srcfile") <- srcfile
obs <- observe(..stacktraceon = FALSE, {
private$sendMessage(recalculating = list(
name = name, status = 'recalculating'
))
# This shinyCallingHandlers should maybe be at a higher level,
# to include the $then/$catch calls below?
hybrid_chain(
hybrid_chain(
shinyCallingHandlers(func()),
catch = function(cond) {
if (inherits(cond, "shiny.custom.error")) {
if (isTRUE(getOption("show.error.messages"))) printError(cond)
structure(list(), class = "try-error", condition = cond)
} else if (inherits(cond, "shiny.output.cancel")) {
structure(list(), class = "cancel-output")
} else if (inherits(cond, "shiny.silent.error")) {
# Don't let shiny.silent.error go through the normal stop
# path of try, because we don't want it to print. But we
# do want to try to return the same looking result so that
# the code below can send the error to the browser.
structure(list(), class = "try-error", condition = cond)
} else {
if (isTRUE(getOption("show.error.messages"))) printError(cond)
if (getOption("shiny.sanitize.errors", FALSE)) {
cond <- simpleError(paste("An error has occurred. Check your",
"logs or contact the app author for",
"clarification."))
}
invisible(structure(list(), class = "try-error", condition = cond))
}
}
),
function(value) {
# Needed so that Shiny knows to flush the outputs. Even if no
# outputs/errors are queued, it's necessary to flush so that the
# client knows that progress is over.
self$requestFlush()
private$sendMessage(recalculating = list(
name = name, status = 'recalculated'
))
if (inherits(value, "cancel-output")) {
return()
}
private$invalidatedOutputErrors$remove(name)
private$invalidatedOutputValues$remove(name)
if (inherits(value, 'try-error')) {
cond <- attr(value, 'condition')
type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
private$invalidatedOutputErrors$set(
name,
list(message = cond$message,
call = utils::capture.output(print(cond$call)),
type = if (length(type)) type))
}
else
private$invalidatedOutputValues$set(name, value)
}
)
}, suspended=private$shouldSuspend(name), label=label)
# If any output attributes were added to the render function attach
# them to observer.
lapply(names(outputAttrs), function(name) {
attr(obs, name) <- outputAttrs[[name]]
})
obs$onInvalidate(function() {
self$showProgress(name)
})
private$.outputs[[name]] <- obs
if (is.null(private$.outputOptions[[name]]))
private$.outputOptions[[name]] <- list()
}
else {
stop(paste("Unexpected", class(func), "output for", name))
}
},
flushOutput = function() {
if (private$busyCount > 0)
return()
appsNeedingFlush$remove(self$token)
if (self$isClosed())
return()
# Return TRUE if there's any stuff to send to the client.
hasPendingUpdates <- function() {
# Even though progressKeys isn't sent to the client, we use it in this
# check. This is because if it is non-empty, sending `values` to the
# client tells it that the flushReact loop is finished, and the client
# then knows to stop showing progress.
return(
length(private$progressKeys) != 0 ||
length(private$invalidatedOutputValues) != 0 ||
length(private$invalidatedOutputErrors) != 0 ||
length(private$inputMessageQueue) != 0
)
}
withReactiveDomain(self, {
# ..stacktraceon matches with the top-level ..stacktraceoff..
private$flushCallbacks$invoke(..stacktraceon = TRUE)
# Schedule execution of onFlushed callbacks
on.exit({
# ..stacktraceon matches with the top-level ..stacktraceoff..
private$flushedCallbacks$invoke(..stacktraceon = TRUE)
}, add = TRUE)
if (!hasPendingUpdates()) {
# Normally, if there are no updates, simply return without sending
# anything to the client. But if we are in test mode, we still want to
# send a message with blank `values`, so that the client knows that
# any changed inputs have been received by the server and processed.
if (isTRUE(private$testMode)) {
private$sendMessage( values = list() )
}
return(invisible())
}
private$progressKeys <- character(0)
values <- as.list(private$invalidatedOutputValues)
private$invalidatedOutputValues <- Map$new()
errors <- as.list(private$invalidatedOutputErrors)
private$invalidatedOutputErrors <- Map$new()
inputMessages <- private$inputMessageQueue
private$inputMessageQueue <- list()
if (isTRUE(private$testMode)) {
private$storeOutputValues(mergeVectors(values, errors))
}
private$sendMessage(
errors = errors,
values = values,
inputMessages = inputMessages
)
})
},
# Schedule an action to execute not (necessarily) now, but when no observers
# that belong to this session are busy executing. This helps prevent (but
# does not guarantee) inputs and reactive values from changing underneath
# async observers as they run.
cycleStartAction = function(callback) {
private$cycleStartActionQueue <- c(private$cycleStartActionQueue, list(callback))
# If no observers are running in this session, we're safe to proceed.
# Otherwise, startCycle() will be called later, via decrementBusyCount().
if (private$busyCount == 0L) {
private$startCycle()
}
},
showProgress = function(id) {
'Send a message to the client that recalculation of the output identified
by \\code{id} is in progress. There is currently no mechanism for
explicitly turning off progress for an output component; instead, all
progress is implicitly turned off when flushOutput is next called.'
# If app is already closed, be sure not to show progress, otherwise we
# will get an error because of the closed websocket
if (self$closed)
return()
if (id %in% private$progressKeys)
return()
private$progressKeys <- c(private$progressKeys, id)
self$sendProgress('binding', list(id = id))
},
sendProgress = function(type, message) {
private$sendMessage(
progress = list(type = type, message = message)
)
},
sendNotification = function(type, message) {
private$sendMessage(
notification = list(type = type, message = message)
)
},
sendModal = function(type, message) {
private$sendMessage(
modal = list(type = type, message = message)
)
},
dispatch = function(msg) {
method <- paste('@', msg$method, sep='')
func <- try(self[[method]], silent = TRUE)
if (inherits(func, 'try-error')) {
private$sendErrorResponse(msg, paste('Unknown method', msg$method))
}
value <- try(do.call(func, as.list(append(msg$args, msg$blobs))),
silent=TRUE)
if (inherits(value, 'try-error')) {
private$sendErrorResponse(msg, conditionMessage(attr(value, 'condition')))
}
else {
private$sendResponse(msg, value)
}
},
sendBinaryMessage = function(type, message) {
typeBytes <- charToRaw(type)
if (length(typeBytes) > 255) {
stop("'type' argument is too long")
}
private$write(c(as.raw(length(typeBytes)), typeBytes, message))
},
sendCustomMessage = function(type, message) {
data <- list()
data[[type]] <- message
private$sendMessage(custom = data)
},
sendInputMessage = function(inputId, message) {
data <- list(id = inputId, message = message)
# Add to input message queue
private$inputMessageQueue[[length(private$inputMessageQueue) + 1]] <- data
# Needed so that Shiny knows to actually flush the input message queue
self$requestFlush()
},
onFlush = function(flushCallback, once = TRUE) {
if (!isTRUE(once)) {
return(private$flushCallbacks$register(flushCallback))
} else {
dereg <- private$flushCallbacks$register(function() {
dereg()
flushCallback()
})
return(dereg)
}
},
onFlushed = function(flushedCallback, once = TRUE) {
if (!isTRUE(once)) {
return(private$flushedCallbacks$register(flushedCallback))
} else {
dereg <- private$flushedCallbacks$register(function() {
dereg()
flushedCallback()
})
return(dereg)
}
},
createBookmarkObservers = function() {
# This registers observers for bookmarking to work.
# Get bookmarking config
store <- getShinyOption("bookmarkStore", default = "disable")
if (store == "disable")
return()
# Warn if trying to enable save-to-server bookmarking on a version of SS,
# SSP, or Connect that doesn't support it.
if (store == "server" && inShinyServer() &&
is.null(getShinyOption("save.interface")))
{
showNotification(
"This app tried to enable saved-to-server bookmarking, but it is not supported by the hosting environment.",
duration = NULL, type = "warning", session = self
)
return()
}
withReactiveDomain(self, {
# This observer fires when the bookmark button is clicked.
observeEvent(self$input[["._bookmark_"]], {
self$doBookmark()
})
# 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.
self$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
},
setBookmarkExclude = function(names) {
private$bookmarkExclude <- names
},
getBookmarkExclude = function() {
scopedExcludes <- lapply(private$getBookmarkExcludeFuns, function(f) f())
scopedExcludes <- unlist(scopedExcludes)
c(private$bookmarkExclude, scopedExcludes)
},
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)
},
doBookmark = function() {
# Get bookmarking store config
store <- getShinyOption("bookmarkStore", default = "disable")
if (store == "disable")
return()
tryCatch(
withLogErrors({
saveState <- ShinySaveState$new(
input = self$input,
exclude = self$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 <- self$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")
}
)
},
exportTestValues = function(..., quoted_ = FALSE, env_ = parent.frame()) {
# Get a named list of unevaluated expressions.
if (quoted_) {
dots <- list(...)
} else {
dots <- eval(substitute(alist(...)))
}
if (anyUnnamed(dots))
stop("exportTestValues: all arguments must be named.")
# Create a named list where each item is a list with an expression and
# environment in which to eval the expression.
items <- lapply(dots, function(expr) {
list(expr = expr, env = env_)
})
private$testExportExprs <- mergeVectors(private$testExportExprs, items)
},
getTestSnapshotUrl = function(input = TRUE, output = TRUE, export = TRUE,
format = "json") {
reqString <- function(group, value) {
if (isTRUE(value))
paste0(group, "=1")
else if (is.character(value))
paste0(group, "=", paste(value, collapse = ","))
else
""
}
paste(
private$testSnapshotUrl,
reqString("input", input),
reqString("output", output),
reqString("export", export),
paste0("format=", format),
sep = "&"
)
},
reactlog = function(logEntry) {
# Use sendCustomMessage instead of sendMessage, because the handler in
# shiny-showcase.js only has access to public API of the Shiny object.
if (private$showcase)
self$sendCustomMessage("reactlog", logEntry)
},
reload = function() {
private$sendMessage(reload = TRUE)
},
sendInsertUI = function(selector, multiple, where, content) {
private$sendMessage(
`shiny-insert-ui` = list(
selector = selector,
multiple = multiple,
where = where,
content = content
)
)
},
sendRemoveUI = function(selector, multiple) {
private$sendMessage(
`shiny-remove-ui` = list(
selector = selector,
multiple = multiple
)
)
},
sendInsertTab = function(inputId, liTag, divTag, menuName,
target, position, select) {
private$sendMessage(
`shiny-insert-tab` = list(
inputId = inputId,
liTag = liTag,
divTag = divTag,
menuName = menuName,
target = target,
position = position,
select = select
)
)
},
sendRemoveTab = function(inputId, target) {
private$sendMessage(
`shiny-remove-tab` = list(
inputId = inputId,
target = target
)
)
},
sendChangeTabVisibility = function(inputId, target, type) {
private$sendMessage(
`shiny-change-tab-visibility` = list(
inputId = inputId,
target = target,
type = type
)
)
},
updateQueryString = function(queryString, mode) {
private$sendMessage(updateQueryString = list(
queryString = queryString, mode = mode))
},
resetBrush = function(brushId) {
private$sendMessage(
resetBrush = list(
brushId = brushId
)
)
},
# Public RPC methods
`@uploadieFinish` = function() {
# Do nothing; just want the side effect of flushReact, output flush, etc.
},
`@uploadInit` = function(fileInfos) {
maxSize <- getOption('shiny.maxRequestSize', 5 * 1024 * 1024)
fileInfos <- lapply(fileInfos, function(fi) {
if (is.null(fi$type))
fi$type <- getContentType(fi$name)
fi
})
sizes <- sapply(fileInfos, function(fi){ fi$size })
if (maxSize > 0 && any(sizes > maxSize)) {
stop("Maximum upload size exceeded")
}
jobId <- private$fileUploadContext$createUploadOperation(fileInfos)
return(list(jobId=jobId,
uploadUrl=paste('session', self$token, 'upload',
paste(jobId, "?w=", workerId(), sep=""),
sep='/')))
},
`@uploadEnd` = function(jobId, inputId) {
fileData <- private$fileUploadContext$getUploadOperation(jobId)$finish()
private$.input$set(inputId, fileData)
setSerializer(inputId, serializerFileInput)
snapshotPreprocessInput(inputId, snapshotPreprocessorFileInput)
invisible()
},
# Provides a mechanism for handling direct HTTP requests that are posted
# to the session (rather than going through the websocket)
handleRequest = function(req) {
# TODO: Turn off caching for the response
subpath <- req$PATH_INFO
matches <- regmatches(subpath,
regexec("^/([a-z]+)/([^?]*)",
subpath,
ignore.case=TRUE))[[1]]
if (length(matches) == 0)
return(httpResponse(400, 'text/html', '<h1>Bad Request</h1>'))
if (matches[2] == 'file') {
savedFile <- self$files$get(URLdecode(matches[3]))
if (is.null(savedFile))
return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
return(httpResponse(200, savedFile$contentType, savedFile$data))
}
if (matches[2] == 'upload' && identical(req$REQUEST_METHOD, "POST")) {
job <- private$fileUploadContext$getUploadOperation(matches[3])
if (!is.null(job)) {
fileName <- req$HTTP_SHINY_FILE_NAME
fileType <- req$HTTP_SHINY_FILE_TYPE
fileSize <- req$CONTENT_LENGTH
job$fileBegin()
reqInput <- req$rook.input
while (length(buf <- reqInput$read(2^16)) > 0)
job$fileChunk(buf)
job$fileEnd()
return(httpResponse(200, 'text/plain', 'OK'))
}
}
# @description Only applicable to files uploaded via IE. When possible,
# adds the appropriate extension to temporary files created by
# \code{mime::parse_multipart}.
# @param multipart A named list as returned by
# \code{mime::parse_multipart}
# @return A named list with datapath updated to point to the new location
# of the file, if an extension was added.
maybeMoveIEUpload <- function(multipart) {
if (is.null(multipart)) return(NULL)
lapply(multipart, function(input) {
oldPath <- input$datapath
newPath <- paste0(oldPath, maybeGetExtension(input$name))
if (oldPath != newPath) {
file.rename(oldPath, newPath)
input$datapath <- newPath
}
input
})
}
if (matches[2] == 'uploadie' && identical(req$REQUEST_METHOD, "POST")) {
id <- URLdecode(matches[3])
res <- maybeMoveIEUpload(mime::parse_multipart(req))
private$.input$set(id, res[[id]])
return(httpResponse(200, 'text/plain', 'OK'))
}
if (matches[2] == 'download') {
# A bunch of ugliness here. Filenames can be dynamically generated by
# the user code, so we don't know what they'll be in advance. But the
# most reliable way to use non-ASCII filenames for downloads is to
# put the actual filename in the URL. So we will start with URLs in
# the form:
#
# /session/$TOKEN/download/$NAME
#
# When a request matching that pattern is received, we will calculate
# the filename and see if it's non-ASCII; if so, we'll redirect to
#
# /session/$TOKEN/download/$NAME/$FILENAME
#
# And when that pattern is received, we will actually return the file.
# Note that this means the filename and contents could be determined
# a few moments apart from each other (an HTTP roundtrip basically),
# hopefully that won't be enough to matter for anyone.
dlmatches <- regmatches(matches[3],
regexec("^([^/]+)(/[^/]+)?$",
matches[3]))[[1]]
dlname <- URLdecode(dlmatches[2])
download <- self$downloads$get(dlname)
if (is.null(download))
return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
filename <- ifelse(is.function(download$filename),
Context$new(getDefaultReactiveDomain(), '[download]')$run(
download$filename
),
download$filename)
# If the URL does not contain the filename, and the desired filename
# contains non-ASCII characters, then do a redirect with the desired
# name tacked on the end.
if (dlmatches[3] == '' && grepl('[^ -~]', filename)) {
return(httpResponse(302, 'text/html', '<h1>Found</h1>', c(
'Location' = sprintf('%s/%s',
URLencode(dlname, TRUE),
URLencode(filename, TRUE)),
'Cache-Control' = 'no-cache')))
}
# Make temp file with the same extension as the user-visible filename.
# If the extension is not used, some functions such as pdf() and zip()
# may append the extension they expect, meaning the data we want will
# be written to a file other than our temp file (e.g. file1231.zip
# instead of file1231.zip).
ext <- tools::file_ext(filename)
if (nzchar(ext))
ext <- paste(".", ext, sep = "")
tmpdata <- tempfile(fileext = ext)
return(Context$new(getDefaultReactiveDomain(), '[download]')$run(function() {
promises::with_promise_domain(reactivePromiseDomain(), {
promises::with_promise_domain(createStackTracePromiseDomain(), {
self$incrementBusyCount()
hybrid_chain(
# ..stacktraceon matches with the top-level ..stacktraceoff..
try(..stacktraceon..(download$func(tmpdata)), silent = TRUE),
function(result) {
if (inherits(result, 'try-error')) {
unlink(tmpdata)
stop(attr(result, "condition", exact = TRUE))
}
if (!file.exists(tmpdata)) {
# If no file was created, return a 404
return(httpResponse(404, content = "404 Not found"))
}
return(httpResponse(
200,
download$contentType %OR% getContentType(filename),
# owned=TRUE means tmpdata will be deleted after response completes
list(file=tmpdata, owned=TRUE),
c(
'Content-Disposition' = ifelse(
dlmatches[3] == '',
'attachment; filename="' %.%
gsub('(["\\\\])', '\\\\\\1', filename) %.% # yes, that many \'s
'"',
'attachment'
),
'Cache-Control'='no-cache')))
},
finally = function() {
self$decrementBusyCount()
}
)
})
})
}))
}
if (matches[2] == 'dataobj') {
# /session/$TOKEN/dataobj/$NAME
dlmatches <- regmatches(matches[3],
regexec("^([^/]+)(/[^/]+)?$",
matches[3]))[[1]]
dlname <- URLdecode(dlmatches[2])
download <- self$downloads$get(dlname)
return(download$filter(download$data, req))
}
return(httpResponse(404, 'text/html', '<h1>Not Found</h1>'))
},
saveFileUrl = function(name, data, contentType, extra=list()) {
"Creates an entry in the file map for the data, and returns a URL pointing
to the file."
self$files$set(name, list(data=data, contentType=contentType))
return(sprintf('session/%s/file/%s?w=%s&r=%s',
URLencode(self$token, TRUE),
URLencode(name, TRUE),
workerId(),
createUniqueId(8)))
},
# Send a file to the client
fileUrl = function(name, file, contentType='application/octet-stream') {
"Return a URL for a file to be sent to the client. If allowDataUriScheme
is TRUE, then the file will be base64 encoded and embedded in the URL.
Otherwise, a URL pointing to the file will be returned."
bytes <- file.info(file)$size
if (is.na(bytes))
return(NULL)
fileData <- readBin(file, 'raw', n=bytes)
if (isTRUE(private$.clientData$.values$allowDataUriScheme)) {
b64 <- rawToBase64(fileData)
return(paste('data:', contentType, ';base64,', b64, sep=''))
} else {
return(self$saveFileUrl(name, fileData, contentType))
}
},
registerDownload = function(name, filename, contentType, func) {
self$downloads$set(name, list(filename = filename,
contentType = contentType,
func = func))
return(sprintf('session/%s/download/%s?w=%s',
URLencode(self$token, TRUE),
URLencode(name, TRUE),
workerId()))
},
# register a data object on the server side (for datatable or selectize, etc)
registerDataObj = function(name, data, filterFunc) {
# abusing downloads at the moment
self$downloads$set(name, list(data = data, filter = filterFunc))
return(sprintf('session/%s/dataobj/%s?w=%s&nonce=%s',
URLencode(self$token, TRUE),
URLencode(name, TRUE),
workerId(),
URLencode(createUniqueId(8), TRUE)))
},
# This function suspends observers for hidden outputs and resumes observers
# for un-hidden outputs.
manageHiddenOutputs = function(outputsToCheck = NULL) {
if (is.null(outputsToCheck)) {
outputsToCheck <- names(private$.outputs)
}
# Find hidden state for each output, and suspend/resume accordingly
for (outputName in outputsToCheck) {
if (private$shouldSuspend(outputName)) {
private$.outputs[[outputName]]$suspend()
} else {
private$.outputs[[outputName]]$resume()
}
}
},
# Set the normal and client data input variables
manageInputs = function(data) {
force(data)
self$cycleStartAction(function() {
private$inputReceivedCallbacks$invoke(data)
data_names <- names(data)
# Separate normal input variables from client data input variables
clientdata_idx <- grepl("^.clientdata_", data_names)
# Set normal (non-clientData) input values
private$.input$mset(data[data_names[!clientdata_idx]])
# Strip off .clientdata_ from clientdata input names, and set values
input_clientdata <- data[data_names[clientdata_idx]]
names(input_clientdata) <- sub("^.clientdata_", "",
names(input_clientdata))
private$.clientData$mset(input_clientdata)
self$manageHiddenOutputs()
})
},
outputOptions = function(name, ...) {
# If no name supplied, return the list of options for all outputs
if (is.null(name))
return(private$.outputOptions)
if (! name %in% names(private$.outputs))
stop(name, " is not in list of output objects")
opts <- list(...)
# If no options are set, return the options for the specified output
if (length(opts) == 0)
return(private$.outputOptions[[name]])
# Set the appropriate option
validOpts <- c("suspendWhenHidden", "priority")
for (optname in names(opts)) {
if (! optname %in% validOpts)
stop(optname, " is not a valid option")
private$.outputOptions[[name]][[optname]] <- opts[[optname]]
}
# If any changes to suspendWhenHidden, need to re-run manageHiddenOutputs
if ("suspendWhenHidden" %in% names(opts)) {
self$manageHiddenOutputs(name)
}
if ("priority" %in% names(opts)) {
private$.outputs[[name]]$setPriority(opts[['priority']])
}
invisible()
},
incrementBusyCount = function() {
if (private$busyCount == 0L) {
private$sendMessage(busy = "busy")
}
private$busyCount <- private$busyCount + 1L
},
decrementBusyCount = function() {
private$busyCount <- private$busyCount - 1L
if (private$busyCount == 0L) {
private$sendMessage(busy = "idle")
self$requestFlush()
# We defer the call to startCycle() using later(), to defend against
# cycles where we continually call startCycle which causes an observer
# to fire which calls startCycle which causes an observer to fire...
#
# It's OK for these cycles to occur, but we must return control to the
# event loop between iterations (or at least sometimes) in order to not
# make the whole Shiny app go unresponsive.
later::later(function() {
if (private$busyCount == 0L) {
private$startCycle()
}
})
}
}
),
active = list(
session = function() {
shinyDeprecated(
msg = paste("Attempted to access deprecated shinysession$session object.",
"Please just access the shinysession object directly."),
version = "0.11.1"
)
self
}
)
)
.createOutputWriter <- function(shinysession, ns = identity) {
structure(list(impl=shinysession, ns=ns), class='shinyoutput')
}
#' @export
`$<-.shinyoutput` <- function(x, name, value) {
name <- .subset2(x, 'ns')(name)
label <- deparse(substitute(value))
if (length(substitute(value)) > 1) {
# value is an object consisting of a call and its arguments. Here we want
# to find the source references for the first argument (if there are
# arguments), which generally corresponds to the reactive expression--
# e.g. in renderTable({ x }), { x } is the expression to trace.
attr(label, "srcref") <- srcrefFromShinyCall(substitute(value)[[2]])
srcref <- attr(substitute(value)[[2]], "srcref")
if (length(srcref) > 0)
attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
}
.subset2(x, 'impl')$defineOutput(name, value, label)
return(invisible(x))
}
#' @export
`[[<-.shinyoutput` <- `$<-.shinyoutput`
#' @export
`$.shinyoutput` <- function(x, name) {
stop("Reading objects from shinyoutput object not allowed.")
}
#' @export
`[[.shinyoutput` <- `$.shinyoutput`
#' @export
`[.shinyoutput` <- function(values, name) {
stop("Single-bracket indexing of shinyoutput object is not allowed.")
}
#' @export
`[<-.shinyoutput` <- function(values, name, value) {
stop("Single-bracket indexing of shinyoutput object is not allowed.")
}
#' Set options for an output object.
#'
#' These are the available options for an output object:
#' \itemize{
#' \item suspendWhenHidden. When \code{TRUE} (the default), the output object
#' will be suspended (not execute) when it is hidden on the web page. When
#' \code{FALSE}, the output object will not suspend when hidden, and if it
#' was already hidden and suspended, then it will resume immediately.
#' \item priority. The priority level of the output object. Queued outputs
#' with higher priority values will execute before those with lower values.
#' }
#'
#' @examples
#' \dontrun{
#' # Get the list of options for all observers within output
#' outputOptions(output)
#'
#' # Disable suspend for output$myplot
#' outputOptions(output, "myplot", suspendWhenHidden = FALSE)
#'
#' # Change priority for output$myplot
#' outputOptions(output, "myplot", priority = 10)
#'
#' # Get the list of options for output$myplot
#' outputOptions(output, "myplot")
#' }
#'
#' @param x A shinyoutput object (typically \code{output}).
#' @param name The name of an output observer in the shinyoutput object.
#' @param ... Options to set for the output observer.
#' @export
outputOptions <- function(x, name, ...) {
if (!inherits(x, "shinyoutput")) {
stop("x must be a shinyoutput object.")
}
if (!missing(name)) {
name <- .subset2(x, 'ns')(name)
} else {
name <- NULL
}
.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, once = once)
}
#' @rdname onFlush
#' @export
onFlushed <- function(fun, once = TRUE, session = getDefaultReactiveDomain()) {
session$onFlushed(fun, once = once)
}
#' @rdname onFlush
#'
#' @seealso \code{\link{onStop}()} for registering callbacks that will be
#' invoked when the application exits, or when a session ends.
#' @export
onSessionEnded <- function(fun, session = getDefaultReactiveDomain()) {
session$onSessionEnded(fun)
}
flushPendingSessions <- function() {
lapply(appsNeedingFlush$values(), function(shinysession) {
tryCatch(
shinysession$flushOutput(),
stop = function(e) {
# If there are any uncaught errors that bubbled up to here, close the
# session.
shinysession$close()
}
)
NULL
})
}
.globals$onStopCallbacks <- Callbacks$new()
#' Run code after an application or session ends
#'
#' This function registers callback functions that are invoked when the
#' application exits (when \code{\link{runApp}} exits), or after each user
#' session ends (when a client disconnects).
#'
#' @param fun A function that will be called after the app has finished running.
#' @param session A scope for when the callback will run. If \code{onStop} is
#' called from within the server function, this will default to the current
#' session, and the callback will be invoked when the current session ends. If
#' \code{onStop} is called outside a server function, then the callback will
#' be invoked with the application exits.
#'
#'
#' @seealso \code{\link{onSessionEnded}()} for the same functionality, but at
#' the session level only.
#'
#' @return A function which, if invoked, will cancel the callback.
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#' # Open this application in multiple browsers, then close the browsers.
#' shinyApp(
#' ui = basicPage("onStop demo"),
#'
#' server = function(input, output, session) {
#' onStop(function() cat("Session stopped\n"))
#' },
#'
#' onStart = function() {
#' cat("Doing application setup\n")
#'
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#' }
#' )
#' }
#' # In the example above, onStop() is called inside of onStart(). This is
#' # the pattern that should be used when creating a shinyApp() object from
#' # a function, or at the console. If instead you are writing an app.R which
#' # will be invoked with runApp(), you can do it that way, or put the onStop()
#' # before the shinyApp() call, as shown below.
#'
#' \dontrun{
#' # ==== app.R ====
#' cat("Doing application setup\n")
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#'
#' shinyApp(
#' ui = basicPage("onStop demo"),
#'
#' server = function(input, output, session) {
#' onStop(function() cat("Session stopped\n"))
#' }
#' )
#' # ==== end app.R ====
#'
#'
#' # Similarly, if you have a global.R, you can call onStop() from there.
#' # ==== global.R ====
#' cat("Doing application setup\n")
#' onStop(function() {
#' cat("Doing application cleanup\n")
#' })
#' # ==== end global.R ====
#' }
#' @export
onStop <- function(fun, session = getDefaultReactiveDomain()) {
if (is.null(getDefaultReactiveDomain())) {
return(.globals$onStopCallbacks$register(fun))
} else {
# Note: In the future if we allow scoping the onStop() callback to modules
# and allow modules to be stopped, then session_proxy objects will need
# its own implementation of $onSessionEnded.
return(session$onSessionEnded(fun))
}
}
# Helper class for emitting log messages to stdout that will be interpreted by
# a Shiny Server parent process. The duration it's trying to record is the time
# between a websocket message being received, and the next flush to the client.
ShinyServerTimingRecorder <- R6Class("ShinyServerTimingRecorder",
cloneable = FALSE,
public = list(
initialize = function() {
private$shiny_stdout <- if (exists(".shiny__stdout", globalenv()))
get(".shiny__stdout", globalenv())
else
NULL
private$guid <- NULL
},
start = function(guid) {
if (is.null(private$shiny_stdout)) return()
private$guid <- guid
if (!is.null(guid)) {
private$write("n")
}
},
stop = function() {
if (is.null(private$shiny_stdout)) return()
if (!is.null(private$guid)) {
private$write("x")
private$guid <- NULL
}
}
),
private = list(
shiny_stdout = NULL,
guid = character(),
write = function(code) {
# eNter or eXit a flushReact
writeLines(paste("_", code, "_flushReact ", private$guid,
" @ ", sprintf("%.3f", as.numeric(Sys.time())),
sep=""), con=private$shiny_stdout)
flush(private$shiny_stdout)
}
)
)
missingOutput <- function(...) req(FALSE)
Reference in New Issue View Git Blame Copy Permalink