mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-02 10:45:06 -05:00
802 lines
26 KiB
R
802 lines
26 KiB
R
#' @include globals.R
|
|
|
|
appsByToken <- Map$new()
|
|
|
|
# Create a map for input handlers and register the defaults.
|
|
inputHandlers <- Map$new()
|
|
|
|
#' Register an Input Handler
|
|
#'
|
|
#' Adds an input handler for data of this type. When called, Shiny will use the
|
|
#' function provided to refine the data passed back from the client (after being
|
|
#' deserialized by RJSONIO) before making it available in the \code{input}
|
|
#' variable of the \code{server.R} file.
|
|
#'
|
|
#' This function will register the handler for the duration of the R process
|
|
#' (unless Shiny is explicitly reloaded). For that reason, the \code{type} used
|
|
#' should be very specific to this package to minimize the risk of colliding
|
|
#' with another Shiny package which might use this data type name. We recommend
|
|
#' the format of "packageName.widgetName".
|
|
#'
|
|
#' Currently Shiny registers the following handlers: \code{shiny.matrix},
|
|
#' \code{shiny.number}, and \code{shiny.date}.
|
|
#'
|
|
#' The \code{type} of a custom Shiny Input widget will be deduced using the
|
|
#' \code{getType()} JavaScript function on the registered Shiny inputBinding.
|
|
#' @param type The type for which the handler should be added -- should be a
|
|
#' single-element character vector.
|
|
#' @param fun The handler function. This is the function that will be used to
|
|
#' parse the data delivered from the client before it is available in the
|
|
#' \code{input} variable. The function will be called with the following three
|
|
#' parameters:
|
|
#' \enumerate{
|
|
#' \item{The value of this input as provided by the client, deserialized
|
|
#' using RJSONIO.}
|
|
#' \item{The \code{shinysession} in which the input exists.}
|
|
#' \item{The name of the input.}
|
|
#' }
|
|
#' @param force If \code{TRUE}, will overwrite any existing handler without
|
|
#' warning. If \code{FALSE}, will throw an error if this class already has
|
|
#' a handler defined.
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # Register an input handler which rounds a input number to the nearest integer
|
|
#' registerInputHandler("mypackage.validint", function(x, shinysession, name) {
|
|
#' if (is.null(x)) return(NA)
|
|
#' round(x)
|
|
#' })
|
|
#'
|
|
#' ## On the Javascript side, the associated input binding must have a corresponding getType method:
|
|
#' getType: function(el) {
|
|
#' return "mypackage.validint";
|
|
#' }
|
|
#'
|
|
#' }
|
|
#' @seealso \code{\link{removeInputHandler}}
|
|
#' @export
|
|
registerInputHandler <- function(type, fun, force=FALSE){
|
|
if (inputHandlers$containsKey(type) && !force){
|
|
stop("There is already an input handler for type: ", type)
|
|
}
|
|
inputHandlers$set(type, fun)
|
|
}
|
|
|
|
#' Deregister an Input Handler
|
|
#'
|
|
#' Removes an Input Handler. Rather than using the previously specified handler
|
|
#' for data of this type, the default RJSONIO serialization will be used.
|
|
#'
|
|
#' @param type The type for which handlers should be removed.
|
|
#' @return The handler previously associated with this \code{type}, if one
|
|
#' existed. Otherwise, \code{NULL}.
|
|
#' @seealso \code{\link{registerInputHandler}}
|
|
#' @export
|
|
removeInputHandler <- function(type){
|
|
inputHandlers$remove(type)
|
|
}
|
|
|
|
# Takes a list-of-lists and returns a matrix. The lists
|
|
# must all be the same length. NULL is replaced by NA.
|
|
registerInputHandler("shiny.matrix", function(data, ...) {
|
|
if (length(data) == 0)
|
|
return(matrix(nrow=0, ncol=0))
|
|
|
|
m <- matrix(unlist(lapply(data, function(x) {
|
|
sapply(x, function(y) {
|
|
ifelse(is.null(y), NA, y)
|
|
})
|
|
})), nrow = length(data[[1]]), ncol = length(data))
|
|
return(m)
|
|
})
|
|
|
|
registerInputHandler("shiny.number", function(val, ...){
|
|
ifelse(is.null(val), NA, val)
|
|
})
|
|
|
|
registerInputHandler("shiny.date", function(val, ...){
|
|
# First replace NULLs with NA, then convert to Date vector
|
|
datelist <- ifelse(lapply(val, is.null), NA, val)
|
|
as.Date(unlist(datelist))
|
|
})
|
|
|
|
registerInputHandler("shiny.action", function(val, ...) {
|
|
# mark up the action button value with a special class so we can recognize it later
|
|
class(val) <- c(class(val), "shinyActionButtonValue")
|
|
val
|
|
})
|
|
|
|
# Provide a character representation of the WS that can be used
|
|
# as a key in a Map.
|
|
wsToKey <- function(WS) {
|
|
as.character(WS$socket)
|
|
}
|
|
|
|
.globals$clients <- function(req) NULL
|
|
|
|
|
|
clearClients <- function() {
|
|
.globals$clients <- function(req) NULL
|
|
}
|
|
|
|
|
|
registerClient <- function(client) {
|
|
.globals$clients <- append(.globals$clients, client)
|
|
}
|
|
|
|
|
|
.globals$resources <- list()
|
|
|
|
.globals$showcaseDefault <- 0
|
|
|
|
.globals$showcaseOverride <- FALSE
|
|
|
|
#' Resource Publishing
|
|
#'
|
|
#' Adds a directory of static resources to Shiny's web server, with the given
|
|
#' path prefix. Primarily intended for package authors to make supporting
|
|
#' JavaScript/CSS files available to their components.
|
|
#'
|
|
#' @param prefix The URL prefix (without slashes). Valid characters are a-z,
|
|
#' A-Z, 0-9, hyphen, period, and underscore; and must begin with a-z or A-Z.
|
|
#' For example, a value of 'foo' means that any request paths that begin with
|
|
#' '/foo' will be mapped to the given directory.
|
|
#' @param directoryPath The directory that contains the static resources to be
|
|
#' served.
|
|
#'
|
|
#' @details You can call \code{addResourcePath} multiple times for a given
|
|
#' \code{prefix}; only the most recent value will be retained. If the
|
|
#' normalized \code{directoryPath} is different than the directory that's
|
|
#' currently mapped to the \code{prefix}, a warning will be issued.
|
|
#'
|
|
#' @seealso \code{\link{singleton}}
|
|
#'
|
|
#' @examples
|
|
#' addResourcePath('datasets', system.file('data', package='datasets'))
|
|
#'
|
|
#' @export
|
|
addResourcePath <- function(prefix, directoryPath) {
|
|
prefix <- prefix[1]
|
|
if (!grepl('^[a-z][a-z0-9\\-_.]*$', prefix, ignore.case=TRUE, perl=TRUE)) {
|
|
stop("addResourcePath called with invalid prefix; please see documentation")
|
|
}
|
|
|
|
if (prefix %in% c('shared')) {
|
|
stop("addResourcePath called with the reserved prefix '", prefix, "'; ",
|
|
"please use a different prefix")
|
|
}
|
|
|
|
directoryPath <- normalizePath(directoryPath, mustWork=TRUE)
|
|
|
|
existing <- .globals$resources[[prefix]]
|
|
|
|
if (!is.null(existing)) {
|
|
if (!identical(existing$directoryPath, directoryPath)) {
|
|
warning("Overriding existing prefix ", prefix, " => ",
|
|
existing$directoryPath)
|
|
}
|
|
}
|
|
|
|
.globals$resources[[prefix]] <- list(directoryPath=directoryPath,
|
|
func=staticHandler(directoryPath))
|
|
}
|
|
|
|
resourcePathHandler <- function(req) {
|
|
if (!identical(req$REQUEST_METHOD, 'GET'))
|
|
return(NULL)
|
|
|
|
path <- req$PATH_INFO
|
|
|
|
match <- regexpr('^/([^/]+)/', path, perl=TRUE)
|
|
if (match == -1)
|
|
return(NULL)
|
|
len <- attr(match, 'capture.length')
|
|
prefix <- substr(path, 2, 2 + len - 1)
|
|
|
|
resInfo <- .globals$resources[[prefix]]
|
|
if (is.null(resInfo))
|
|
return(NULL)
|
|
|
|
suffix <- substr(path, 2 + len, nchar(path))
|
|
|
|
subreq <- as.environment(as.list(req, all.names=TRUE))
|
|
subreq$PATH_INFO <- suffix
|
|
subreq$SCRIPT_NAME <- paste(subreq$SCRIPT_NAME, substr(path, 1, 2 + len), sep='')
|
|
|
|
return(resInfo$func(subreq))
|
|
}
|
|
|
|
#' Define Server Functionality
|
|
#'
|
|
#' Defines the server-side logic of the Shiny application. This generally
|
|
#' involves creating functions that map user inputs to various kinds of output.
|
|
#'
|
|
#' @param func The server function for this application. See the details section
|
|
#' for more information.
|
|
#'
|
|
#' @details
|
|
#' Call \code{shinyServer} from your application's \code{server.R} file, passing
|
|
#' in a "server function" that provides the server-side logic of your
|
|
#' application.
|
|
#'
|
|
#' The server function will be called when each client (web browser) first loads
|
|
#' the Shiny application's page. It must take an \code{input} and an
|
|
#' \code{output} parameter. Any return value will be ignored. It also takes an
|
|
#' optional \code{session} parameter, which is used when greater control is
|
|
#' needed.
|
|
#'
|
|
#' See the \href{http://rstudio.github.com/shiny/tutorial/}{tutorial} for more
|
|
#' on how to write a server function.
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # A very simple Shiny app that takes a message from the user
|
|
#' # and outputs an uppercase version of it.
|
|
#' shinyServer(function(input, output, session) {
|
|
#' output$uppercase <- renderText({
|
|
#' toupper(input$message)
|
|
#' })
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' @export
|
|
shinyServer <- function(func) {
|
|
.globals$server <- list(func)
|
|
invisible(func)
|
|
}
|
|
|
|
decodeMessage <- function(data) {
|
|
readInt <- function(pos) {
|
|
packBits(rawToBits(data[pos:(pos+3)]), type='integer')
|
|
}
|
|
|
|
if (readInt(1) != 0x01020202L)
|
|
return(fromJSON(rawToChar(data), asText=TRUE, simplify=FALSE))
|
|
|
|
i <- 5
|
|
parts <- list()
|
|
while (i <= length(data)) {
|
|
length <- readInt(i)
|
|
i <- i + 4
|
|
if (length != 0)
|
|
parts <- append(parts, list(data[i:(i+length-1)]))
|
|
else
|
|
parts <- append(parts, list(raw(0)))
|
|
i <- i + length
|
|
}
|
|
|
|
mainMessage <- decodeMessage(parts[[1]])
|
|
mainMessage$blobs <- parts[2:length(parts)]
|
|
return(mainMessage)
|
|
}
|
|
|
|
createAppHandlers <- function(httpHandlers, serverFuncSource) {
|
|
appvars <- new.env()
|
|
appvars$server <- NULL
|
|
|
|
sys.www.root <- system.file('www', package='shiny')
|
|
|
|
# This value, if non-NULL, must be present on all HTTP and WebSocket
|
|
# requests as the Shiny-Shared-Secret header or else access will be
|
|
# denied (403 response for HTTP, and instant close for websocket).
|
|
sharedSecret <- getOption('shiny.sharedSecret', NULL)
|
|
|
|
appHandlers <- list(
|
|
http = joinHandlers(c(
|
|
sessionHandler,
|
|
httpHandlers,
|
|
sys.www.root,
|
|
resourcePathHandler,
|
|
reactLogHandler)),
|
|
ws = function(ws) {
|
|
if (!is.null(sharedSecret)
|
|
&& !identical(sharedSecret, ws$request$HTTP_SHINY_SHARED_SECRET)) {
|
|
ws$close()
|
|
return(TRUE)
|
|
}
|
|
|
|
shinysession <- ShinySession$new(ws)
|
|
appsByToken$set(shinysession$token, shinysession)
|
|
shinysession$setShowcase(.globals$showcaseDefault)
|
|
|
|
ws$onMessage(function(binary, msg) {
|
|
# To ease transition from websockets-based code. Should remove once we're stable.
|
|
if (is.character(msg))
|
|
msg <- charToRaw(msg)
|
|
|
|
if (getOption('shiny.trace', FALSE)) {
|
|
if (binary)
|
|
message("RECV ", '$$binary data$$')
|
|
else
|
|
message("RECV ", rawToChar(msg))
|
|
}
|
|
|
|
if (identical(charToRaw("\003\xe9"), msg))
|
|
return()
|
|
|
|
msg <- decodeMessage(msg)
|
|
|
|
# Do our own list simplifying here. sapply/simplify2array give names to
|
|
# character vectors, which is rarely what we want.
|
|
if (!is.null(msg$data)) {
|
|
for (name in names(msg$data)) {
|
|
val <- msg$data[[name]]
|
|
|
|
splitName <- strsplit(name, ':')[[1]]
|
|
if (length(splitName) > 1) {
|
|
msg$data[[name]] <- NULL
|
|
|
|
if (!inputHandlers$containsKey(splitName[[2]])){
|
|
# No input handler registered for this type
|
|
stop("No handler registered for for type ", name)
|
|
}
|
|
|
|
msg$data[[ splitName[[1]] ]] <-
|
|
inputHandlers$get(splitName[[2]])(
|
|
val,
|
|
shinysession,
|
|
splitName[[1]] )
|
|
}
|
|
else if (is.list(val) && is.null(names(val))) {
|
|
val_flat <- unlist(val, recursive = TRUE)
|
|
|
|
if (is.null(val_flat)) {
|
|
# This is to assign NULL instead of deleting the item
|
|
msg$data[name] <- list(NULL)
|
|
} else {
|
|
msg$data[[name]] <- val_flat
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
switch(
|
|
msg$method,
|
|
init = {
|
|
|
|
serverFunc <- serverFuncSource()
|
|
if (!identicalFunctionBodies(serverFunc, appvars$server)) {
|
|
appvars$server <- serverFunc
|
|
if (!is.null(appvars$server))
|
|
{
|
|
# Tag this function as the Shiny server function. A debugger may use this
|
|
# tag to give this function special treatment.
|
|
# It's very important that it's appvars$server itself and NOT a copy that
|
|
# is invoked, otherwise new breakpoints won't be picked up.
|
|
attr(appvars$server, "shinyServerFunction") <- TRUE
|
|
registerDebugHook("server", appvars, "Server Function")
|
|
}
|
|
}
|
|
|
|
# Check for switching into/out of showcase mode
|
|
if (.globals$showcaseOverride &&
|
|
exists(".clientdata_url_search", where = msg$data)) {
|
|
mode <- showcaseModeOfQuerystring(msg$data$.clientdata_url_search)
|
|
if (!is.null(mode))
|
|
shinysession$setShowcase(mode)
|
|
}
|
|
|
|
shinysession$manageInputs(msg$data)
|
|
|
|
# The client tells us what singletons were rendered into
|
|
# the initial page
|
|
if (!is.null(msg$data$.clientdata_singletons)) {
|
|
shinysession$singletons <<- strsplit(
|
|
msg$data$.clientdata_singletons, ',')[[1]]
|
|
}
|
|
|
|
local({
|
|
args <- list(
|
|
input=shinysession$input,
|
|
output=.createOutputWriter(shinysession))
|
|
|
|
# The clientData and session arguments are optional; check if
|
|
# each exists
|
|
if ('clientData' %in% names(formals(serverFunc)))
|
|
args$clientData <- shinysession$clientData
|
|
|
|
if ('session' %in% names(formals(serverFunc)))
|
|
args$session <- shinysession$session
|
|
|
|
withReactiveDomain(shinysession$session, {
|
|
do.call(appvars$server, args)
|
|
})
|
|
})
|
|
},
|
|
update = {
|
|
shinysession$manageInputs(msg$data)
|
|
},
|
|
shinysession$dispatch(msg)
|
|
)
|
|
shinysession$manageHiddenOutputs()
|
|
|
|
if (exists(".shiny__stdout", globalenv()) &&
|
|
exists("HTTP_GUID", ws$request)) {
|
|
# safe to assume we're in shiny-server
|
|
shiny_stdout <- get(".shiny__stdout", globalenv())
|
|
|
|
# eNter a flushReact
|
|
writeLines(paste("_n_flushReact ", get("HTTP_GUID", ws$request),
|
|
" @ ", sprintf("%.3f", as.numeric(Sys.time())),
|
|
sep=""), con=shiny_stdout)
|
|
flush(shiny_stdout)
|
|
|
|
flushReact()
|
|
|
|
# eXit a flushReact
|
|
writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
|
|
" @ ", sprintf("%.3f", as.numeric(Sys.time())),
|
|
sep=""), con=shiny_stdout)
|
|
flush(shiny_stdout)
|
|
} else {
|
|
flushReact()
|
|
}
|
|
lapply(appsByToken$values(), function(shinysession) {
|
|
shinysession$flushOutput()
|
|
NULL
|
|
})
|
|
})
|
|
|
|
ws$onClose(function() {
|
|
shinysession$close()
|
|
appsByToken$remove(shinysession$token)
|
|
})
|
|
|
|
return(TRUE)
|
|
}
|
|
)
|
|
return(appHandlers)
|
|
}
|
|
|
|
getEffectiveBody <- function(func) {
|
|
# Note: NULL values are OK. isS4(NULL) returns FALSE, body(NULL)
|
|
# returns NULL.
|
|
if (isS4(func) && class(func) == "functionWithTrace")
|
|
body(func@original)
|
|
else
|
|
body(func)
|
|
}
|
|
|
|
identicalFunctionBodies <- function(a, b) {
|
|
identical(getEffectiveBody(a), getEffectiveBody(b))
|
|
}
|
|
|
|
handlerManager <- HandlerManager$new()
|
|
|
|
addSubApp <- function(appObj, autoRemove = TRUE) {
|
|
path <- createUniqueId(16, "/app")
|
|
appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
|
|
|
|
# remove the leading / from the path so a relative path is returned
|
|
# (needed for the case where the root URL for the Shiny app isn't /, such
|
|
# as portmapped URLs)
|
|
finalPath <- paste(
|
|
substr(path, 2, nchar(path)),
|
|
"/?w=", workerId(),
|
|
"&__subapp__=1",
|
|
sep="")
|
|
handlerManager$addHandler(routeHandler(path, appHandlers$http), finalPath)
|
|
handlerManager$addWSHandler(routeWSHandler(path, appHandlers$ws), finalPath)
|
|
|
|
if (autoRemove) {
|
|
# If a session is currently active, remove this subapp automatically when
|
|
# the current session ends
|
|
onReactiveDomainEnded(getDefaultReactiveDomain(), function() {
|
|
removeSubApp(finalPath)
|
|
})
|
|
}
|
|
|
|
return(finalPath)
|
|
}
|
|
|
|
removeSubApp <- function(path) {
|
|
handlerManager$removeHandler(path)
|
|
handlerManager$removeWSHandler(path)
|
|
}
|
|
|
|
startApp <- function(appObj, port, host, quiet) {
|
|
appHandlers <- createAppHandlers(appObj$httpHandler, appObj$serverFuncSource)
|
|
handlerManager$addHandler(appHandlers$http, "/", tail = TRUE)
|
|
handlerManager$addWSHandler(appHandlers$ws, "/", tail = TRUE)
|
|
|
|
if (is.numeric(port) || is.integer(port)) {
|
|
if (!quiet) {
|
|
message('\n', 'Listening on http://', host, ':', port)
|
|
}
|
|
return(startServer(host, port, handlerManager$createHttpuvApp()))
|
|
} else if (is.character(port)) {
|
|
if (!quiet) {
|
|
message('\n', 'Listening on domain socket ', port)
|
|
}
|
|
mask <- attr(port, 'mask')
|
|
return(startPipeServer(port, mask, handlerManager$createHttpuvApp()))
|
|
}
|
|
}
|
|
|
|
# Run an application that was created by \code{\link{startApp}}. This
|
|
# function should normally be called in a \code{while(TRUE)} loop.
|
|
serviceApp <- function() {
|
|
if (timerCallbacks$executeElapsed()) {
|
|
for (shinysession in appsByToken$values()) {
|
|
shinysession$manageHiddenOutputs()
|
|
}
|
|
|
|
flushReact()
|
|
|
|
for (shinysession in appsByToken$values()) {
|
|
shinysession$flushOutput()
|
|
}
|
|
}
|
|
|
|
# If this R session is interactive, then call service() with a short timeout
|
|
# to keep the session responsive to user input
|
|
maxTimeout <- ifelse(interactive(), 100, 1000)
|
|
|
|
timeout <- max(1, min(maxTimeout, timerCallbacks$timeToNextEvent()))
|
|
service(timeout)
|
|
}
|
|
|
|
.shinyServerMinVersion <- '0.3.4'
|
|
|
|
#' Run Shiny Application
|
|
#'
|
|
#' Runs a Shiny application. This function normally does not return; interrupt
|
|
#' R to stop the application (usually by pressing Ctrl+C or Esc).
|
|
#'
|
|
#' The host parameter was introduced in Shiny 0.9.0. Its default value of
|
|
#' \code{"127.0.0.1"} means that, contrary to previous versions of Shiny, only
|
|
#' the current machine can access locally hosted Shiny apps. To allow other
|
|
#' clients to connect, use the value \code{"0.0.0.0"} instead (which was the
|
|
#' value that was hard-coded into Shiny in 0.8.0 and earlier).
|
|
#'
|
|
#' @param appDir The directory of the application. Should contain
|
|
#' \code{server.R}, plus, either \code{ui.R} or a \code{www} directory that
|
|
#' contains the file \code{index.html}. Defaults to the working directory.
|
|
#' @param port The TCP port that the application should listen on. Defaults to
|
|
#' choosing a random port.
|
|
#' @param launch.browser If true, the system's default web browser will be
|
|
#' launched automatically after the app is started. Defaults to true in
|
|
#' interactive sessions only. This value of this parameter can also be a
|
|
#' function to call with the application's URL.
|
|
#' @param host The IPv4 address that the application should listen on. Defaults
|
|
#' to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not. See
|
|
#' Details.
|
|
#' @param workerId Can generally be ignored. Exists to help some editions of
|
|
#' Shiny Server Pro route requests to the correct process.
|
|
#' @param quiet Should Shiny status messages be shown? Defaults to FALSE.
|
|
#' @param display.mode The mode in which to display the application. If set to
|
|
#' the value \code{"showcase"}, shows application code and metadata from a
|
|
#' \code{DESCRIPTION} file in the application directory alongside the
|
|
#' application. If set to \code{"normal"}, displays the application normally.
|
|
#' Defaults to \code{"auto"}, which displays the application in the mode
|
|
#' given in its \code{DESCRIPTION} file, if any.
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # Start app in the current working directory
|
|
#' runApp()
|
|
#'
|
|
#' # Start app in a subdirectory called myapp
|
|
#' runApp("myapp")
|
|
#'
|
|
#'
|
|
#' # Apps can be run without a server.r and ui.r file
|
|
#' runApp(list(
|
|
#' ui = bootstrapPage(
|
|
#' numericInput('n', 'Number of obs', 100),
|
|
#' plotOutput('plot')
|
|
#' ),
|
|
#' server = function(input, output) {
|
|
#' output$plot <- renderPlot({ hist(runif(input$n)) })
|
|
#' }
|
|
#' ))
|
|
#' }
|
|
#' @export
|
|
runApp <- function(appDir=getwd(),
|
|
port=NULL,
|
|
launch.browser=getOption('shiny.launch.browser',
|
|
interactive()),
|
|
host=getOption('shiny.host', '127.0.0.1'),
|
|
workerId="", quiet=FALSE,
|
|
display.mode=c("auto", "normal", "showcase")) {
|
|
on.exit({
|
|
handlerManager$clear()
|
|
}, add = TRUE)
|
|
|
|
|
|
if (is.null(host) || is.na(host))
|
|
host <- '0.0.0.0'
|
|
|
|
# Make warnings print immediately
|
|
ops <- options(warn = 1)
|
|
on.exit(options(ops), add = TRUE)
|
|
|
|
workerId(workerId)
|
|
|
|
if (nzchar(Sys.getenv('SHINY_PORT'))) {
|
|
# If SHINY_PORT is set, we're running under Shiny Server. Check the version
|
|
# to make sure it is compatible. Older versions of Shiny Server don't set
|
|
# SHINY_SERVER_VERSION, those will return "" which is considered less than
|
|
# any valid version.
|
|
ver <- Sys.getenv('SHINY_SERVER_VERSION')
|
|
if (compareVersion(ver, .shinyServerMinVersion) < 0) {
|
|
warning('Shiny Server v', .shinyServerMinVersion,
|
|
' or later is required; please upgrade!')
|
|
}
|
|
}
|
|
|
|
# Showcase mode is disabled by default; it must be explicitly enabled in
|
|
# either the DESCRIPTION file for directory-based apps, or via
|
|
# the display.mode parameter. The latter takes precedence.
|
|
setShowcaseDefault(0)
|
|
|
|
# If appDir specifies a path, and display mode is specified in the
|
|
# DESCRIPTION file at that path, apply it here.
|
|
if (is.character(appDir)) {
|
|
desc <- file.path.ci(appDir, "DESCRIPTION")
|
|
if (file.exists(desc)) {
|
|
settings <- read.dcf(desc)
|
|
if ("DisplayMode" %in% colnames(settings)) {
|
|
mode <- settings[1,"DisplayMode"]
|
|
if (mode == "Showcase") {
|
|
setShowcaseDefault(1)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# If display mode is specified as an argument, apply it (overriding the
|
|
# value specified in DESCRIPTION, if any).
|
|
display.mode <- match.arg(display.mode)
|
|
if (display.mode == "normal")
|
|
setShowcaseDefault(0)
|
|
else if (display.mode == "showcase")
|
|
setShowcaseDefault(1)
|
|
|
|
require(shiny)
|
|
|
|
# determine port if we need to
|
|
if (is.null(port)) {
|
|
|
|
# Try up to 20 random ports. If we don't succeed just plow ahead
|
|
# with the final value we tried, and let the "real" startServer
|
|
# somewhere down the line fail and throw the error to the user.
|
|
#
|
|
# If we (think we) succeed, save the value as .globals$lastPort,
|
|
# and try that first next time the user wants a random port.
|
|
|
|
for (i in 1:20) {
|
|
if (!is.null(.globals$lastPort)) {
|
|
port <- .globals$lastPort
|
|
.globals$lastPort <- NULL
|
|
}
|
|
else {
|
|
# Try up to 20 random ports
|
|
port <- p_randomInt(3000, 8000)
|
|
}
|
|
|
|
# Test port to see if we can use it
|
|
tmp <- try(startServer(host, port, list()), silent=TRUE)
|
|
if (!inherits(tmp, 'try-error')) {
|
|
stopServer(tmp)
|
|
.globals$lastPort <- port
|
|
break
|
|
}
|
|
}
|
|
}
|
|
|
|
appParts <- as.shiny.appobj(appDir)
|
|
if (!is.null(appParts$onStart))
|
|
appParts$onStart()
|
|
if (!is.null(appParts$onEnd))
|
|
on.exit(appParts$onEnd(), add = TRUE)
|
|
|
|
server <- startApp(appParts, port, host, quiet)
|
|
|
|
on.exit({
|
|
stopServer(server)
|
|
}, add = TRUE)
|
|
|
|
if (!is.character(port)) {
|
|
# http://0.0.0.0/ doesn't work on QtWebKit (i.e. RStudio viewer)
|
|
browseHost <- if (identical(host, "0.0.0.0")) "127.0.0.1" else host
|
|
|
|
appUrl <- paste("http://", browseHost, ":", port, sep="")
|
|
if (is.function(launch.browser))
|
|
launch.browser(appUrl)
|
|
else if (launch.browser)
|
|
utils::browseURL(appUrl)
|
|
} else {
|
|
appUrl <- NULL
|
|
}
|
|
|
|
# call application hooks
|
|
callAppHook("onAppStart", appUrl)
|
|
on.exit({
|
|
callAppHook("onAppStop", appUrl)
|
|
}, add = TRUE)
|
|
|
|
.globals$retval <- NULL
|
|
.globals$stopped <- FALSE
|
|
shinyCallingHandlers(
|
|
while (!.globals$stopped) {
|
|
serviceApp()
|
|
Sys.sleep(0.001)
|
|
}
|
|
)
|
|
|
|
return(.globals$retval)
|
|
}
|
|
|
|
#' Stop the currently running Shiny app
|
|
#'
|
|
#' Stops the currently running Shiny app, returning control to the caller of
|
|
#' \code{\link{runApp}}.
|
|
#'
|
|
#' @param returnValue The value that should be returned from
|
|
#' \code{\link{runApp}}.
|
|
#'
|
|
#' @export
|
|
stopApp <- function(returnValue = NULL) {
|
|
.globals$retval <- returnValue
|
|
.globals$stopped <- TRUE
|
|
httpuv::interrupt()
|
|
}
|
|
|
|
#' Run Shiny Example Applications
|
|
#'
|
|
#' Launch Shiny example applications, and optionally, your system's web browser.
|
|
#'
|
|
#' @param example The name of the example to run, or \code{NA} (the default) to
|
|
#' list the available examples.
|
|
#' @param port The TCP port that the application should listen on. Defaults to
|
|
#' choosing a random port.
|
|
#' @param launch.browser If true, the system's default web browser will be
|
|
#' launched automatically after the app is started. Defaults to true in
|
|
#' interactive sessions only.
|
|
#' @param host The IPv4 address that the application should listen on. Defaults
|
|
#' to the \code{shiny.host} option, if set, or \code{"127.0.0.1"} if not.
|
|
#' @param display.mode The mode in which to display the example. Defaults to
|
|
#' \code{showcase}, but may be set to \code{normal} to see the example without
|
|
#' code or commentary.
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # List all available examples
|
|
#' runExample()
|
|
#'
|
|
#' # Run one of the examples
|
|
#' runExample("01_hello")
|
|
#'
|
|
#' # Print the directory containing the code for all examples
|
|
#' system.file("examples", package="shiny")
|
|
#' }
|
|
#' @export
|
|
runExample <- function(example=NA,
|
|
port=NULL,
|
|
launch.browser=getOption('shiny.launch.browser',
|
|
interactive()),
|
|
host=getOption('shiny.host', '127.0.0.1'),
|
|
display.mode=c("auto", "normal", "showcase")) {
|
|
examplesDir <- system.file('examples', package='shiny')
|
|
dir <- resolve(examplesDir, example)
|
|
if (is.null(dir)) {
|
|
if (is.na(example)) {
|
|
errFun <- message
|
|
errMsg <- ''
|
|
}
|
|
else {
|
|
errFun <- stop
|
|
errMsg <- paste('Example', example, 'does not exist. ')
|
|
}
|
|
|
|
errFun(errMsg,
|
|
'Valid examples are "',
|
|
paste(list.files(examplesDir), collapse='", "'),
|
|
'"')
|
|
}
|
|
else {
|
|
runApp(dir, port = port, host = host, launch.browser = launch.browser,
|
|
display.mode = display.mode)
|
|
}
|
|
}
|