File: server-input-handlers.R

package info (click to toggle)
r-cran-shiny 1.0.0%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 4,080 kB
  • ctags: 290
  • sloc: makefile: 22; sh: 13
file content (220 lines) | stat: -rw-r--r-- 7,747 bytes parent folder | download | duplicates (2)
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
})