server-input-handlers.R

# 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 `input` variable
#' of the `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 `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". It should be called from the
#' package's `.onLoad()` function.
#'
#' Currently Shiny registers the following handlers: `shiny.matrix`,
#' `shiny.number`, and `shiny.date`.
#'
#' The `type` of a custom Shiny Input widget will be deduced using the
#' `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
#'   `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 `shinysession` in which the
#'   input exists.} \item{The name of the input.} }
#' @param force If `TRUE`, will overwrite any existing handler without warning.
#'   If `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
#' # In a package, this should be called from the .onLoad function.
#' 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 [removeInputHandler()] [applyInputHandlers()]
#' @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 `type`, if one
#'   existed. Otherwise, `NULL`.
#' @seealso [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 `"x:shiny.date"`. This function would apply the `"shiny.date"`
#' input handler to the value, and then rename the result to `"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
  setSerializer(name, 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("shinyActionButtonValue", class(val))
  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`.
  setSerializer(name, serializerFileInput)

  snapshotPreprocessInput(name, snapshotPreprocessorFileInput)

  val
})


# to be used with !!!answer
registerInputHandler("shiny.symbolList", function(val, ...) {
  if (is.null(val)) {
    list()
  } else {
    lapply(val, as.symbol)
  }
})
# to be used with !!answer
registerInputHandler("shiny.symbol", function(val, ...) {
  if (is.null(val) || identical(val, "")) {
    NULL
  } else {
    as.symbol(val)
  }
})