Merge pull request #51 from plotly/0.0.2-issue11984

Refactor DashR callbacks for increased parity with Dash for Python API

Author: rpkyle

DESCRIPTION

@@ -1,10 +1,10 @@
 Package: dashR
 Title: An interface to the dash ecosystem for authoring reactive web applications
-Version: 0.0.1
+Version: 0.0.2
 Authors@R: c(person("Ryan", "Kyle", role = c("aut", "cre"), email = "[email protected]"), person("Carson", "Sievert", role = c("aut")))
 Description: An interface to the dash ecosystem for authoring reactive web applications.
 Depends:
-  R (>= 3.5)
+  R (>= 3.4)
 Imports:
   R6,
   fiery (> 1.0.0),

NAMESPACE

@@ -3,7 +3,6 @@
 S3method(print,dash_component)
 export(Dash)
 export(dash_css)
-export(event)
 export(heroku_app_deploy)
 export(heroku_app_template)
 export(input)

R/dash.R

@@ -180,6 +180,7 @@ Dash <- R6::R6Class(
 
       dash_index <- routes_pathname_prefix
       route$add_handler("get", dash_index, function(request, response, keys, ...) {
+
         response$body <- private$.index
         response$status <- 200L
         response$type <- 'html'
@@ -188,6 +189,7 @@ Dash <- R6::R6Class(
 
       dash_layout <- paste0(routes_pathname_prefix, "_dash-layout")
       route$add_handler("get", dash_layout, function(request, response, keys, ...) {
+
         lay <- private$layout_render()
         response$body <- to_JSON(lay, pretty = TRUE)
         response$status <- 200L
@@ -196,6 +198,7 @@ Dash <- R6::R6Class(
       })
 
       dash_deps <- paste0(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)
@@ -206,19 +209,13 @@ Dash <- R6::R6Class(
           return(FALSE)
         }
 
-        # client wants the mapping formatted this way -- https://github.com/plotly/dash/blob/d2ebc837/dash/dash.py#L367-L378
-        outputs <- strsplit(names(private$callback_map), "\\.")
-        payload <- Map(function(x, y) {
-          # IMPORTANT: if state/events don't exist, dash-renderer wants them
-          # to be an empty array (i.e., null/missing won't work)
+        payload <- Map(function(callback_signature) {
           list(
-            output = list(id = y[[1]], property = y[[2]]),
-            inputs = setNames(callback_inputs(x), NULL),
-            state = setNames(callback_states(x), NULL),
-            # Chris mentioned that events might/should be deprecated
-            events = setNames(callback_events(x), NULL)
+            output=callback_signature$output,
+            inputs=callback_signature$inputs,
+            state=callback_signature$state
           )
-        }, private$callback_map, outputs)
+        }, private$callback_map)
 
         response$body <- to_JSON(setNames(payload, NULL))
         response$status <- 200L
@@ -228,7 +225,6 @@ Dash <- R6::R6Class(
 
       dash_update <- paste0(routes_pathname_prefix, "_dash-update-component")
       route$add_handler("post", dash_update, function(request, response, keys, ...) {
-
         request <- request_parse_json(request)
 
         if (!"output" %in% names(request$body)) {
@@ -240,41 +236,14 @@ Dash <- R6::R6Class(
 
         # get the callback associated with this particular output
         thisOutput <- with(request$body$output, paste(id, property, sep = "."))
-        callback <- private$callback_map[[thisOutput]]
+        callback <- private$callback_map[[thisOutput]][['func']]
         if (!length(callback)) stop_report("Couldn't find output component.")
         if (!is.function(callback)) {
           stop(sprintf("Couldn't find a callback function associated with '%s'", thisOutput))
         }
 
-        callback_args <- formals(callback)
-        if (length(callback_args)) {
-          get_key <- function(x) paste0(x[["id"]], ".", x[["property"]])
-          input_keys <- vapply(request$body$inputs, get_key, character(1))
-          state_keys <- vapply(request$body$states, get_key, character(1))
-
-          get_value <- function(x) getFromNamespace("simplify", "jsonlite")(x[["value"]])
-          input_values <- lapply(request$body$inputs, get_value)
-          state_values <- lapply(request$body$state, get_value)
-
-          client_values <- c(
-            setNames(input_values, input_keys),
-            setNames(state_values, state_keys)
-          )
-
-          get_dependency_key <- function(arg) {
-            val <- tryNULL(eval(arg))
-            if (is.dependency(val)) val[["key"]] else NA
-          }
-
-          callback_arg_keys <- sapply(callback_args, get_dependency_key)
-
-          # note that a modifyList() strategy throws away NULL args, which is WRONG
-          for (i in names(client_values)) {
-            callback_args[[match(i, callback_arg_keys)]] <- client_values[[i]]
-          }
-        }
-
-        output_value <- do.call(callback, args = as.list(callback_args))
+        callback_args <- lapply(c(request$body$inputs, request$body$state), `[[`, 3)
+        output_value <- do.call(callback, callback_args)
 
         # have to format the response body like this
         # https://github.com/plotly/dash/blob/064c811d/dash/dash.py#L562-L584
@@ -295,6 +264,7 @@ Dash <- R6::R6Class(
       # https://plotly.slack.com/archives/D07PDTRK6/p1507657249000714?thread_ts=1505157408.000123&cid=D07PDTRK6
       dash_suite <- paste0(routes_pathname_prefix, "_dash-component-suites")
       route$add_handler("get", dash_suite, function(request, response, keys, ...) {
+
         response$status <- 500L
         response$body <- "Not yet implemented"
         TRUE
@@ -320,6 +290,8 @@ Dash <- R6::R6Class(
     },
     layout_set = function(...) {
       private$layout <- if (is.function(..1)) ..1 else list(...)
+      # render the layout, and then return the rendered layout without printing
+      invisible(private$layout_render())
     },
 
     # ------------------------------------------------------------------------
@@ -366,55 +338,21 @@ Dash <- R6::R6Class(
     # ------------------------------------------------------------------------
     # callback registration
     # ------------------------------------------------------------------------
-    callback = function(func = NULL, output = NULL) {
-
-      # argument type checking
-      assertthat::assert_that(is.function(func))
-      assertthat::assert_that(is.output(output))
-
-      # TODO: cache layouts so we don't have to do this for every callback...
-      layout <- private$layout_render()
-      if (identical(layout, welcome_page())) {
-        stop("The layout must be set before defining any callbacks", call. = FALSE)
-      }
-
-      # -----------------------------------------------------------------------
-      # verify that output/input/state IDs provided exists in the layout
-      # -----------------------------------------------------------------------
-      callbackInputs <- callback_inputs(func)
-      callbackStates <- callback_states(func)
-
-      callback_ids <- unlist(c(
-        output$id,
-        sapply(callbackInputs, "[[", "id"),
-        sapply(callbackStates, "[[", "id")
-      ))
-      illegal_ids <- setdiff(callback_ids, private$layout_ids)
-      if (length(illegal_ids) && !private$suppress_callback_exceptions) {
-        warning(
-          sprintf(
-            "The following id(s) do not match any in the layout: '%s'",
-            paste(illegal_ids, collapse = "', '")
-          ),
-          call. = FALSE
+    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))]
+
+      # register the callback_map
+      private$callback_map[[paste(output$id, output$property, sep='.')]] <- list(
+          output=output,
+          inputs=inputs,
+          state=state,
+          func=func
         )
-      }
-
-      # ----------------------------------------------------------------------
-      # verify that properties attached to output/inputs/state value are valid
-      # ----------------------------------------------------------------------
-      if (!private$suppress_callback_exceptions) {
-        validate_dependency(layout, output)
-        lapply(callbackInputs, function(i) validate_dependency(layout, i))
-        lapply(callbackStates, function(s) validate_dependency(layout, s))
-      }
-
-      # store the callback mapping/function so we may access it later
-      # https://github.com/plotly/dash/blob/d2ebc837/dash/dash.py#L530-L546
-      private$callback_map[[output[["key"]]]] <- func
     },
 
-
     # ------------------------------------------------------------------------
     # convenient fiery wrappers
     # ------------------------------------------------------------------------
@@ -443,7 +381,7 @@ Dash <- R6::R6Class(
     dependencies = list(),
     dependencies_user = list(),
     dependencies_internal = list(),
-    
+
     # layout stuff
     layout = welcome_page(),
     layout_ids = NULL,
@@ -505,27 +443,27 @@ Dash <- R6::R6Class(
         # construct function name based on package name
         fn_name <- paste0(".", pkg, "_js_metadata")
         fn_summary <- getAnywhere(fn_name)
-        
+
         # ensure that the object refers to a function,
         # and we are able to locate it somewhere
         if (length(fn_summary$where) == 0) return(NULL)
-        
+
         if (mode(fn_summary$obj[[1]]) == "function") {
           # function is available
           dep_list <- do.call(fn_summary$obj[[1]], list())
 
           return(dep_list)
         } else {
-          return(NULL)  
+          return(NULL)
         }
       })
-      
+
       deps_layout <- unlist(deps_layout, recursive=FALSE)
 
       # add on HTML dependencies we've identified by crawling the layout
       private$dependencies <- c(private$dependencies, deps_layout)
 
-      # DashR's own dependencies      
+      # DashR's own dependencies
       private$dependencies_internal <- dashR:::.dashR_js_metadata()
 
       # return the computed layout
@@ -572,6 +510,7 @@ Dash <- R6::R6Class(
     # akin to https://github.com/plotly/dash-renderer/blob/master/dash_renderer/__init__.py
     react_version_enabled= function() {
       version <- private$dependencies_internal$react$version
+      return(version)
       },
     react_deps = function() {
       deps <- private$dependencies_internal
@@ -580,11 +519,13 @@ Dash <- R6::R6Class(
     react_versions = function() {
       vapply(private$react_deps(), "[[", character(1), "version")
       },
-    
+
     # akin to https://github.com/plotly/dash/blob/d2ebc837/dash/dash.py#L338
     # note discussion here https://github.com/plotly/dash/blob/d2ebc837/dash/dash.py#L279-L284
     .index = NULL,
     index = function() {
+
+
       # collect and resolve dependencies
       depsAll <- compact(c(
         private$react_deps()[private$react_versions() %in% private$react_version_enabled()],
@@ -643,9 +584,6 @@ Dash <- R6::R6Class(
   )
 )
 
-
-
-
 # verify that properties attached to output/inputs/state value are valid
 # @param layout
 # @param component a component (should be a dependency)
@@ -669,16 +607,16 @@ validate_dependency <- function(layout, dependency) {
   TRUE
 }
 
-assert_valid_wildcards <- function (...) 
+assert_valid_wildcards <- function (...)
 {
   args <- list(...)
   validation_results <- lapply(args, function(x) {
     grepl(c('^data-[a-zA-Z0-9]{1,}$|^aria-[a-zA-Z0-9]{1,}$'), x)
     }
   )
   if(FALSE %in% validation_results) {
-    stop(sprintf("The following wildcards are not currently valid in DashR: '%s'", 
-                 paste((args)[grepl(FALSE, unlist(validation_results))], 
+    stop(sprintf("The following wildcards are not currently valid in DashR: '%s'",
+                 paste((args)[grepl(FALSE, unlist(validation_results))],
                        collapse=", ")), call. = FALSE)
   } else {
     return(args)

R/dependencies.R

@@ -13,7 +13,7 @@
 
 #' @rdname dependencies
 #' @export
-output <- function(id = NULL, property = "children") {
+output <- function(id, property) {
   structure(
     dependency(id, property),
     class = c("dash_dependency", "output")
@@ -22,7 +22,7 @@ output <- function(id = NULL, property = "children") {
 
 #' @rdname dependencies
 #' @export
-input <- function(id = NULL, property = "value") {
+input <- function(id, property) {
   structure(
     dependency(id, property),
     class = c("dash_dependency", "input")
@@ -31,27 +31,17 @@ input <- function(id = NULL, property = "value") {
 
 #' @rdname dependencies
 #' @export
-state <- function(id = NULL, property = "value") {
+state <- function(id, property) {
   structure(
     dependency(id, property),
     class = c("dash_dependency", "state")
   )
 }
 
-#' @rdname dependencies
-#' @export
-event <- function(id = NULL, property = "value") {
-  structure(
-    dependency(id, property),
-    class = c("dash_dependency", "event")
-  )
-}
-
 dependency <- function(id = NULL, property = NULL) {
   if (is.null(id)) stop("Must specify an id", call. = FALSE)
   list(
     id = id,
-    property = property,
-    key = paste0(id, ".", property)
+    property = property
   )
 }

R/internal.R

@@ -48,11 +48,11 @@
                                                           all_files = FALSE), 
                                                      class = "html_dependency"), 
                         `dash-renderer` = structure(list(name = "dash-renderer", 
-                                                         version = "0.13.0", 
-                                                         src = list(href = "https://unpkg.com/dash-renderer@0.13.0",
-                                                                    file = "lib/dash-renderer@0.13.0"), 
+                                                         version = "0.18.0", 
+                                                         src = list(href = "https://unpkg.com/dash-renderer@0.18.0",
+                                                                    file = "lib/dash-renderer@0.18.0"), 
                                                          meta = NULL, 
-                                                         script = "dash_renderer/bundle.js", 
+                                                         script = "dash_renderer/dash_renderer.min.js", 
                                                          stylesheet = NULL, 
                                                          head = NULL, 
                                                          attachment = NULL,