From 742c6fc194558f8c7fe446236db9701155d08b0a Mon Sep 17 00:00:00 2001 From: Hammad Khan Date: Thu, 19 Aug 2021 11:36:36 -0400 Subject: [PATCH 01/15] Added add_meta helper --- NAMESPACE | 1 + R/dependencies.R | 13 ++++++++++++ R/utils.R | 55 ++++++++++++++++++++++++++++++++++++++---------- 3 files changed, 58 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c8e3960b..7eb98887 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ export(dashNoUpdate) export(input) export(output) export(state) +export(add_meta) importFrom(R6,R6Class) importFrom(assertthat,assert_that) importFrom(base64enc,base64encode) diff --git a/R/dependencies.R b/R/dependencies.R index 4e9767e6..bbaa6624 100644 --- a/R/dependencies.R +++ b/R/dependencies.R @@ -307,3 +307,16 @@ ALLSMALLER <- as.symbol("ALLSMALLER") #' @rdname selectors #' @export MATCH <- as.symbol("MATCH") + + +# Dash 2 Helper Functions + +#' @export +add_meta <- function(app, meta) { + assert_dash(app) + if (!is.list(meta[[1]])) { + meta <- list(meta) + } + app$.__enclos_env__$private$meta_tags <- c(app$.__enclos_env__$private$meta_tags, meta) + invisible(app) +} diff --git a/R/utils.R b/R/utils.R index 70892f35..af8703bf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -423,12 +423,12 @@ assert_valid_callbacks <- function(output, params, func) { 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) @@ -439,7 +439,7 @@ assert_valid_callbacks <- function(output, params, func) { }) } - + # Check that outputs are not inputs # https://github.com/plotly/dash/issues/323 @@ -675,7 +675,7 @@ assertValidExternals <- function(scripts, stylesheets) { "rev") script_attributes <- character() stylesheet_attributes <- character() - + for (item in scripts) { if (is.list(item)) { if (!"src" %in% names(item) || !(any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$", @@ -713,10 +713,10 @@ assertValidExternals <- function(scripts, stylesheets) { stylesheet_attributes <- c(stylesheet_attributes, character(0)) } } - + invalid_script_attributes <- setdiff(script_attributes, allowed_js_attribs) invalid_stylesheet_attributes <- setdiff(stylesheet_attributes, allowed_css_attribs) - + if (length(invalid_script_attributes) > 0 || length(invalid_stylesheet_attributes) > 0) { stop(sprintf("The following script or stylesheet attributes are invalid: %s.", paste0(c(invalid_script_attributes, invalid_stylesheet_attributes), collapse=", ")), call. = FALSE) @@ -1031,7 +1031,7 @@ removeHandlers <- function(fnList) { setCallbackContext <- function(callback_elements) { # 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=".")) @@ -1043,7 +1043,7 @@ setCallbackContext <- function(callback_elements) { } else { states <- sapply(callback_elements$state, function(x) { states_vector <- unlist(x) - setNames(list(states_vector[grepl("value|value.", names(states_vector))]), + setNames(list(states_vector[grepl("value|value.", names(states_vector))]), paste(as.character(jsonlite::toJSON(x[[1]])), x$property, sep=".")) }) } @@ -1055,7 +1055,7 @@ setCallbackContext <- function(callback_elements) { input_id <- splitIdProp(x)[1] prop <- splitIdProp(x)[2] - # The following conditionals check whether the callback is a pattern-matching callback and if it has been triggered. + # 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) @@ -1087,7 +1087,7 @@ setCallbackContext <- function(callback_elements) { } else { value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value") } - + return(list(`prop_id` = x, `value` = value)) } ) @@ -1536,3 +1536,36 @@ validate_keys <- function(string, is_template) { return(string) } } + +# Dash2 Helper Functions + +#' Is the given object a Dash app? +#' @param x Any object. +is_dash_app <- function(x) { + inherits(x, "Dash") +} + +assert_dash <- function(x) { + if (!is_dash_app(x)) { + stop("You must provide a Dash app object (created with `dash::Dash$new()` or `dash2::dash_app()`)", call. = FALSE) + } + invisible(TRUE) +} + +componentify <- function(x) { + if (asNamespace("dash")$is.component(x)) { + x + } else if (inherits(x, "shiny.tag") || inherits(x, "shiny.tag.list")) { + stop("dash2: layout cannot include Shiny tags (you might have loaded the {shiny} package after loading {dash2})", call. = FALSE) + } else if (is.list(x)) { + dash::htmlDiv(children = lapply(x, componentify)) + } else if (length(x) == 1) { + dash::htmlSpan(children = x) + } else { + stop("dash2: layout must be a dash component or list of dash components", call. = FALSE) + } +} + +remove_empty <- function(x) { + Filter(Negate(is.null), x) +} From 1c3286522894623ad86a0853d9e4bbd480f2f791 Mon Sep 17 00:00:00 2001 From: Hammad Khan Date: Thu, 19 Aug 2021 14:07:43 -0400 Subject: [PATCH 02/15] Add helper functions and export pipe --- DESCRIPTION | 3 +- NAMESPACE | 8 +- R/dependencies.R | 172 ++++++++++++++++++++++++++++++++++++++++++ R/utils-pipe.R | 14 ++++ man/add_meta.Rd | 29 +++++++ man/add_script.Rd | 51 +++++++++++++ man/add_stylesheet.Rd | 51 +++++++++++++ man/is_dash_app.Rd | 14 ++++ man/pipe.Rd | 20 +++++ man/run_app.Rd | 25 ++++++ man/set_layout.Rd | 28 +++++++ 11 files changed, 413 insertions(+), 2 deletions(-) create mode 100644 R/utils-pipe.R create mode 100644 man/add_meta.Rd create mode 100644 man/add_script.Rd create mode 100644 man/add_stylesheet.Rd create mode 100644 man/is_dash_app.Rd create mode 100644 man/pipe.Rd create mode 100644 man/run_app.Rd create mode 100644 man/set_layout.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 59171370..57f99bbd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,7 +19,8 @@ Imports: mime, crayon, brotli, - glue + glue, + magrittr Suggests: testthat License: MIT + file LICENSE diff --git a/NAMESPACE b/NAMESPACE index 7eb98887..e4c35577 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,16 +1,21 @@ # Generated by roxygen2: do not edit by hand S3method(print,dash_component) +export("%>%") export(ALL) export(ALLSMALLER) export(Dash) export(MATCH) +export(add_meta) +export(add_script) +export(add_stylesheet) export(clientsideFunction) export(dashNoUpdate) export(input) export(output) +export(run_app) +export(set_layout) export(state) -export(add_meta) importFrom(R6,R6Class) importFrom(assertthat,assert_that) importFrom(base64enc,base64encode) @@ -26,6 +31,7 @@ importFrom(htmltools,htmlDependencies) importFrom(htmltools,htmlDependency) importFrom(htmltools,renderDependencies) importFrom(jsonlite,toJSON) +importFrom(magrittr,"%>%") importFrom(reqres,default_parsers) importFrom(routr,Route) importFrom(routr,RouteStack) diff --git a/R/dependencies.R b/R/dependencies.R index bbaa6624..4a2b32f9 100644 --- a/R/dependencies.R +++ b/R/dependencies.R @@ -311,6 +311,22 @@ MATCH <- as.symbol("MATCH") # Dash 2 Helper Functions +#' Add `` tags to a Dash app +#' +#' @param app A dash application created with [`dash_app()`]. +#' @param meta A single meta tag or a list of meta tags. Each meta tag is a +#' named list with two elements representing a meta tag. See examples below. +#' @examples +#' app <- dash_app() +#' +#' # Add a single meta tag +#' app %>% add_meta(list(name = "description", content = "My App")) +#' +#' # Add multiple meta tags +#' app %>% add_meta(list( +#' list(name = "keywords", content = "dash, analysis, graphs"), +#' list(name = "viewport", content = "width=device-width, initial-scale=1.0") +#' )) #' @export add_meta <- function(app, meta) { assert_dash(app) @@ -320,3 +336,159 @@ add_meta <- function(app, meta) { app$.__enclos_env__$private$meta_tags <- c(app$.__enclos_env__$private$meta_tags, meta) invisible(app) } + + +#' Add external (CSS) stylesheets to a Dash app +#' +#' @param app A dash application created with [`dash_app()`]. +#' @param stylesheet A single stylesheet or a list of stylesheets. Each +#' stylesheet is either a string (the URL), or a named list with `href` (the +#' URL) and any other valid `` tag attributes. See examples below. +#' Note that this is only used to add **external** stylesheets, not local. +#' @examples +#' app <- dash_app() +#' +#' # Add a single stylesheet with URL +#' app %>% add_stylesheet("https://cdn.jsdelivr.net/npm/bootstrap@5.0.1/dist/css/bootstrap.min.css") +#' +#' # Add multiple stylesheets with URL +#' app %>% add_stylesheet(list( +#' "https://cdn.jsdelivr.net/npm/bootstrap@5.0.2/dist/css/bootstrap.min.css", +#' "https://code.jquery.com/ui/1.12.1/themes/base/jquery-ui.css" +#' )) +#' +#' # Add a single stylesheet with a list +#' app %>% add_stylesheet( +#' list( +#' href = "https://cdn.jsdelivr.net/npm/bootstrap@5.0.1/dist/css/bootstrap.min.css", +#' integrity = "sha384-+0n0xVW2eSR5OomGNYDnhzAbDsOXxcvSN1TPprVMTNDbiYZCxYbOOl7+AMvyTG2x" +#' ) +#' ) +#' +#' # Add multiple stylesheets with both URL and list +#' app %>% add_stylesheet( +#' list( +#' "https://code.jquery.com/ui/1.12.1/themes/base/jquery-ui.css", +#' "https://fonts.googleapis.com/css?family=Lora", +#' list( +#' href = "https://cdn.jsdelivr.net/npm/bootstrap@5.0.1/dist/css/bootstrap.min.css", +#' integrity = "sha384-+0n0xVW2eSR5OomGNYDnhzAbDsOXxcvSN1TPprVMTNDbiYZCxYbOOl7+AMvyTG2x" +#' ) +#' ) +#' ) +#' @export +add_stylesheet <- function(app, stylesheet) { + assert_dash(app) + if (!is.list(stylesheet) || !is.null(names(stylesheet))) { + stylesheet <- list(stylesheet) + } + app$.__enclos_env__$self$config$external_stylesheets <- c(app$.__enclos_env__$self$config$external_stylesheets, stylesheet) + invisible(app) +} + + +#' Add external (JavaScript) scripts to a Dash app +#' +#' @param app A dash application created with [`dash_app()`] +#' @param script A single script or a list of scripts. Each script is either +#' a string (the URL), or a named list with `src` (the URL) and any other valid +#' `