mirror of
https://github.com/rstudio/shiny.git
synced 2026-01-09 15:08:04 -05:00
1b3ed88bd1
Co-authored-by: Barret Schloerke <schloerke@gmail.com> Co-authored-by: Winston Chang <winston@stdout.org> Co-authored-by: Carson Sievert <cpsievert1@gmail.com> Co-authored-by: Joe Cheng <joe@rstudio.com>
1740 lines
55 KiB
R
1740 lines
55 KiB
R
#' @include globals.R
|
|
#' @include map.R
|
|
NULL
|
|
|
|
#' Make a random number generator repeatable
|
|
#'
|
|
#' Given a function that generates random data, returns a wrapped version of
|
|
#' that function that always uses the same seed when called. The seed to use can
|
|
#' be passed in explicitly if desired; otherwise, a random number is used.
|
|
#'
|
|
#' @param rngfunc The function that is affected by the R session's seed.
|
|
#' @param seed The seed to set every time the resulting function is called.
|
|
#' @return A repeatable version of the function that was passed in.
|
|
#'
|
|
#' @note When called, the returned function attempts to preserve the R session's
|
|
#' current seed by snapshotting and restoring
|
|
#' [base::.Random.seed()].
|
|
#'
|
|
#' @examples
|
|
#' rnormA <- repeatable(rnorm)
|
|
#' rnormB <- repeatable(rnorm)
|
|
#' rnormA(3) # [1] 1.8285879 -0.7468041 -0.4639111
|
|
#' rnormA(3) # [1] 1.8285879 -0.7468041 -0.4639111
|
|
#' rnormA(5) # [1] 1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924
|
|
#' rnormB(5) # [1] -0.7946034 0.2568374 -0.6567597 1.2451387 -0.8375699
|
|
#' @export
|
|
repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max)) {
|
|
force(seed)
|
|
|
|
function(...) {
|
|
# When we exit, restore the seed to its original state
|
|
if (exists('.Random.seed', where=globalenv())) {
|
|
currentSeed <- get('.Random.seed', pos=globalenv())
|
|
on.exit(assign('.Random.seed', currentSeed, pos=globalenv()))
|
|
}
|
|
else {
|
|
on.exit(rm('.Random.seed', pos=globalenv()))
|
|
}
|
|
|
|
set.seed(seed)
|
|
|
|
rngfunc(...)
|
|
}
|
|
}
|
|
|
|
.globals$ownSeed <- NULL
|
|
# Evaluate an expression using Shiny's own private stream of
|
|
# randomness (not affected by set.seed).
|
|
withPrivateSeed <- function(expr) {
|
|
# Save the old seed if present.
|
|
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
|
hasOrigSeed <- TRUE
|
|
origSeed <- .GlobalEnv$.Random.seed
|
|
} else {
|
|
hasOrigSeed <- FALSE
|
|
}
|
|
|
|
# Swap in the private seed.
|
|
if (is.null(.globals$ownSeed)) {
|
|
if (hasOrigSeed) {
|
|
# Move old seed out of the way if present.
|
|
rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
|
|
}
|
|
} else {
|
|
.GlobalEnv$.Random.seed <- .globals$ownSeed
|
|
}
|
|
|
|
# On exit, save the modified private seed, and put the old seed back.
|
|
on.exit({
|
|
.globals$ownSeed <- .GlobalEnv$.Random.seed
|
|
|
|
if (hasOrigSeed) {
|
|
.GlobalEnv$.Random.seed <- origSeed
|
|
} else {
|
|
rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
|
|
}
|
|
# Need to call this to make sure that the value of .Random.seed gets put
|
|
# into R's internal RNG state. (Issue #1763)
|
|
httpuv::getRNGState()
|
|
})
|
|
|
|
expr
|
|
}
|
|
|
|
# Version of runif that runs with private seed
|
|
p_runif <- function(...) {
|
|
withPrivateSeed(stats::runif(...))
|
|
}
|
|
|
|
# Version of sample that runs with private seed
|
|
p_sample <- function(...) {
|
|
withPrivateSeed(sample(...))
|
|
}
|
|
|
|
# Return a random integral value in the range [min, max).
|
|
# If only one argument is passed, then min=0 and max=argument.
|
|
randomInt <- function(min, max) {
|
|
if (missing(max)) {
|
|
max <- min
|
|
min <- 0
|
|
}
|
|
if (min < 0 || max <= min)
|
|
stop("Invalid min/max values")
|
|
|
|
min + sample(max-min, 1)-1
|
|
}
|
|
|
|
p_randomInt <- function(...) {
|
|
withPrivateSeed(randomInt(...))
|
|
}
|
|
|
|
isWholeNum <- function(x, tol = .Machine$double.eps^0.5) {
|
|
abs(x - round(x)) < tol
|
|
}
|
|
|
|
# Given a vector or list, drop all the NULL items in it
|
|
dropNulls <- function(x) {
|
|
x[!vapply(x, is.null, FUN.VALUE=logical(1))]
|
|
}
|
|
|
|
nullOrEmpty <- function(x) {
|
|
is.null(x) || length(x) == 0
|
|
}
|
|
# Given a vector or list, drop all the NULL items in it
|
|
dropNullsOrEmpty <- function(x) {
|
|
x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
|
|
}
|
|
|
|
# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
|
|
anyNamed <- function(x) {
|
|
# Zero-length vector
|
|
if (length(x) == 0) return(FALSE)
|
|
|
|
nms <- names(x)
|
|
|
|
# List with no name attribute
|
|
if (is.null(nms)) return(FALSE)
|
|
|
|
# List with name attribute; check for any ""
|
|
any(nzchar(nms))
|
|
}
|
|
|
|
# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
|
|
anyUnnamed <- function(x) {
|
|
# Zero-length vector
|
|
if (length(x) == 0) return(FALSE)
|
|
|
|
nms <- names(x)
|
|
|
|
# List with no name attribute
|
|
if (is.null(nms)) return(TRUE)
|
|
|
|
# List with name attribute; check for any ""
|
|
any(!nzchar(nms))
|
|
}
|
|
|
|
|
|
# Given a vector/list, returns a named vector/list (the labels will be blank).
|
|
asNamed <- function(x) {
|
|
if (is.null(names(x))) {
|
|
names(x) <- character(length(x))
|
|
}
|
|
|
|
x
|
|
}
|
|
|
|
empty_named_list <- function() {
|
|
list(a = 1)[0]
|
|
}
|
|
|
|
# Given two named vectors, join them together, and keep only the last element
|
|
# with a given name in the resulting vector. If b has any elements with the same
|
|
# name as elements in a, the element in a is dropped. Also, if there are any
|
|
# duplicated names in a or b, only the last one with that name is kept.
|
|
mergeVectors <- function(a, b) {
|
|
if (anyUnnamed(a) || anyUnnamed(b)) {
|
|
stop("Vectors must be either NULL or have names for all elements")
|
|
}
|
|
|
|
x <- c(a, b)
|
|
drop_idx <- duplicated(names(x), fromLast = TRUE)
|
|
x[!drop_idx]
|
|
}
|
|
|
|
# Sort a vector by the names of items. If there are multiple items with the
|
|
# same name, preserve the original order of those items. For empty
|
|
# vectors/lists/NULL, return the original value.
|
|
sortByName <- function(x) {
|
|
if (anyUnnamed(x))
|
|
stop("All items must be named")
|
|
|
|
# Special case for empty vectors/lists, and NULL
|
|
if (length(x) == 0)
|
|
return(x)
|
|
|
|
x[order(names(x))]
|
|
}
|
|
|
|
# Sort a vector. If a character vector, sort using C locale, which is consistent
|
|
# across platforms. Note that radix sort uses C locale according to ?sort.
|
|
sort_c <- function(x, ...) {
|
|
# Use UTF-8 encoding, because if encoding is "unknown" for non-ASCII
|
|
# characters, the sort() will throw an error.
|
|
if (is.character(x))
|
|
x <- enc2utf8(x)
|
|
sort(x, method = "radix", ...)
|
|
}
|
|
|
|
|
|
# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
|
|
# list is passed to list2env(), it errors. But an empty named list is OK. For
|
|
# R >=3.2.0, this wrapper is not necessary.
|
|
list2env2 <- function(x, ...) {
|
|
# Ensure that zero-length lists have a name attribute
|
|
if (length(x) == 0)
|
|
attr(x, "names") <- character(0)
|
|
|
|
list2env(x, ...)
|
|
}
|
|
|
|
# Combine dir and (file)name into a file path. If a file already exists with a
|
|
# name differing only by case, then use it instead.
|
|
file.path.ci <- function(...) {
|
|
result <- find.file.ci(...)
|
|
if (!is.null(result))
|
|
return(result)
|
|
|
|
# If not found, return the file path that was given to us.
|
|
return(file.path(...))
|
|
}
|
|
|
|
# Does a particular file exist? Case-insensitive for filename, case-sensitive
|
|
# for path (on platforms with case-sensitive file system).
|
|
file.exists.ci <- function(...) {
|
|
!is.null(find.file.ci(...))
|
|
}
|
|
|
|
# Look for a file, case-insensitive for filename, case-sensitive for path (on
|
|
# platforms with case-sensitive filesystem). If found, return the path to the
|
|
# file, with the correct case. If not found, return NULL.
|
|
find.file.ci <- function(...) {
|
|
default <- file.path(...)
|
|
if (length(default) > 1)
|
|
stop("find.file.ci can only check for one file at a time.")
|
|
if (file.exists(default))
|
|
return(default)
|
|
|
|
dir <- dirname(default)
|
|
name <- basename(default)
|
|
|
|
# If we got here, then we'll check for a directory with the exact case, and a
|
|
# name with any case.
|
|
all_files <- list.files(dir, all.files=TRUE, full.names=TRUE,
|
|
include.dirs=TRUE)
|
|
match_idx <- tolower(name) == tolower(basename(all_files))
|
|
matches <- all_files[match_idx]
|
|
if (length(matches) == 0)
|
|
return(NULL)
|
|
|
|
return(matches[1])
|
|
}
|
|
|
|
# The function base::dir.exists was added in R 3.2.0, but for backward
|
|
# compatibility we need to add this function
|
|
dirExists <- function(paths) {
|
|
file.exists(paths) & file.info(paths)$isdir
|
|
}
|
|
|
|
# Removes empty directory (vectorized). This is needed because file.remove()
|
|
# on Unix will remove empty directories, but on Windows, it will not. On
|
|
# Windows, you would need to use unlink(recursive=TRUE), which is not very
|
|
# safe. This function does it safely on Unix and Windows.
|
|
dirRemove <- function(path) {
|
|
for (p in path) {
|
|
if (!dirExists(p)) {
|
|
stop("Cannot remove non-existent directory ", p, ".")
|
|
}
|
|
if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) {
|
|
stop("Cannot remove non-empty directory ", p, ".")
|
|
}
|
|
result <- unlink(p, recursive = TRUE)
|
|
if (result == 1) {
|
|
stop("Error removing directory ", p, ".")
|
|
}
|
|
}
|
|
}
|
|
|
|
# Attempt to join a path and relative path, and turn the result into a
|
|
# (normalized) absolute path. The result will only be returned if it is an
|
|
# existing file/directory and is a descendant of dir.
|
|
#
|
|
# Example:
|
|
# resolve("/Users/jcheng", "shiny") # "/Users/jcheng/shiny"
|
|
# resolve("/Users/jcheng", "./shiny") # "/Users/jcheng/shiny"
|
|
# resolve("/Users/jcheng", "shiny/../shiny/") # "/Users/jcheng/shiny"
|
|
# resolve("/Users/jcheng", ".") # NULL
|
|
# resolve("/Users/jcheng", "..") # NULL
|
|
# resolve("/Users/jcheng", "shiny/..") # NULL
|
|
resolve <- function(dir, relpath) {
|
|
abs.path <- file.path(dir, relpath)
|
|
if (!file.exists(abs.path))
|
|
return(NULL)
|
|
abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE)
|
|
dir <- normalizePath(dir, winslash='/', mustWork=TRUE)
|
|
# trim the possible trailing slash under Windows (#306)
|
|
if (isWindows()) dir <- sub('/$', '', dir)
|
|
if (nchar(abs.path) <= nchar(dir) + 1)
|
|
return(NULL)
|
|
if (substr(abs.path, 1, nchar(dir)) != dir ||
|
|
substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') {
|
|
return(NULL)
|
|
}
|
|
return(abs.path)
|
|
}
|
|
|
|
# Given a string, make sure it has a trailing slash.
|
|
ensure_trailing_slash <- function(path) {
|
|
if (!grepl("/$", path)) {
|
|
path <- paste0(path, "/")
|
|
}
|
|
path
|
|
}
|
|
|
|
|
|
isWindows <- function() .Platform$OS.type == 'windows'
|
|
|
|
# This is a wrapper for download.file and has the same interface.
|
|
# The only difference is that, if the protocol is https, it changes the
|
|
# download settings, depending on platform.
|
|
download <- function(url, ...) {
|
|
# First, check protocol. If http or https, check platform:
|
|
if (grepl('^https?://', url)) {
|
|
|
|
# Check whether we are running R 3.2
|
|
isR32 <- getRversion() >= "3.2"
|
|
|
|
# Windows
|
|
if (.Platform$OS.type == "windows") {
|
|
|
|
if (isR32) {
|
|
method <- "wininet"
|
|
} else {
|
|
|
|
# If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux
|
|
seti2 <- `::`(utils, 'setInternet2')
|
|
|
|
# Check whether we are already using internet2 for internal
|
|
internet2_start <- seti2(NA)
|
|
|
|
# If not then temporarily set it
|
|
if (!internet2_start) {
|
|
# Store initial settings, and restore on exit
|
|
on.exit(suppressWarnings(seti2(internet2_start)))
|
|
|
|
# Needed for https. Will get warning if setInternet2(FALSE) already run
|
|
# and internet routines are used. But the warnings don't seem to matter.
|
|
suppressWarnings(seti2(TRUE))
|
|
}
|
|
|
|
method <- "internal"
|
|
}
|
|
|
|
# download.file will complain about file size with something like:
|
|
# Warning message:
|
|
# In download.file(url, ...) : downloaded length 19457 != reported length 200
|
|
# because apparently it compares the length with the status code returned (?)
|
|
# so we supress that
|
|
suppressWarnings(utils::download.file(url, method = method, ...))
|
|
|
|
} else {
|
|
# If non-Windows, check for libcurl/curl/wget/lynx, then call download.file with
|
|
# appropriate method.
|
|
|
|
if (isR32 && capabilities("libcurl")) {
|
|
method <- "libcurl"
|
|
} else if (nzchar(Sys.which("wget")[1])) {
|
|
method <- "wget"
|
|
} else if (nzchar(Sys.which("curl")[1])) {
|
|
method <- "curl"
|
|
|
|
# curl needs to add a -L option to follow redirects.
|
|
# Save the original options and restore when we exit.
|
|
orig_extra_options <- getOption("download.file.extra")
|
|
on.exit(options(download.file.extra = orig_extra_options))
|
|
|
|
options(download.file.extra = paste("-L", orig_extra_options))
|
|
|
|
} else if (nzchar(Sys.which("lynx")[1])) {
|
|
method <- "lynx"
|
|
} else {
|
|
stop("no download method found")
|
|
}
|
|
|
|
utils::download.file(url, method = method, ...)
|
|
}
|
|
|
|
} else {
|
|
utils::download.file(url, ...)
|
|
}
|
|
}
|
|
|
|
getContentType <- function(file, defaultType = 'application/octet-stream') {
|
|
subtype <- ifelse(grepl('[.]html?$', file), 'charset=UTF-8', '')
|
|
mime::guess_type(file, unknown = defaultType, subtype = subtype)
|
|
}
|
|
|
|
#' Parse a GET query string from a URL
|
|
#'
|
|
#' Returns a named list of key-value pairs.
|
|
#'
|
|
#' @noMd
|
|
#' @param str The query string. It can have a leading \code{"?"} or not.
|
|
#' @param nested Whether to parse the query string of as a nested list when it
|
|
#' contains pairs of square brackets \code{[]}. For example, the query
|
|
#' \samp{a[i1][j1]=x&b[i1][j1]=y&b[i2][j1]=z} will be parsed as \code{list(a =
|
|
#' list(i1 = list(j1 = 'x')), b = list(i1 = list(j1 = 'y'), i2 = list(j1 =
|
|
#' 'z')))} when \code{nested = TRUE}, and \code{list(`a[i1][j1]` = 'x',
|
|
#' `b[i1][j1]` = 'y', `b[i2][j1]` = 'z')} when \code{nested = FALSE}.
|
|
#' @export
|
|
#' @examples
|
|
#' parseQueryString("?foo=1&bar=b%20a%20r")
|
|
#'
|
|
#' \dontrun{
|
|
#' # Example of usage within a Shiny app
|
|
#' function(input, output, session) {
|
|
#'
|
|
#' output$queryText <- renderText({
|
|
#' query <- parseQueryString(session$clientData$url_search)
|
|
#'
|
|
#' # Ways of accessing the values
|
|
#' if (as.numeric(query$foo) == 1) {
|
|
#' # Do something
|
|
#' }
|
|
#' if (query[["bar"]] == "targetstring") {
|
|
#' # Do something else
|
|
#' }
|
|
#'
|
|
#' # Return a string with key-value pairs
|
|
#' paste(names(query), query, sep = "=", collapse=", ")
|
|
#' })
|
|
#' }
|
|
#' }
|
|
#'
|
|
parseQueryString <- function(str, nested = FALSE) {
|
|
if (is.null(str) || nchar(str) == 0)
|
|
return(list())
|
|
|
|
# Remove leading ?
|
|
if (substr(str, 1, 1) == '?')
|
|
str <- substr(str, 2, nchar(str))
|
|
|
|
pairs <- strsplit(str, '&', fixed = TRUE)[[1]]
|
|
# Drop any empty items (if there's leading/trailing/consecutive '&' chars)
|
|
pairs <- pairs[pairs != ""]
|
|
pairs <- strsplit(pairs, '=', fixed = TRUE)
|
|
|
|
keys <- vapply(pairs, function(x) x[1], FUN.VALUE = character(1))
|
|
values <- vapply(pairs, function(x) x[2], FUN.VALUE = character(1))
|
|
# Replace NA with '', so they don't get converted to 'NA' by URLdecode
|
|
values[is.na(values)] <- ''
|
|
|
|
# Convert "+" to " ", since URLdecode doesn't do it
|
|
keys <- gsub('+', ' ', keys, fixed = TRUE)
|
|
values <- gsub('+', ' ', values, fixed = TRUE)
|
|
|
|
keys <- URLdecode(keys)
|
|
values <- URLdecode(values)
|
|
|
|
res <- stats::setNames(as.list(values), keys)
|
|
if (!nested) return(res)
|
|
|
|
# Make a nested list from a query of the form ?a[1][1]=x11&a[1][2]=x12&...
|
|
for (i in grep('\\[.+\\]', keys)) {
|
|
k <- strsplit(keys[i], '[][]')[[1L]] # split by [ or ]
|
|
res <- assignNestedList(res, k[k != ''], values[i])
|
|
res[[keys[i]]] <- NULL # remove res[['a[1][1]']]
|
|
}
|
|
res
|
|
}
|
|
|
|
# Assign value to the bottom element of the list x using recursive indices idx
|
|
assignNestedList <- function(x = list(), idx, value) {
|
|
for (i in seq_along(idx)) {
|
|
sub <- idx[seq_len(i)]
|
|
if (is.null(x[[sub]])) x[[sub]] <- list()
|
|
}
|
|
x[[idx]] <- value
|
|
x
|
|
}
|
|
|
|
# decide what to do in case of errors; it is customizable using the shiny.error
|
|
# option (e.g. we can set options(shiny.error = recover))
|
|
#' @include conditions.R
|
|
shinyCallingHandlers <- function(expr) {
|
|
withCallingHandlers(captureStackTraces(expr),
|
|
error = function(e) {
|
|
# Don't intercept shiny.silent.error (i.e. validation errors)
|
|
if (inherits(e, "shiny.silent.error"))
|
|
return()
|
|
|
|
handle <- getOption('shiny.error')
|
|
if (is.function(handle)) handle()
|
|
}
|
|
)
|
|
}
|
|
|
|
|
|
#' Register a function with the debugger (if one is active).
|
|
#'
|
|
#' Call this function after exprToFunction to give any active debugger a hook
|
|
#' to set and clear breakpoints in the function. A debugger may implement
|
|
#' registerShinyDebugHook to receive callbacks when Shiny functions are
|
|
#' instantiated at runtime.
|
|
#'
|
|
#' @param name Name of the field or object containing the function.
|
|
#' @param where The reference object or environment containing the function.
|
|
#' @param label A label to display on the function in the debugger.
|
|
#' @noRd
|
|
registerDebugHook <- function(name, where, label) {
|
|
if (exists("registerShinyDebugHook", mode = "function")) {
|
|
registerShinyDebugHook <- get("registerShinyDebugHook", mode = "function")
|
|
params <- new.env(parent = emptyenv())
|
|
params$name <- name
|
|
params$where <- where
|
|
params$label <- label
|
|
registerShinyDebugHook(params)
|
|
}
|
|
}
|
|
|
|
Callbacks <- R6Class(
|
|
'Callbacks',
|
|
portable = FALSE,
|
|
class = FALSE,
|
|
public = list(
|
|
.nextId = integer(0),
|
|
.callbacks = 'Map',
|
|
|
|
initialize = function() {
|
|
# NOTE: we avoid using '.Machine$integer.max' directly
|
|
# as R 3.3.0's 'radixsort' could segfault when sorting
|
|
# an integer vector containing this value
|
|
.nextId <<- as.integer(.Machine$integer.max - 1L)
|
|
.callbacks <<- Map$new()
|
|
},
|
|
register = function(callback) {
|
|
if (!is.function(callback)) {
|
|
stop("callback must be a function")
|
|
}
|
|
id <- as.character(.nextId)
|
|
.nextId <<- .nextId - 1L
|
|
.callbacks$set(id, callback)
|
|
return(function() {
|
|
.callbacks$remove(id)
|
|
})
|
|
},
|
|
invoke = function(..., onError=NULL, ..stacktraceon = FALSE) {
|
|
# Ensure that calls are invoked in the order that they were registered
|
|
keys <- as.character(sort(as.integer(.callbacks$keys()), decreasing = TRUE))
|
|
callbacks <- .callbacks$mget(keys)
|
|
|
|
for (callback in callbacks) {
|
|
if (is.null(onError)) {
|
|
if (..stacktraceon) {
|
|
..stacktraceon..(callback(...))
|
|
} else {
|
|
callback(...)
|
|
}
|
|
} else {
|
|
tryCatch(
|
|
captureStackTraces(
|
|
if (..stacktraceon)
|
|
..stacktraceon..(callback(...))
|
|
else
|
|
callback(...)
|
|
),
|
|
error = onError
|
|
)
|
|
}
|
|
}
|
|
},
|
|
count = function() {
|
|
.callbacks$size()
|
|
}
|
|
)
|
|
)
|
|
|
|
# convert a data frame to JSON as required by DataTables request
|
|
dataTablesJSON <- function(data, req) {
|
|
n <- nrow(data)
|
|
# DataTables requests were sent via POST
|
|
params <- URLdecode(rawToChar(req$rook.input$read()))
|
|
q <- parseQueryString(params, nested = TRUE)
|
|
ci <- q$search[['caseInsensitive']] == 'true'
|
|
|
|
# data may have been replaced/updated in the new table while the Ajax request
|
|
# from the previous table is still on its way, so it is possible that the old
|
|
# request asks for more columns than the current data, in which case we should
|
|
# discard this request and return empty data; the next Ajax request from the
|
|
# new table will retrieve the correct number of columns of data
|
|
if (length(q$columns) != ncol(data)) {
|
|
res <- toJSON(list(
|
|
draw = as.integer(q$draw),
|
|
recordsTotal = n,
|
|
recordsFiltered = 0,
|
|
data = NULL
|
|
))
|
|
return(httpResponse(200, 'application/json', enc2utf8(res)))
|
|
}
|
|
|
|
# global searching
|
|
i <- seq_len(n)
|
|
if (length(q$search[['value']]) && q$search[['value']] != '') {
|
|
i0 <- apply(data, 2, function(x) {
|
|
grep2(q$search[['value']], as.character(x),
|
|
fixed = q$search[['regex']] == 'false', ignore.case = ci)
|
|
})
|
|
i <- intersect(i, unique(unlist(i0)))
|
|
}
|
|
|
|
# search by columns
|
|
if (length(i)) for (j in names(q$columns)) {
|
|
col <- q$columns[[j]]
|
|
# if the j-th column is not searchable or the search string is "", skip it
|
|
if (col[['searchable']] != 'true') next
|
|
if ((k <- col[['search']][['value']]) == '') next
|
|
j <- as.integer(j)
|
|
dj <- data[, j + 1]
|
|
r <- commaToRange(k)
|
|
ij <- if (length(r) == 2 && is.numeric(dj)) {
|
|
which(dj >= r[1] & dj <= r[2])
|
|
} else {
|
|
grep2(k, as.character(dj), fixed = col[['search']][['regex']] == 'false',
|
|
ignore.case = ci)
|
|
}
|
|
i <- intersect(ij, i)
|
|
if (length(i) == 0) break
|
|
}
|
|
if (length(i) != n) data <- data[i, , drop = FALSE]
|
|
|
|
# sorting
|
|
oList <- list()
|
|
for (ord in q$order) {
|
|
k <- ord[['column']] # which column to sort
|
|
d <- ord[['dir']] # direction asc/desc
|
|
if (q$columns[[k]][['orderable']] != 'true') next
|
|
col <- data[, as.integer(k) + 1]
|
|
oList[[length(oList) + 1]] <- (if (d == 'asc') identity else `-`)(
|
|
if (is.numeric(col)) col else xtfrm(col)
|
|
)
|
|
}
|
|
if (length(oList)) {
|
|
i <- do.call(order, oList)
|
|
data <- data[i, , drop = FALSE]
|
|
}
|
|
# paging
|
|
if (q$length != '-1') {
|
|
i <- seq(as.integer(q$start) + 1L, length.out = as.integer(q$length))
|
|
i <- i[i <= nrow(data)]
|
|
fdata <- data[i, , drop = FALSE] # filtered data
|
|
} else fdata <- data
|
|
|
|
fdata <- unname(as.matrix(fdata))
|
|
if (is.character(fdata) && q$escape != 'false') {
|
|
if (q$escape == 'true') {
|
|
# fdata must be a matrix at this point, and we need to preserve
|
|
# dimensions. Note that it could be a 1xn matrix.
|
|
dims <- dim(fdata)
|
|
fdata <- htmlEscape(fdata)
|
|
dim(fdata) <- dims
|
|
|
|
} else {
|
|
k <- as.integer(strsplit(q$escape, ',')[[1]])
|
|
# use seq_len() in case escape = negative indices, e.g. c(-1, -5)
|
|
for (j in seq_len(ncol(fdata))[k]) fdata[, j] <- htmlEscape(fdata[, j])
|
|
}
|
|
}
|
|
|
|
res <- toJSON(list(
|
|
draw = as.integer(q$draw),
|
|
recordsTotal = n,
|
|
recordsFiltered = nrow(data),
|
|
data = fdata
|
|
))
|
|
httpResponse(200, 'application/json', enc2utf8(res))
|
|
}
|
|
|
|
# when both ignore.case and fixed are TRUE, we use grep(ignore.case = FALSE,
|
|
# fixed = TRUE) to do lower-case matching of pattern on x
|
|
grep2 <- function(pattern, x, ignore.case = FALSE, fixed = FALSE, ...) {
|
|
if (fixed && ignore.case) {
|
|
pattern <- tolower(pattern)
|
|
x <- tolower(x)
|
|
ignore.case <- FALSE
|
|
}
|
|
# when the user types in the search box, the regular expression may not be
|
|
# complete before it is sent to the server, in which case we do not search
|
|
if (!fixed && inherits(try(grep(pattern, ''), silent = TRUE), 'try-error'))
|
|
return(seq_along(x))
|
|
grep(pattern, x, ignore.case = ignore.case, fixed = fixed, ...)
|
|
}
|
|
|
|
getExists <- function(x, mode, envir = parent.frame()) {
|
|
if (exists(x, envir = envir, mode = mode, inherits = FALSE))
|
|
get(x, envir = envir, mode = mode, inherits = FALSE)
|
|
}
|
|
|
|
# convert a string of the form "lower,upper" to c(lower, upper)
|
|
commaToRange <- function(string) {
|
|
if (!grepl(',', string)) return()
|
|
r <- strsplit(string, ',')[[1]]
|
|
if (length(r) > 2) return()
|
|
if (length(r) == 1) r <- c(r, '') # lower,
|
|
r <- as.numeric(r)
|
|
if (is.na(r[1])) r[1] <- -Inf
|
|
if (is.na(r[2])) r[2] <- Inf
|
|
r
|
|
}
|
|
|
|
# for options passed to DataTables/Selectize/..., the options of the class AsIs
|
|
# will be evaluated as literal JavaScript code
|
|
checkAsIs <- function(options) {
|
|
evalOptions <- if (length(options)) {
|
|
nms <- names(options)
|
|
if (length(nms) == 0L || any(nms == '')) stop("'options' must be a named list")
|
|
i <- unlist(lapply(options, function(x) {
|
|
is.character(x) && inherits(x, 'AsIs')
|
|
}))
|
|
if (any(i)) {
|
|
# must convert to character, otherwise toJSON() turns it to an array []
|
|
options[i] <- lapply(options[i], paste, collapse = '\n')
|
|
nms[i] # options of these names will be evaluated in JS
|
|
}
|
|
}
|
|
list(options = options, eval = evalOptions)
|
|
}
|
|
|
|
srcrefFromShinyCall <- function(expr) {
|
|
srcrefs <- attr(expr, "srcref")
|
|
num_exprs <- length(srcrefs)
|
|
if (num_exprs < 1)
|
|
return(NULL)
|
|
c(srcrefs[[1]][1], srcrefs[[1]][2],
|
|
srcrefs[[num_exprs]][3], srcrefs[[num_exprs]][4],
|
|
srcrefs[[1]][5], srcrefs[[num_exprs]][6])
|
|
}
|
|
|
|
# Indicates whether the given querystring should cause the associated request
|
|
# to be handled in showcase mode. Returns the showcase mode if set, or NULL
|
|
# if no showcase mode is set.
|
|
showcaseModeOfQuerystring <- function(querystring) {
|
|
if (nchar(querystring) > 0) {
|
|
qs <- parseQueryString(querystring)
|
|
if (exists("showcase", where = qs)) {
|
|
return(as.numeric(qs$showcase))
|
|
}
|
|
}
|
|
return(NULL)
|
|
}
|
|
|
|
showcaseModeOfReq <- function(req) {
|
|
showcaseModeOfQuerystring(req$QUERY_STRING)
|
|
}
|
|
|
|
# Returns (just) the filename containing the given source reference, or an
|
|
# empty string if the source reference doesn't include file information.
|
|
srcFileOfRef <- function(srcref) {
|
|
fileEnv <- attr(srcref, "srcfile")
|
|
# The 'srcfile' attribute should be a non-null environment containing the
|
|
# variable 'filename', which gives the full path to the source file.
|
|
if (!is.null(fileEnv) &&
|
|
is.environment(fileEnv) &&
|
|
exists("filename", where = fileEnv))
|
|
basename(fileEnv[["filename"]])
|
|
else
|
|
""
|
|
}
|
|
|
|
# Format a number without sci notation, and keep as many digits as possible (do
|
|
# we really need to go beyond 15 digits?)
|
|
formatNoSci <- function(x) {
|
|
if (is.null(x)) return(NULL)
|
|
format(x, scientific = FALSE, digits = 15)
|
|
}
|
|
|
|
# Returns a function that calls the given func and caches the result for
|
|
# subsequent calls, unless the given file's mtime changes.
|
|
cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) {
|
|
dir <- normalizePath(dir, mustWork=TRUE)
|
|
mtime <- NA
|
|
value <- NULL
|
|
function(...) {
|
|
fname <- if (case.sensitive)
|
|
file.path(dir, file)
|
|
else
|
|
file.path.ci(dir, file)
|
|
|
|
now <- file.info(fname)$mtime
|
|
if (!identical(mtime, now)) {
|
|
value <<- func(fname, ...)
|
|
mtime <<- now
|
|
}
|
|
value
|
|
}
|
|
}
|
|
|
|
# turn column-based data to row-based data (mainly for JSON), e.g. data.frame(x
|
|
# = 1:10, y = 10:1) ==> list(list(x = 1, y = 10), list(x = 2, y = 9), ...)
|
|
columnToRowData <- function(data) {
|
|
do.call(
|
|
mapply, c(
|
|
list(FUN = function(...) list(...), SIMPLIFY = FALSE, USE.NAMES = FALSE),
|
|
as.list(data)
|
|
)
|
|
)
|
|
}
|
|
|
|
#' Declare an error safe for the user to see
|
|
#'
|
|
#' This should be used when you want to let the user see an error
|
|
#' message even if the default is to sanitize all errors. If you have an
|
|
#' error `e` and call `stop(safeError(e))`, then Shiny will
|
|
#' ignore the value of `getOption("shiny.sanitize.errors")` and always
|
|
#' display the error in the app itself.
|
|
#'
|
|
#' @param error Either an "error" object or a "character" object (string).
|
|
#' In the latter case, the string will become the message of the error
|
|
#' returned by `safeError`.
|
|
#'
|
|
#' @return An "error" object
|
|
#'
|
|
#' @details An error generated by `safeError` has priority over all
|
|
#' other Shiny errors. This can be dangerous. For example, if you have set
|
|
#' `options(shiny.sanitize.errors = TRUE)`, then by default all error
|
|
#' messages are omitted in the app, and replaced by a generic error message.
|
|
#' However, this does not apply to `safeError`: whatever you pass
|
|
#' through `error` will be displayed to the user. So, this should only
|
|
#' be used when you are sure that your error message does not contain any
|
|
#' sensitive information. In those situations, `safeError` can make
|
|
#' your users' lives much easier by giving them a hint as to where the
|
|
#' error occurred.
|
|
#'
|
|
#' @seealso [shiny-options()]
|
|
#'
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#'
|
|
#' # uncomment the desired line to experiment with shiny.sanitize.errors
|
|
#' # options(shiny.sanitize.errors = TRUE)
|
|
#' # options(shiny.sanitize.errors = FALSE)
|
|
#'
|
|
#' # Define UI
|
|
#' ui <- fluidPage(
|
|
#' textInput('number', 'Enter your favorite number from 1 to 10', '5'),
|
|
#' textOutput('normalError'),
|
|
#' textOutput('safeError')
|
|
#' )
|
|
#'
|
|
#' # Server logic
|
|
#' server <- function(input, output) {
|
|
#' output$normalError <- renderText({
|
|
#' number <- input$number
|
|
#' if (number %in% 1:10) {
|
|
#' return(paste('You chose', number, '!'))
|
|
#' } else {
|
|
#' stop(
|
|
#' paste(number, 'is not a number between 1 and 10')
|
|
#' )
|
|
#' }
|
|
#' })
|
|
#' output$safeError <- renderText({
|
|
#' number <- input$number
|
|
#' if (number %in% 1:10) {
|
|
#' return(paste('You chose', number, '!'))
|
|
#' } else {
|
|
#' stop(safeError(
|
|
#' paste(number, 'is not a number between 1 and 10')
|
|
#' ))
|
|
#' }
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' # Complete app with UI and server components
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
#' @export
|
|
safeError <- function(error) {
|
|
if (inherits(error, "character")) {
|
|
error <- simpleError(error)
|
|
}
|
|
if (!inherits(error, "error")) {
|
|
stop("The class of the `error` parameter must be either 'error' or 'character'")
|
|
}
|
|
class(error) <- c("shiny.custom.error", class(error))
|
|
error
|
|
}
|
|
|
|
#***********************************************************************#
|
|
#**** Keep this function internal for now, may chnage in the future ****#
|
|
#***********************************************************************#
|
|
# #' Propagate an error through Shiny, but catch it before it throws
|
|
# #'
|
|
# #' Throws a type of exception that is caught by observers. When such an
|
|
# #' exception is triggered, all reactive links are broken. So, essentially,
|
|
# #' \code{reactiveStop()} behaves just like \code{stop()}, except that
|
|
# #' instead of ending the session, it is silently swalowed by Shiny.
|
|
# #'
|
|
# #' This function should be used when you want to disrupt the reactive
|
|
# #' links in a reactive chain, but do not want to end the session. For
|
|
# #' example, this enables you to disallow certain inputs, but get back
|
|
# #' to business as usual when valid inputs are re-entered.
|
|
# #' \code{reactiveStop} is also called internally by Shiny to create
|
|
# #' special errors, such as the ones generated by \code{\link{validate}()},
|
|
# #' \code{\link{req}()} and \code{\link{cancelOutput}()}.
|
|
# #'
|
|
# #' @param message An optional error message.
|
|
# #' @param class An optional class to add to the error.
|
|
# #' @export
|
|
# #' @examples
|
|
# #' ## Note: the breaking of the reactive chain that happens in the app
|
|
# #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is
|
|
# #' ## easily visualized with `reactlogShow()`
|
|
# #'
|
|
# #' ## Only run examples in interactive R sessions
|
|
# #' if (interactive()) {
|
|
# #'
|
|
# #' ui <- fluidPage(
|
|
# #' textInput('txt', 'Enter some text...'),
|
|
# #' selectInput('allowBad', 'Allow the string \'bad\'?',
|
|
# #' c('TRUE', 'FALSE'), selected = 'FALSE')
|
|
# #' )
|
|
# #'
|
|
# #' server <- function(input, output) {
|
|
# #' val <- reactive({
|
|
# #' if (!(as.logical(input$allowBad))) {
|
|
# #' if (identical(input$txt, "bad")) {
|
|
# #' reactiveStop()
|
|
# #' }
|
|
# #' }
|
|
## ' })
|
|
# #'
|
|
# #' observe({
|
|
# #' val()
|
|
# #' })
|
|
# #' }
|
|
# #'
|
|
# #' shinyApp(ui, server)
|
|
# #' }
|
|
# #' @export
|
|
reactiveStop <- function(message = "", class = NULL) {
|
|
stopWithCondition(c("shiny.silent.error", class), message)
|
|
}
|
|
|
|
#' Validate input values and other conditions
|
|
#'
|
|
#' @description
|
|
#' `validate()` provides convenient mechanism for validating that an output
|
|
#' has all the inputs necessary for successful rendering. It takes any number
|
|
#' of (unnamed) arguments, each representing a condition to test. If any
|
|
#' of condition fails (i.e. is not ["truthy"][isTruthy]), a special type of
|
|
#' error is signaled to stop execution. If this error is not handled by
|
|
#' application-specific code, it is displayed to the user by Shiny.
|
|
#'
|
|
#' If you use `validate()` in a [reactive()] validation failures will
|
|
#' automatically propagate to outputs that use the reactive.
|
|
#'
|
|
#' @section `need()`:
|
|
#' An easy way to provide arguments to `validate()` is to use `need()`, which
|
|
#' takes an expression and a string. If the expression is not
|
|
#' ["truthy"][isTruthy] then the string will be used as the error message.
|
|
#'
|
|
#' If "truthiness" is flexible for your use case, you'll need to explicitly
|
|
#' generate a logical values. For example, if you want allow `NA` but not
|
|
#' `NULL`, you can `!is.null(input$foo)`.
|
|
#'
|
|
#' If you need validation logic that differs significantly from `need()`, you
|
|
#' can create your own validation test functions. A passing test should return
|
|
#' `NULL`. A failing test should return either a string providing the error
|
|
#' to display to the user, or if the failure should happen silently, `FALSE`.
|
|
#'
|
|
#' Alternatively you can use `validate()` within an `if` statement, which is
|
|
#' particularly useful for more complex conditions:
|
|
#'
|
|
#' ```
|
|
#' if (input$x < 0 && input$choice == "positive") {
|
|
#' validate("If choice is positive then x must be greater than 0")
|
|
#' }
|
|
#' ```
|
|
#'
|
|
#' @param ... A list of tests. Each test should equal `NULL` for success,
|
|
#' `FALSE` for silent failure, or a string for failure with an error
|
|
#' message.
|
|
#' @param errorClass A CSS class to apply. The actual CSS string will have
|
|
#' `shiny-output-error-` prepended to this value.
|
|
#' @export
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#' options(device.ask.default = FALSE)
|
|
#'
|
|
#' ui <- fluidPage(
|
|
#' checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)),
|
|
#' selectizeInput('in2', 'Select a state', choices = c("", state.name)),
|
|
#' plotOutput('plot')
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output) {
|
|
#' output$plot <- renderPlot({
|
|
#' validate(
|
|
#' need(input$in1, 'Check at least one letter!'),
|
|
#' need(input$in2 != '', 'Please choose a state.')
|
|
#' )
|
|
#' plot(1:10, main = paste(c(input$in1, input$in2), collapse = ', '))
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#'
|
|
#' }
|
|
validate <- function(..., errorClass = character(0)) {
|
|
results <- sapply(list2(...), function(x) {
|
|
# Detect NULL or NA
|
|
if (is.null(x))
|
|
return(NA_character_)
|
|
else if (identical(x, FALSE))
|
|
return("")
|
|
else if (is.character(x))
|
|
return(paste(as.character(x), collapse = "\n"))
|
|
else
|
|
stop("Unexpected validation result: ", as.character(x))
|
|
})
|
|
|
|
results <- stats::na.omit(results)
|
|
if (length(results) == 0)
|
|
return(invisible())
|
|
|
|
# There may be empty strings remaining; these are message-less failures that
|
|
# started as FALSE
|
|
results <- results[nzchar(results)]
|
|
reactiveStop(paste(results, collapse="\n"), c(errorClass, "validation"))
|
|
}
|
|
|
|
#' @param expr An expression to test. The condition will pass if the expression
|
|
#' meets the conditions spelled out in Details.
|
|
#' @param message A message to convey to the user if the validation condition is
|
|
#' not met. If no message is provided, one will be created using `label`.
|
|
#' To fail with no message, use `FALSE` for the message.
|
|
#' @param label A human-readable name for the field that may be missing. This
|
|
#' parameter is not needed if `message` is provided, but must be provided
|
|
#' otherwise.
|
|
#' @export
|
|
#' @rdname validate
|
|
need <- function(expr, message = paste(label, "must be provided"), label) {
|
|
|
|
force(message) # Fail fast on message/label both being missing
|
|
|
|
if (!isTruthy(expr))
|
|
return(message)
|
|
else
|
|
return(invisible(NULL))
|
|
}
|
|
|
|
#' Check for required values
|
|
#'
|
|
#' Ensure that values are available (["truthy"][isTruthy]) before proceeding
|
|
#' with a calculation or action. If any of the given values is not truthy, the
|
|
#' operation is stopped by raising a "silent" exception (not logged by Shiny,
|
|
#' nor displayed in the Shiny app's UI).
|
|
#'
|
|
#' The `req` function was designed to be used in one of two ways. The first
|
|
#' is to call it like a statement (ignoring its return value) before attempting
|
|
#' operations using the required values:
|
|
#'
|
|
#' ```
|
|
#' rv <- reactiveValues(state = FALSE)
|
|
#' r <- reactive({
|
|
#' req(input$a, input$b, rv$state)
|
|
#' # Code that uses input$a, input$b, and/or rv$state...
|
|
#' })
|
|
#' ```
|
|
#'
|
|
#' In this example, if `r()` is called and any of `input$a`,
|
|
#' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`,
|
|
#' etc., then the `req` call will trigger an error that propagates all the
|
|
#' way up to whatever render block or observer is executing.
|
|
#'
|
|
#' The second is to use it to wrap an expression that must be truthy:
|
|
#'
|
|
#' ```
|
|
#' output$plot <- renderPlot({
|
|
#' if (req(input$plotType) == "histogram") {
|
|
#' hist(dataset())
|
|
#' } else if (input$plotType == "scatter") {
|
|
#' qplot(dataset(), aes(x = x, y = y))
|
|
#' }
|
|
#' })
|
|
#' ```
|
|
#'
|
|
#' In this example, `req(input$plotType)` first checks that
|
|
#' `input$plotType` is truthy, and if so, returns it. This is a convenient
|
|
#' way to check for a value "inline" with its first use.
|
|
#'
|
|
#' @section Using `req(FALSE)`:
|
|
#'
|
|
#' You can use `req(FALSE)` (i.e. no condition) if you've already performed
|
|
#' all the checks you needed to by that point and just want to stop the reactive
|
|
#' chain now. There is no advantange to this, except perhaps ease of readibility
|
|
#' if you have a complicated condition to check for (or perhaps if you'd like to
|
|
#' divide your condition into nested `if` statements).
|
|
#'
|
|
#' @section Using `cancelOutput = TRUE`:
|
|
#'
|
|
#' When `req(..., cancelOutput = TRUE)` is used, the "silent" exception is
|
|
#' also raised, but it is treated slightly differently if one or more outputs are
|
|
#' currently being evaluated. In those cases, the reactive chain does not proceed
|
|
#' or update, but the output(s) are left is whatever state they happen to be in
|
|
#' (whatever was their last valid state).
|
|
#'
|
|
#' Note that this is always going to be the case if
|
|
#' this is used inside an output context (e.g. `output$txt <- ...`). It may
|
|
#' or may not be the case if it is used inside a non-output context (e.g.
|
|
#' [reactive()], [observe()] or [observeEvent()])
|
|
#' --- depending on whether or not there is an `output$...` that is triggered
|
|
#' as a result of those calls. See the examples below for concrete scenarios.
|
|
#'
|
|
#' @param ... Values to check for truthiness.
|
|
#' @param cancelOutput If `TRUE` and an output is being evaluated, stop
|
|
#' processing as usual but instead of clearing the output, leave it in
|
|
#' whatever state it happens to be in.
|
|
#' @return The first value that was passed in.
|
|
#' @export
|
|
#' @examples
|
|
#' ## Only run examples in interactive R sessions
|
|
#' if (interactive()) {
|
|
#' ui <- fluidPage(
|
|
#' textInput('data', 'Enter a dataset from the "datasets" package', 'cars'),
|
|
#' p('(E.g. "cars", "mtcars", "pressure", "faithful")'), hr(),
|
|
#' tableOutput('tbl')
|
|
#' )
|
|
#'
|
|
#' server <- function(input, output) {
|
|
#' output$tbl <- renderTable({
|
|
#'
|
|
#' ## to require that the user types something, use: `req(input$data)`
|
|
#' ## but better: require that input$data is valid and leave the last
|
|
#' ## valid table up
|
|
#' req(exists(input$data, "package:datasets", inherits = FALSE),
|
|
#' cancelOutput = TRUE)
|
|
#'
|
|
#' head(get(input$data, "package:datasets", inherits = FALSE))
|
|
#' })
|
|
#' }
|
|
#'
|
|
#' shinyApp(ui, server)
|
|
#' }
|
|
req <- function(..., cancelOutput = FALSE) {
|
|
dotloop(function(item) {
|
|
if (!isTruthy(item)) {
|
|
if (isTRUE(cancelOutput)) {
|
|
cancelOutput()
|
|
} else {
|
|
reactiveStop(class = "validation")
|
|
}
|
|
}
|
|
}, ...)
|
|
|
|
if (!missing(..1))
|
|
..1
|
|
else
|
|
invisible()
|
|
}
|
|
|
|
#***********************************************************************#
|
|
#**** Keep this function internal for now, may chnage in the future ****#
|
|
#***********************************************************************#
|
|
# #' Cancel processing of the current output
|
|
# #'
|
|
# #' Signals an error that Shiny treats specially if an output is currently being
|
|
# #' evaluated. Execution will stop, but rather than clearing the output (as
|
|
# #' \code{\link{req}} does) or showing an error message (as \code{\link{stop}}
|
|
# #' does), the output simply remains unchanged.
|
|
# #'
|
|
# #' If \code{cancelOutput} is called in any non-output context (like in an
|
|
# #' \code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same
|
|
# #' as \code{\link{req}(FALSE)}.
|
|
# #' @export
|
|
# #' @examples
|
|
# #' ## Only run examples in interactive R sessions
|
|
# #' if (interactive()) {
|
|
# #'
|
|
# #' # uncomment the desired line to experiment with cancelOutput() vs. req()
|
|
# #'
|
|
# #' ui <- fluidPage(
|
|
# #' textInput('txt', 'Enter text'),
|
|
# #' textOutput('check')
|
|
# #' )
|
|
# #'
|
|
# #' server <- function(input, output) {
|
|
# #' output$check <- renderText({
|
|
# #' # req(input$txt)
|
|
# #' if (input$txt == 'hi') return('hi')
|
|
# #' else if (input$txt == 'bye') return('bye')
|
|
# #' # else cancelOutput()
|
|
# #' })
|
|
# #' }
|
|
# #'
|
|
# #' shinyApp(ui, server)
|
|
# #' }
|
|
cancelOutput <- function() {
|
|
reactiveStop(class = "shiny.output.cancel")
|
|
}
|
|
|
|
# Execute a function against each element of ..., but only evaluate each element
|
|
# after the previous element has been passed to fun_. The return value of fun_
|
|
# is discarded, and only invisible() is returned from dotloop.
|
|
#
|
|
# Can be used to facilitate short-circuit eval on dots.
|
|
dotloop <- function(fun_, ...) {
|
|
for (i in seq_len(nargs() - 1)) {
|
|
fun_(eval(as.symbol(paste0("..", i))))
|
|
}
|
|
invisible()
|
|
}
|
|
|
|
#' Truthy and falsy values
|
|
#'
|
|
#' The terms "truthy" and "falsy" generally indicate whether a value, when
|
|
#' coerced to a [base::logical()], is `TRUE` or `FALSE`. We use
|
|
#' the term a little loosely here; our usage tries to match the intuitive
|
|
#' notions of "Is this value missing or available?", or "Has the user provided
|
|
#' an answer?", or in the case of action buttons, "Has the button been
|
|
#' clicked?".
|
|
#'
|
|
#' For example, a `textInput` that has not been filled out by the user has
|
|
#' a value of `""`, so that is considered a falsy value.
|
|
#'
|
|
#' To be precise, a value is truthy *unless* it is one of:
|
|
#'
|
|
#' * `FALSE`
|
|
#' * `NULL`
|
|
#' * `""`
|
|
#' * An empty atomic vector
|
|
#' * An atomic vector that contains only missing values
|
|
#' * A logical vector that contains all `FALSE` or missing values
|
|
#' * An object of class `"try-error"`
|
|
#' * A value that represents an unclicked [actionButton()]
|
|
#'
|
|
#' Note in particular that the value `0` is considered truthy, even though
|
|
#' `as.logical(0)` is `FALSE`.
|
|
#'
|
|
#' @param x An expression whose truthiness value we want to determine
|
|
#' @export
|
|
isTruthy <- function(x) {
|
|
if (inherits(x, 'try-error'))
|
|
return(FALSE)
|
|
|
|
if (!is.atomic(x))
|
|
return(TRUE)
|
|
|
|
if (is.null(x))
|
|
return(FALSE)
|
|
if (length(x) == 0)
|
|
return(FALSE)
|
|
if (all(is.na(x)))
|
|
return(FALSE)
|
|
if (is.character(x) && !any(nzchar(stats::na.omit(x))))
|
|
return(FALSE)
|
|
if (inherits(x, 'shinyActionButtonValue') && x == 0)
|
|
return(FALSE)
|
|
if (is.logical(x) && !any(stats::na.omit(x)))
|
|
return(FALSE)
|
|
|
|
return(TRUE)
|
|
}
|
|
|
|
# add class(es) to the error condition, which will be used as names of CSS
|
|
# classes, e.g. shiny-output-error shiny-output-error-validation
|
|
stopWithCondition <- function(class, message) {
|
|
cond <- structure(
|
|
list(message = message),
|
|
class = c(class, 'error', 'condition')
|
|
)
|
|
stop(cond)
|
|
}
|
|
|
|
#' Collect information about the Shiny Server environment
|
|
#'
|
|
#' This function returns the information about the current Shiny Server, such as
|
|
#' its version, and whether it is the open source edition or professional
|
|
#' edition. If the app is not served through the Shiny Server, this function
|
|
#' just returns `list(shinyServer = FALSE)`.
|
|
#'
|
|
#' This function will only return meaningful data when using Shiny Server
|
|
#' version 1.2.2 or later.
|
|
#' @export
|
|
#' @return A list of the Shiny Server information.
|
|
serverInfo <- function() {
|
|
.globals$serverInfo
|
|
}
|
|
.globals$serverInfo <- list(shinyServer = FALSE)
|
|
|
|
setServerInfo <- function(...) {
|
|
infoOld <- serverInfo()
|
|
infoNew <- list(...)
|
|
infoOld[names(infoNew)] <- infoNew
|
|
.globals$serverInfo <- infoOld
|
|
}
|
|
|
|
# assume file is encoded in UTF-8, but warn against BOM
|
|
checkEncoding <- function(file) {
|
|
# skip *nix because its locale is normally UTF-8 based (e.g. en_US.UTF-8), and
|
|
# *nix users have to make a conscious effort to save a file with an encoding
|
|
# that is not UTF-8; if they choose to do so, we cannot do much about it
|
|
# except sitting back and seeing them punished after they choose to escape a
|
|
# world of consistency (falling back to getOption('encoding') will not help
|
|
# because native.enc is also normally UTF-8 based on *nix)
|
|
if (!isWindows()) return('UTF-8')
|
|
size <- file.info(file)[, 'size']
|
|
if (is.na(size)) stop('Cannot access the file ', file)
|
|
# BOM is 3 bytes, so if the file contains BOM, it must be at least 3 bytes
|
|
if (size < 3L) return('UTF-8')
|
|
|
|
# check if there is a BOM character: this is also skipped on *nix, because R
|
|
# on *nix simply ignores this meaningless character if present, but it hurts
|
|
# on Windows
|
|
if (identical(charToRaw(readChar(file, 3L, TRUE)), charToRaw('\UFEFF'))) {
|
|
warning('You should not include the Byte Order Mark (BOM) in ', file, '. ',
|
|
'Please re-save it in UTF-8 without BOM. See ',
|
|
'https://shiny.rstudio.com/articles/unicode.html for more info.')
|
|
return('UTF-8-BOM')
|
|
}
|
|
x <- readChar(file, size, useBytes = TRUE)
|
|
if (is.na(iconv(x, 'UTF-8', 'UTF-8'))) {
|
|
warning('The input file ', file, ' does not seem to be encoded in UTF8')
|
|
}
|
|
'UTF-8'
|
|
}
|
|
|
|
# read a file using UTF-8 and (on Windows) convert to native encoding if possible
|
|
readUTF8 <- function(file) {
|
|
enc <- checkEncoding(file)
|
|
file <- base::file(file, encoding = enc)
|
|
on.exit(close(file), add = TRUE)
|
|
x <- enc2utf8(readLines(file, warn = FALSE))
|
|
tryNativeEncoding(x)
|
|
}
|
|
|
|
# if the UTF-8 string can be represented in the native encoding, use native encoding
|
|
tryNativeEncoding <- function(string) {
|
|
if (!isWindows()) return(string)
|
|
string2 <- enc2native(string)
|
|
if (identical(enc2utf8(string2), string)) string2 else string
|
|
}
|
|
|
|
# similarly, try to source() a file with UTF-8
|
|
sourceUTF8 <- function(file, envir = globalenv()) {
|
|
lines <- readUTF8(file)
|
|
enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown'
|
|
src <- srcfilecopy(file, lines, isFile = TRUE) # source reference info
|
|
# oddly, parse(file) does not work when file contains multibyte chars that
|
|
# **can** be encoded natively on Windows (might be a bug in base R); we
|
|
# rewrite the source code in a natively encoded temp file and parse it in this
|
|
# case (the source reference is still pointed to the original file, though)
|
|
if (isWindows() && enc == 'unknown') {
|
|
file <- tempfile(); on.exit(unlink(file), add = TRUE)
|
|
writeLines(lines, file)
|
|
}
|
|
exprs <- try(parse(file, keep.source = FALSE, srcfile = src, encoding = enc))
|
|
if (inherits(exprs, "try-error")) {
|
|
diagnoseCode(file)
|
|
stop("Error sourcing ", file)
|
|
}
|
|
|
|
# Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the
|
|
# ..stacktraceon..() that we care about, but the `{` is needed to make that
|
|
# possible.
|
|
exprs <- makeCall(`{`, exprs)
|
|
# Need to wrap exprs in a list because we want it treated as a single argument
|
|
exprs <- makeCall(..stacktraceon.., list(exprs))
|
|
|
|
eval(exprs, envir)
|
|
}
|
|
|
|
# @param func Name of function, in unquoted form
|
|
# @param args An evaluated list of unevaluated argument expressions
|
|
makeCall <- function(func, args) {
|
|
as.call(c(list(substitute(func)), args))
|
|
}
|
|
|
|
# a workaround for https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16264
|
|
srcfilecopy <- function(filename, lines, ...) {
|
|
if (getRversion() > '3.2.2') return(base::srcfilecopy(filename, lines, ...))
|
|
src <- base::srcfilecopy(filename, lines = '', ...)
|
|
src$lines <- lines
|
|
src
|
|
}
|
|
|
|
# write text as UTF-8
|
|
writeUTF8 <- function(text, ...) {
|
|
text <- enc2utf8(text)
|
|
writeLines(text, ..., useBytes = TRUE)
|
|
}
|
|
|
|
URLdecode <- function(value) {
|
|
decodeURIComponent(value)
|
|
}
|
|
|
|
URLencode <- function(value, reserved = FALSE) {
|
|
value <- enc2utf8(value)
|
|
if (reserved) encodeURIComponent(value) else encodeURI(value)
|
|
}
|
|
|
|
# Make sure user-supplied dates are either NULL or can be coerced to a
|
|
# yyyy-mm-dd formatted string. If a date is specified, this function returns a
|
|
# string for consistency across locales. Also, `as.Date()` is used to coerce
|
|
# strings to date objects so that strings like "2016-08-9" are expanded to
|
|
# "2016-08-09". If any of the values result in error or NA, then the input
|
|
# `date` is returned unchanged.
|
|
dateYMD <- function(date = NULL, argName = "value") {
|
|
if (!length(date)) return(NULL)
|
|
tryCatch({
|
|
res <- format(as.Date(date), "%Y-%m-%d")
|
|
if (any(is.na(res))) stop()
|
|
date <- res
|
|
},
|
|
error = function(e) {
|
|
warning(
|
|
"Couldn't coerce the `", argName,
|
|
"` argument to a date string with format yyyy-mm-dd",
|
|
call. = FALSE
|
|
)
|
|
}
|
|
)
|
|
date
|
|
}
|
|
|
|
# This function takes a name and function, and it wraps that function in a new
|
|
# function which calls the original function using the specified name. This can
|
|
# be helpful for profiling, because the specified name will show up on the stack
|
|
# trace.
|
|
wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE, dots = TRUE) {
|
|
if (name == "name" || name == "func" || name == "relabelWrapper") {
|
|
stop("Invalid name for wrapFunctionLabel: ", name)
|
|
}
|
|
assign(name, func, environment())
|
|
registerDebugHook(name, environment(), name)
|
|
|
|
if (isTRUE(dots)) {
|
|
if (..stacktraceon) {
|
|
# We need to wrap the `...` in `!!quote(...)` so that R CMD check won't
|
|
# complain about "... may be used in an incorrect context"
|
|
body <- expr({ ..stacktraceon..((!!name)(!!quote(...))) })
|
|
} else {
|
|
body <- expr({ (!!name)(!!quote(...)) })
|
|
}
|
|
relabelWrapper <- new_function(pairlist2(... =), body, environment())
|
|
} else {
|
|
# Same logic as when `dots = TRUE`, but without the `...`
|
|
if (..stacktraceon) {
|
|
body <- expr({ ..stacktraceon..((!!name)()) })
|
|
} else {
|
|
body <- expr({ (!!name)() })
|
|
}
|
|
relabelWrapper <- new_function(list(), body, environment())
|
|
}
|
|
|
|
# Preserve the original function that was passed in; is used for caching.
|
|
attr(relabelWrapper, "wrappedFunc") <- func
|
|
relabelWrapper
|
|
}
|
|
|
|
|
|
# This is a very simple mutable object which only stores one value
|
|
# (which we can set and get). Using this class is sometimes useful
|
|
# when communicating persistent changes across functions.
|
|
Mutable <- R6Class("Mutable",
|
|
private = list(
|
|
value = NULL
|
|
),
|
|
public = list(
|
|
set = function(value) { private$value <- value },
|
|
get = function() { private$value }
|
|
)
|
|
)
|
|
|
|
# More convenient way of chaining together promises than then/catch/finally,
|
|
# without the performance impact of %...>%.
|
|
promise_chain <- function(promise, ..., catch = NULL, finally = NULL,
|
|
domain = NULL, replace = FALSE) {
|
|
|
|
do <- function() {
|
|
p <- Reduce(function(memo, func) {
|
|
promises::then(memo, func)
|
|
}, list(...), promise)
|
|
|
|
if (!is.null(catch)) {
|
|
p <- promises::catch(p, catch)
|
|
}
|
|
|
|
if (!is.null(finally)) {
|
|
p <- promises::finally(p, finally)
|
|
}
|
|
|
|
p
|
|
}
|
|
|
|
if (!is.null(domain)) {
|
|
promises::with_promise_domain(domain, do(), replace = replace)
|
|
} else {
|
|
do()
|
|
}
|
|
}
|
|
|
|
# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`,
|
|
# and `finally` are all executed synchronously
|
|
hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL,
|
|
domain = NULL, replace = FALSE) {
|
|
|
|
do <- function() {
|
|
runFinally <- TRUE
|
|
tryCatch(
|
|
{
|
|
captureStackTraces({
|
|
result <- withVisible(force(expr))
|
|
if (promises::is.promising(result$value)) {
|
|
# Purposefully NOT including domain (nor replace), as we're already in
|
|
# the domain at this point
|
|
p <- promise_chain(valueWithVisible(result), ..., catch = catch, finally = finally)
|
|
runFinally <- FALSE
|
|
p
|
|
} else {
|
|
result <- Reduce(
|
|
function(v, func) {
|
|
if (v$visible) {
|
|
withVisible(func(v$value))
|
|
} else {
|
|
withVisible(func(invisible(v$value)))
|
|
}
|
|
},
|
|
list(...),
|
|
result
|
|
)
|
|
|
|
valueWithVisible(result)
|
|
}
|
|
})
|
|
},
|
|
error = function(e) {
|
|
if (!is.null(catch))
|
|
catch(e)
|
|
else
|
|
stop(e)
|
|
},
|
|
finally = if (runFinally && !is.null(finally)) finally()
|
|
)
|
|
}
|
|
|
|
if (!is.null(domain)) {
|
|
promises::with_promise_domain(domain, do(), replace = replace)
|
|
} else {
|
|
do()
|
|
}
|
|
}
|
|
|
|
# Given a list with items named `value` and `visible`, return `x$value` either
|
|
# visibly, or invisibly, depending on the value of `x$visible`.
|
|
valueWithVisible <- function(x) {
|
|
if (x$visible) x$value else invisible(x$value)
|
|
}
|
|
|
|
|
|
createVarPromiseDomain <- function(env, name, value) {
|
|
force(env)
|
|
force(name)
|
|
force(value)
|
|
|
|
promises::new_promise_domain(
|
|
wrapOnFulfilled = function(onFulfilled) {
|
|
function(...) {
|
|
orig <- env[[name]]
|
|
env[[name]] <- value
|
|
on.exit(env[[name]] <- orig)
|
|
|
|
onFulfilled(...)
|
|
}
|
|
},
|
|
wrapOnRejected = function(onRejected) {
|
|
function(...) {
|
|
orig <- env[[name]]
|
|
env[[name]] <- value
|
|
on.exit(env[[name]] <- orig)
|
|
|
|
onRejected(...)
|
|
}
|
|
},
|
|
wrapSync = function(expr) {
|
|
orig <- env[[name]]
|
|
env[[name]] <- value
|
|
on.exit(env[[name]] <- orig)
|
|
|
|
force(expr)
|
|
}
|
|
)
|
|
}
|
|
|
|
getSliderType <- function(min, max, value) {
|
|
vals <- dropNulls(list(value, min, max))
|
|
if (length(vals) == 0) return("")
|
|
type <- unique(lapply(vals, function(x) {
|
|
if (inherits(x, "Date")) "date"
|
|
else if (inherits(x, "POSIXt")) "datetime"
|
|
else "number"
|
|
}))
|
|
if (length(type) > 1) {
|
|
rlang::abort(c(
|
|
"Type mismatch for `min`, `max`, and `value`.",
|
|
"All values must either be numeric, Date, or POSIXt."
|
|
))
|
|
}
|
|
type[[1]]
|
|
}
|
|
|
|
# Reads the `shiny.sharedSecret` global option, and returns a function that can
|
|
# be used to test header values for a match.
|
|
loadSharedSecret <- function() {
|
|
normalizeToRaw <- function(value, label = "value") {
|
|
if (is.null(value)) {
|
|
raw()
|
|
} else if (is.character(value)) {
|
|
charToRaw(paste(value, collapse = "\n"))
|
|
} else if (is.raw(value)) {
|
|
value
|
|
} else {
|
|
stop("Wrong type for ", label, "; character or raw expected")
|
|
}
|
|
}
|
|
|
|
sharedSecret <- normalizeToRaw(getOption("shiny.sharedSecret"))
|
|
if (is.null(sharedSecret)) {
|
|
function(x) TRUE
|
|
} else {
|
|
# We compare the digest of the two values so that their lengths are equalized
|
|
function(x) {
|
|
x <- normalizeToRaw(x)
|
|
# Constant time comparison to avoid timing attacks
|
|
constantTimeEquals(sharedSecret, x)
|
|
}
|
|
}
|
|
}
|
|
|
|
# Compares two raw vectors of equal length for equality, in constant time
|
|
constantTimeEquals <- function(raw1, raw2) {
|
|
stopifnot(is.raw(raw1))
|
|
stopifnot(is.raw(raw2))
|
|
if (length(raw1) != length(raw2)) {
|
|
return(FALSE)
|
|
}
|
|
|
|
sum(as.integer(xor(raw1, raw2))) == 0
|
|
}
|
|
|
|
cat_line <- function(...) {
|
|
cat(paste(..., "\n", collapse = ""))
|
|
}
|
|
|
|
select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n")
|
|
{
|
|
if (!is.null(title)) {
|
|
cat(title, "\n", sep = "")
|
|
}
|
|
nc <- length(choices)
|
|
op <- paste0(format(seq_len(nc)), ": ", choices)
|
|
fop <- format(op)
|
|
cat("", fop, "", sep = "\n")
|
|
repeat {
|
|
answer <- readline(msg)
|
|
answer <- strsplit(answer, "[ ,]+")[[1]]
|
|
if (all(answer %in% seq_along(choices))) {
|
|
return(choices[as.integer(answer)])
|
|
}
|
|
}
|
|
}
|
|
|
|
#' @noRd
|
|
isAppDir <- function(path) {
|
|
|
|
if (file.exists(file.path.ci(path, "app.R")))
|
|
return(TRUE)
|
|
|
|
if (file.exists(file.path.ci(path, "server.R"))
|
|
&& file.exists(file.path.ci(path, "ui.R")))
|
|
return(TRUE)
|
|
|
|
FALSE
|
|
}
|
|
|
|
# Borrowed from rprojroot which borrowed from devtools
|
|
#' @noRd
|
|
is_root <- function(path) {
|
|
identical(
|
|
normalizePath(path, winslash = "/"),
|
|
normalizePath(dirname(path), winslash = "/")
|
|
)
|
|
}
|
|
|
|
#' @noRd
|
|
findEnclosingApp <- function(path = ".") {
|
|
orig_path <- path
|
|
path <- normalizePath(path, winslash = "/", mustWork = TRUE)
|
|
repeat {
|
|
if (isAppDir(path))
|
|
return(path)
|
|
if (is_root(path))
|
|
stop("Shiny app not found at ", orig_path, " or in any parent directory.")
|
|
path <- dirname(path)
|
|
}
|
|
}
|
|
|
|
# Check if a package is installed, and if version is specified,
|
|
# that we have at least that version
|
|
is_available <- function(package, version = NULL) {
|
|
installed <- nzchar(system.file(package = package))
|
|
if (is.null(version)) {
|
|
return(installed)
|
|
}
|
|
installed && isTRUE(utils::packageVersion(package) >= version)
|
|
}
|
|
|
|
|
|
# cached version of utils::packageVersion("shiny")
|
|
shinyPackageVersion <- local({
|
|
version <- NULL
|
|
function() {
|
|
if (is.null(version)) {
|
|
version <<- utils::packageVersion("shiny")
|
|
}
|
|
version
|
|
}
|
|
})
|