Nothing
# ----------------------------------------------------------------------------
# Class assertion
# ----------------------------------------------------------------------------
# fiery server
is.fire <- function(x) inherits(x, "Fire")
# dependencies
is.dependency <- function(x) inherits(x, "dash_dependency")
is.output <- function(x) inherits(x, "output")
is.input <- function(x) inherits(x, "input")
is.state <- function(x) inherits(x, "state")
is.event <- function(x) is.dependency(x) && inherits(x, "event")
# components (TODO: this should be exported by dashRtranspile!)
is.component <- function(x) inherits(x, "dash_component")
# retrieve the arguments of a callback function that are dash inputs
callback_inputs <- function(func) {
compact(lapply(formals(func), function(x) {
# missing arguments produce an error when evaluated
# TODO: should we only evaluate when `!identical(x, quote(expr = ))`?
val <- tryNULL(eval(x))
if (is.input(val)) val else NULL
}))
}
callback_states <- function(func) {
compact(lapply(formals(func), function(x) {
# missing arguments produce an error when evaluated
# TODO: should we only evaluate when `!identical(x, quote(expr = ))`?
val <- tryNULL(eval(x))
if (is.state(val)) val else NULL
}))
}
callback_events <- function(func) {
compact(lapply(formals(func), function(x) {
# missing arguments produce an error when evaluated
# TODO: should we only evaluate when `!identical(x, quote(expr = ))`?
val <- tryNULL(eval(x))
if (is.event(val)) val else NULL
}))
}
# search through a component (a recursive data structure) for a component with
# a given id and return the component's type
component_props_given_id <- function(component, id) {
is_component <- is.component(component)
is_match <- if (is_component) isTRUE(component$props$id == id) else FALSE
props <- if (is_match) component$propNames else NA
if (is_component && !is_match) {
if ("children" %in% names(component$props)) {
return(unlist(lapply(component$props$children, component_props_given_id, id)))
}
}
props
}
component_contains_type <- function(component, package, type) {
is_component <- is.component(component)
is_match <- if (is_component) isTRUE(component$type == type) && isTRUE(component$package == package) else FALSE
if (is_component && !is_match) {
if ("children" %in% names(component$props)) {
return(any(unlist(lapply(component$props$children, component_contains_type, package, type))))
}
}
is_match
}
# ----------------------------------------------------------------------
# HTTP helpers
# ----------------------------------------------------------------------
request_parse_json <- function(request) {
# request body must be parsed on demand (to avoid errors by odd formats)
# http://www.data-imaginist.com/2017/Introducing-reqres/
if (!request$is("json")) stop("Expected a JSON request", call. = FALSE)
# Unlike `reqres::default_parsers["application/json"]`, we don't
# simplify the *entire* JSON blob, but we do simplify input/state value(s)
# https://gist.github.com/cpsievert/04d53edbe902ca86a41949e24e8b4af7
from_JSON <- function(raw, directives) {
jsonlite::fromJSON(rawToChar(raw), simplifyVector = FALSE)
}
success <- request$parse(list(`application/json` = from_JSON))
if (!success) stop("Failed to parse body", call. = FALSE)
request
}
# ----------------------------------------------------------------------------
# HTML dependency helpers
# ----------------------------------------------------------------------------
# @param dependencies a list of HTML dependencies
# @param local should local versions be served instead of CDN hrefs?
# @param prefix the prefix to use for responding to requests, if set
render_dependencies <- function(dependencies, local = TRUE, prefix=NULL) {
html <- sapply(dependencies, function(dep, is_local=local, path_prefix=prefix) {
assertthat::assert_that(inherits(dep, "html_dependency"))
srcs <- names(dep[["src"]])
src <- if (!is_local && !"href" %in% srcs && "file" %in% srcs) {
msg <- paste0("No remote hyperlink found for HTML dependency ",
dep[["name"]],
". Using local file instead.")
message(msg)
"file"
} else if (is_local && !"file" %in% srcs && "href" %in% srcs) {
msg <- paste0("No local file found for HTML dependency ",
dep[["name"]],
". Using the remote URL instead.")
message(msg)
"href"
} else if (!is_local) {
"href"
} 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
# applications should have the app name injected as well.
#
# This is essentially analogous to this codeblock on the Python side:
# https://github.com/plotly/dash/blob/1249ffbd051bfb5fdbe439612cbec7fa8fff5ab5/dash/dash.py#L207
#
# Use the system file modification timestamp for the current
# package and add the version number of the package as a query
# parameter for cache busting
if (!is.null(dep$package)) {
full_path <- getDependencyPath(dep)
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(tagdata = dep$src$href)
} else {
script_mtime <- file.mtime(getDependencyPath(dep))
modtime <- as.integer(script_mtime)
dep$script <- buildFingerprint(dep$script, dep$version, modtime)
dep[["script"]] <- paste0(path_prefix,
"_dash-component-suites/",
dep$name,
"/",
basename(dep[["script"]]),
"?v=",
dep$version,
"&m=",
modified)
html <- generate_js_dist_html(tagdata = dep[["script"]], as_is = TRUE)
}
} else if (!(is_local) & "stylesheet" %in% names(dep) & src == "href") {
html <- generate_css_dist_html(tagdata = paste(dep[["src"]][["href"]],
dep[["stylesheet"]],
sep="/"),
local = FALSE)
} else if ("stylesheet" %in% names(dep) & src == "file") {
dep[["stylesheet"]] <- paste0(path_prefix,
"_dash-component-suites/",
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(tagdata = sheetpath, as_is = TRUE)
} else {
sheetpath <- paste0(dep[["src"]][["file"]],
dep[["stylesheet"]],
"?v=",
dep$version)
html <- generate_css_dist_html(tagdata = sheetpath, as_is = TRUE)
}
} else {
sheetpath <- paste0(dep[["src"]][["file"]],
dep[["stylesheet"]])
html <- generate_css_dist_html(tagdata = sheetpath, as_is = TRUE)
}
}
})
paste(html, collapse = "\n")
}
# ----------------------------------------------------------------------------
# Other (generic) helpers
# ----------------------------------------------------------------------------
"%||%" <- function(x, y) {
if (length(x)) x else y
}
compact <- function(x) {
Filter(Negate(is.null), x)
}
# same as plotly:::to_JSON
to_JSON <- function(x, ...) {
jsonlite::toJSON(x, digits = 50, auto_unbox = TRUE, force = TRUE,
null = "null", na = "null", ...)
}
# same as plotly:::new_id
new_id <- function() {
basename(tempfile(""))
}
dir_exists <- function(paths) {
utils::file_test("-d", paths)
}
tryNULL <- function(expr) {
tryCatch(expr, error = function(e) NULL)
}
str_trim <- function(x) {
sub("\\s+$", "", sub("^\\s+", "", x))
}
setdiffsym <- function(x, y) {
setdiff(union(x, y), intersect(x, y))
}
stop_report <- function(msg = "") {
stop(
msg, "\n\n",
"Please let us know about this error via ",
"https://github.com/plotly/dashR/issues/new",
call. = FALSE
)
}
try_library <- function(pkg, fun = NULL) {
if (system.file(package = pkg) != "") {
return(invisible())
}
stop("Package `", pkg, "` required", if (!is.null(fun))
paste0(" for `", fun, "`"), ".\n", "Please install and try again.",
call. = FALSE)
}
assert_valid_children <- function(children, ...) {
kids <- list(children)
if (...length()) {
pattern <- paste(paste0('^', ...), collapse = '|')
kids <- kids[!grepl(pattern, names2(kids))]
}
if (!length(kids)) return(NULL)
assert_no_names(kids)
}
assert_no_names <- function (x)
{
if(!(is.list(x))) x <- list(x)
nms <- names(x)
if (is.null(nms))
return(x)
if (identical("", unique(nms)))
return(setNames(x, NULL))
stop(sprintf("Didn't recognize the following named arguments: '%s'",
paste(nms, collapse = "', '")), call. = FALSE)
}
assertValidWildcards <- function(dependency) {
if (is.symbol(dependency$id)) {
result <- (jsonlite::validate(as.character(dependency$id)) && grepl("{", dependency$id))
} else {
result <- TRUE
}
if (!result) {
dependencyType <- class(dependency)
stop(sprintf("A callback %s ID contains restricted pattern matching callback selectors ALL, MATCH or ALLSMALLER. Please verify that it is formatted as a pattern matching callback list ID, or choose a different component ID.",
dependencyType[dependencyType %in% c("input", "output", "state")]),
call. = FALSE)
} else {
return(result)
}
}
# 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.
#
# this attempts to avoid cryptic errors produced by
# get_package_mapping, which requires three parameters:
# -- the script name (i.e. x$script below)
# -- the package name from the URL (i.e. x$package)
# -- the list of dependencies (i.e. deps)
#
# within get_package_mapping, x$package is also required,
# so deps missing it here are assigned NULL and then
# filtered out by the subsequent vapply statement
clean_dependencies <- function(deps) {
dep_list <- lapply(deps, function(x) {
if (is.null(x$src$file) | (is.null(x$script) & is.null(x$stylesheet) & is.null(x$other)) | (is.null(x$package))) {
if (is.null(x$src$href))
stop(sprintf("Script, CSS, or other dependencies with NULL href fields must include a file path, dependency name, and R package name."), call. = FALSE)
else
return(NULL)
}
else
return(x)
}
)
deps_with_file <- dep_list[!vapply(dep_list, is.null, logical(1))]
return(deps_with_file)
}
insertIntoCallbackMap <- function(map, inputs, output, state, func, clientside_function) {
output_id <- createCallbackId(output)
if (output_id %in% names(map)) {
stop(
sprintf(
"One or more of the following outputs are duplicated across callbacks: %s. Please ensure that all ID and property combinations are unique.",
output_id
),
call. = FALSE
)
}
map[[output_id]] <- list(
inputs = inputs,
output = output,
state = state,
func = func,
clientside_function = clientside_function
)
if (length(map) >= 2) {
ids <- lapply(names(map), function(x) getIdProps(x)$ids)
props <- lapply(names(map), function(x) 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))
if (!is.list(output[[1]])) listed_output <- list(output) else listed_output <- output
invalid_outputs <- vapply(listed_output, function(x) {
!any(c('output') %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)
}
# Verify that output contains no elements that are not a member of the 'output' class.
if (any(invalid_outputs)) {
stop(sprintf("Callback outputs must be output function calls. Please verify formatting of callback outputs."), 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))) {
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)
}
# Verify that 'input', 'state' and 'output' parameters only contain 'Wildcard' keywords if they are JSON formatted ids for pattern matching callbacks
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)
})
} else {
valid_wildcard_output <- sapply(list(output), function(x) {
assertValidWildcards(x)
})
}
# Check that outputs are not inputs
# https://github.com/plotly/dash/issues/323
# 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)
}
# TO DO: check that components contain props
TRUE
}
names2 <- function(x) names(x) %||% rep('', length(x))
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'))) {
return(TRUE)
} else {
return(FALSE)
}
}
resolvePrefix <- function(prefix, environment_var, base_pathname) {
if (!(is.null(prefix))) {
assertthat::assert_that(is.character(prefix))
return(prefix)
} else {
# Check environment variables
prefix_env <- Sys.getenv(environment_var)
env_base_pathname <- Sys.getenv("DASH_URL_BASE_PATHNAME")
app_name <- Sys.getenv("DASH_APP_NAME")
if (prefix_env != "")
return(prefix_env)
else if (app_name != "")
return(sprintf("/%s/", app_name))
else if (env_base_pathname != "")
return(env_base_pathname)
else
return(base_pathname)
}
}
# The function below requires a dependency path, package information
# retrieved from a request URL, as well as a list of dependencies
# (currently in htmltools htmlDependency format). get_package_mapping
# 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
# this function returns a list with two elements:
# rpkg_name = character string supplying the name of the R package
# rpkg_path = character string providing the path to the dependency
get_package_mapping <- function(script_name, url_package, dependencies) {
# TODO: improve validation of dependency inputs, particularly
# to avoid duplicating dependencies in the package_map
package_map <- vapply(unique(dependencies), function(x) {
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)
else if (!is.null(x$other))
dep_path <- file.path(x$src$file, x$other)
# remove n>1 slashes and replace with / if present;
# 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),
dep_name=x$name,
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) {
filename_ext <- getFileExt(filename)
if (filename_ext == 'js')
return('application/JavaScript')
else if (filename_ext == 'css')
return('text/css')
else if (filename_ext %in% c('js.map', 'map'))
return('application/json')
else
return(mime::guess_type(filename,
empty = "application/octet-stream"))
}
generate_css_dist_html <- function(tagdata,
local = FALSE,
local_path = NULL,
prefix = NULL,
as_is = FALSE) {
attribs <- names(tagdata)
if (!(local)) {
if (any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
tagdata,
perl=TRUE)) || as_is) {
if (is.list(tagdata))
glue::glue('<link ', glue::glue_collapse(glue::glue('{attribs}="{tagdata}"'), sep=" "), ' rel="stylesheet">')
else {
interpolated_link <- glue::glue('href="{tagdata}"')
glue::glue('<link ', '{interpolated_link}', ' rel="stylesheet">')
}
}
else
stop(sprintf("Invalid URL supplied in external_stylesheets. Please check the syntax used for this parameter."), call. = FALSE)
} else {
modified <- as.integer(file.mtime(local_path))
# strip leading slash from href if present
if (is.list(tagdata)) {
tagdata$href <- paste0(prefix, sub("^/", "", tagdata$href))
glue::glue('<link ', glue::glue_collapse(glue::glue('{attribs}="{tagdata}?m={modified}"'), sep=" "), ' rel="stylesheet">')
}
else {
tagdata <- sub("^/", "", tagdata)
interpolated_link <- glue::glue('href="{prefix}{tagdata}?m={modified}"')
glue::glue('<link ', '{interpolated_link}', ' rel="stylesheet">')
}
}
}
generate_js_dist_html <- function(tagdata,
local = FALSE,
local_path = NULL,
prefix = NULL,
as_is = FALSE) {
attribs <- names(tagdata)
if (!(local)) {
if (any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
tagdata,
perl=TRUE)) || as_is) {
if (is.list(tagdata))
glue::glue('<script ', glue::glue_collapse(glue::glue('{attribs}="{tagdata}"'), sep=" "), '></script>')
else {
interpolated_link <- glue::glue('src="{tagdata}"')
glue::glue('<script ', '{interpolated_link}', '></script>')
}
}
else
stop(sprintf("Invalid URL supplied. Please check the syntax used for this parameter."), call. = FALSE)
} else {
modified <- as.integer(file.mtime(local_path))
# strip leading slash from href if present
if (is.list(tagdata)) {
tagdata$src <- paste0(prefix, sub("^/", "", tagdata$src))
glue::glue('<script ', glue::glue_collapse(glue::glue('{attribs}="{tagdata}?m={modified}"'), sep=" "), '></script>')
}
else {
tagdata <- sub("^/", "", tagdata)
interpolated_link <- glue::glue('src="{prefix}{tagdata}?m={modified}"')
glue::glue('<script ', '{interpolated_link}', '></script>')
}
}
}
assertValidExternals <- function(scripts, stylesheets) {
allowed_js_attribs <- c("async",
"crossorigin",
"defer",
"integrity",
"nomodule",
"nonce",
"referrerpolicy",
"src",
"type",
"charset",
"language")
allowed_css_attribs <- c("as",
"crossorigin",
"disabled",
"href",
"hreflang",
"importance",
"integrity",
"media",
"referrerpolicy",
"rel",
"sizes",
"title",
"type",
"methods",
"prefetch",
"target",
"charset",
"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\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
item,
perl=TRUE))))
stop("A valid URL must be included with every entry in external_scripts. Please sure no 'src' entries are missing or malformed.", call. = FALSE)
if (any(names(item) == ""))
stop("Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.", call. = FALSE)
script_attributes <- c(script_attributes, names(item))
}
else {
if (!grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
item,
perl=TRUE))
stop("A valid URL must be included with every entry in external_scripts. Please sure no 'src' entries are missing or malformed.", call. = FALSE)
script_attributes <- c(script_attributes, character(0))
}
}
for (item in stylesheets) {
if (is.list(item)) {
if (!"href" %in% names(item) || !(any(grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
item,
perl=TRUE))))
stop("A valid URL must be included with every entry in external_stylesheets. Please sure no 'href' entries are missing or malformed.", call. = FALSE)
if (any(names(item) == ""))
stop("Please verify that all attributes are named elements when specifying URLs for scripts and stylesheets.", call. = FALSE)
stylesheet_attributes <- c(stylesheet_attributes, names(item))
}
else {
if (!grepl("^(?:http(s)?:\\/\\/)?[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+$",
item,
perl=TRUE))
stop("A valid URL must be included with every entry in external_stylesheets. Please sure no 'href' entries are missing or malformed.", call. = FALSE)
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)
}
invisible(TRUE)
}
generate_meta_tags <- function(metas) {
has_ie_compat <- any(vapply(metas, function(x)
x$name == "http-equiv" && x$content == "X-UA-Compatible",
logical(1)), na.rm=TRUE)
has_charset <- any(vapply(metas, function(x)
"charset" %in% names(x),
logical(1)), na.rm=TRUE)
# allow arbitrary tags with varying numbers of keys
tags <- vapply(metas,
function(tag) sprintf("<meta %s>", paste(sprintf("%s=\"%s\"",
names(tag),
unlist(tag, use.names = FALSE)),
collapse=" ")),
character(1))
if (!has_ie_compat) {
tags <- c('<meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\">', tags)
}
if (!has_charset) {
tags <- c('<meta charset=\"UTF-8\">', tags)
}
return(tags)
}
# This function takes the list object containing asset paths
# for all stylesheets and scripts, as well as the URL path
# to search, then returns the absolute local path (when
# present) to the requested asset
#
# e.g. assets_map is a named list potentially containing
# $css, a list of absolute paths as character strings
# for all locally supplied CSS assets, named with their
# 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]
}
# This function returns the URL corresponding to assets
# included in the asset map, with the request prefix
# prepended, e.g. when asset_path is
#
# assets/stylesheet.css
# "/Users/testuser/assets/stylesheet.css"
#
# ... the function will return
#
# "/assets/stylesheet.css"
#
get_asset_url <- function(asset_path, prefix = "/") {
# the subpath is stored in the names attribute
# of the return object from get_asset_path, so
# we can retrieve it using names()
asset <- names(asset_path)
# strip one or more trailing slashes, since we'll
# introduce one when we concatenate the prefix and
# asset path
prefix <- gsub(pattern = "/+$",
replacement = "",
x = 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) &&
"x" %in% names(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
# 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
# typically run interactively.
obj <- suppressMessages(plotly::plotly_build(layout_objs)$x)
layout_objs <- obj[c("data", "layout")]
return(layout_objs)
} else {
for (i in seq_along(layout_objs)) {
# if the current element is a nested list, pass the
# element to encode_plotly to continue recursing the
# tree of components
if (any(sapply(layout_objs[[i]], is.list)))
layout_objs[[i]] <- encode_plotly(layout_objs[[i]])
}
}
}
layout_objs
}
# This function formats the output from sys.calls()
# so that it is pretty printed to stderr()
printCallStack <- function(call_stack, header=TRUE) {
if (header) {
write(crayon::yellow$bold(" ### Dash for R Traceback (most recent/innermost call last) ###"), stderr())
}
write(
crayon::white(
paste0(
" ",
seq_along(
call_stack
),
": ",
call_stack,
" ",
lapply(call_stack, attr, "flineref")
)
),
stderr()
)
}
stackTraceToHTML <- function(call_stack,
throwing_call,
error_message) {
if(is.null(call_stack)) {
return(NULL)
}
header <- " ### Dash for R Traceback (most recent/innermost call last) ###\n"
formattedStack <- c(paste0(
" ",
seq_along(
call_stack
),
": ",
call_stack,
" ",
lapply(call_stack, attr, "lineref"),
collapse="\n"
)
)
template <- "%s\nError: %s: %s\n%s"
response <- sprintf(template,
header,
throwing_call,
error_message,
formattedStack)
# properly format anonymous tags if present in call stack
#response <- gsub("<anonymous>", "<anonymous>", response)
return(response)
}
# This function is essentially the R equivalent of a
# Python decorator method; if debug mode is active,
# it will wrap an expression using withCallingHandlers
# and capture the call stack. By default, the call
# stack will be "pruned" of error handling functions
# for greater readability.
getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
if (debug) {
tryCatch(withCallingHandlers(
expr,
error = function(e) {
if (is.null(attr(e, "stack.trace", exact = TRUE))) {
calls <- sys.calls()
reverseStack <- rev(calls)
attr(e, "stack.trace") <- calls
if (!is.null(e$call[[1]]))
errorCall <- e$call[[1]]
else {
# attempt to capture the error or warning if thrown by
# simpleError or simpleWarning (which may arise for user-defined errors)
#
# the first matching call in the reversed stack will always be
# getStackTrace, so we select the second match instead
errorCall <- reverseStack[grepl(x=reverseStack, "simpleError|simpleWarning")][[2]]
}
functionsAsList <- lapply(calls, function(completeCall) {
# avoid attempting to cast closures as strings, which will fail
# some calls in the stack are symbol (name) objects, while others
# are calls, which must be deparsed; the first element in the vector
# should be the function signature
if (is.name(completeCall[[1]]))
currentCall <- as.character(completeCall[[1]])
else if (is.call(completeCall[[1]]))
currentCall <- deparse(completeCall)[1]
else
currentCall <- completeCall[[1]]
attr(currentCall, "flineref") <- getLineWithError(completeCall, formatted=TRUE)
attr(currentCall, "lineref") <- getLineWithError(completeCall, formatted=FALSE)
if (is.function(currentCall) & !is.primitive(currentCall)) {
constructedCall <- paste0("<anonymous> 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
indexFromLast <- match(TRUE, lapply(reverseStack, function(currentCall) {
# if the first element of the current call pulled from the stack
# is a function, deparse the error object's call and compare
# to the current call from the stack -- if they're the same,
# return TRUE -- the match function will return the position
# of the first successful match.
#
# since the stack of calls being evaluated is reversed, "pruning"
# here has the effect of capturing the stack up to the most recent
# call which matches the call throwing the error. the call may have
# not thrown an error further up the stack, so we want to be sure
# to stop at the correct position.
if (is.function(currentCall[[1]])) {
identical(deparse(errorCall), deparse(currentCall[[1]]))
} else if (currentCall[[1]] == "stop") {
# handle case where function developer deliberately invokes a stop
# condition and halts function execution
TRUE
} else {
FALSE
}
}))
# the position to stop at is one less than the difference
# 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[seq(startIndex, stopIndex)]
functionsAsList <- removeHandlers(functionsAsList)
}
warning(call. = FALSE, immediate. = TRUE, sprintf("Execution error in %s: %s",
functionsAsList[[length(functionsAsList)]],
conditionMessage(e)))
stack_message <- stackTraceToHTML(functionsAsList,
functionsAsList[[length(functionsAsList)]],
conditionMessage(e))
assign("stack_message", value=stack_message,
envir=sys.frame(countEnclosingFrames("private"))$private)
printCallStack(functionsAsList)
}
}
),
error = function(e) {
write(crayon::yellow$bold("in debug mode, catching error as warning ..."), stderr())
}
)
} else {
evalq(expr)
}
}
getLineWithError <- function(currentCall, formatted=TRUE) {
srcref <- attr(currentCall, "srcref", exact = TRUE)
if (!is.null(srcref) & !(getAppPath()==FALSE)) {
# filename
srcfile <- attr(srcref, "srcfile", exact = TRUE)
# line number
context <- sprintf("-- %s, Line %s", srcfile$filename, srcref[[1]])
if (formatted)
context <- crayon::yellow$italic(context)
return(context)
} else
""
}
# This helper function drops error
# handling functions from the call
# stack, as these are generally not
# useful.
#
# TODO: modify this function such
# that these handlers are only pruned
# *after* the function throwing the
# error has entered the stack for
# the last time.
removeHandlers <- function(fnList) {
omittedStrings <- c("withCallingHandlers",
"tryCatch",
"tryCatchList",
"tryCatchOne",
"doTryCatch",
".handleSimpleError",
"h",
".handleSimpleError",
"withRestarts")
return(fnList[!fnList %in% omittedStrings])
}
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="."))
})
} else if (is.character(callback_elements$state[[1]][[1]])) {
states <- sapply(callback_elements$state, function(x) {
setNames(list(x$value), paste(x$id, x$property, sep="."))
})
} else {
states <- sapply(callback_elements$state, function(x) {
states_vector <- unlist(x)
setNames(list(states_vector[grepl("value|value.", names(states_vector))]),
paste(as.character(jsonlite::toJSON(x[[1]])), x$property, sep="."))
})
}
splitIdProp <- function(x) unlist(strsplit(x, split = "[.]"))
triggered <- lapply(callback_elements$changedPropIds,
function(x) {
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.
if (startsWith(input_id, "{")){
id_match <- vapply(callback_elements$inputs, function(x) {
x <- unlist(x)
any(x[grepl("id.", names(x))] %in% jsonlite::fromJSON(input_id)[[1]])
}, logical(1))[[1]]
} else {
id_match <- vapply(callback_elements$inputs, function(x) {
unlist(x)
any(x$id %in% input_id)}, logical(1))
}
if (startsWith(input_id, "{")){
prop_match <- vapply(callback_elements$inputs, function(x) {
x <- unlist(x)
any(x[names(x) == "property"] %in% prop)
}, logical(1))[[1]]
} else {
prop_match <- vapply(callback_elements$inputs, function(x) {
unlist(x)
any(x$property %in% prop)}, logical(1))
}
if (startsWith(input_id, "{")){
if (length(callback_elements$inputs) == 1 || !is.null(unlist(callback_elements$inputs, recursive = F)$value)) {
value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value")
} else {
value <- sapply(callback_elements$inputs[id_match & prop_match][[1]], `[[`, "value")
}
} else {
value <- sapply(callback_elements$inputs[id_match & prop_match], `[[`, "value")
}
return(list(`prop_id` = x, `value` = value))
}
)
if (length(callback_elements$inputs[[1]]) == 0 || is.character(callback_elements$inputs[[1]][[1]])) {
inputs <- sapply(callback_elements$inputs, function(x) {
setNames(list(x$value), paste(x$id, x$property, sep="."))
})
} else if (length(callback_elements$inputs[[1]]) > 1) {
inputs <- sapply(callback_elements$inputs, function(x) {
inputs_vector <- unlist(x)
setNames(list(inputs_vector[grepl("value|value.", names(inputs_vector))]), paste(as.character(jsonlite::toJSON(x$id)), x$property, sep="."))
})
} else {
inputs <- sapply(callback_elements$inputs, function(x) {
inputs_vector <- unlist(x)
setNames(list(inputs_vector[grepl("value|value.", names(inputs_vector))]), paste(as.character(jsonlite::toJSON(x[[1]]$id)), x[[1]]$property, sep="."))
})
}
return(list(states=states,
triggered=unlist(triggered, recursive=FALSE),
inputs=inputs))
}
getDashMetadata <- function(pkgname) {
fnList <- ls(getNamespace(pkgname), all.names = TRUE)
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(gsub("^\\.{2}|\\.{2}$", "", output), '...', 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))
}
modtimeFromPath <- function(path, recursive = FALSE, asset_path="") {
# ensure path is properly formatted
path <- normalizePath(path)
if (is.null(path)) {
return(NULL)
}
if (recursive) {
if (asset_path != "") {
all_files <- file.info(list.files(path, recursive = TRUE))
# need to exclude files which are in assets directory so we don't always hard reload
initpath <- vapply(strsplit(rownames(all_files), split = .Platform$file.sep), `[`, FUN.VALUE=character(1), 1)
# now subset the modtimes, and identify the most recently modified file
modtime <- as.integer(max(all_files$mtime[which(initpath != asset_path)], na.rm = TRUE))
} else {
# now identify the most recently modified file
all_files <- list.files(path, recursive = TRUE, full.names = TRUE)
modtime <- as.integer(max(file.info(all_files)$mtime, na.rm=TRUE))
}
} else {
# check if the path is for a directory or file, and handle accordingly
if (length(path) == 1 && dir.exists(path))
modtime <- as.integer(max(file.info(list.files(path, full.names = TRUE))$mtime, na.rm=TRUE))
else
modtime <- as.integer(file.info(path)$mtime)
}
return(modtime)
}
getAppPath <- function() {
# attempt to retrieve path for Dash apps served via
# Rscript or source()
cmd_args <- commandArgs(trailingOnly = FALSE)
file_argument <- "--file="
matched_arg <- grep(file_argument, cmd_args)
# if app is instantiated via Rscript, cmd_args should contain path
if (length(matched_arg) > 0) {
# Rscript
return(normalizePath(sub(file_argument, "", cmd_args[matched_arg])))
}
# if app is instantiated via source(), sys.frames should contain path
else if (!is.null(sys.frames()[[1]]$ofile)) {
return(normalizePath(sys.frames()[[1]]$ofile))
}
else {
return(FALSE)
}
}
# this function enables Dash to set file modification times
# as attributes on the vectors stored within the asset map
#
# this permits storing additional information on the object
# without dramatically modifying the existing API, and makes
# it somewhat trivial to request the set of modification times
setModtimeAsAttr <- function(path) {
if (!is.null(path)) {
mtime <- modtimeFromPath(path)
attributes(path)$modtime <- mtime
return(path)
} else {
return(NULL)
}
}
countEnclosingFrames <- function(object) {
for (i in 1:sys.nframe()) {
objs <- ls(envir=sys.frame(i))
if (object %in% objs)
return(i)
}
}
changedAssets <- function(before, after) {
# identify files that used to exist in the asset map,
# but which have been removed
deletedElements <- before[which(is.na(match(before, after)))]
# identify files which were added since the last refresh
addedElements <- after[which(is.na(match(after, before)))]
# identify any items that have been updated since the last
# refresh based on modification time attributes set in map
#
# in R, attributes are discarded when subsetting, so it's
# necessary to subset the attributes being compared instead.
# here we only compare objects which overlap
before_modtimes <-attributes(before)$modtime[before %in% after]
after_modtimes <- attributes(after)$modtime[after %in% before]
changedElements <- after[which(after_modtimes > before_modtimes)]
if (length(deletedElements) == 0) {
deletedElements <- NULL
}
if (length(changedElements) == 0) {
changedElements <- NULL
}
if (length(addedElements) == 0) {
addedElements <- NULL
}
invisible(return(
list(deleted = deletedElements,
changed = changedElements,
new = addedElements)
)
)
}
dashLogger <- function(event = NULL,
message = NULL,
request = NULL,
time = Sys.time(),
...) {
orange <- crayon::make_style("orange")
# dashLogger is being called from within fiery, and the Fire() object generator
# is called from a private method within the Dash() R6 class; this makes
# accessing variables set within Dash's private fields somewhat complicated
#
# the following lines retrieve the value of the silence_route_logging parameter,
# which is many frames up the stack; if it's not found, we'll assume FALSE
self_object <- dynGet("self", ifnotfound = NULL)
if (!is.null(self_object))
silence_routes_logging <- self_object$config$silence_routes_logging
else
silence_routes_logging <- FALSE
if (!is.null(event)) {
msg <- sprintf("%s: %s", event, message)
msg <- switch(event, error = crayon::red(msg), warning = crayon::yellow(msg),
message = crayon::blue(msg), msg)
# assign the status group for color coding
if (event == "request") {
status_group <- as.integer(cut(request$respond()$status,
breaks = c(100, 200, 300, 400, 500, 600), right = FALSE))
msg <- switch(status_group, crayon::blue$bold(msg), crayon::green$bold(msg),
crayon::cyan$bold(msg), orange$bold(msg), crayon::red$bold(msg))
}
# if log messages are suppressed, report only server stop/start messages, errors, and warnings
# otherwise, print everything to console
if (event %in% c("start", "stop", "error", "warning") || !(silence_routes_logging)) {
cat(msg, file = stdout(), append = TRUE)
cat("\n", file = stdout(), append = TRUE)
}
}
}
#' Define a clientside callback
#'
#' Create a callback that updates the output by calling a clientside (JavaScript) function instead of an R function.
#' Note that it is also possible to specify JavaScript as a character string instead of passing `clientsideFunction`.
#' In this case Dash will inline your JavaScript automatically, without needing to save a script inside `assets`.
#'
#' @param namespace Character. Describes where the JavaScript function resides (Dash will look
#' for the function at `window[namespace][function_name]`.)
#' @param function_name Character. Provides the name of the JavaScript function to call.
#'
#' @details With this signature, Dash's front-end will call `window.my_clientside_library.my_function` with the current
#' values of the `value` properties of the components `my-input` and `another-input` whenever those values change.
#' Include a JavaScript file by including it your `assets/` folder. The file can be named anything but you'll need to
#' assign the function's namespace to the `window`. For example, this file might look like:
#' \preformatted{window.my_clientside_library = \{
#' my_function: function(input_value_1, input_value_2) \{
#' return (
#' parseFloat(input_value_1, 10) +
#' parseFloat(input_value_2, 10)
#' );
#' \}
#'\}
#'}
#'
#'
#' @export
#' @examples \dontrun{
#' app$callback(
#' output('output-clientside', 'children'),
#' params=list(input('input', 'value')),
#' clientsideFunction(
#' namespace = 'my_clientside_library',
#' function_name = 'my_function'
#' )
#' )
#'
#' # Passing JavaScript as a character string
#' app$callback(
#' output('output-clientside', 'children'),
#' params=list(input('input', 'value')),
#' "function (value) {
#' return 'Client says \"' + value + '\"';
#' }"
#')}
clientsideFunction <- function(namespace, function_name) {
return(list(namespace=namespace, function_name=function_name))
}
buildFingerprint <- function(path, version, hash_value) {
path <- file.path(path)
filename <- getFileSansExt(path)
extension <- getFileExt(path)
sprintf("%s.v%sm%s.%s",
file.path(dirname(path), filename),
gsub("[^\\w-]", "_", version, perl = TRUE),
hash_value,
extension)
}
checkFingerprint <- function(path) {
name_parts <- unlist(strsplit(basename(path), ".", fixed = TRUE))
# Check if the resource has a fingerprint
if ((length(name_parts) > 2) && grepl("^v[\\w-]+m[0-9a-fA-F]+$", name_parts[2], perl = TRUE)) {
return(list(paste(name_parts[name_parts != name_parts[2]], collapse = "."), TRUE))
}
return(list(basename(path), FALSE))
}
getDependencyPath <- function(dep) {
if (missing(dep)) {
stop("getDependencyPath requires that a valid dependency object is passed. Please verify that dep is non-missing.")
}
if(!(is.null(dep$script))) {
filename <- checkFingerprint(dep$script)[[1]]
dirname <- returnDirname(dep$script)
} else {
filename <- dep$stylesheet
dirname <- returnDirname(filename)
}
dep_path <- file.path(dep$src$file, filename)
# the gsub line is to remove stray duplicate slashes, to
# permit exact string matching on pathnames
dep_path <- gsub("//+",
"/",
dep_path)
# this may generate doubled slashes, which should not
# pose problems on Mac OS, Windows, or Linux systems
full_path_to_dependency <- system.file(file.path(dep$src$file,
dirname,
filename),
package=dep$package)
if (!file.exists(full_path_to_dependency)) {
write(crayon::yellow(sprintf("The dependency path '%s' within the '%s' package is invalid; cannot find '%s'.",
dep_path,
dep$package,
filename)
),
stderr())
}
return(full_path_to_dependency)
}
# the base R functions which strip extensions and filenames without
# extensions from paths are not robust to multipart extensions,
# such as .js.map or .min.js; these are functions intended to
# perform reliably in such cases. the first occurrence of a dot
# is replaced with an asterisk, which is generally an invalid
# filename character in any modern filesystem, since it represents
# a wildcard. the resulting string is then split on the asterisk.
getFileSansExt <- function(filepath) {
unlist(strsplit(sub("[.]", "*", basename(filepath)), "[*]"))[1]
}
getFileExt <- function(filepath) {
unlist(strsplit(sub("[.]", "*", basename(filepath)), "[*]"))[2]
}
returnDirname <- function(filepath) {
dirname <- dirname(filepath)
if (is.null(dirname) || dirname == ".")
return("")
return(dirname)
}
isDynamic <- function(eager_loading, resource) {
if (
is.null(resource$dynamic) && is.null(resource$async)
)
return(FALSE)
# need assert that async and dynamic are not both present
if (
(!is.null(resource$dynamic) && (resource$dynamic == FALSE)) ||
(eager_loading==TRUE && !is.null(resource$async) && (resource$async %in% c("eager", TRUE)))
)
return(FALSE)
else
return(TRUE)
}
tryCompress <- function(request, response) {
# charToRaw requires a length one character string
response$body <- paste(response$body, collapse="\n")
# the reqres gzip implementation requires file I/O
# brotli does not; when available, use brotli with
# a moderate level of compression for speed --
# the viewer pane only supports gzip and deflate,
# so gzip will be used when launching apps within
# RStudio
tryBrotli <- request$accepts_encoding('br')
if (tryBrotli == "br") {
response$body <- brotli::brotli_compress(charToRaw(response$body),
quality = 3)
response$set_header('Content-Encoding',
"br")
return(response)
}
return(response$compress())
}
get_relative_path <- function(requests_pathname, path) {
# Returns a path with the config setting 'requests_pathname_prefix' prefixed to
# it. This is particularly useful for apps deployed on Dash Enterprise, which makes
# it easier to serve apps under both URL prefixes and localhost.
if (requests_pathname == "/" && path == "") {
return("/")
}
else if (requests_pathname != "/" && path == "") {
return(requests_pathname)
}
else if (!startsWith(path, "/")) {
stop(sprintf(paste0("Unsupported relative path! Paths that aren't prefixed" ,
"with a leading '/' are not supported. You supplied '%s'."),
path))
}
else {
return(paste(gsub("/$", "", requests_pathname), gsub("^/", "", path), sep = "/"))
}
}
strip_relative_path <- function(requests_pathname, path) {
# Returns a relative path with the `requests_pathname_prefix` and leadings and trailing
# slashes stripped from it. This function is particularly relevant to dccLocation pathname routing.
if (is.null(path)) {
return(NULL)
}
else if ((requests_pathname != "/" && !startsWith(path, gsub("/$", "", requests_pathname)))
|| (requests_pathname == "/" && !startsWith(path, "/"))) {
stop(sprintf(paste0("Unsupported relative path! Path's that are not prefixed ",
"with a leading 'requests_pathname_prefix` are not suported. ",
"You supplied '%s', and requests_pathname_prefix was '%s'."),
path, requests_pathname
))
}
else if (requests_pathname != "/" && startsWith(path, gsub("/$", "", requests_pathname))) {
path = sub(gsub("/$", "", requests_pathname), "", path)
}
return(trimws(gsub("/", "", path)))
}
interpolate_str <- function(index_template, ...) {
# This function takes an index string, along with
# user specified keys for the html keys of the index
# and sets the default values of the keys to the
# ones specified by the keys themselves, returning
# the custom index template.
template = index_template
kwargs <- list(...)
for (name in names(kwargs)) {
key = paste0('\\{', name, '\\}')
template = sub(key, kwargs[[name]], template)
}
return(template)
}
validate_keys <- function(string, is_template) {
required_keys <- c("app_entry", "config", "scripts")
if (is_template)
keys_present <- vapply(required_keys, function(x) grepl(x, string), logical(1))
else
keys_present <- vapply(required_keys, function(x) x %in% string, logical(1))
if (!all(keys_present)) {
stop(sprintf("Did you forget to include %s in your index string?",
paste(names(keys_present[keys_present==FALSE]), collapse = ", ")))
} else {
return(string)
}
}
# Dash Layout 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$new()` or `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("dash: layout cannot include Shiny tags (you might have loaded the {shiny} package after loading {dash})", call. = FALSE)
} else if (is.list(x)) {
x <- remove_empty(x)
htmlDiv(children = lapply(x, componentify))
} else if (length(x) == 1) {
htmlSpan(children = x)
} else if (is.null(x)) {
return(NULL)
} else {
stop("dash: layout must be a dash component or list of dash components", call. = FALSE)
}
}
remove_empty <- function(x) {
Filter(Negate(is.null), x)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.