Provide support for multiple outputs (#119)

Author: rpkyle

.circleci/config.yml

@@ -26,14 +26,10 @@ 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
+          name: ⚙️  Integration tests
           command: |
             python -m venv venv
             . venv/bin/activate
@@ -42,6 +38,11 @@ jobs:
             export PATH=$PATH:/home/circleci/.local/bin/
             pytest tests/integration/
 
+      - run:
+          name: 🔎 Unit tests
+          command: |
+              sudo Rscript -e 'testthat::test_dir("tests/")'
+
 workflows:
   version: 2
   build:

NAMESPACE

@@ -3,6 +3,7 @@
 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)
@@ -303,14 +301,46 @@ Dash <- R6::R6Class(
           # 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'
@@ -504,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/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=".", SIMPLIFY = FALSE)
+      
+    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))
+}

tests/integration/callbacks/multiple_outputs.py

@@ -0,0 +1,112 @@
+from selenium.webdriver.support.select import Select
+
+app = """
+library(dash)
+library(dashHtmlComponents)
+library(dashCoreComponents)
+library(plotly)
+library(dashTable)
+
+app <- Dash$new()       
+app$layout(
+  htmlDiv(list(
+    htmlDiv(list(
+      htmlH1('Multi output example'),
+      dccDropdown(id='data-dropdown',
+                  options = list(
+                    list(label = 'Movies',
+                         value = 'movies'),
+                    list(label = 'Series',
+                         value = 'series')
+                  ),
+                  value = 'movies')
+    ),
+    id = 'container',
+    style = list(
+      backgroundColor = '#ff998a'
+    )
+    ),
+    htmlDiv(list(
+      htmlH2('Make a selection from the dropdown menu.',
+             id = 'text-box'),
+      dccRadioItems(id='radio-partial',
+                    options = list(
+                      list(label = 'All',
+                           value = 'all'),
+                      list(label = 'Do not update colour',
+                           value = 'static')
+                    ),
+                    value = 'all')
+    )
+    )
+  )
+  )
+)
+app$callback(output=list(
+  output(id='text-box', property='children'),
+  output(id='container', property='style')
+),
+params=list(
+  input(id='data-dropdown', property='value'),
+  input(id='radio-partial', property='value')
+),
+function(value, choice) {
+  if (is.null(value)) {
+    return(dashNoUpdate())
+  }
+  
+  if (choice == "all" && value == "series") {
+    style <- list(
+      backgroundColor = '#ff998a'
+    )
+  } else if (choice == "all") {
+    style <- list(
+      backgroundColor = '#fff289'
+    )
+  } else {
+    return(list(sprintf("You have chosen %s.", value),
+                dashNoUpdate()))
+  }
+  
+  return(list(sprintf("You have chosen %s.", value),
+              style))
+}
+)
+app$run_server(debug=TRUE)
+"""
+
+
+def test_rsnu001_multiple_outputs(dashr):
+    dashr.start_server(app)
+    dashr.find_element("#data-dropdown").click()
+    dashr.find_elements("div.VirtualizedSelectOption")[1].click()
+    dashr.wait_for_text_to_equal(
+        "#text-box",
+        "You have chosen series."
+    )
+    backgroundColor = dashr.find_element('#container').value_of_css_property("background-color")
+    assert backgroundColor == "rgba(255, 153, 138, 1)"
+    dashr.find_element("#data-dropdown").click()
+    dashr.find_elements("div.VirtualizedSelectOption")[0].click()
+    dashr.wait_for_text_to_equal(
+        "#text-box",
+        "You have chosen movies."
+    )
+    backgroundColor = dashr.find_element('#container').value_of_css_property("background-color")
+    assert backgroundColor == "rgba(255, 242, 137, 1)"
+    dashr.find_elements("input[type='radio']")[1].click()
+    dashr.find_element("#data-dropdown").click()
+    dashr.find_elements("div.VirtualizedSelectOption")[1].click()
+    dashr.wait_for_text_to_equal(
+        "#text-box",
+        "You have chosen series."
+    )
+    assert backgroundColor == "rgba(255, 242, 137, 1)"
+    dashr.find_elements("input[type='radio']")[0].click()
+    dashr.find_element("#data-dropdown").click()
+    dashr.find_elements("div.VirtualizedSelectOption")[0].click()
+    dashr.wait_for_text_to_equal(
+        "#text-box",
+        "You have chosen movies."
+    )
+    assert backgroundColor == "rgba(255, 242, 137, 1)"