Nothing
#' @importFrom htmlwidgets JS
#' @export
htmlwidgets::JS
mergeLists <- function(a, b) {
if (is.null(a)) {
a <- list()
}
if (is.null(b)) {
b <- list()
}
for (i in seq_along(b)) {
name <- names(b[i])
if (is.null(name) || name == "") {
a <- c(a, b[i])
} else if (!is.null(b[[i]])) {
a[[name]] <- b[[i]]
}
}
a
}
filterNulls <- function(x) {
Filter(Negate(is.null), x)
}
is.JS <- function(x) {
inherits(x, class(JS("")))
}
isNamedList <- function(x) {
if (!is.list(x)) {
return(FALSE)
}
if (length(x) >= 1 && is.null(names(x))) {
return(FALSE)
}
if (any(names(x) == "")) {
return(FALSE)
}
TRUE
}
is.Date <- function(x) {
inherits(x, "Date")
}
is.POSIXct <- function(x) {
inherits(x, "POSIXct")
}
is.POSIXlt <- function(x) {
inherits(x, "POSIXlt")
}
is.tag <- function(x) {
inherits(x, "shiny.tag")
}
is.htmlwidget <- function(x) {
inherits(x, "htmlwidget")
}
is.htmlDependency <- function(x) {
inherits(x, "html_dependency")
}
# Test both shiny.tag.list and regular lists of tags
isTagList <- function(x) {
inherits(x, "shiny.tag.list") || (is.list(x) && all(sapply(x, is.tag)))
}
asReactTag <- function(x) {
if (is.htmlwidget(x)) {
if (inherits(x, "reactable")) {
# Extract tag for subtables / nested tables
x$x$tag <- htmltools::tagAppendAttributes(x$x$tag, nested = TRUE)
return(asReactTag(x$x$tag))
} else {
tags <- htmltools::as.tags(x)
tags <- asReactTag(tags)
# Add a key for proper widget rerenders
tags <- reactR::React$WidgetContainer(tags, key = digest::digest(x))
return(tags)
}
}
# Unnest and wrap tag lists in fragments for proper hydration
if (isTagList(x)) {
x <- unnestTagList(x)
# Preserve HTML dependencies
deps <- htmltools::htmlDependencies(x)
# Collect inline HTML dependencies
inlineDeps <- sapply(x, is.htmlDependency)
if (any(inlineDeps)) {
deps <- c(deps, x[inlineDeps])
x[inlineDeps] <- NULL
}
x <- lapply(x, asReactTag)
x <- do.call(reactR::React$Fragment, x)
return(htmltools::attachDependencies(x, deps))
}
if (!is.tag(x)) {
# Nodes should be strings for proper hydration
if (!is.null(x) && (!is.character(x) || is.na(x))) {
x <- format(x)
}
return(x)
}
# Unnest tag lists for proper hydration
x$children <- unnestTagList(x$children)
# Preserve HTML dependencies
deps <- htmltools::htmlDependencies(x$children)
# Collect inline HTML dependencies
inlineDeps <- sapply(x$children, is.htmlDependency)
if (any(inlineDeps)) {
deps <- c(deps, x$children[inlineDeps])
x$children[inlineDeps] <- NULL
}
x <- htmltools::attachDependencies(x, deps, append = TRUE)
# Filter null elements for proper hydration
x$children <- filterNulls(x$children)
x$children <- lapply(x$children, asReactTag)
x$attribs <- asReactAttributes(x$attribs)
x
}
# Recursively unnest tag lists
unnestTagList <- function(x) {
isList <- function(x) {
# Ignore HTML tags/widgets/dependencies, which are technically lists
is.list(x) && !is.tag(x) && !is.htmlwidget(x) && !is.htmlDependency(x)
}
if (!isList(x)) {
return(x)
}
# Preserve HTML dependencies of tag lists
htmlDeps <- htmltools::htmlDependencies(x)
tags <- Reduce(function(a, b) {
if (is.null(b)) {
return(a)
}
if (isTagList(b)) {
# Preserve HTML dependencies of nested tag lists
deps <- htmltools::htmlDependencies(b)
if (!is.null(deps)) {
htmlDeps <<- c(htmlDeps, deps)
}
b <- unnestTagList(b)
}
# Merge without losing attributes
if (isList(b)) {
c(a, b)
} else {
c(a, list(b))
}
}, x, list())
htmltools::attachDependencies(tags, htmlDeps)
}
asReactAttributes <- function(attribs) {
reactAttribs <- list(
autofocus = "autoFocus",
autocomplete = "autoComplete",
autoplay = "autoPlay",
charset = "charSet",
checked = "defaultChecked",
class = "className",
colspan = "colSpan",
crossorigin = "crossOrigin",
enctype = "encType",
"for" = "htmlFor",
formaction = "formAction",
formenctype = "formEncType",
formmethod = "formMethod",
formnovalidate = "formNoValidate",
formtarget = "formTarget",
frameborder = "frameBorder",
hreflang = "hrefLang",
"http-equiv" = "httpEquiv",
inputmode = "inputMode",
maxlength = "maxLength",
mediagroup = "mediaGroup",
minlength = "minLength",
novalidate = "noValidate",
radiogroup = "radioGroup",
readonly = "readOnly",
rowspan = "rowSpan",
spellcheck = "spellCheck",
srcdoc = "srcDoc",
srclang = "srcLang",
tabindex = "tabIndex",
usemap = "useMap",
value = "defaultValue"
)
for (name in names(attribs)) {
if (!is.null(reactAttribs[[name]])) {
attribs[[reactAttribs[[name]]]] <- attribs[[name]]
attribs[[name]] <- NULL
}
}
style <- attribs$style
if (!is.null(style) && is.character(style)) {
attribs$style <- asReactStyle(style)
}
attribs
}
asReactStyle <- function(style) {
if (!is.character(style)) {
return(style)
}
pairs <- strsplit(unlist(strsplit(style, ";")), ":")
if (length(pairs) > 0) {
pairs <- Reduce(function(props, pair) {
if (length(pair) == 2) {
name <- trimws(pair[[1]])
value <- trimws(pair[[2]])
props[[name]] <- value
}
props
}, pairs, list())
}
pairs
}
# Backport for R 3.1
trimws <- function(x) {
x <- sub("[ \t\r\n]+$", "", x, perl = TRUE)
sub("^[ \t\r\n]+", "", x, perl = TRUE)
}
# Call function with a variable number of args.
# Args default to NULL if not supplied.
callFunc <- function(func, ...) {
args <- list(...)
numArgs <- length(formals(func))
do.call(func, args[seq_len(numArgs)])
}
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.