Provide support for multiple outputs

.circleci/config.yml

@@ -26,11 +26,7 @@ jobs:
       - run:
           name: 🚧 install R dependencies
           command: |
-              sudo Rscript -e 'install.packages("remotes")'
-              sudo R -e "remotes::install_github('plotly/dash-core-components', dependencies=TRUE)"
-              sudo R -e "remotes::install_github('plotly/dash-html-components', dependencies=TRUE)"
-              sudo R -e "remotes::install_github('plotly/dash-table', dependencies=TRUE)"
-              sudo R CMD INSTALL .
+              sudo Rscript -e 'install.packages("remotes"); remotes::install_github("plotly/dashR", dependencies=TRUE, upgrade=TRUE); install.packages(".", type="source", repos=NULL)'
 
       - run:
           name: ⚙️ run integration test

NAMESPACE

@@ -2,6 +2,8 @@
 
 S3method(print,dash_component)
 export(Dash)
+export(dashNoUpdate)
+export(createCallbackId)
 export(input)
 export(output)
 export(state)

R/dash.R

@@ -196,7 +196,6 @@ Dash <- R6::R6Class(
 
       dash_layout <- paste0(self$config$routes_pathname_prefix, "_dash-layout")
       route$add_handler("get", dash_layout, function(request, response, keys, ...) {
-
         rendered_layout <- private$layout_render()
         # pass the layout on to encode_plotly in case there are dccGraph
         # components which include Plotly.js figures for which we'll need to 
@@ -210,7 +209,6 @@ Dash <- R6::R6Class(
 
       dash_deps <- paste0(self$config$routes_pathname_prefix, "_dash-dependencies")
       route$add_handler("get", dash_deps, function(request, response, keys, ...) {
-
         # dash-renderer wants an empty array when no dependencies exist (see python/01.py)
         if (!length(private$callback_map)) {
           response$body <- to_JSON(list())
@@ -222,7 +220,7 @@ Dash <- R6::R6Class(
         payload <- Map(function(callback_signature) {
           list(
             inputs=callback_signature$inputs,
-            output=paste0(callback_signature$output, collapse="."),
+            output=createCallbackId(callback_signature$output),
             state=callback_signature$state
           )
         }, private$callback_map)
@@ -287,24 +285,62 @@ Dash <- R6::R6Class(
         output_value <- getStackTrace(do.call(callback, callback_args),
                                       debug = private$debug,
                                       pruned_errors = private$pruned_errors)
-  
+
         # reset callback context
         private$callback_context_ <- NULL
-
-        if (is.null(private$stack_message)) {
+
+        # inspect the output_value to determine whether any outputs have no_update
+        # objects within them; these should not be updated
+        if (length(output_value) == 1 && class(output_value) == "no_update") {
+          response$body <- character(1) # return empty string
+          response$status <- 204L
+        }
+        else if (is.null(private$stack_message)) {
           # pass on output_value to encode_plotly in case there are dccGraph
           # components which include Plotly.js figures for which we'll need to 
           # run plotly_build from the plotly package
           output_value <- encode_plotly(output_value)
 
-          # have to format the response body like this
-          # https://github.com/plotly/dash/blob/064c811d/dash/dash.py#L562-L584
-          resp <- list(
-            response = list(
-              props = setNames(list(output_value), gsub( "(^.+)(\\.)", "", request$body$output))
-            )
-          )
+          # for multiple outputs, have to format the response body like this, including 'multi' key:
+          # https://github.com/plotly/dash/blob/d9ddc877d6b15d9354bcef4141acca5d5fe6c07b/dash/dash.py#L1174-L1209
+
+          # for single outputs, the response body is formatted slightly differently:
+          # https://github.com/plotly/dash/blob/d9ddc877d6b15d9354bcef4141acca5d5fe6c07b/dash/dash.py#L1210-L1220
 
+          if (substr(request$body$output, 1, 2) == '..') {
+            # omit return objects of class "no_update" from output_value
+            updatable_outputs <- "no_update" != vapply(output_value, class, character(1))
+            output_value <- output_value[updatable_outputs]
+
+            # if multi-output callback, isolate the output IDs and properties
+            ids <- getIdProps(request$body$output)$ids[updatable_outputs]
+            props <- getIdProps(request$body$output)$props[updatable_outputs]
+
+            # prepare a response object which has list elements corresponding to ids
+            # which themselves contain named list elements corresponding to props
+            # then fill in nested list elements based on output_value
+
+            allprops <- setNames(vector("list", length(unique(ids))), unique(ids))
+
+            idmap <- setNames(ids, props)
+
+            for (id in unique(ids)) {
+              allprops[[id]] <- output_value[grep(id, ids)]
+              names(allprops[[id]]) <- names(idmap[which(idmap==id)])
+            }
+
+            resp <- list(
+             response = allprops,
+             multi = TRUE
+             )
+          } else {
+            resp <- list(
+              response = list(
+                props = setNames(list(output_value), gsub( "(^.+)(\\.)", "", request$body$output))
+              )
+            )
+          }
+
           response$body <- to_JSON(resp)
           response$status <- 200L
           response$type <- 'json'
@@ -498,14 +534,14 @@ Dash <- R6::R6Class(
 
       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))]
-
+      
       # register the callback_map
-      private$callback_map[[paste(output$id, output$property, sep='.')]] <- list(
-          inputs=inputs,
-          output=output,
-          state=state,
-          func=func
-        )
+      private$callback_map <- insertIntoCallbackMap(private$callback_map,
+                                                    inputs,
+                                                    output,
+                                                    state,
+                                                    func)
+
     },
 
     # ------------------------------------------------------------------------

R/dependencies.R

@@ -5,11 +5,13 @@
 #' Use in conjunction with the `callback()` method from the [dash::Dash] class
 #' to define the update logic in your application.
 #'
+#' The `dashNoUpdate()` function permits application developers to prevent a
+#' single output from updating the layout. It has no formal arguments.
+#' 
 #' @name dependencies
 #' @param id a component id
 #' @param property the component property to use
 
-
 #' @rdname dependencies
 #' @export
 output <- function(id, property) {
@@ -44,3 +46,11 @@ dependency <- function(id = NULL, property = NULL) {
     property = property
   )
 }
+
+#' @rdname dependencies
+#' @export
+dashNoUpdate <- function() {
+  x <- list(NULL)
+  class(x) <- "no_update"
+  return(x)
+}

R/utils.R

@@ -138,7 +138,7 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) {
 
     # According to Dash convention, label react and react-dom as originating
     # in dash_renderer package, even though all three are currently served
-    # u p from the DashR package
+    # up from the DashR package
     if (dep$name %in% c("react", "react-dom", "prop-types")) {
       dep$name <- "dash-renderer"
     }
@@ -352,14 +352,38 @@ clean_dependencies <- function(deps) {
   return(deps_with_file)
 }
 
+insertIntoCallbackMap <- function(map, inputs, output, state, func) {
+  map[[createCallbackId(output)]] <- list(inputs=inputs,
+                                          output=output,
+                                          state=state,
+                                          func=func
+                                          )
+  if (length(map) >= 2) {
+    ids <- lapply(names(map), function(x) dash:::getIdProps(x)$ids)
+    props <- lapply(names(map), function(x) dash:::getIdProps(x)$props)
+
+    outputs_as_list <- mapply(paste, ids, props, sep=".")
+
+    if (length(Reduce(intersect, outputs_as_list))) {
+      stop(sprintf("One or more outputs are duplicated across callbacks. Please ensure that all ID and property combinations are unique."), call. = FALSE)        
+    }
+  }
+  return(map)
+}
+
 assert_valid_callbacks <- function(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))]
-  
+
   invalid_params <- vapply(params, function(x) {
     !any(c('input', 'state') %in% attr(x, "class"))
   }, FUN.VALUE=logical(1))
 
+  # Verify that no outputs are duplicated
+  if (length(output) != length(unique(output))) {
+    stop(sprintf("One or more callback outputs have been duplicated; please confirm that all outputs are unique."), call. = FALSE)      
+  }
+
   # Verify that params contains no elements that are not either members of 'input' or 'state' classes
   if (any(invalid_params)) {
     stop(sprintf("Callback parameters must be inputs or states. Please verify formatting of callback parameters."), call. = FALSE)
@@ -371,10 +395,22 @@ assert_valid_callbacks <- function(output, params, func) {
   }
 
   # Assert that the component ID as passed is a string.
-  if(!(is.character(output$id) & !grepl("^\\s*$", output$id) & !grepl("\\.", output$id))) {
-    stop(sprintf("Callback IDs must be (non-empty) character strings that do not contain one or more dots/periods. Please verify that the component ID is valid."), call. = FALSE)
+  # This function inspects the output object to see if its ID
+  # is a valid string.
+  validateOutput <- function(string) {
+    return((is.character(string[["id"]]) & !grepl("^\\s*$", string[["id"]]) & !grepl("\\.", string[["id"]])))
   }
 
+  # Check if the callback uses multiple outputs
+  if (any(sapply(output, is.list))) {
+    invalid_callback_ID <- (!all(vapply(output, validateOutput, logical(1))))
+  } else {
+    invalid_callback_ID <-  (!validateOutput(output))
+  } 
+  if (invalid_callback_ID) {
+    stop(sprintf("Callback IDs must be (non-empty) character strings that do not contain one or more dots/periods. Please verify that the component ID is valid."), call. = FALSE)
+  }
+
   # Assert that user_function is a valid function
   if(!(is.function(func))) {
     stop(sprintf("The callback method's 'func' parameter requires a function as its argument. Please verify that 'func' is a valid, executable R function."), call. = FALSE)
@@ -397,7 +433,22 @@ assert_valid_callbacks <- function(output, params, func) {
 
   # Check that outputs are not inputs
   # https://github.com/plotly/dash/issues/323
-  inputs_vs_outputs <- lapply(inputs, function(x) identical(x, output))
+
+  # helper function to permit same mapply syntax regardless
+  # of whether output is defined using output function or not
+  listWrap <- function(x){
+    if (!any(sapply(x, is.list))) {
+      return(list(x))
+    } else {
+      x
+    }
+  }
+
+  # determine whether any input matches the output, or outputs, if
+  # multiple callback scenario
+  inputs_vs_outputs <- mapply(function(inputObject, outputObject) {
+    identical(outputObject[["id"]], inputObject[["id"]]) & identical(outputObject[["property"]], inputObject[["property"]])
+  }, inputs, listWrap(output))
 
   if(TRUE %in% inputs_vs_outputs) {
     stop(sprintf("Circular input and output arguments were found. Please verify that callback outputs are not also input arguments."), call. = FALSE)
@@ -828,3 +879,25 @@ getDashMetadata <- function(pkgname) {
   metadataFn <- as.vector(fnList[grepl("^\\.dash.+_js_metadata$", fnList)])
   return(metadataFn)
 }
+
+createCallbackId <- function(output) {
+  # check if callback uses single output
+  if (!any(sapply(output, is.list))) {
+    id <- paste0(output, collapse=".")
+  } else {
+    # multi-output callback, concatenate
+    ids <- vapply(output, function(x) {
+      paste(x, collapse = ".")
+    }, character(1))
+    id <- paste0("..", paste0(ids, collapse="..."), "..")
+  }
+  return(id)
+}
+
+getIdProps <- function(output) {
+  output_ids <- strsplit(substr(output, 3, nchar(output)-2), '...', fixed=TRUE)
+  idprops <- lapply(output_ids, strsplit, '.', fixed=TRUE)
+  ids <- vapply(unlist(idprops, recursive=FALSE), '[', character(1), 1)
+  props <- vapply(unlist(idprops, recursive=FALSE), '[', character(1), 2)
+  return(list(ids=ids, props=props))
+}