1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
|
# 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 jsonlite) 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 jsonlite.}
#' \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 jsonlite 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)
}
# Apply input handler to a single input value
applyInputHandler <- function(name, val, shinysession) {
splitName <- strsplit(name, ':')[[1]]
if (length(splitName) > 1) {
if (!inputHandlers$containsKey(splitName[[2]])) {
# No input handler registered for this type
stop("No handler registered for type ", name)
}
inputName <- splitName[[1]]
# Get the function for processing this type of input
inputHandler <- inputHandlers$get(splitName[[2]])
return(inputHandler(val, shinysession, inputName))
} else if (is.list(val) && is.null(names(val))) {
return(unlist(val, recursive = TRUE))
} else {
return(val)
}
}
#' Apply input handlers to raw input values
#'
#' The purpose of this function is to make it possible for external packages to
#' test Shiny inputs. It takes a named list of raw input values, applies input
#' handlers to those values, and then returns a named list of the processed
#' values.
#'
#' The raw input values should be in a named list. Some values may have names
#' like \code{"x:shiny.date"}. This function would apply the \code{"shiny.date"}
#' input handler to the value, and then rename the result to \code{"x"}, in the
#' output.
#'
#' @param inputs A named list of input values.
#' @param shinysession A Shiny session object.
#'
#' @seealso registerInputHandler
#' @keywords internal
applyInputHandlers <- function(inputs, shinysession = getDefaultReactiveDomain()) {
inputs <- mapply(applyInputHandler, names(inputs), inputs,
MoreArgs = list(shinysession = shinysession),
SIMPLIFY = FALSE)
# Convert names like "button1:shiny.action" to "button1"
names(inputs) <- vapply(
names(inputs),
function(name) { strsplit(name, ":")[[1]][1] },
FUN.VALUE = character(1)
)
inputs
}
# 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.password", function(val, shinysession, name) {
# Mark passwords as not serializable
.subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerUnserializable)
val
})
registerInputHandler("shiny.date", function(val, ...){
# First replace NULLs with NA, then convert to Date vector
datelist <- ifelse(lapply(val, is.null), NA, val)
res <- NULL
tryCatch({
res <- as.Date(unlist(datelist))
},
error = function(e) {
# It's possible for client to send a string like "99999-01-01", which
# as.Date can't handle.
warning(e$message)
res <<- as.Date(rep(NA, length(datelist)))
}
)
res
})
registerInputHandler("shiny.datetime", function(val, ...){
# First replace NULLs with NA, then convert to POSIXct vector
times <- lapply(val, function(x) {
if (is.null(x)) NA
else x
})
as.POSIXct(unlist(times), origin = "1970-01-01", tz = "UTC")
})
registerInputHandler("shiny.action", function(val, shinysession, name) {
# mark up the action button value with a special class so we can recognize it later
class(val) <- c(class(val), "shinyActionButtonValue")
val
})
registerInputHandler("shiny.file", function(val, shinysession, name) {
# This function is only used when restoring a Shiny fileInput. When a file is
# uploaded the usual way, it takes a different code path and won't hit this
# function.
if (is.null(val))
return(NULL)
# The data will be a named list of lists; convert to a data frame.
val <- as.data.frame(lapply(val, unlist), stringsAsFactors = FALSE)
# `val$datapath` should be a filename without a path, for security reasons.
if (basename(val$datapath) != val$datapath) {
stop("Invalid '/' found in file input path.")
}
# Prepend the persistent dir
oldfile <- file.path(getCurrentRestoreContext()$dir, val$datapath)
# Copy the original file to a new temp dir, so that a restored session can't
# modify the original.
newdir <- file.path(tempdir(), createUniqueId(12))
dir.create(newdir)
val$datapath <- file.path(newdir, val$datapath)
file.copy(oldfile, val$datapath)
# Need to mark this input value with the correct serializer. When a file is
# uploaded the usual way (instead of being restored), this occurs in
# session$`@uploadEnd`.
.subset2(shinysession$input, "impl")$setMeta(name, "shiny.serializer", serializerFileInput)
val
})
|