#' 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
#' pre-built widgets make it possible to build beautiful, responsive, and
#' powerful applications with minimal effort.
#'
#' The Shiny tutorial at \url{http://rstudio.github.com/shiny/tutorial} explains
#' the framework in depth, walks you through building a simple application, and
#' includes extensive annotated examples.
#'
#' @name shiny-package
#' @aliases shiny
#' @docType package
#' @import httpuv caTools RJSONIO xtable digest methods
NULL
createUniqueId <- function(bytes) {
# TODO: Use a method that isn't affected by the R seed
paste(as.character(as.raw(floor(runif(bytes, min=1, max=255)))), collapse='')
}
#' @include utils.R
ShinySession <- setRefClass(
'ShinySession',
fields = list(
.websocket = 'ANY',
.invalidatedOutputValues = 'Map',
.invalidatedOutputErrors = 'Map',
.inputMessageQueue = 'list', # A list of inputMessages to send when flushed
.outputs = 'list', # Keeps track of all the output observer objects
.outputOptions = 'list', # Options for each of the output observer objects
.progressKeys = 'character',
.fileUploadContext = 'FileUploadContext',
.input = 'ReactiveValues', # Internal object for normal input sent from client
.clientData = 'ReactiveValues', # Internal object for other data sent from the client
.closedCallbacks = 'Callbacks',
.flushCallbacks = 'Callbacks',
.flushedCallbacks = 'Callbacks',
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',
session = 'environment', # Object for the server app to access session stuff
.workerId = 'character',
singletons = 'character' # Tracks singleton HTML fragments sent to the page
),
methods = list(
initialize = function(websocket, workerId) {
.websocket <<- websocket
.workerId <<- workerId
.invalidatedOutputValues <<- Map$new()
.invalidatedOutputErrors <<- Map$new()
.inputMessageQueue <<- list()
.progressKeys <<- character(0)
closed <<- FALSE
# TODO: Put file upload context in user/app-specific dir if possible
.fileUploadContext <<- FileUploadContext$new()
.input <<- ReactiveValues$new()
.clientData <<- ReactiveValues$new()
input <<- .createReactiveValues(.input, readonly=TRUE)
.setLabel(input, 'input')
clientData <<- .createReactiveValues(.clientData, readonly=TRUE)
.setLabel(clientData, 'clientData')
output <<- .createOutputWriter(.self)
token <<- createUniqueId(16)
.outputs <<- list()
.outputOptions <<- list()
session <<- new.env(parent=emptyenv())
session$clientData <<- clientData
session$sendCustomMessage <<- .self$.sendCustomMessage
session$sendInputMessage <<- .self$.sendInputMessage
session$onSessionEnded <<- .self$onSessionEnded
session$onFlush <<- .self$onFlush
session$onFlushed <<- .self$onFlushed
session$isClosed <<- .self$isClosed
session$input <<- .self$input
session$output <<- .self$output
session$.impl <<- .self
if (!is.null(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)) {
try({
creds <- fromJSON(websocket$request$HTTP_SHINY_SERVER_CREDENTIALS)
session$user <<- creds$user
session$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 = session)
.write(toJSON(list(config = list(
workerId = .workerId,
sessionId = token
))))
},
onSessionEnded = function(callback) {
"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(.closedCallbacks$register(callback))
},
close = function() {
closed <<- TRUE
for (output in .outputs) {
output$suspend()
}
.closedCallbacks$invoke(onError=function(e) {
warning(simpleWarning(
paste("An error occurred in an onSessionEnded handler:",
e$message),
e$call
))
})
flushReact()
lapply(appsByToken$values(), function(shinysession) {
shinysession$flushOutput()
NULL
})
},
isClosed = function() {
return(closed)
},
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, suspend the previous copy of it
if (!is.null(.outputs[[name]])) {
.outputs[[name]]$suspend()
}
if (is.function(func)) {
if (length(formals(func)) != 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 <- %s', name, paste(label, collapse='\n'))
attr(label, "srcref") <- srcref
attr(label, "srcfile") <- srcfile
obs <- observe({
value <- try(shinyCallingHandlers(func()), silent=FALSE)
.invalidatedOutputErrors$remove(name)
.invalidatedOutputValues$remove(name)
if (inherits(value, 'try-error')) {
cond <- attr(value, 'condition')
.invalidatedOutputErrors$set(
name,
list(message=cond$message,
call=capture.output(print(cond$call))))
}
else
.invalidatedOutputValues$set(name, value)
}, suspended=.shouldSuspend(name), label=label)
obs$onInvalidate(function() {
showProgress(name)
})
.outputs[[name]] <<- obs
if (is.null(.outputOptions[[name]]))
.outputOptions[[name]] <<- list()
}
else {
stop(paste("Unexpected", class(func), "output for", name))
}
},
flushOutput = function() {
.flushCallbacks$invoke()
on.exit(.flushedCallbacks$invoke())
if (length(.progressKeys) == 0
&& length(.invalidatedOutputValues) == 0
&& length(.invalidatedOutputErrors) == 0
&& length(.inputMessageQueue) == 0) {
return(invisible())
}
.progressKeys <<- character(0)
values <- .invalidatedOutputValues
.invalidatedOutputValues <<- Map$new()
errors <- .invalidatedOutputErrors
.invalidatedOutputErrors <<- Map$new()
inputMessages <- .inputMessageQueue
.inputMessageQueue <<- list()
json <- toJSON(list(errors=as.list(errors),
values=as.list(values),
inputMessages=inputMessages))
.write(json)
},
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 (closed)
return()
if (id %in% .progressKeys)
return()
.progressKeys <<- c(.progressKeys, id)
json <- toJSON(list(progress=list(id)))
.write(json)
},
dispatch = function(msg) {
method <- paste('@', msg$method, sep='')
# we must use $ instead of [[ here at the moment; see
# https://github.com/rstudio/shiny/issues/274
func <- try(do.call(`$`, list(.self, method)), silent=TRUE)
if (inherits(func, 'try-error')) {
.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')) {
.sendErrorResponse(msg, conditionMessage(attr(value, 'condition')))
}
else {
.sendResponse(msg, value)
}
},
.sendResponse = function(requestMsg, value) {
if (is.null(requestMsg$tag)) {
warning("Tried to send response for untagged message; method: ",
requestMsg$method)
return()
}
.write(toJSON(list(response=list(tag=requestMsg$tag, value=value))))
},
.sendErrorResponse = function(requestMsg, error) {
if (is.null(requestMsg$tag))
return()
.write(toJSON(list(response=list(tag=requestMsg$tag, error=error))))
},
.sendCustomMessage = function(type, message) {
data <- list()
data[[type]] <- message
.write(toJSON(list(custom=data)))
},
.sendInputMessage = function(inputId, message) {
data <- list(id = inputId, message = message)
# Add to input message queue
.inputMessageQueue[[length(.inputMessageQueue) + 1]] <<- data
},
onFlush = function(func, once = TRUE) {
if (!isTRUE(once)) {
return(.flushCallbacks$register(func))
} else {
dereg <- .flushCallbacks$register(function() {
dereg()
func()
})
return(dereg)
}
},
onFlushed = function(func, once = TRUE) {
if (!isTRUE(once)) {
return(.flushedCallbacks$register(func))
} else {
dereg <- .flushedCallbacks$register(function() {
dereg()
func()
})
return(dereg)
}
},
.write = function(json) {
if (closed){
return()
}
if (getOption('shiny.trace', FALSE))
message('SEND ',
gsub('(?m)base64,[a-zA-Z0-9+/=]+','[base64 data]',json,perl=TRUE))
if (getOption('shiny.transcode.json', TRUE))
json <- iconv(json, to='UTF-8')
.websocket$send(json)
},
# Public RPC methods
`@uploadInit` = function(fileInfos) {
maxSize <- getOption('shiny.maxRequestSize', 5 * 1024 * 1024)
fileInfos <- lapply(fileInfos, function(fi) {
if (is.null(fi$type))
fi$type <- getContentType(tools::file_ext(fi$name))
fi
})
sizes <- sapply(fileInfos, function(fi){ fi$size })
if (maxSize > 0 && any(sizes > maxSize)) {
stop("Maximum upload size exceeded")
}
jobId <- .fileUploadContext$createUploadOperation(fileInfos)
return(list(jobId=jobId,
uploadUrl=paste('session', token, 'upload',
paste(jobId, "?w=", .workerId,sep=""),
sep='/')))
},
`@uploadEnd` = function(jobId, inputId) {
fileData <- .fileUploadContext$getUploadOperation(jobId)$finish()
.input$set(inputId, fileData)
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', 'Bad Request
'))
if (matches[2] == 'file') {
savedFile <- files$get(utils::URLdecode(matches[3]))
if (is.null(savedFile))
return(httpResponse(404, 'text/html', 'Not Found
'))
return(httpResponse(200, savedFile$contentType, savedFile$data))
}
if (matches[2] == 'upload' && identical(req$REQUEST_METHOD, "POST")) {
job <- .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'))
}
}
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 <- utils::URLdecode(dlmatches[2])
download <- downloads$get(dlname)
if (is.null(download))
return(httpResponse(404, 'text/html', 'Not Found
'))
filename <- ifelse(is.function(download$filename),
Context$new('[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', 'Found
', c(
'Location' = sprintf('%s/%s',
utils::URLencode(dlname, TRUE),
utils::URLencode(filename, TRUE)),
'Cache-Control' = 'no-cache')))
}
tmpdata <- tempfile()
result <- try(Context$new('[download]')$run(function() { download$func(tmpdata) }))
if (is(result, 'try-error')) {
unlink(tmpdata)
return(httpResponse(500, 'text/plain',
attr(result, 'condition')$message))
}
return(httpResponse(
200,
download$contentType %OR% getContentType(tools::file_ext(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')))
}
if (matches[2] == 'datatable') {
# /session/$TOKEN/datatable/$NAME
dlmatches <- regmatches(matches[3],
regexec("^([^/]+)(/[^/]+)?$",
matches[3]))[[1]]
dlname <- utils::URLdecode(dlmatches[2])
download <- downloads$get(dlname)
return(httpResponse(
200, 'application/json', dataTablesJSON(download$data, req$QUERY_STRING)
))
}
return(httpResponse(404, 'text/html', 'Not Found
'))
},
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."
files$set(name, list(data=data, contentType=contentType))
return(sprintf('session/%s/file/%s?w=%s&r=%s',
URLencode(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(.clientData$.values$allowDataUriScheme)) {
b64 <- base64encode(fileData)
return(paste('data:', contentType, ';base64,', b64, sep=''))
} else {
return(saveFileUrl(name, fileData, contentType))
}
},
registerDownload = function(name, filename, contentType, func) {
downloads$set(name, list(filename = filename,
contentType = contentType,
func = func))
return(sprintf('session/%s/download/%s?w=%s',
URLencode(token, TRUE),
URLencode(name, TRUE),
.workerId))
},
# this can be more general registrations; not limited to data tables
registerDataTable = function(name, data) {
# abusing downloads at the moment
downloads$set(name, list(data = data))
return(sprintf('session/%s/datatable/%s?w=%s',
URLencode(token, TRUE),
URLencode(name, TRUE),
.workerId))
},
.getOutputOption = function(outputName, propertyName, defaultValue) {
opts <- .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 <- .clientData$.values[[paste("output_", name, "_hidden",
sep="")]]
if (is.null(hidden)) hidden <- TRUE
return(hidden && .getOutputOption(name, 'suspendWhenHidden', TRUE))
},
# This function suspends observers for hidden outputs and resumes observers
# for un-hidden outputs.
manageHiddenOutputs = function() {
# Find hidden state for each output, and suspend/resume accordingly
for (outputName in names(.outputs)) {
if (.shouldSuspend(outputName)) {
.outputs[[outputName]]$suspend()
} else {
.outputs[[outputName]]$resume()
}
}
},
# Set the normal and client data input variables
manageInputs = function(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
.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))
.clientData$mset(input_clientdata)
},
outputOptions = function(name, ...) {
# If no name supplied, return the list of options for all outputs
if (is.null(name))
return(.outputOptions)
if (! name %in% names(.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(.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")
.outputOptions[[name]][[optname]] <<- opts[[optname]]
}
# If any changes to suspendWhenHidden, need to re-run manageHiddenOutputs
if ("suspendWhenHidden" %in% names(opts)) {
manageHiddenOutputs()
}
if ("priority" %in% names(opts)) {
.outputs[[name]]$setPriority(opts[['priority']])
}
invisible()
}
)
)
.createOutputWriter <- function(shinysession) {
structure(list(impl=shinysession), class='shinyoutput')
}
#' @S3method $<- shinyoutput
`$<-.shinyoutput` <- function(x, name, value) {
label <- deparse(substitute(value))
attr(label, "srcref") <- srcrefFromShinyCall(substitute(value)[[2]])
attr(label, "srcfile") <- srcFileOfRef(attr(substitute(value)[[2]], "srcref")[[1]])
.subset2(x, 'impl')$defineOutput(name, value, label)
return(invisible(x))
}
#' @S3method [[<- shinyoutput
`[[<-.shinyoutput` <- `$<-.shinyoutput`
#' @S3method $ shinyoutput
`$.shinyoutput` <- function(x, name) {
stop("Reading objects from shinyoutput object not allowed.")
}
#' @S3method [[ shinyoutput
`[[.shinyoutput` <- `$.shinyoutput`
#' @S3method [ shinyoutput
`[.shinyoutput` <- function(values, name) {
stop("Single-bracket indexing of shinyoutput object is not allowed.")
}
#' @S3method [<- shinyoutput
`[<-.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.")
.subset2(x, 'impl')$outputOptions(name, ...)
}