From 2e097894d7c44e3473b54640c90f36a5986f0a4f Mon Sep 17 00:00:00 2001 From: Ryan Patrick Kyle Date: Tue, 1 Oct 2019 15:39:23 -0400 Subject: [PATCH] Implement support for clientside callbacks in Dash for R (#130) --- .circleci/config.yml | 5 +- NAMESPACE | 1 + R/dash.R | 237 ++++++++++-------- R/utils.R | 195 +++++++------- .../clientside/assets/clientside.js | 6 + .../integration/clientside/test_clientside.py | 73 ++++++ 6 files changed, 310 insertions(+), 207 deletions(-) create mode 100644 tests/integration/clientside/assets/clientside.js create mode 100644 tests/integration/clientside/test_clientside.py diff --git a/.circleci/config.yml b/.circleci/config.yml index 3928a8ed..0501af6f 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -22,11 +22,12 @@ jobs: echo "JOB PARALLELISM: ${CIRCLE_NODE_TOTAL}" echo "CIRCLE_REPOSITORY_URL: ${CIRCLE_REPOSITORY_URL}" echo $CIRCLE_JOB > circlejob.txt + git rev-parse HEAD | tr -d '\n' > commit.txt - run: name: 🚧 install R dependencies command: | - sudo Rscript -e 'install.packages("remotes"); remotes::install_github("plotly/dashR", dependencies=TRUE, upgrade=TRUE); install.packages(".", type="source", repos=NULL)' + sudo Rscript -e 'commit_hash <- readChar("commit.txt", file.info("commit.txt")$size); message("Preparing to install plotly/dashR ", commit_hash, " ..."); install.packages("remotes"); remotes::install_github("plotly/dashR", upgrade=TRUE, ref=commit_hash, force=TRUE)' - run: name: ⚙️ Integration tests @@ -36,7 +37,7 @@ jobs: git clone --depth 1 https://github.com/plotly/dash.git cd dash && pip install -e .[testing] --quiet && cd .. export PATH=$PATH:/home/circleci/.local/bin/ - pytest --cli-log-level DEBUG tests/integration/ + pytest tests/integration/ - run: name: 🔎 Unit tests diff --git a/NAMESPACE b/NAMESPACE index f600e6b9..717692bc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method(print,dash_component) export(Dash) export(dashNoUpdate) export(createCallbackId) +export(clientsideFunction) export(input) export(output) export(state) diff --git a/R/dash.R b/R/dash.R index 2724d0ae..6eba02d9 100644 --- a/R/dash.R +++ b/R/dash.R @@ -21,13 +21,13 @@ #' of the HTML page).\cr #' `server` \tab \tab The web server used to power the application. #' Must be a [fiery::Fire] object.\cr -#' `assets_folder` \tab \tab Character. A path, relative to the current working directory, -#' for extra files to be used in the browser. Default is "assets". All .js and +#' `assets_folder` \tab \tab Character. A path, relative to the current working directory, +#' for extra files to be used in the browser. Default is "assets". All .js and #' .css files will be loaded immediately unless excluded by `assets_ignore`, #' and other files such as images will be served if requested. Default is `assets`. \cr -#' `assets_url_path` \tab \tab Character. Specify the URL path for asset serving. Default is `assets`. \cr -#' `assets_ignore` \tab \tab Character. A regular expression, to match assets to omit from -#' immediate loading. Ignored files will still be served if specifically requested. You +#' `assets_url_path` \tab \tab Character. Specify the URL path for asset serving. Default is `assets`. \cr +#' `assets_ignore` \tab \tab Character. A regular expression, to match assets to omit from +#' immediate loading. Ignored files will still be served if specifically requested. You #' cannot use this to prevent access to sensitive files. \cr #' `serve_locally` \tab \tab Whether to serve HTML dependencies locally or #' remotely (via URL).\cr @@ -39,7 +39,7 @@ #' `external_stylesheets` \tab \tab An optional list of valid URLs from which #' to serve CSS for rendered pages.\cr #' `suppress_callback_exceptions` \tab \tab Whether to relay warnings about -#' possible layout mis-specifications when registering a callback. \cr +#' possible layout mis-specifications when registering a callback. \cr #' `components_cache_max_age` \tab \tab An integer value specifying the time #' interval prior to expiring cached assets. The default is 2678400 seconds, #' or 31 calendar days. @@ -76,15 +76,22 @@ #' \describe{ #' \item{output}{a named list including a component `id` and `property`} #' \item{params}{an unnamed list of [input] and [state] statements, each with defined `id` and `property`} -#' \item{func}{any valid R function which generates [output] provided [input] and/or [state] arguments} +#' \item{func}{any valid R function which generates [output] provided [input] and/or [state] arguments, or a call to [clientsideFunction] including `namespace` and `function_name` arguments for a locally served JavaScript function} #' } #' The `output` argument defines which layout component property should -#' receive the results (via the [output] object). The events that +#' receive the results (via the [output] object). The events that #' trigger the callback are then described by the [input] (and/or [state]) #' object(s) (which should reference layout components), which become -#' argument values for the callback handler defined in `func`. +#' argument values for R callback handlers defined in `func`. +#' +#' `func` may either be an anonymous R function, or a call to +#' `clientsideFunction()`, which describes a locally served JavaScript +#' function instead. The latter defines a "clientside callback", which +#' updates components without passing data to and from the Dash backend. +#' The latter may offer improved performance relative to callbacks written +#' in R. #' } -#' \item{`run_server(host = Sys.getenv('DASH_HOST', "127.0.0.1"), +#' \item{`run_server(host = Sys.getenv('DASH_HOST', "127.0.0.1"), #' port = Sys.getenv('DASH_PORT', 8050), block = TRUE, showcase = FALSE, ...)`}{ #' Launch the application. If provided, `host`/`port` set #' the `host`/`port` fields of the underlying [fiery::Fire] web @@ -166,7 +173,7 @@ Dash <- R6::R6Class( router <- routr::RouteStack$new() # ensure that assets_folder is neither NULL nor character(0) - if (!(is.null(private$assets_folder)) & length(private$assets_folder) != 0) { + if (!(is.null(private$assets_folder)) & length(private$assets_folder) != 0) { if (!(dir.exists(private$assets_folder)) && gsub("/+", "", assets_folder) != "assets") { warning(sprintf( "The supplied assets folder, '%s', could not be found in the project directory.", @@ -180,7 +187,7 @@ Dash <- R6::R6Class( private$other <- private$asset_map$other } } - + # ------------------------------------------------------------------------ # Set a sensible default logger # ------------------------------------------------------------------------ @@ -198,7 +205,7 @@ Dash <- R6::R6Class( 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 + # components which include Plotly.js figures for which we'll need to # run plotly_build from the plotly package lay <- encode_plotly(rendered_layout) response$body <- to_JSON(lay, pretty = TRUE) @@ -221,7 +228,8 @@ Dash <- R6::R6Class( list( inputs=callback_signature$inputs, output=createCallbackId(callback_signature$output), - state=callback_signature$state + state=callback_signature$state, + clientside_function=callback_signature$clientside_function ) }, private$callback_map) @@ -288,7 +296,7 @@ Dash <- R6::R6Class( # reset callback context private$callback_context_ <- NULL - + # 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") { @@ -297,38 +305,38 @@ Dash <- R6::R6Class( } 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 + # 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) - + # 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 @@ -340,7 +348,7 @@ Dash <- R6::R6Class( ) ) } - + response$body <- to_JSON(resp) response$status <- 200L response$type <- 'json' @@ -364,8 +372,8 @@ Dash <- R6::R6Class( # https://github.com/plotly/dash/blob/1249ffbd051bfb5fdbe439612cbec7fa8fff5ab5/dash/dash.py#L488 # https://docs.python.org/3/library/pkgutil.html#pkgutil.get_data dash_suite <- paste0(self$config$routes_pathname_prefix, "_dash-component-suites/:package_name/:filename") - - route$add_handler("get", dash_suite, function(request, response, keys, ...) { + + route$add_handler("get", dash_suite, function(request, response, keys, ...) { filename <- basename(file.path(keys$filename)) dep_list <- c(private$dependencies_internal, private$dependencies, @@ -380,16 +388,16 @@ Dash <- R6::R6Class( # return warning if a dependency goes unmatched, since the page # will probably fail to render properly anyway without it if (length(dep_pkg$rpkg_path) == 0) { - warning(sprintf("The dependency '%s' could not be loaded; the file was not found.", - filename), + warning(sprintf("The dependency '%s' could not be loaded; the file was not found.", + filename), call. = FALSE) - + response$body <- NULL response$status <- 404L } else { dep_path <- system.file(dep_pkg$rpkg_path, package = dep_pkg$rpkg_name) - + response$body <- readLines(dep_path, warn = FALSE, encoding = "UTF-8") @@ -408,11 +416,11 @@ Dash <- R6::R6Class( # ensure slashes are not doubled dash_assets <- sub("//", "/", dash_assets) - + route$add_handler("get", dash_assets, function(request, response, keys, ...) { # unfortunately, keys do not exist for wildcard headers in routr -- URL must be parsed # e.g. for "http://127.0.0.1:8050/assets/stylesheet.css?m=1552591104" - # + # # the following regex pattern will return "/stylesheet.css": assets_pattern <- paste0("(?<=", gsub("/", @@ -420,23 +428,23 @@ Dash <- R6::R6Class( private$assets_url_path), ")([^?])+" ) - + # now, identify vector positions for asset string matching pattern above asset_match <- gregexpr(pattern = assets_pattern, request$url, perl=TRUE) # use regmatches to retrieve only the substring following assets_url_path asset_to_match <- unlist(regmatches(request$url, asset_match)) - + # now that we've parsed the URL, attempt to match the subpath in the map, # then return the local absolute path to the asset asset_path <- get_asset_path(private$asset_map, asset_to_match) - + # the following codeblock attempts to determine whether the requested # content exists, if the data should be encoded as plain text or binary, # and opens/closes a file handle if the type is assumed to be binary if (!(is.null(asset_path)) && file.exists(asset_path)) { - response$type <- request$headers[["Content-Type"]] %||% - mime::guess_type(asset_to_match, + response$type <- request$headers[["Content-Type"]] %||% + mime::guess_type(asset_to_match, empty = "application/octet-stream") if (grepl("text|javascript", response$type)) { @@ -444,13 +452,13 @@ Dash <- R6::R6Class( warn = FALSE, encoding = "UTF-8") } else { - file_handle <- file(asset_path, "rb") + file_handle <- file(asset_path, "rb") response$body <- readBin(file_handle, raw(), file.size(asset_path)) close(file_handle) } - + response$set_header('Cache-Control', sprintf('public, max-age=%s', components_cache_max_age) @@ -459,19 +467,19 @@ Dash <- R6::R6Class( } TRUE }) - + dash_favicon <- paste0(self$config$routes_pathname_prefix, "_favicon.ico") - + route$add_handler("get", dash_favicon, function(request, response, keys, ...) { asset_path <- get_asset_path(private$asset_map, "/favicon.ico") - + file_handle <- file(asset_path, "rb") response$body <- readBin(file_handle, raw(), file.size(asset_path)) close(file_handle) - + response$set_header('Cache-Control', sprintf('public, max-age=%s', components_cache_max_age) @@ -480,7 +488,7 @@ Dash <- R6::R6Class( response$status <- 200L TRUE }) - + # Add a 'catchall' handler to redirect other requests to the index dash_catchall <- paste0(self$config$routes_pathname_prefix, "*") route$add_handler('get', dash_catchall, function(request, response, keys, ...) { @@ -534,41 +542,48 @@ 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))] - + + if (is.function(func)) { + clientside_function <- NULL + } else { + clientside_function <- func + func <- NULL + } + # register the callback_map private$callback_map <- insertIntoCallbackMap(private$callback_map, inputs, output, state, - func) - + func, + clientside_function) }, # ------------------------------------------------------------------------ # request and return callback context - # ------------------------------------------------------------------------ + # ------------------------------------------------------------------------ callback_context = function() { if (is.null(private$callback_context_)) { warning("callback_context is undefined; callback_context may only be accessed within a callback.") - } + } private$callback_context_ }, - + # ------------------------------------------------------------------------ # convenient fiery wrappers # ------------------------------------------------------------------------ - run_server = function(host = Sys.getenv('DASH_HOST', "127.0.0.1"), - port = Sys.getenv('DASH_PORT', 8050), - block = TRUE, - showcase = FALSE, - dev_tools_prune_errors = TRUE, - debug = FALSE, + run_server = function(host = Sys.getenv('DASH_HOST', "127.0.0.1"), + port = Sys.getenv('DASH_PORT', 8050), + block = TRUE, + showcase = FALSE, + dev_tools_prune_errors = TRUE, + debug = FALSE, dev_tools_ui = NULL, dev_tools_props_check = NULL, ...) { self$server$host <- host self$server$port <- as.numeric(port) - + if (is.null(dev_tools_ui) && debug || isTRUE(dev_tools_ui)) { self$config$ui <- TRUE } else { @@ -583,7 +598,7 @@ Dash <- R6::R6Class( private$prune_errors <- dev_tools_prune_errors private$debug <- debug - + self$server$ignite(block = block, showcase = showcase, ...) } ), @@ -592,7 +607,7 @@ Dash <- R6::R6Class( # private fields defined on initiation name = NULL, serve_locally = NULL, - assets_folder = NULL, + assets_folder = NULL, assets_url_path = NULL, assets_ignore = NULL, routes_pathname_prefix = NULL, @@ -602,15 +617,15 @@ Dash <- R6::R6Class( css = NULL, scripts = NULL, other = NULL, - + # initialize flags for debug mode and stack pruning, debug = NULL, prune_errors = NULL, stack_message = NULL, # callback context - callback_context_ = NULL, - + callback_context_ = NULL, + # fields for tracking HTML dependencies dependencies = list(), dependencies_user = list(), @@ -660,7 +675,7 @@ Dash <- R6::R6Class( # load package-level HTML dependencies from attached pkgs metadataFns <- lapply(.packages(), getDashMetadata) metadataFns <- metadataFns[lengths(metadataFns) != 0] - + deps_layout <- lapply(metadataFns, function(dep) { # the objective is to identify JS dependencies # without requiring that a proprietary R format @@ -706,18 +721,18 @@ Dash <- R6::R6Class( walk_assets_directory = function(assets_dir = private$assets_folder) { # obtain the full canonical path asset_path <- normalizePath(file.path(assets_dir)) - + # remove multiple slashes if present asset_path <- gsub("//+", "/", asset_path) - + # collect all the file paths to all files in assets, walk # directory tree recursively files <- list.files(path = asset_path, full.names = TRUE, recursive = TRUE) - + # if the user supplies an assets_ignore filter regex, use this # to filter the file map to exclude anything that matches if (private$assets_ignore != "") { @@ -725,7 +740,7 @@ Dash <- R6::R6Class( files, perl = TRUE)] } - + # regex to match substring of absolute path # the following lines escape out slashes, keeping subpath # but without private$assets_folder included @@ -735,17 +750,17 @@ Dash <- R6::R6Class( private$assets_folder), ")([^?])+" ) - + # if file extension is .css, add to stylesheets sheet_paths <- files[tools::file_ext(files) == "css"] - + # if file extension is .js, add to scripts script_paths <- files[tools::file_ext(files) == "js"] - + # file_paths includes all assets that are neither CSS nor JS # this is to avoid duplicate entries in the map when flattened file_paths <- files[!(tools::file_ext(files) %in% c("css", "js"))] - + # for CSS, JavaScript, and everything to be served in assets, construct # a map -- a list of three character string vectors, in which the elements # are absolute (local system) paths to the assets being served, and the @@ -762,7 +777,7 @@ Dash <- R6::R6Class( } else { css_map <- NULL } - + if (length(script_paths)) { # first, sort the filenames alphanumerically script_paths <- script_paths[order(basename(script_paths))] @@ -775,7 +790,7 @@ Dash <- R6::R6Class( } else { scripts_map <- NULL } - + if (length(file_paths)) { # first, sort the filenames alphanumerically file_paths <- file_paths[order(basename(file_paths))] @@ -788,9 +803,9 @@ Dash <- R6::R6Class( } else { other_files_map <- NULL } - - return(list(css = css_map, - scripts = scripts_map, + + return(list(css = css_map, + scripts = scripts_map, other = other_files_map)) }, @@ -819,12 +834,12 @@ Dash <- R6::R6Class( # 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, - + collect_resources = function() { # Dash's own dependencies # serve the dev version of dash-renderer when in debug mode dependencies_all_internal <- .dash_js_metadata() - + if (private$debug) { depsSubset <- dependencies_all_internal[!names(dependencies_all_internal) %in% c("dash-renderer-prod", "dash-renderer-map-prod", @@ -834,9 +849,9 @@ Dash <- R6::R6Class( "dash-renderer-map-dev", "prop-types-dev")] } - + private$dependencies_internal <- depsSubset - + # collect and resolve package dependencies depsAll <- compact(c( private$react_deps()[private$react_versions() %in% private$react_version_enabled()], @@ -845,24 +860,24 @@ Dash <- R6::R6Class( private$dependencies_user, private$dependencies_internal[grepl(pattern = "dash-renderer", x = private$dependencies_internal)] )) - + # normalizes local paths and keeps newer versions of duplicates - depsAll <- depsAll[!vapply(depsAll, + depsAll <- depsAll[!vapply(depsAll, function(v) { !is.null(v[["script"]]) && tools::file_ext(v[["script"]]) == "map" }, logical(1))] - + # styleheets always go in header css_deps <- compact(lapply(depsAll, function(dep) { if (is.null(dep$stylesheet)) return(NULL) dep$script <- NULL dep })) - - css_deps <- render_dependencies(css_deps, - local = private$serve_locally, + + css_deps <- render_dependencies(css_deps, + local = private$serve_locally, prefix=self$config$requests_pathname_prefix) - + # scripts go after dash-renderer dependencies (i.e., React), # but before dash-renderer itself scripts_deps <- compact(lapply(depsAll, function(dep) { @@ -870,30 +885,30 @@ Dash <- R6::R6Class( dep$stylesheet <- NULL dep })) - + scripts_deps <- render_dependencies(scripts_deps, - local = private$serve_locally, + local = private$serve_locally, prefix=self$config$requests_pathname_prefix) - + # collect CSS assets from dependencies if (!(is.null(private$css))) { css_assets <- generate_css_dist_html(href = paste0(private$assets_url_path, names(private$css)), local = TRUE, local_path = private$css, prefix = self$config$requests_pathname_prefix) - } + } else { css_assets <- NULL } - + # collect CSS assets from external_stylesheets - css_external <- vapply(self$config$external_stylesheets, - generate_css_dist_html, + css_external <- vapply(self$config$external_stylesheets, + generate_css_dist_html, FUN.VALUE=character(1), - local = FALSE) - + local = FALSE) + # collect JS assets from dependencies - # + # if (!(is.null(private$scripts))) { scripts_assets <- generate_js_dist_html(href = paste0(private$assets_url_path, names(private$scripts)), local = TRUE, @@ -905,9 +920,9 @@ Dash <- R6::R6Class( # collect JS assets from external_scripts scripts_external <- vapply(self$config$external_scripts, - generate_js_dist_html, + generate_js_dist_html, FUN.VALUE=character(1)) - + # create tag for favicon, if present # other_files_map[names(other_files_map) %in% "/favicon.ico"] if ("/favicon.ico" %in% names(private$other)) { @@ -918,40 +933,40 @@ Dash <- R6::R6Class( # set script tag to invoke a new dash_renderer scripts_invoke_renderer <- sprintf("", - "_dash-renderer", - "application/javascript", + "_dash-renderer", + "application/javascript", "var renderer = new DashRenderer();") - + # serving order of CSS and JS tags: package -> external -> assets css_tags <- paste(c(css_deps, css_external, css_assets), collapse = "\n") - + scripts_tags <- paste(c(scripts_deps, scripts_external, scripts_assets, scripts_invoke_renderer), collapse = "\n") - - return(list(css_tags = css_tags, + + return(list(css_tags = css_tags, scripts_tags = scripts_tags, favicon = favicon)) }, - + index = function() { # generate tags for all assets all_tags <- private$collect_resources() - + # retrieve favicon tag for serving in the index favicon <- all_tags[["favicon"]] - + # retrieve CSS tags for serving in the index css_tags <- all_tags[["css_tags"]] - + # retrieve script tags for serving in the index scripts_tags <- all_tags[["scripts_tags"]] - + private$.index <- sprintf( ' diff --git a/R/utils.R b/R/utils.R index 92d6e261..c69816aa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -135,14 +135,14 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) { } else { "file" } - + # According to Dash convention, label react and react-dom as originating # in dash_renderer package, even though all three are currently served # up from the DashR package if (dep$name %in% c("react", "react-dom", "prop-types")) { dep$name <- "dash-renderer" } - + # The following lines inject _dash-component-suites into the src tags, # as this is the current Dash convention. The dependency paths cannot # be set solely at component library generation time, since hosted @@ -156,13 +156,13 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) { # parameter for cache busting if (!is.null(dep$package)) { if(!(is.null(dep$script))) { - filename <- dep$script + filename <- dep$script } else { filename <- dep$stylesheet } - + dep_path <- paste(dep$src$file, filename, sep="/") - + # the gsub line is to remove stray duplicate slashes, to # permit exact string matching on pathnames dep_path <- gsub("//+", @@ -173,25 +173,25 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) { package = dep$package) if (!file.exists(full_path)) { - warning(sprintf("The dependency path '%s' within the '%s' package is invalid; cannot find '%s'.", + warning(sprintf("The dependency path '%s' within the '%s' package is invalid; cannot find '%s'.", full_path, dep$package, filename), call. = FALSE) } - + modified <- as.integer(file.mtime(full_path)) } else { modified <- as.integer(Sys.time()) } - + # we don't want to serve the JavaScript source maps here, # until we are able to provide full support for debug mode, # as in Dash for Python if ("script" %in% names(dep) && tools::file_ext(dep[["script"]]) != "map") { if (!(is_local) & !(is.null(dep$src$href))) { html <- generate_js_dist_html(href = dep$src$href) - + } else { dep[["script"]] <- paste0(path_prefix, "_dash-component-suites/", @@ -202,12 +202,12 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) { dep$version, "&m=", modified) - + html <- generate_js_dist_html(href = dep[["script"]], as_is = TRUE) } } else if (!(is_local) & "stylesheet" %in% names(dep) & src == "href") { html <- generate_css_dist_html(href = paste(dep[["src"]][["href"]], - dep[["stylesheet"]], + dep[["stylesheet"]], sep="/"), local = FALSE) } else if ("stylesheet" %in% names(dep) & src == "file") { @@ -216,21 +216,21 @@ render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) { dep$name, "/", basename(dep[["stylesheet"]])) - + if (!(is.null(dep$version))) { if(!is.null(dep$package)) { sheetpath <- paste0(dep[["stylesheet"]], "?v=", dep$version) - + html <- generate_css_dist_html(href = sheetpath, as_is = TRUE) } else { sheetpath <- paste0(dep[["src"]][["file"]], dep[["stylesheet"]], "?v=", dep$version) - - html <- generate_css_dist_html(href = sheetpath, as_is = TRUE) + + html <- generate_css_dist_html(href = sheetpath, as_is = TRUE) } } else { @@ -324,7 +324,7 @@ assert_no_names <- function (x) # 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 -# insufficient information to do so. +# insufficient information to do so. # # this attempts to avoid cryptic errors produced by # get_package_mapping, which requires three parameters: @@ -348,24 +348,25 @@ clean_dependencies <- function(deps) { } ) deps_with_file <- dep_list[!vapply(dep_list, is.null, logical(1))] - + return(deps_with_file) } -insertIntoCallbackMap <- function(map, inputs, output, state, func) { +insertIntoCallbackMap <- function(map, inputs, output, state, func, clientside_function) { map[[createCallbackId(output)]] <- list(inputs=inputs, output=output, state=state, - func=func + func=func, + clientside_function=clientside_function ) 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) + stop(sprintf("One or more outputs are duplicated across callbacks. Please ensure that all ID and property combinations are unique."), call. = FALSE) } } return(map) @@ -378,12 +379,12 @@ assert_valid_callbacks <- function(output, params, func) { 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) + 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) @@ -393,44 +394,46 @@ assert_valid_callbacks <- function(output, params, func) { if (!(valid_seq(params))) { stop(sprintf("Strict ordering of callback handler parameters is required. Please ensure that input parameters precede all state parameters."), call. = FALSE) } - + # Assert that the component ID as passed is a string. # 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) + if (!(all(names(func) == c("namespace", "function_name")))) { + stop(sprintf("The callback method's 'func' parameter requires an R function or clientsideFunction call as its argument. Please verify that 'func' is either a valid R function or clientsideFunction."), call. = FALSE) + } } - + # Check if inputs are a nested list if(!(any(sapply(inputs, is.list)))) { stop(sprintf("Callback inputs should be a nested list, in which each element of the sublist represents a component ID and its properties."), call. = FALSE) } - + # Check if state is a nested list, if the list is not empty if(!(length(state) == 0) & !(any(sapply(state, is.list)))) { stop(sprintf("Callback states should be a nested list, in which each element of the sublist represents a component ID and its properties."), call. = FALSE) } - + # Check that input is not NULL if(is.null(inputs)) { stop(sprintf("The callback method requires that one or more properly formatted inputs are passed."), call. = FALSE) } - + # Check that outputs are not inputs # https://github.com/plotly/dash/issues/323 @@ -443,17 +446,17 @@ assert_valid_callbacks <- function(output, params, func) { 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) } - + # TO DO: check that components contain props TRUE } @@ -464,9 +467,9 @@ valid_seq <- function(params) { class_attr <- vapply(params, function(x) { attr(x, "class")[attr(x, "class") %in% c('input', 'state')] }, FUN.VALUE=character(1)) - + rle_result <- rle(class_attr)$values - + if (identical(rle_result, 'input')) { return(TRUE) } else if (identical(rle_result, c('input', 'state'))) { @@ -479,7 +482,7 @@ valid_seq <- function(params) { resolve_prefix <- function(prefix, environment_var) { if (!(is.null(prefix))) { assertthat::assert_that(is.character(prefix)) - + return(prefix) } else { prefix_env <- Sys.getenv(environment_var) @@ -497,7 +500,7 @@ resolve_prefix <- function(prefix, environment_var) { # optionally returns an R package name (if the file is contained # inside an R package), or NULL if the dependency is not found, # and a (local) path to the dependency. -# +# # script_name is e.g. "dash_core_components.min.js" # url_package is e.g. "dash_core_components" # dependencies = list of htmlDependency objects @@ -511,14 +514,14 @@ get_package_mapping <- function(script_name, url_package, dependencies) { if (x$name %in% c('react', 'react-dom', 'prop-types')) { x$name <- 'dash-renderer' } - + if (!is.null(x$script)) dep_path <- file.path(x$src$file, x$script) else if (!is.null(x$stylesheet)) dep_path <- file.path(x$src$file, x$stylesheet) - + # remove n>1 slashes and replace with / if present; - # htmltools seems to permit // in pathnames, but + # htmltools seems to permit // in pathnames, but # this complicates string matching unless they're # removed from the pathname result <- c(pkg_name=ifelse("package" %in% names(x), x$package, NULL), @@ -526,26 +529,26 @@ get_package_mapping <- function(script_name, url_package, dependencies) { dep_path=gsub("//+", replacement = "/", dep_path) ) }, FUN.VALUE = character(3)) - + package_map <- t(package_map) - + # pos_match is a vector of logical() values -- this allows filtering # of the package_map entries based on name, path, and matching of # URL package name against R package names. when all conditions are # satisfied, pos_match will return TRUE pos_match <- grepl(paste0(script_name, "$"), package_map[, "dep_path"]) & grepl(url_package, package_map[,"dep_name"]) - + rpkg_name <- package_map[,"pkg_name"][pos_match] rpkg_path <- package_map[,"dep_path"][pos_match] - + return(list(rpkg_name=rpkg_name, rpkg_path=rpkg_path)) } get_mimetype <- function(filename) { # the tools package is available to all filename_ext <- file_ext(filename) - + if (filename_ext == 'js') return('application/JavaScript') else if (filename_ext == 'css') @@ -556,14 +559,14 @@ get_mimetype <- function(filename) { return(NULL) } -generate_css_dist_html <- function(href, - local = FALSE, +generate_css_dist_html <- function(href, + local = FALSE, local_path = NULL, prefix = NULL, as_is = FALSE) { if (!(local)) { - if (grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", - href, + if (grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", + href, perl=TRUE) || as_is) { sprintf("", href) } @@ -573,21 +576,21 @@ generate_css_dist_html <- function(href, # strip leading slash from href if present href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) - sprintf("", - prefix, - href, + sprintf("", + prefix, + href, modified) } -} +} -generate_js_dist_html <- function(href, +generate_js_dist_html <- function(href, local = FALSE, local_path = NULL, prefix = NULL, as_is = FALSE) { if (!(local)) { - if (grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", - href, + if (grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", + href, perl=TRUE) || as_is) { sprintf("", href) } @@ -598,11 +601,11 @@ generate_js_dist_html <- function(href, href <- sub("^/", "", href) modified <- as.integer(file.mtime(local_path)) sprintf("", - prefix, - href, + prefix, + href, modified) } -} +} # This function takes the list object containing asset paths # for all stylesheets and scripts, as well as the URL path @@ -615,7 +618,7 @@ generate_js_dist_html <- function(href, # assets pathname (i.e. "assets/stylesheet.css"), and # $scripts, a list of character strings formatted # identically to $css, also named with subpaths. -# +# get_asset_path <- function(assets_map, asset_path) { unlist(setNames(assets_map, NULL))[asset_path] } @@ -647,7 +650,7 @@ get_asset_url <- function(asset_path, prefix = "/") { # prepend the asset name with the route prefix return(paste(prefix, asset, sep="/")) } - + encode_plotly <- function(layout_objs) { if (is.list(layout_objs)) { if ("plotly" %in% class(layout_objs) && @@ -655,11 +658,11 @@ encode_plotly <- function(layout_objs) { any(c("visdat", "data") %in% names(layout_objs$x))) { # check to determine whether the current element is an # object output from the plot_ly or ggplotly function; - # if it is, we can safely assume that it contains no - # other plot_ly or ggplotly objects and return the updated + # if it is, we can safely assume that it contains no + # other plot_ly or ggplotly objects and return the updated # element as a mutated plotly figure argument that contains - # only data and layout attributes. we suppress messages - # since the plotly_build function will supply them, as it's + # only data and layout attributes. we suppress messages + # since the plotly_build function will supply them, as it's # typically run interactively. obj <- suppressMessages(plotly::plotly_build(layout_objs)$x) layout_objs <- obj[c("data", "layout")] @@ -698,14 +701,14 @@ printCallStack <- function(call_stack, header=TRUE) { ) } -stackTraceToHTML <- function(call_stack, - throwing_call, +stackTraceToHTML <- function(call_stack, + throwing_call, error_message) { if(is.null(call_stack)) { return(NULL) } header <- " ### DashR Traceback (most recent/innermost call last) ###" - + formattedStack <- c(paste0( " ", seq_along( @@ -715,7 +718,7 @@ stackTraceToHTML <- function(call_stack, call_stack, collapse="
" ) - ) + ) template <- "
%s

Error: %s: %s
%s
" response <- sprintf(template, @@ -745,7 +748,7 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) { calls <- sys.calls() reverseStack <- rev(calls) attr(e, "stack.trace") <- calls - + if (!is.null(e$call[[1]])) errorCall <- e$call[[1]] else { @@ -756,21 +759,21 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) { # getStackTrace, so we select the second match instead errorCall <- reverseStack[grepl(x=reverseStack, "simpleError|simpleWarning")][[2]] } - + functionsAsList <- lapply(calls, function(completeCall) { currentCall <- completeCall[[1]] - + if (is.function(currentCall) & !is.primitive(currentCall)) { - constructedCall <- paste0(" function(", + constructedCall <- paste0(" function(", paste(names(formals(currentCall)), collapse = ", "), ")") return(constructedCall) } else { return(currentCall) } - + }) - + if (prune_errors) { # this line should match the last occurrence of the function # which raised the error within the call stack; prune here @@ -804,25 +807,25 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) { # between the total number of calls and the index of the # call throwing the error stopIndex <- length(calls) - indexFromLast + 1 - + startIndex <- match(TRUE, lapply(functionsAsList, function(fn) fn == "getStackTrace")) functionsAsList <- functionsAsList[startIndex:stopIndex] functionsAsList <- removeHandlers(functionsAsList) } - + # use deparse in case the call throwing the error is a symbol, # since this cannot be "printed" without deparsing the call - warning(call. = FALSE, immediate. = TRUE, sprintf("Execution error in %s: %s", - deparse(functionsAsList[[length(functionsAsList)]]), + warning(call. = FALSE, immediate. = TRUE, sprintf("Execution error in %s: %s", + deparse(functionsAsList[[length(functionsAsList)]]), conditionMessage(e))) - + stack_message <- stackTraceToHTML(functionsAsList, deparse(functionsAsList[[length(functionsAsList)]]), conditionMessage(e)) - - assign("stack_message", value=stack_message, + + assign("stack_message", value=stack_message, envir=sys.frame(1)$private) - + printCallStack(functionsAsList) } } @@ -863,29 +866,29 @@ setCallbackContext <- function(callback_elements) { states <- lapply(callback_elements$states, function(x) { setNames(x$value, paste(x$id, x$property, sep=".")) }) - + splitIdProp <- function(x) unlist(strsplit(x, split = "[.]")) - - triggered <- lapply(callback_elements$changedPropIds, + + 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) } ) - + inputs <- sapply(callback_elements$inputs, function(x) { setNames(list(x$value), paste(x$id, x$property, sep=".")) }) - - return(list(states=states, - triggered=unlist(triggered, recursive=FALSE), + + return(list(states=states, + triggered=unlist(triggered, recursive=FALSE), inputs=inputs)) } @@ -916,3 +919,7 @@ getIdProps <- function(output) { props <- vapply(unlist(idprops, recursive=FALSE), '[', character(1), 2) return(list(ids=ids, props=props)) } + +clientsideFunction <- function(namespace, function_name) { + return(list(namespace=namespace, function_name=function_name)) +} diff --git a/tests/integration/clientside/assets/clientside.js b/tests/integration/clientside/assets/clientside.js new file mode 100644 index 00000000..a7517424 --- /dev/null +++ b/tests/integration/clientside/assets/clientside.js @@ -0,0 +1,6 @@ +if(!window.dash_clientside) {window.dash_clientside = {};} +window.dash_clientside.clientside = { + display: function (value) { + return 'Client says "' + value + '"'; + } +} diff --git a/tests/integration/clientside/test_clientside.py b/tests/integration/clientside/test_clientside.py new file mode 100644 index 00000000..e2066b6e --- /dev/null +++ b/tests/integration/clientside/test_clientside.py @@ -0,0 +1,73 @@ +from selenium.webdriver.support.select import Select +import time, os + +app = """ +library(dash) +library(dashCoreComponents) +library(dashHtmlComponents) + +app <- Dash$new() + +app$layout(htmlDiv(list( + dccInput(id='input'), + htmlDiv(id='output-clientside'), + htmlDiv(id='output-serverside') + ) + ) +) + +app$callback( + output(id = "output-serverside", property = "children"), + params = list( + input(id = "input", property = "value") + ), + function(value) { + sprintf("Server says %s", value) + } +) + +app$callback( + output('output-clientside', 'children'), + params=list(input('input', 'value')), + clientsideFunction( + namespace = 'clientside', + function_name = 'display' + ) +) + +app$run_server() +""" + + +def test_rscc001_clientside(dashr): + os.chdir(os.path.dirname(__file__)) + dashr.start_server(app) + dashr.wait_for_text_to_equal( + '#output-clientside', + 'Client says "undefined"' + ) + dashr.wait_for_text_to_equal( + "#output-serverside", + "Server says NULL" + ) + input1 = dashr.find_element("#input") + dashr.clear_input(input1) + input1.send_keys("Clientside") + dashr.wait_for_text_to_equal( + '#output-clientside', + 'Client says "Clientside"' + ) + dashr.wait_for_text_to_equal( + "#output-serverside", + "Server says Clientside" + ) + dashr.clear_input(input1) + input1.send_keys("Callbacks") + dashr.wait_for_text_to_equal( + '#output-clientside', + 'Client says "Callbacks"' + ) + dashr.wait_for_text_to_equal( + "#output-serverside", + "Server says Callbacks" + )