189 - Add Pattern Matching Callbacks for Dash R

.github/FUNDING.yml

@@ -1 +1,2 @@
+github: plotly
 custom: https://plotly.com/products/consulting-and-oem/

.gitignore

@@ -7,3 +7,4 @@ node_modules/
 python/
 todo.txt
 r-finance*
+build/

CHANGELOG.md

@@ -4,6 +4,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ## [Unreleased]
 ### Added
+- Pattern-matching IDs and callbacks. Component IDs can be lists, and callbacks can reference patterns of components, using three different wildcards: `ALL`, `MATCH`, and `ALLSMALLER`. This lets you create components on demand, and have callbacks respond to any and all of them. To help with this, `app$callback_context` gets three new entries: `outputs_list`, `inputs_list`, and `states_list`, which contain all the ids, properties, and except for the outputs, the property values from all matched components. [#228](https://github.com/plotly/dashR/pull/228)
 - New and improved callback graph in the debug menu. Now based on Cytoscape for much more interactivity, plus callback profiling including number of calls, fine-grained time information, bytes sent and received, and more. You can even add custom timing information on the server with `callback_context.record_timing(name, duration, description)` [#224](https://github.com/plotly/dashR/pull/224)
 - Support for setting attributes on `external_scripts` and `external_stylesheets`, and validation for the parameters passed (attributes are verified, and elements that are lists themselves must be named). [#226](https://github.com/plotly/dashR/pull/226)
 - Dash for R now supports user-defined routes and redirects via the `app$server_route` and `app$redirect` methods. [#225](https://github.com/plotly/dashR/pull/225)

NAMESPACE

@@ -1,7 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,dash_component)
+export(ALL)
+export(ALLSMALLER)
 export(Dash)
+export(MATCH)
 export(clientsideFunction)
 export(dashNoUpdate)
 export(input)

R/dash.R

@@ -221,18 +221,38 @@ Dash <- R6::R6Class(
  callback_args <- list()
 
  for (input_element in request$body$inputs) {
- if(is.null(input_element$value))
+ if (any(grepl("id.", names(unlist(input_element))))) {
+ if (!is.null(input_element$id)) input_element <- list(input_element)
+ values <- character(0)
+ for (wildcard_input in input_element) {
+ values <- c(values, wildcard_input$value)
+ }
+ callback_args <- c(callback_args, ifelse(length(values), list(values), list(NULL)))
+ }
+ else if(is.null(input_element$value)) {
  callback_args <- c(callback_args, list(list(NULL)))
- else
+ }
+ else {
  callback_args <- c(callback_args, list(input_element$value))
+ }
  }
 
  if (length(request$body$state)) {
  for (state_element in request$body$state) {
- if(is.null(state_element$value))
+ if (any(grepl("id.", names(unlist(state_element))))) {
+ if (!is.null(state_element$id)) state_element <- list(state_element)
+ values <- character(0)
+ for (wildcard_state in state_element) {
+ values <- c(values, wildcard_state$value)
+ }
+ callback_args <- c(callback_args, ifelse(length(values), list(values), list(NULL)))
+ }
+ else if(is.null(state_element$value)) {
  callback_args <- c(callback_args, list(list(NULL)))
- else
+ }
+ else {
  callback_args <- c(callback_args, list(state_element$value))
+ }
  }
  }
 
@@ -290,6 +310,12 @@ Dash <- R6::R6Class(
  response = allprops,
  multi = TRUE
  )
+ } else if (is.list(request$body$outputs$id)) {
+ props = setNames(list(output_value), gsub( "(^.+)(\\.)", "", request$body$output))
+ resp <- list(
+ response = setNames(list(props), to_JSON(request$body$outputs$id)),
+ multi = TRUE
+ )
  } else {
  resp <- list(
  response = list(
@@ -770,12 +796,43 @@ Dash <- R6::R6Class(
  #' containing valid JavaScript, or a call to [clientsideFunction],
  #' including `namespace` and `function_name` arguments for a locally served
  #' JavaScript function.
+ #'
+ #'
+ #' For pattern-matching callbacks, the `id` field of a component is written
+ #' in JSON-like syntax which describes a dictionary object when serialized
+ #' for consumption by the Dash renderer. The fields are arbitrary keys
+ #' , which describe the targets of the callback.
+ #'
+ #' For example, when we write `input(id=list("foo" = ALL, "bar" = "dropdown")`,
+ #' Dash interprets this as "match any input that has an ID list where 'foo'
+ #' is 'ALL' and 'bar' is anything." If any of the dropdown
+ #' `value` properties change, all of their values are returned to the callback.
+ #'
+ #' However, for readability, we recommend using keys like type, index, or id.
+ #' `type` can be used to refer to the class or set of dynamic components and
+ #' `index` or `id` could be used to refer to the component you are matching
+ #' within that set. While your application may have a single set of dynamic
+ #' components, it's possible to specify multiple sets of dynamic components
+ #' in more complex apps or if you are using `MATCH`.
+ #'
+ #' Like `ALL`, `MATCH` will fire the callback when any of the component's properties
+ #' change. However, instead of passing all of the values into the callback, `MATCH`
+ #' will pass just a single value into the callback. Instead of updating a single
+ #' output, it will update the dynamic output that is "matched" with.
+ #'
+ #' `ALLSMALLER` is used to pass in the values of all of the targeted components
+ #' on the page that have an index smaller than the index corresponding to the div.
+ #' For example, `ALLSMALLER` makes it possible to filter results that are
+ #' increasingly specific as the user applies each additional selection.
+ #'
+ #' `ALLSMALLER` can only be used in `input` and `state` items, and must be used
+ #' on a key that has `MATCH` in the `output` item(s). `ALLSMALLER` it isn't always
+ #' necessary (you can usually use `ALL` and filter out the indices in your callback),
+ #' but it will make your logic simpler.
  callback = function(output, params, func) {
  assert_valid_callbacks(output, params, func)
-
  inputs <- params[vapply(params, function(x) 'input' %in% attr(x, "class"), FUN.VALUE=logical(1))]
  state <- params[vapply(params, function(x) 'state' %in% attr(x, "class"), FUN.VALUE=logical(1))]
-
  if (is.function(func)) {
  clientside_function <- NULL
  } else if (is.character(func)) {

R/dependencies.R

@@ -1,5 +1,15 @@
 # akin to https://github.com/plotly/dash/blob/d2ebc837/dash/dependencies.py
 
+# Helper functions for handling dependency ids or props
+setWildcardId <- function(id) {
+ # Sort the keys of a wildcard id
+ id <- id[order(names(id))]
+ all_selectors <- vapply(id, function(x) {is.symbol(x)}, logical(1))
+ id[all_selectors] <- as.character(id[all_selectors])
+ id[!all_selectors] <- lapply(id[!all_selectors], function(x) {jsonlite::unbox(x)})
+ return(as.character(jsonlite::toJSON(id, auto_unbox = FALSE)))
+}
+
 #' Input/Output/State definitions
 #'
 #' Use in conjunction with the `callback()` method from the [dash::Dash] class
@@ -8,13 +18,23 @@
 #' The `dashNoUpdate()` function permits application developers to prevent a
 #' single output from updating the layout. It has no formal arguments.
 #' 
+#' `ALL`, `ALLSMALLER` and `MATCH` are symbols corresponding to the
+#' pattern-matching callback selectors with the same names. These allow you
+#' to write callbacks that respond to or update an arbitrary or dynamic
+#' number of components. For more information, see the `callback` section
+#' in \link{dash}.
+#'
 #' @name dependencies
 #' @param id a component id
 #' @param property the component property to use
 
 #' @rdname dependencies
 #' @export
+
 output <- function(id, property) {
+ if (is.list(id)) {
+ id = setWildcardId(id)
+ }
  structure(
  dependency(id, property),
  class = c("dash_dependency", "output")
@@ -24,6 +44,9 @@ output <- function(id, property) {
 #' @rdname dependencies
 #' @export
 input <- function(id, property) {
+ if (is.list(id)) {
+ id = setWildcardId(id)
+ }
  structure(
  dependency(id, property),
  class = c("dash_dependency", "input")
@@ -33,6 +56,9 @@ input <- function(id, property) {
 #' @rdname dependencies
 #' @export
 state <- function(id, property) {
+ if (is.list(id)) {
+ id = setWildcardId(id)
+ }
  structure(
  dependency(id, property),
  class = c("dash_dependency", "state")
@@ -41,6 +67,9 @@ state <- function(id, property) {
 
 dependency <- function(id = NULL, property = NULL) {
  if (is.null(id)) stop("Must specify an id", call. = FALSE)
+ if (is.list(id)) {
+ id = setWildcardId(id)
+ }
  list(
  id = id,
  property = property
@@ -54,3 +83,15 @@ dashNoUpdate <- function() {
  class(x) <- "no_update"
  return(x)
 }
+
+#' @rdname dependencies
+#' @export
+ALL <- as.symbol("ALL")
+
+#' @rdname dependencies
+#' @export
+ALLSMALLER <- as.symbol("ALLSMALLER")
+
+#' @rdname dependencies
+#' @export
+MATCH <- as.symbol("MATCH")

R/utils.R

@@ -290,6 +290,22 @@ assert_no_names <- function (x)
  paste(nms, collapse = "', '")), call. = FALSE)
 }
 
+assertValidWildcards <- function(dependency) {
+ if (is.symbol(dependency$id)) {
+ result <- (jsonlite::validate(as.character(dependency$id)) && grepl("{", dependency$id))
+ } else {
+ result <- TRUE
+ }
+ if (!result) {
+ dependencyType <- class(dependency)
+ stop(sprintf("A callback %s ID contains restricted pattern matching callback selectors ALL, MATCH or ALLSMALLER. Please verify that it is formatted as a pattern matching callback list ID, or choose a different component ID.",
+ dependencyType[dependencyType %in% c("input", "output", "state")]),
+ call. = FALSE)
+ } else {
+ return(result)
+ }
+}
+
 # the following function attempts to prune remote CSS
 # or local CSS/JS dependencies that either should not
 # be resolved to local R package paths, or which have
@@ -403,6 +419,27 @@ assert_valid_callbacks <- function(output, params, func) {
  stop(sprintf("The callback method requires that one or more properly formatted inputs are passed."), call. = FALSE)
  }
 
+ # Verify that 'input', 'state' and 'output' parameters only contain 'Wildcard' keywords if they are JSON formatted ids for pattern matching callbacks
+ valid_wildcard_inputs <- sapply(inputs, function(x) {
+ assertValidWildcards(x)
+ })
+
+
+ valid_wildcard_state <- sapply(state, function(x) {
+ assertValidWildcards(x)
+ })
+
+ if(any(sapply(output, is.list))) {
+ valid_wildcard_output <- sapply(output, function(x) {
+ assertValidWildcards(x)
+ })
+ } else {
+ valid_wildcard_output <- sapply(list(output), function(x) {
+ assertValidWildcards(x)
+ })
+ }
+
+
  # Check that outputs are not inputs
  # https://github.com/plotly/dash/issues/323
 
@@ -987,29 +1024,78 @@ removeHandlers <- function(fnList) {
 }
 
 setCallbackContext <- function(callback_elements) {
- states <- lapply(callback_elements$states, function(x) {
- setNames(x$value, paste(x$id, x$property, sep="."))
- })
+ # Set state elements for this callback
+
+ if (length(callback_elements$state[[1]]) == 0) {
+ states <- sapply(callback_elements$state, function(x) {
+ setNames(list(x$value), paste(x$id, x$property, sep="."))
+ })
+ } else if (is.character(callback_elements$state[[1]][[1]])) {
+ states <- sapply(callback_elements$state, function(x) {
+ setNames(list(x$value), paste(x$id, x$property, sep="."))
+ })
+ } else {
+ states <- sapply(callback_elements$state, function(x) {
+ states_vector <- unlist(x)
+ setNames(list(states_vector[grepl("value|value.", names(states_vector))]), 
+ paste(as.character(jsonlite::toJSON(x[[1]])), x$property, sep="."))
+ })
+ }
 
  splitIdProp <- function(x) unlist(strsplit(x, split = "[.]"))
 
  triggered <- lapply(callback_elements$changedPropIds,
  function(x) {
  input_id <- splitIdProp(x)[1]
  prop <- splitIdProp(x)[2]
-
- id_match <- vapply(callback_elements$inputs, function(x) x$id %in% input_id, logical(1))
- prop_match <- vapply(callback_elements$inputs, function(x) x$property %in% prop, logical(1))
-
- value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value")
-
- list(`prop_id` = x, `value` = value)
+
+ # The following conditionals check whether the callback is a pattern-matching callback and if it has been triggered. 
+ if (startsWith(input_id, "{")){
+ id_match <- vapply(callback_elements$inputs, function(x) {
+ x <- unlist(x)
+ any(x[grepl("id.", names(x))] %in% jsonlite::fromJSON(input_id)[[1]])
+ }, logical(1))[[1]]
+ } else {
+ id_match <- vapply(callback_elements$inputs, function(x) x$id %in% input_id, logical(1))
+ }
+
+ if (startsWith(input_id, "{")){
+ prop_match <- vapply(callback_elements$inputs, function(x) {
+ x <- unlist(x)
+ any(x[names(x) == "property"] %in% prop)
+ }, logical(1))[[1]]
+ } else {
+ prop_match <- vapply(callback_elements$inputs, function(x) x$property %in% prop, logical(1))
+ }
+
+ if (startsWith(input_id, "{")){
+ if (length(callback_elements$inputs) == 1 || !is.null(unlist(callback_elements$inputs, recursive = F)$value)) {
+ value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value")
+ } else {
+ value <- sapply(callback_elements$inputs[id_match & prop_match][[1]], `[[`, "value")
+ }
+ } else {
+ value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value")
+ }
+
+ return(list(`prop_id` = x, `value` = value))
  }
- )
-
- inputs <- sapply(callback_elements$inputs, function(x) {
- setNames(list(x$value), paste(x$id, x$property, sep="."))
- })
+ )
+ if (length(callback_elements$inputs[[1]]) == 0 || is.character(callback_elements$inputs[[1]][[1]])) {
+ inputs <- sapply(callback_elements$inputs, function(x) {
+ setNames(list(x$value), paste(x$id, x$property, sep="."))
+ })
+ } else if (length(callback_elements$inputs[[1]]) > 1) {
+ inputs <- sapply(callback_elements$inputs, function(x) {
+ inputs_vector <- unlist(x)
+ setNames(list(inputs_vector[grepl("value|value.", names(inputs_vector))]), paste(as.character(jsonlite::toJSON(x$id)), x$property, sep="."))
+ })
+ } else {
+ inputs <- sapply(callback_elements$inputs, function(x) {
+ inputs_vector <- unlist(x)
+ setNames(list(inputs_vector[grepl("value|value.", names(inputs_vector))]), paste(as.character(jsonlite::toJSON(x[[1]]$id)), x[[1]]$property, sep="."))
+ })
+ }
 
  return(list(states=states,
  triggered=unlist(triggered, recursive=FALSE),