Nothing
# Like base::paste, but converts all string args to UTF-8 first.
paste8 <- function(..., sep = " ", collapse = NULL) {
args <- c(
lapply(list(...), enc2utf8),
list(
sep = if (is.null(sep)) sep else enc2utf8(sep),
collapse = if (is.null(collapse)) collapse else enc2utf8(collapse)
)
)
do.call(paste, args)
}
# A special case of paste8 that employs paste0. Avoids the overhead of lapply.
concat8 <- function(...) {
enc2utf8(paste0(...))
}
# Reusable function for registering a set of methods with S3 manually. The
# methods argument is a list of character vectors, each of which has the form
# c(package, genname, class).
registerMethods <- function(methods) {
lapply(methods, function(method) {
pkg <- method[[1]]
generic <- method[[2]]
class <- method[[3]]
func <- get(paste(generic, class, sep="."))
if (pkg %in% loadedNamespaces()) {
registerS3method(generic, class, func, envir = asNamespace(pkg))
}
setHook(
packageEvent(pkg, "onLoad"),
function(...) {
registerS3method(generic, class, func, envir = asNamespace(pkg))
}
)
})
}
.onLoad <- function(...) {
# htmltools provides methods for knitr::knit_print, but knitr isn't a Depends or
# Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to
# declare it as an export, not an S3method. That means that R will only know to
# use our methods if htmltools is actually attached, i.e., you have to use
# library(htmltools) in a knitr document or else you'll get escaped HTML in your
# document. This code snippet manually registers our methods with S3 once both
# htmltools and knitr are loaded.
registerMethods(list(
# c(package, genname, class)
c("knitr", "knit_print", "html"),
c("knitr", "knit_print", "shiny.tag"),
c("knitr", "knit_print", "shiny.tag.list"),
c("knitr", "knit_print", "html_dependency")
))
}
depListToNamedDepList <- function(dependencies) {
if (inherits(dependencies, "html_dependency"))
dependencies <- list(dependencies)
if (is.null(names(dependencies))) {
names(dependencies) <- sapply(dependencies, `[[`, "name")
}
return(dependencies)
}
#' Resolve a list of dependencies
#'
#' Given a list of dependencies, removes any redundant dependencies (based on
#' name equality). If multiple versions of a dependency are found, the copy with
#' the latest version number is used.
#'
#' @param dependencies A list of [htmlDependency()] objects.
#' @param resolvePackageDir Whether to resolve the relative path to an absolute
#' path via [system.file()] when the `package` attribute is
#' present in a dependency object.
#' @return dependencies A list of [htmlDependency()] objects with
#' redundancies removed.
#'
#' @export
resolveDependencies <- function(dependencies, resolvePackageDir = TRUE) {
deps <- resolveFunctionalDependencies(dependencies)
# Get names and numeric versions in vector/list form
depnames <- vapply(deps, function(x) x$name, character(1))
depvers <- numeric_version(vapply(deps, function(x) x$version, character(1)))
# Get latest version of each dependency. `unique` uses the first occurrence of
# each dependency name, which is important for inter-dependent libraries.
return(lapply(unique(depnames), function(depname) {
# Sort by depname equality, then by version. Since na.last=NA, all elements
# whose names do not match will not be included in the sorted vector.
sorted <- order(ifelse(depnames == depname, TRUE, NA), depvers,
na.last = NA, decreasing = TRUE)
# The first element in the list is the one with the largest version.
dep <- deps[[sorted[[1]]]]
if (resolvePackageDir && !is.null(dep$package)) {
dir <- dep$src$file
if (!is.null(dir)) dep$src$file <- system_file(dir, package = dep$package)
dep$package <- NULL
}
dep
}))
}
# Remove `remove` from `dependencies` if the name matches.
# dependencies is a named list of dependencies.
# remove is a named list of dependencies that take priority.
# If warnOnConflict, then warn when a dependency is being removed because of an
# older version already being loaded.
#' Subtract dependencies
#'
#' Remove a set of dependencies from another list of dependencies. The set of
#' dependencies to remove can be expressed as either a character vector or a
#' list; if the latter, a warning can be emitted if the version of the
#' dependency being removed is later than the version of the dependency object
#' that is causing the removal.
#'
#' @param dependencies A list of [htmlDependency()] objects from which
#' dependencies should be removed.
#' @param remove A list of [htmlDependency()] objects indicating which
#' dependencies should be removed, or a character vector indicating dependency
#' names.
#' @param warnOnConflict If `TRUE`, a warning is emitted for each
#' dependency that is removed if the corresponding dependency in `remove`
#' has a lower version number. Has no effect if `remove` is provided as a
#' character vector.
#'
#' @return A list of [htmlDependency()] objects that don't intersect
#' with `remove`.
#'
#' @export
subtractDependencies <- function(dependencies, remove, warnOnConflict = TRUE) {
dependencies <- resolveFunctionalDependencies(dependencies)
depnames <- vapply(dependencies, function(x) x$name, character(1))
if (is.character(remove)) {
rmnames <- remove
} else {
remove <- resolveFunctionalDependencies(remove)
rmnames <- vapply(remove, function(x) x$name, character(1))
}
matches <- depnames %in% rmnames
if (warnOnConflict && !is.character(remove)) {
for (loser in dependencies[matches]) {
winner <- remove[[head(rmnames == loser$name, 1)]]
if (compareVersion(loser$version, winner$version) > 0) {
warning(sprintf(paste("The dependency %s %s conflicts with",
"version %s"), loser$name, loser$version, winner$version
))
}
}
}
# Return only deps that weren't in remove
return(dependencies[!matches])
}
# Given a vector or list, drop all the NULL items in it
dropNulls <- function(x) {
x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}
nullOrEmpty <- function(x) {
length(x) == 0
}
# Given a vector or list, drop all the NULL or length-0 items in it
dropNullsOrEmpty <- function(x) {
x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
}
isResolvedTag <- function(x) {
inherits(x, "shiny.tag") && length(x$.renderHooks) == 0
}
isTag <- function(x) {
inherits(x, "shiny.tag")
}
#' @rdname print.html
#' @export
print.shiny.tag <- function(x, browse = is.browsable(x), ...) {
if (browse)
html_print(x)
else
print(HTML(as.character(x)), ...)
invisible(x)
}
# indent can be numeric to indicate an initial indent level,
# or FALSE to suppress
#' @export
format.shiny.tag <- function(x, ..., singletons = character(0), indent = 0) {
as.character(renderTags(x, singletons = singletons, indent = indent)$html)
}
#' @export
as.character.shiny.tag <- function(x, ...) {
as.character(renderTags(x)$html)
}
#' @export
as.character.html <- function(x, ...) {
as.vector(enc2utf8(x))
}
#' @export
print.shiny.tag.list <- function(x, ...) {
if (isTRUE(attr(x, "print.as.list", exact = TRUE))) {
attr(x, "print.as.list") <- NULL
class(x) <- setdiff(class(x), "shiny.tag.list")
return(print(x))
}
print.shiny.tag(x, ...)
}
#' @export
format.shiny.tag.list <- format.shiny.tag
#' @export
as.character.shiny.tag.list <- as.character.shiny.tag
#' Print method for HTML/tags
#'
#' S3 method for printing HTML that prints markup or renders HTML in a web
#' browser.
#'
#' @param x The value to print.
#' @param browse If `TRUE`, the HTML will be rendered and displayed in a
#' browser (or possibly another HTML viewer supplied by the environment via
#' the `viewer` option). If `FALSE` then the HTML object's markup
#' will be rendered at the console.
#' @param ... Additional arguments passed to print.
#'
#' @export
print.html <- function(x, ..., browse = is.browsable(x)) {
if (browse)
html_print(x)
else
cat(x, "\n", sep = "")
invisible(x)
}
#' @export
format.html <- function(x, ...) {
as.character(x)
}
normalizeText <- function(text) {
if (!is.null(attr(text, "html", TRUE)))
text
else
htmlEscape(text, attribute=FALSE)
}
#' Create a list of tags
#'
#' Create a `list()` of [tag]s with methods for [print()], [as.character()],
#' etc.
#'
#' @param ... A collection of [tag]s.
#' @export
#' @examples
#' tagList(
#' h1("Title"),
#' h2("Header text"),
#' p("Text here")
#' )
tagList <- function(...) {
lst <- dots_list(...)
class(lst) <- c("shiny.tag.list", "list")
return(lst)
}
#' Tag function
#'
#' Create 'lazily' rendered HTML [tags] (and/or [htmlDependencies()]).
#'
#' When possible, use [`tagAddRenderHook()`] to provide both a tag
#' structure and utilize a render function.
#'
#' @param func a function with no arguments that returns HTML tags and/or
#' dependencies.
#' @seealso [`tagAddRenderHook()`]
#' @export
#' @examples
#' myDivDep <- tagFunction(function() {
#' if (isTRUE(getOption("useDep", TRUE))) {
#' htmlDependency(
#' name = "lazy-dependency",
#' version = "1.0", src = ""
#' )
#' }
#' })
#' myDiv <- attachDependencies(div(), myDivDep)
#' renderTags(myDiv)
#' withr::with_options(list(useDep = FALSE), renderTags(myDiv))
#'
tagFunction <- function(func) {
if (!is.function(func) || length(formals(func)) != 0) {
stop("`func` must be a function with no arguments")
}
structure(func, class = "shiny.tag.function")
}
#' Modify a tag prior to rendering
#'
#' Adds a hook to call on a [tag()] object when it is is rendered as HTML (with,
#' for example, [print()], [renderTags()], [as.tags()], etc).
#'
#' The primary motivation for [tagAddRenderHook()] is to create tags that can
#' change their attributes (e.g., change CSS classes) depending upon the context
#' in which they're rendered (e.g., use one set of CSS classes in one a page
#' layout, but a different set in another page layout). In this situation,
#' [tagAddRenderHook()] is preferable to [tagFunction()] since the latter is more a
#' "black box" in the sense that you don't know anything about the tag structure
#' until it's rendered.
#'
#' @param tag A [`tag()`] object.
#' @param func A function (_hook_) to call when the `tag` is rendered. This function
#' should have at least one argument (the `tag`) and return anything that can
#' be converted into tags via [as.tags()].
#' @param replace If `TRUE`, the previous hooks will be removed. If `FALSE`,
#' `func` is appended to the previous hooks.
#' @return A [tag()] object with a `.renderHooks` field containing a list of functions
#' (e.g. `func`). When the return value is _rendered_ (such as with [`as.tags()`]),
#' these functions will be called just prior to writing the HTML.
#' @export
#' @seealso [tagFunction()]
#' @examples
#' # Have a place holder div and return a span instead
#' obj <- div("example", .renderHook = function(x) {
#' x$name <- "span"
#' x
#' })
#' obj$name # "div"
#' print(obj) # Prints as a `span`
#'
#' # Add a class to the tag
#' # Should print a `span` with class `"extra"`
#' spanExtra <- tagAddRenderHook(obj, function(x) {
#' tagAppendAttributes(x, class = "extra")
#' })
#' spanExtra
#'
#' # Replace the previous render method
#' # Should print a `div` with class `"extra"`
#' divExtra <- tagAddRenderHook(obj, replace = TRUE, function(x) {
#' tagAppendAttributes(x, class = "extra")
#' })
#' divExtra
#'
#' # Add more child tags
#' spanExtended <- tagAddRenderHook(obj, function(x) {
#' tagAppendChildren(x, " ", tags$strong("bold text"))
#' })
#' spanExtended
#'
#' # Add a new html dependency
#' newDep <- tagAddRenderHook(obj, function(x) {
#' fa <- htmlDependency(
#' "font-awesome", "4.5.0", c(href="shared/font-awesome"),
#' stylesheet = "css/font-awesome.min.css")
#' attachDependencies(x, fa, append = TRUE)
#' })
#' # Also add a jqueryui html dependency
#' htmlDependencies(newDep) <- htmlDependency(
#' "jqueryui", "1.11.4", c(href="shared/jqueryui"),
#' script = "jquery-ui.min.js")
#' # At render time, both dependencies will be found
#' renderTags(newDep)$dependencies
#'
#' # Ignore the original tag and return something completely new.
#' newObj <- tagAddRenderHook(obj, function(x) {
#' tags$p("Something else")
#' })
#' newObj
tagAddRenderHook <- function(tag, func, replace = FALSE) {
if (!is.function(func) || length(formals(func)) == 0) {
stop("`func` must be a function that accepts at least 1 argument")
}
tag$.renderHooks <-
if (isTRUE(replace)) {
list(func)
} else {
append(tag$.renderHooks, list(func))
}
tag
}
#' Append tag attributes
#'
#' Append (`tagAppendAttributes()`), check existence (`tagHasAttribute()`),
#' and obtain the value (`tagGetAttribute()`) of HTML attribute(s).
#'
#' @export
#' @param tag a [tag] object.
#' @param ... Attributes to append as named argument-value pairs. A named
#' argument with an `NA` value is rendered as a boolean attribute (see
#' example).
#' @param .cssSelector A character string containing a [CSS
#' selector](https://developer.mozilla.org/en-US/docs/Learn/CSS/Building_blocks/Selectors)
#' for targeting particular (inner) tags of interest. At the moment, only a
#' combination of
#' [type](https://www.w3.org/TR/CSS22/selector.html#type-selectors) (e.g,
#' `div`), [class](https://www.w3.org/TR/CSS22/selector.html#class-html)
#' (e.g., `.my-class`),
#' [id](https://www.w3.org/TR/CSS22/selector.html#id-selectors) (e.g.,
#' `#myID`), and
#' [universal](https://www.w3.org/TR/CSS22/selector.html#universal-selector)
#' (`*`) selectors within a given [simple
#' selector](https://www.w3.org/TR/CSS22/selector.html#selector-syntax) is
#' supported. Note, if `.cssSelector` is used, the returned tags will have
#' their `$children` fields flattened to a single `list()` via [`tagQuery()`].
#' @seealso [tagAppendChildren()], [tagQuery()]
#' @examples
#' html <- div(a())
#' tagAppendAttributes(html, class = "foo")
#' tagAppendAttributes(html, .cssSelector = "a", class = "bar")
#' tagAppendAttributes(html, contenteditable = NA)
#'
#' tagHasAttribute(div(foo = "bar"), "foo")
#' tagGetAttribute(div(foo = "bar"), "foo")
#'
tagAppendAttributes <- function(tag, ..., .cssSelector = NULL) {
throw_if_tag_function(tag)
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
addAttrs(...)$
allTags()
)
}
newAttribs <- dropNullsOrEmpty(dots_list(...))
if (any(!nzchar(names2(newAttribs)))) {
stop(
"At least one of the new attribute values did not have a name.\n",
"Did you forget to include an attribute name?"
)
}
tag$attribs <- c(tag$attribs, newAttribs)
tag
}
#' @rdname tagAppendAttributes
#' @param attr The name of an attribute.
#' @export
tagHasAttribute <- function(tag, attr) {
throw_if_tag_function(tag)
result <- attr %in% names(tag$attribs)
result
}
#' @rdname tagAppendAttributes
#' @export
tagGetAttribute <- function(tag, attr) {
throw_if_tag_function(tag)
# Find out which positions in the attributes list correspond to the given attr
attribs <- tag$attribs
attrIdx <- which(attr == names(attribs))
if (length(attrIdx) == 0) {
return (NULL)
}
result <- attribs[attrIdx]
# Remove NA values or return a single NA value
if (anyNA(result)) {
na_idx <- is.na(result)
if (all(na_idx)) {
return(NA)
}
result <- result[!na_idx]
}
if (all(vapply(result, is.atomic, logical(1)))) {
# Convert all attribs to chars explicitly; prevents us from messing up factors
# Separate multiple attributes with the same name
vals <- vapply(result, function(val) {
val <- as.character(val)
# Combine vector values if they exist
if (length(val) > 1) {
val <- paste0(val, collapse = " ")
}
val
}, character(1))
result <- paste0(vals, collapse = " ")
} else {
# When retrieving values that are not atomic, return a list of values
names(result) <- NULL
}
result
}
#' Modify tag contents
#'
#' Modify the contents (aka children) of a [tag] object.
#'
#' @inheritParams tagAppendAttributes
#' @param child A child element to append to a parent tag.
#' @export
#' @seealso [tagAppendAttributes()], [tagQuery()]
#' @examples
#' html <- div(a(), h1())
#' tagAppendChild(html, span())
#' tagAppendChild(html, .cssSelector = "a", span())
#'
#' tagAppendChildren(html, span(), p())
#' tagAppendChildren(html, .cssSelector = "a", span(), p())
#'
#' tagSetChildren(html, span(), p())
#'
#' tagInsertChildren(html, after = 1, span(), p())
#'
tagAppendChild <- function(tag, child, .cssSelector = NULL) {
throw_if_tag_function(tag)
if (!is.null(.cssSelector)) {
return(
tagAppendChildren(tag, child, .cssSelector = .cssSelector)
)
}
tag$children[[length(tag$children)+1]] <- child
tag
}
#' @rdname tagAppendChild
#' @param ... a collection of `child` elements.
#' @param list Deprecated. Use `!!!` instead to splice into `...`.
#' @export
tagAppendChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
append(!!!children)$
allTags()
)
}
tag$children <- unname(c(tag$children, children))
tag
}
#' @rdname tagAppendChild
#' @export
tagSetChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
empty()$
append(!!!children)$
allTags()
)
}
tag$children <- children
tag
}
#' @rdname tagAppendChild
#' @param after an integer value (i.e., subscript) referring to the child position to append after.
#' @export
tagInsertChildren <- function(tag, after, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
each(function(x, i) {
tagInsertChildren(x, after = after, !!!children)
})$
allTags()
)
}
tag$children <- unname(append(tag$children, children, after))
tag
}
throw_if_tag_function <- function(tag) {
if (is_tag_function(tag))
stop("`tag` can not be a `tagFunction()`")
}
# Use `known_tags` from `known_tags.R`
# Then remove `known_tags` once done creating tag functions
#' @include known_tags.R
names(known_tags) <- known_tags
#' Create HTML tags
#'
#' Create an R object that represents an HTML tag. For convenience, common HTML
#' tags (e.g., `<div>`) can be created by calling for their tag name directly
#' (e.g., `div()`). To create less common HTML5 (or SVG) tags (e.g.,
#' `<article>`), use the `tags` list collection (e.g., `tags$article()`). To
#' create other non HTML/SVG tags, use the lower-level `tag()` constructor.
#'
#' @name builder
#' @param ... Tag attributes (named arguments) and children (unnamed arguments).
#' A named argument with an `NA` value is rendered as a boolean attributes
#' (see example). Children may include any combination of:
#' * Other tags objects
#' * [HTML()] strings
#' * [htmlDependency()]s
#' * Single-element atomic vectors
#' * `list()`s containing any combination of the above
#' @return A `list()` with a `shiny.tag` class that can be converted into an
#' HTML string via `as.character()` and saved to a file with `save_html()`.
#' @seealso [tagList()], [withTags()], [tagAppendAttributes()], [tagQuery()]
#' @examples
#' tags$html(
#' tags$head(
#' tags$title('My first page')
#' ),
#' tags$body(
#' h1('My first heading'),
#' p('My first paragraph, with some ', strong('bold'), ' text.'),
#' div(
#' id = 'myDiv', class = 'simpleDiv',
#' 'Here is a div with some attributes.'
#' )
#' )
#' )
#'
#' # html5 <audio> with boolean control attribute
#' # https://www.w3.org/TR/html5/infrastructure.html#sec-boolean-attributes
#' tags$audio(
#' controls = NA,
#' tags$source(
#' src = "myfile.wav",
#' type = "audio/wav"
#' )
#' )
#'
#' # suppress the whitespace between tags
#' tags$span(
#' tags$strong("I'm strong", .noWS="outside")
#' )
#'
NULL
#' @rdname builder
#' @format NULL
#' @docType NULL
#' @keywords NULL
#' @export
tags <- lapply(known_tags, function(tagname) {
# Overwrite the body with the `tagname` value injected into the body
new_function(
args = exprs(... = , .noWS = NULL, .renderHook = NULL),
expr({
validateNoWS(.noWS)
contents <- dots_list(...)
tag(!!tagname, contents, .noWS = .noWS, .renderHook = .renderHook)
}),
env = asNamespace("htmltools")
)
})
# known_tags is no longer needed, so remove it.
rm(known_tags)
#' @rdname builder
#' @export
p <- tags$p
#' @rdname builder
#' @export
h1 <- tags$h1
#' @rdname builder
#' @export
h2 <- tags$h2
#' @rdname builder
#' @export
h3 <- tags$h3
#' @rdname builder
#' @export
h4 <- tags$h4
#' @rdname builder
#' @export
h5 <- tags$h5
#' @rdname builder
#' @export
h6 <- tags$h6
#' @rdname builder
#' @export
a <- tags$a
#' @rdname builder
#' @export
br <- tags$br
#' @rdname builder
#' @export
div <- tags$div
#' @rdname builder
#' @export
span <- tags$span
#' @rdname builder
#' @export
pre <- tags$pre
#' @rdname builder
#' @export
code <- tags$code
#' @rdname builder
#' @export
img <- tags$img
#' @rdname builder
#' @export
strong <- tags$strong
#' @rdname builder
#' @export
em <- tags$em
#' @rdname builder
#' @export
hr <- tags$hr
#' @rdname builder
#' @param _tag_name A character string to use for the tag name.
#' @param varArgs List of tag attributes and children.
#' @param .noWS Character vector used to omit some of the whitespace that would
#' normally be written around this tag. Valid options include `before`,
#' `after`, `outside`, `after-begin`, and `before-end`.
#' Any number of these options can be specified.
#' @param .renderHook A function (or list of functions) to call when the `tag` is rendered. This
#' function should have at least one argument (the `tag`) and return anything
#' that can be converted into tags via [as.tags()]. Additional hooks may also be
#' added to a particular `tag` via [tagAddRenderHook()].
#' @export
tag <- function(`_tag_name`, varArgs, .noWS = NULL, .renderHook = NULL) {
validateNoWS(.noWS)
# Get arg names; if not a named list, use vector of empty strings
varArgsNames <- names2(varArgs)
# Named arguments become attribs, dropping NULL and length-0 values
named_idx <- nzchar(varArgsNames)
attribs <- dropNullsOrEmpty(varArgs[named_idx])
# Unnamed arguments are flattened and added as children.
# Use unname() to remove the names attribute from the list, which would
# consist of empty strings anyway.
children <- unname(varArgs[!named_idx])
st <- list(name = `_tag_name`,
attribs = attribs,
children = children)
# Conditionally include the `.noWS` field.
# We do this to avoid breaking the hashes of existing tags that weren't leveraging .noWS.
if (!is.null(.noWS)) {
st$.noWS <- .noWS
}
# Conditionally include the `.renderHooks` field.
# We do this to avoid breaking the hashes of existing tags that weren't leveraging .renderHooks.
if (!is.null(.renderHook)) {
if (!is.list(.renderHook)) {
.renderHook <- list(.renderHook)
}
st$.renderHooks <- .renderHook
}
# Return tag data structure
structure(st, class = "shiny.tag")
}
isTagList <- function(x) {
is.list(x) && (inherits(x, "shiny.tag.list") || identical(class(x), "list"))
}
noWSOptions <- c("before", "after", "after-begin", "before-end", "outside", "inside")
# Ensure that the provided `.noWS` string contains only valid options
validateNoWS <- function(.noWS) {
if (!all(.noWS %in% noWSOptions)) {
stop("Invalid .noWS option(s) '", paste(.noWS, collapse="', '") ,"' specified.")
}
}
#' @include utils.R
tagWrite <- function(tag, textWriter, indent=0, eol = "\n") {
if (length(tag) == 0)
return (NULL)
# optionally process a list of tags
if (!isTag(tag) && isTagList(tag)) {
tag <- dropNullsOrEmpty(flattenTags(tag))
lapply(tag, tagWrite, textWriter, indent)
return (NULL)
}
nextIndent <- if (is.numeric(indent)) indent + 1 else indent
indent <- if (is.numeric(indent)) indent else 0
# compute indent text
indentText <- paste(rep(" ", indent*2), collapse="")
textWriter$writeWS(indentText)
# Check if it's just text (may either be plain-text or HTML)
if (is.character(tag)) {
.noWS <- attr(tag, "noWS", exact = TRUE)
if ("before" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$write(normalizeText(tag))
if ("after" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$writeWS(eol)
return (NULL)
}
.noWS <- tag$.noWS
if ("before" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
# write tag name
textWriter$write(concat8("<", tag$name))
# Convert all attribs to chars explicitly; prevents us from messing up factors
attribs <- flattenTagAttribs(lapply(tag$attribs, as.character))
attribNames <- names2(attribs)
if (any(!nzchar(attribNames))) {
# Can not display attrib without a key
stop(
"A tag's attribute value did not have a name.\n",
"Did you forget to name all of your attribute values?"
)
}
# write attributes
for (attrib in attribNames) {
attribValue <- attribs[[attrib]]
if (length(attribValue) > 1) {
attribValue <- concat8(attribValue, collapse = " ")
}
if (!is.na(attribValue)) {
if (is.logical(attribValue)) {
attribValue <- tolower(attribValue)
}
text <- htmlEscape(attribValue, attribute=TRUE)
textWriter$write(concat8(" ", attrib,"=\"", text, "\""))
}
else {
textWriter$write(concat8(" ", attrib))
}
}
# write any children
children <- dropNullsOrEmpty(flattenTags(tag$children))
if (length(children) > 0) {
textWriter$write(">")
# special case for a single child text node (skip newlines and indentation)
if ((length(children) == 1) && is.character(children[[1]]) ) {
textWriter$write(concat8(normalizeText(children[[1]]), "</", tag$name, ">"))
}
else {
if ("after-begin" %in% .noWS || "inside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$writeWS("\n")
for (child in children)
tagWrite(child, textWriter, nextIndent)
textWriter$writeWS(indentText)
if ("before-end" %in% .noWS || "inside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$write(concat8("</", tag$name, ">"))
}
}
else {
# only self-close void elements
# (see: http://dev.w3.org/html5/spec/single-page.html#void-elements)
if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr",
"img", "input", "keygen", "link", "meta", "param",
"source", "track", "wbr")) {
textWriter$write("/>")
}
else {
textWriter$write(concat8("></", tag$name, ">"))
}
}
if ("after" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$writeWS(eol)
}
#' Render tags into HTML
#'
#' Renders tags (and objects that can be converted into tags using
#' [as.tags()]) into HTML. (Generally intended to be called from web
#' framework libraries, not directly by most users--see
#' [print.html()] for higher level rendering.)
#'
#' @param x Tag object(s) to render
#' @param singletons A list of [singleton] signatures to consider already
#' rendered; any matching singletons will be dropped instead of rendered.
#' (This is useful (only?) for incremental rendering.)
#' @param indent Initial indent level, or `FALSE` if no indentation should
#' be used.
#'
#' @return `renderTags` returns a list with the following variables:
#' * `head`: An [HTML()] string that should be included in `<head>`.
#' * `singletons`: Character vector of singleton signatures that are
#' known after rendering.
#' * `dependencies`: A list of [resolved][resolveDependencies] [htmlDependency()] objects.
#' * `html`: An [HTML()] string that represents the main HTML that was rendered.
#'
#' @export
renderTags <- function(x, singletons = character(0), indent = 0) {
x <- tagify(x)
# Do singleton and head processing before rendering
singletonInfo <- takeSingletons(x, singletons)
headInfo <- takeHeads(singletonInfo$ui)
deps <- resolveDependencies(findDependencies(singletonInfo$ui, tagify = FALSE))
headIndent <- if (is.numeric(indent)) indent + 1 else indent
headHtml <- doRenderTags(headInfo$head, indent = headIndent)
bodyHtml <- doRenderTags(headInfo$ui, indent = indent)
return(list(head = headHtml,
singletons = singletonInfo$singletons,
dependencies = deps,
html = bodyHtml))
}
#' @details `doRenderTags` is intended for very low-level use; it ignores
#' render hooks, singletons, head, and dependency handling, and simply renders the given tag
#' objects as HTML. Please use `renderTags()` if `x` has not already handled its dependencies
#' and render hooks.
#' @return `doRenderTags` returns a simple [HTML()] string.
#' @rdname renderTags
#' @export
doRenderTags <- function(x, indent = 0) {
assertNotTagEnvLike(x, "doRenderTags")
textWriter <- WSTextWriter()
tagWrite(x, textWriter, indent)
# Strip off trailing \n (if present?)
textWriter$eatWS()
HTML(textWriter$readAll())
}
# Walk a tree of tag objects, rewriting objects according to func.
# preorder=TRUE means preorder tree traversal, that is, an object
# should be rewritten before its children.
rewriteTags <- function(ui, func, preorder) {
assertNotTagEnvLike(ui, "rewriteTags")
if (preorder)
ui <- func(ui)
if (isTag(ui)) {
ui$children[] <- lapply(ui$children, rewriteTags, func, preorder)
} else if (isTagList(ui)) {
ui[] <- lapply(ui, rewriteTags, func, preorder)
}
if (!preorder)
ui <- func(ui)
return(ui)
}
#' Singleton manipulation functions
#'
#' Functions for manipulating [singleton()] objects in tag
#' hierarchies. Intended for framework authors.
#'
#' @rdname singleton_tools
#' @name singleton_tools
NULL
#' @param ui Tag object or lists of tag objects. See [builder] topic.
#' @return `surroundSingletons` preprocesses a tag object by changing any
#' singleton X into `<!--SHINY.SINGLETON[sig]-->X'<!--/SHINY.SINGLETON[sig]-->`
#' where sig is the sha1 of X, and X' is X minus the singleton attribute.
#' @rdname singleton_tools
#' @export
surroundSingletons <- local({
# In the case of nested singletons, outer singletons are processed
# before inner singletons (otherwise the processing of inner
# singletons would cause the sha1 of the outer singletons to be
# different).
surroundSingleton <- function(uiObj) {
if (is.singleton(uiObj)) {
sig <- digest(uiObj, "sha1")
uiObj <- singleton(uiObj, FALSE)
return(tagList(
HTML(sprintf("<!--SHINY.SINGLETON[%s]-->", sig)),
uiObj,
HTML(sprintf("<!--/SHINY.SINGLETON[%s]-->", sig))
))
} else {
uiObj
}
}
function(ui) {
rewriteTags(ui, surroundSingleton, TRUE)
}
})
#' @param singletons Character vector of singleton signatures that have already
#' been encountered (i.e. returned from previous calls to
#' `takeSingletons`).
#' @param desingleton Logical value indicating whether singletons that are
#' encountered should have the singleton attribute removed.
#' @return `takeSingletons` returns a list with the elements `ui` (the
#' processed tag objects with any duplicate singleton objects removed) and
#' `singletons` (the list of known singleton signatures).
#' @rdname singleton_tools
#' @export
takeSingletons <- function(ui, singletons=character(0), desingleton=TRUE) {
result <- rewriteTags(ui, function(uiObj) {
if (is.singleton(uiObj)) {
sig <- digest(uiObj, "sha1")
if (sig %in% singletons)
return(NULL)
singletons <<- append(singletons, sig)
if (desingleton)
uiObj <- singleton(uiObj, FALSE)
return(uiObj)
} else {
return(uiObj)
}
}, TRUE)
return(list(ui=result, singletons=singletons))
}
# Given a tag object, extract out any children of tags$head
# and return them separate from the body.
takeHeads <- function(ui) {
headItems <- list()
result <- rewriteTags(ui, function(uiObj) {
if (isTag(uiObj) && tolower(uiObj$name) == "head") {
headItems <<- append(headItems, uiObj$children)
return(NULL)
}
return(uiObj)
}, FALSE)
return(list(ui=result, head=headItems))
}
#' Collect attached dependencies from HTML tag object
#'
#' Walks a hierarchy of tags looking for attached dependencies.
#'
#' @param tags A tag-like object to search for dependencies.
#' @param tagify Whether to tagify the input before searching for dependencies.
#'
#' @return A list of [htmlDependency()] objects.
#'
#' @export
findDependencies <- function(tags, tagify = TRUE) {
if (isTRUE(tagify)) {
tags <- tagify(tags)
}
deps <- resolveFunctionalDependencies(htmlDependencies(tags))
children <- if (is.list(tags)) {
if (isTag(tags)) {
tags$children
} else {
tags
}
}
childDeps <- unlist(lapply(children, findDependencies, tagify = FALSE), recursive = FALSE, use.names = FALSE)
c(childDeps, deps)
}
#' Resolves any [tagFunction()]s inside a list of [htmlDependencies()]. To
#' resolve [tagFunction()]s _and then_ remove redundant dependencies all at once,
#' use [resolveDependencies()] (which calls this function internally).
#' @noRd
resolveFunctionalDependencies <- function(dependencies) {
if (!length(dependencies)) {
return(dependencies)
}
dependencies <- asDependencies(dependencies)
dependencies <- lapply(dependencies, function(dep) {
if (is_tag_function(dep)) {
dep <- dep()
}
if (isTag(dep) || inherits(dep, "shiny.tag.list")) {
warning(
"It appears attachDependencies() has been used to attach a tagFunction()",
"that returns a shiny.tag/shiny.tag.list, which is considered poor practice",
"since those tags will never actually get rendered", call. = FALSE
)
return(findDependencies(dep))
}
asDependencies(dep)
})
unlist(dependencies, recursive = FALSE, use.names = FALSE)
}
#' Mark Characters as HTML
#'
#' Marks the given text as HTML, which means the [tag] functions will know
#' not to perform HTML escaping on it.
#'
#' @param text The text value to mark with HTML
#' @param ... Any additional values to be converted to character and
#' concatenated together
#' @param .noWS Character vector used to omit some of the whitespace that would
#' normally be written around this HTML. Valid options include `before`,
#' `after`, and `outside` (equivalent to `before` and
#' `end`).
#' @return The input `text`, but marked as HTML.
#'
#' @examples
#' el <- div(HTML("I like <u>turtles</u>"))
#' cat(as.character(el))
#'
#' @export
HTML <- function(text, ..., .noWS = NULL) {
htmlText <- c(text, as.character(dots_list(...)))
htmlText <- paste8(htmlText, collapse=" ")
attr(htmlText, "html") <- TRUE
attr(htmlText, "noWS") <- .noWS
class(htmlText) <- c("html", "character")
htmlText
}
#' Evaluate an expression using `tags`
#'
#' This function makes it simpler to write HTML-generating code. Instead of
#' needing to specify `tags` each time a tag function is used, as in
#' `tags$div()` and `tags$p()`, code inside `withTags` is
#' evaluated with `tags` searched first, so you can simply use
#' `div()` and `p()`.
#'
#' If your code uses an object which happens to have the same name as an
#' HTML tag function, such as `source()` or `summary()`, it will call
#' the tag function. To call the intended (non-tags function), specify the
#' namespace, as in `base::source()` or `base::summary()`.
#'
#' @param code A set of tags.
#' @param .noWS Default whitespace behavior for all tags within this call to
#' `withTags()`. Setting `.noWS` on an individual tag fuction inside
#' `withTags()` will override the default. See [tag()] for complete options.
#'
#' @examples
#' # Using tags$ each time
#' tags$div(class = "myclass",
#' tags$h3("header"),
#' tags$p("text")
#' )
#'
#' # Equivalent to above, but using withTags
#' withTags(
#' div(class = "myclass",
#' h3("header"),
#' p("text")
#' )
#' )
#'
#' # Setting .noWS for all tags in withTags()
#' withTags(
#' div(
#' class = "myclass",
#' h3("header"),
#' p("One", strong(span("two")), "three")
#' ),
#' .noWS = c("outside", "inside")
#' )
#'
#'
#' @export
withTags <- function(code, .noWS = NULL) {
if (!is.null(.noWS)) {
.noWSWithTags <- .noWS
tags <- lapply(tags, function(tag) {
function(..., .noWS = .noWSWithTags) {
tag(..., .noWS = .noWS)
}
})
}
eval(substitute(code), envir = as.list(tags), enclos = parent.frame())
}
# Make sure any objects in the tree that can be converted to tags, have been
tagify <- function(x) {
rewriteTags(x, function(uiObj) {
if (isResolvedTag(uiObj) || isTagList(uiObj) || is.character(uiObj))
return(uiObj)
else
tagify(as.tags(uiObj))
}, FALSE)
}
# Given a list of tags, lists, and other items, return a flat list, where the
# items from the inner, nested lists are pulled to the top level, recursively.
# Be sure to check for tagEnvLike objects and not allow them
flattenTags <- function(x) {
assertNotTagEnvLike(x, "flattenTags")
if (isTag(x)) {
# For tags, wrap them into a list (which will be unwrapped by caller)
list(x)
} else if (isTagList(x)) {
if (length(x) == 0) {
# Empty lists are simply returned
x
} else {
# For items that are lists (but not tags), recurse
ret <- unlist(lapply(x, flattenTags), recursive = FALSE)
# Copy over attributes put on the original list (ex: html deps)
mostattributes(ret) <- attributes(x)
ret
}
} else if (is.character(x)){
# This will preserve attributes if x is a character with attribute,
# like what HTML() produces
list(x)
} else {
# For other items, coerce to character and wrap them into a list (which
# will be unwrapped by caller). Note that this will strip attributes.
flattenTags(as.tags(x))
}
}
# This method should be just like `flattenTags()`, except the final `else` will
# return `list(x)`, rather than calling `flattenTags(as.tags(x))`.
#
# By not calling `as.tags(x)`, tagFunctions are not evaluated and other items
# are not converted.
flattenTagsRaw <- function(x) {
relocateHtmlDeps <- function(z, type) {
zDeps <- htmlDependencies(z)
zDepsLen <- length(zDeps)
# Return early if there are no dependencies
if (zDepsLen == 0) return(z)
# Append the incoming html deps to z's children
# Perform position insert to not lose attrs on z/z$children
switch(type,
"tag" = {
children <- z[["children"]]
childrenLen <- length(children)
if (is.null(children)) {
z[["children"]] <- zDeps
} else {
z[["children"]][(childrenLen + 1):(childrenLen + zDepsLen)] <- zDeps
}
},
"tagList" = {
zLen <- length(z)
z[(zLen + 1):(zLen + zDepsLen)] <- zDeps
},
stop("unknown type: ", type)
)
# Remove html deps on z, as they are now in the children
htmlDependencies(z) <- NULL
z
}
if (isTagEnv(x)) {
# For tags, wrap them into a list (which will be unwrapped by caller)
list(x)
} else if (isTag(x)) {
# Append individual html deps as children elements.
# Attributes are eaisly lost when unlisted or collected.
# Instead, use the _newer_/stable approach of adding the html dep as a direct child
x <- relocateHtmlDeps(x, type = "tag")
# For tags, wrap them into a list (which will be unwrapped by caller)
list(x)
} else if (isTagList(x)) {
# For items that are lists (but not tags), recurse
ret <- unlist(lapply(x, flattenTagsRaw), recursive = FALSE)
# Copy over attributes put on the original list (ex: html deps, class)
mostattributes(ret) <- attributes(x)
# Append individual html deps into the final list from the flattened tags
# It does not work out well to add attributes to `ret`, as the html deps are not found by findDependencies()
# Instead, use the _newer_/stable approach of adding the html dep as a direct child
ret <- relocateHtmlDeps(ret, type = "tagList")
# Return the list of items
ret
} else {
# This will preserve attributes if x is a character with attribute,
# like what HTML() produces
list(x)
}
}
combineKeys <- function(x) {
if (anyNA(x)) {
na_idx <- is.na(x)
if (all(na_idx)) {
return(NA)
}
x <- x[!na_idx]
}
unlist(x, recursive = FALSE, use.names = FALSE)
}
# Do not adjust single values
# Only merge keys
flattenTagAttribs <- function(attribs) {
attribs <- dropNullsOrEmpty(attribs)
attribNames <- names(attribs)
if (anyDuplicated(attribNames)) {
uniqueAttribNames <- sort(unique(attribNames))
attribs <- lapply(uniqueAttribNames, function(name) {
obj <- attribs[attribNames == name]
combineKeys(obj)
})
names(attribs) <- uniqueAttribNames
}
attribs
}
#' Convert a value to tags
#'
#' An S3 method for converting arbitrary values to a value that can be used as
#' the child of a tag or `tagList`. The default implementation simply calls
#' [as.character()].
#'
#' @param x Object to be converted.
#' @param ... Any additional parameters.
#'
#' @export
as.tags <- function(x, ...) {
UseMethod("as.tags")
}
#' @export
as.tags.default <- function(x, ...) {
# Plain (non-classed) lists will hit as.tags.list(), but lists with a class
# will get here. (tagLists will already have been handled by
# as.tags.shiny.tag.list)
if (is.list(x)) {
tagList(!!!unclass(x))
} else {
tagList(as.character(x))
}
}
#' @export
as.tags.html <- function(x, ...) {
x
}
#' @export
as.tags.shiny.tag <- function(x, ...) {
if (isResolvedTag(x)) {
return(x)
}
hook <- x$.renderHooks[[1]]
# remove first hook
x$.renderHooks[[1]] <- NULL
# Recursively call as.tags on the updated object
# (Perform in two lines to avoid lazy arg evaluation issues)
y <- hook(x)
as.tags(y)
}
#' @export
as.tags.shiny.tag.list <- function(x, ...) {
x
}
#' @export
as.tags.shiny.tag.function <- function(x, ...) {
x()
}
#' @export
as.tags.list <- function(x, ...) {
# Only non-classed lists will hit this method
# (classed lists will reach the default method)
tagList(!!!x)
}
#' @export
as.tags.character <- function(x, ...) {
# For printing as.tags("<strong>") directly at console, without dropping any
# attached dependencies
tagList(x)
}
#' @export
as.tags.html_dependency <- function(x, ...) {
attachDependencies(tagList(), x)
}
#' Preserve HTML regions
#'
#' Use "magic" HTML comments to protect regions of HTML from being modified by
#' text processing tools.
#'
#' Text processing tools like markdown and pandoc are designed to turn
#' human-friendly markup into common output formats like HTML. This works well
#' for most prose, but components that generate their own HTML may break if
#' their markup is interpreted as the input language. The `htmlPreserve`
#' function is used to mark regions of an input document as containing pure HTML
#' that must not be modified. This is achieved by substituting each such region
#' with a benign but unique string before processing, and undoing those
#' substitutions after processing.
#'
#' @param x A character vector of HTML to be preserved.
#'
#' @return `htmlPreserve` returns a single-element character vector with
#' "magic" HTML comments surrounding the original text (unless the original
#' text was empty, in which case an empty string is returned).
#'
#' @examples
#' # htmlPreserve will prevent "<script>alert(10*2*3);</script>"
#' # from getting an <em> tag inserted in the middle
#' markup <- paste(sep = "\n",
#' "This is *emphasized* text in markdown.",
#' htmlPreserve("<script>alert(10*2*3);</script>"),
#' "Here is some more *emphasized text*."
#' )
#' extracted <- extractPreserveChunks(markup)
#' markup <- extracted$value
#' # Just think of this next line as Markdown processing
#' output <- gsub("\\*(.*?)\\*", "<em>\\1</em>", markup)
#' output <- restorePreserveChunks(output, extracted$chunks)
#' output
#'
#' @export
htmlPreserve <- function(x) {
html_preserve(x, inline = "auto")
}
html_preserve <- function(x, inline = "auto") {
x <- paste(x, collapse = "\n")
# Do nothing for empty string
if (!nzchar(x)) {
return(x)
}
# rmarkdown sets this option to TRUE to leverage various benefits
# that come with preserving HTML via pandoc 2.0's raw attribute feature
# https://github.com/rstudio/rmarkdown/pull/1965#issuecomment-734804176
if (!getOption("htmltools.preserve.raw", FALSE)) {
return(sprintf("<!--html_preserve-->%s<!--/html_preserve-->", x))
}
# With no other context, the presence of line break(s) determines whether a
# block or inline code chunk is used for pandoc's raw attributes (the inline
# version may add an additional <p> tag around the HTML (which can be
# problematic, for instance, when embedding shiny inside flexdashboard)
# Thankfully knitr::knit_print() can tell us whether we're inside a inline
# code which is why this is here essentially just for non-knit usage
# https://github.com/rstudio/flexdashboard/issues/379
# https://github.com/rstudio/rmarkdown/issues/2259#issuecomment-995996958
if (identical(inline, "auto")) {
inline <- grepl(x, "\n", fixed = TRUE)
}
if (inline) {
sprintf("`%s`{=html}", x)
} else {
sprintf("\n```{=html}\n%s\n```\n", x)
}
}
# Temporarily set x in env to value, evaluate expr, and
# then restore x to its original state
withTemporary <- function(env, x, value, expr, unset = FALSE) {
if (exists(x, envir = env, inherits = FALSE)) {
oldValue <- get(x, envir = env, inherits = FALSE)
on.exit(
assign(x, oldValue, envir = env, inherits = FALSE),
add = TRUE)
} else {
on.exit(
rm(list = x, envir = env, inherits = FALSE),
add = TRUE
)
}
if (!missing(value) && !isTRUE(unset))
assign(x, value, envir = env, inherits = FALSE)
else {
if (exists(x, envir = env, inherits = FALSE))
rm(list = x, envir = env, inherits = FALSE)
}
force(expr)
}
# Evaluate an expression using Shiny's own private stream of
# randomness (not affected by set.seed).
withPrivateSeed <- local({
ownSeed <- NULL
function(expr) {
withTemporary(.GlobalEnv, ".Random.seed",
ownSeed, unset=is.null(ownSeed), {
tryCatch({
expr
}, finally = {ownSeed <<- .Random.seed})
}
)
}
})
# extract_preserve_chunks looks for regions in strval marked by
# <!--html_preserve-->...<!--/html_preserve--> and replaces each such region
# with a long unique ID. The return value is a list with $value as the string
# with the regions replaced, and $chunks as a named character vector where the
# names are the IDs and the values are the regions that were extracted.
#
# Nested regions are handled appropriately; the outermost region is what's used
# and any inner regions simply have their boundaries removed before the values
# are stashed in $chunks.
#' @return `extractPreserveChunks` returns a list with two named elements:
#' `value` is the string with the regions replaced, and `chunks` is
#' a named character vector where the names are the IDs and the values are the
#' regions that were extracted.
#' @rdname htmlPreserve
#' @export
extractPreserveChunks <- function(strval) {
# Literal start/end marker text. Case sensitive.
startmarker <- "<!--html_preserve-->"
endmarker <- "<!--/html_preserve-->"
# Start and end marker length MUST be different, it's how we tell them apart
startmarker_len <- nchar(startmarker)
endmarker_len <- nchar(endmarker)
# Pattern must match both start and end markers
pattern <- "<!--/?html_preserve-->"
# It simplifies string handling greatly to collapse multiple char elements
if (length(strval) != 1)
strval <- paste(strval, collapse = "\n")
# matches contains the index of all the start and end markers
startmatches <- gregexpr(startmarker, strval, fixed = TRUE)[[1]]
endmatches <- gregexpr(endmarker, strval, fixed = TRUE)[[1]]
matches <- c(startmatches, endmatches)
o <- order(matches)
matches <- matches[o]
lengths <- c(
attr(startmatches, "match.length", TRUE),
attr(endmatches, "match.length", TRUE)
)[o]
# No markers? Just return.
if (unique(matches)[[1]] == -1)
return(list(value = strval, chunks = character(0)))
# If TRUE, it's a start; if FALSE, it's an end
boundary_type <- lengths == startmarker_len
# Positive number means we're inside a region, zero means we just exited to
# the top-level, negative number means error (an end without matching start).
# For example:
# boundary_type - TRUE TRUE FALSE FALSE TRUE FALSE
# preserve_level - 1 2 1 0 1 0
preserve_level <- cumsum(ifelse(boundary_type, 1, -1))
# Sanity check.
if (any(preserve_level < 0) || tail(preserve_level, 1) != 0) {
stop("Invalid nesting of html_preserve directives")
}
# Identify all the top-level boundary markers. We want to find all of the
# elements of preserve_level whose value is 0 and preceding value is 1, or
# whose value is 1 and preceding value is 0. Since we know that preserve_level
# values can only go up or down by 1, we can simply shift preserve_level by
# one element and add it to preserve_level; in the result, any value of 1 is a
# match.
is_top_level <- 1 == (preserve_level + c(0, preserve_level[-length(preserve_level)]))
preserved <- character(0)
top_level_matches <- matches[is_top_level]
# Iterate backwards so string mutation doesn't screw up positions for future
# iterations
for (i in seq.int(length(top_level_matches) - 1, 1, by = -2)) {
start_outer <- top_level_matches[[i]]
start_inner <- start_outer + startmarker_len
end_inner <- top_level_matches[[i+1]]
end_outer <- end_inner + endmarker_len
id <- withPrivateSeed(
paste("preserve", paste(
format(as.hexmode(sample(256, 8, replace = TRUE)-1), width=2),
collapse = ""),
sep = "")
)
preserved[id] <- gsub(pattern, "", substr(strval, start_inner, end_inner-1))
strval <- paste(
substr(strval, 1, start_outer - 1),
id,
substr(strval, end_outer, nchar(strval)),
sep="")
substr(strval, start_outer, end_outer-1) <- id
}
list(value = strval, chunks = preserved)
}
#' @param strval Input string from which to extract/restore chunks.
#' @param chunks The `chunks` element of the return value of
#' `extractPreserveChunks`.
#' @return `restorePreserveChunks` returns a character vector with the
#' chunk IDs replaced with their original values.
#' @rdname htmlPreserve
#' @export
restorePreserveChunks <- function(strval, chunks) {
strval <- enc2utf8(strval)
chunks <- enc2utf8(chunks)
for (id in names(chunks))
strval <- gsub(id, chunks[[id]], strval, fixed = TRUE, useBytes = TRUE)
Encoding(strval) <- 'UTF-8'
strval
}
#' Knitr S3 methods
#'
#' These S3 methods are necessary to allow HTML tags to print themselves in
#' knitr/rmarkdown documents.
#'
#' @name knitr_methods
#' @param x Object to knit_print
#' @param ... Additional knit_print arguments
#' @param inline Whether or not the code chunk is inline.
NULL
#' @rdname knitr_methods
#' @export
knit_print.shiny.tag <- function(x, ..., inline = FALSE) {
x <- tagify(x)
output <- surroundSingletons(x)
deps <- resolveDependencies(findDependencies(x, tagify = FALSE), resolvePackageDir = FALSE)
content <- takeHeads(output)
head_content <- doRenderTags(tagList(content$head))
meta <- if (length(head_content) > 1 || head_content != "") {
list(structure(head_content, class = "shiny_head"))
}
meta <- c(meta, deps)
knitr::asis_output(
html_preserve(format(content$ui, indent=FALSE), inline),
meta = meta)
}
#' @rdname knitr_methods
#' @export
knit_print.html <- function(x, ..., inline = FALSE) {
deps <- resolveDependencies(findDependencies(x, tagify = FALSE))
knitr::asis_output(html_preserve(as.character(x), inline),
meta = if (length(deps)) list(deps))
}
#' @rdname knitr_methods
#' @export
knit_print.shiny.tag.list <- knit_print.shiny.tag
#' @rdname knitr_methods
#' @export
knit_print.html_dependency <- knit_print.shiny.tag
#' Include Content From a File
#'
#' Load HTML, text, or rendered Markdown from a file and turn into HTML.
#'
#' These functions provide a convenient way to include an extensive amount of
#' HTML, textual, Markdown, CSS, or JavaScript content, rather than using a
#' large literal R string.
#'
#' @param path The path of the file to be included. It is highly recommended to
#' use a relative path (the base path being the Shiny application directory),
#' not an absolute path.
#'
#' @rdname include
#' @name include
#' @aliases includeHTML
#' @export
includeHTML <- function(path) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
if (detect_html_document(lines)) {
rlang::warn(c(
"`includeHTML()` was provided a `path` that appears to be a complete HTML document.",
"x" = paste("Path:", path),
"i" = paste(
"Use `tags$iframe()` to include an HTML document.",
"You can either ensure `path` is accessible in your app or document",
"(see e.g. `shiny::addResourcePath()`) and pass the relative path to",
"the `src` argument. Or you can read the contents of `path` and pass",
"the contents to `srcdoc`."
)
))
}
return(HTML(paste8(lines, collapse='\n')))
}
detect_html_document <- function(lines) {
if (length(lines) > 1) {
lines <- paste8(lines, collapse = "\n")
}
lines <- trimws(lines)
# A complete html document starts with doctype declaration or opening <html>
if (!grepl("^<!DOCTYPE html>|<html", lines, ignore.case = TRUE)) {
return(FALSE)
}
# and ends by closing the `</html>` tag
if (!grepl("</html>$", lines, ignore.case = TRUE)) {
return(FALSE)
}
# There are more requirements for the HTML document to be technically complete
# and valid, but the above conditions are sufficient for us to warn that the
# document should not be treated as an HTML fragment.
TRUE
}
#' @note `includeText` escapes its contents, but does no other processing.
#' This means that hard breaks and multiple spaces will be rendered as they
#' usually are in HTML: as a single space character. If you are looking for
#' preformatted text, wrap the call with [pre()], or consider using
#' `includeMarkdown` instead.
#'
#' @rdname include
#' @export
includeText <- function(path) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
return(paste8(lines, collapse='\n'))
}
#' @note The `includeMarkdown` function requires the `markdown`
#' package.
#' @rdname include
#' @export
includeMarkdown <- function(path) {
# markdown >= v1.3 switched from markdownToHTML() to mark()
html <- if (packageVersion("markdown") < "1.3") {
markdown::markdownToHTML(path, fragment.only = TRUE)
} else {
markdown::mark(path, output = NULL)
}
Encoding(html) <- 'UTF-8'
return(HTML(html))
}
#' @param ... Any additional attributes to be applied to the generated tag.
#' @rdname include
#' @export
includeCSS <- function(path, ...) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
args <- dots_list(...)
if (is.null(args$type))
args$type <- 'text/css'
return(do.call(tags$style,
c(list(HTML(paste8(lines, collapse='\n'))), args)))
}
#' @rdname include
#' @export
includeScript <- function(path, ...) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
return(tags$script(HTML(paste8(lines, collapse='\n')), ...))
}
#' Include content only once
#'
#' Use `singleton` to wrap contents (tag, text, HTML, or lists) that should
#' be included in the generated document only once, yet may appear in the
#' document-generating code more than once. Only the first appearance of the
#' content (in document order) will be used.
#'
#' @param x A [tag()], text, [HTML()], or list.
#' @param value Whether the object should be a singleton.
#'
#' @export
singleton <- function(x, value = TRUE) {
attr(x, "htmltools.singleton") <- if (isTRUE(value)) TRUE else NULL
return(x)
}
#' @rdname singleton
#' @export
is.singleton <- function(x) {
isTRUE(attr(x, "htmltools.singleton"))
}
#' Validate proper CSS formatting of a unit
#'
#' Checks that the argument is valid for use as a CSS unit of length.
#'
#' `NULL` and `NA` are returned unchanged.
#'
#' Single element numeric vectors are returned as a character vector with the
#' number plus a suffix of `"px"`.
#'
#' Single element character vectors must be `"auto"`, `"fit-content"`
#' or `"inherit"`, a number, or a length calculated by the `"calc"`
#' CSS function. If the number has a suffix, it must be valid: `px`,
#' `\%`, `ch`, `em`, `rem`, `pt`, `in`, `cm`,
#' `mm`, `ex`, `pc`, `vh`, `vw`, `vmin`, or
#' `vmax`.
#' If the number has no suffix, the suffix `"px"` is appended.
#'
#'
#' Any other value will cause an error to be thrown.
#'
#' @param x The unit to validate. Will be treated as a number of pixels if a
#' unit is not specified.
#' @return A properly formatted CSS unit of length, if possible. Otherwise, will
#' throw an error.
#' @examples
#' validateCssUnit("10%")
#' validateCssUnit(400) #treated as '400px'
#' @export
validateCssUnit <- function(x) {
if (is.null(x) || is.na(x))
return(x)
if (length(x) > 1 || (!is.character(x) && !is.numeric(x)))
stop('CSS units must be a single-element numeric or character vector')
# if the input is a character vector consisting only of digits (e.g. "960"),
# coerce it to a numeric value
if (is.character(x) && nchar(x) > 0 && gsub("\\d*", "", x) == "")
x <- as.numeric(x)
pattern <-
"^(auto|inherit|fit-content|calc\\(.*\\)|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|ch|em|ex|rem|pt|pc|px|vh|vw|vmin|vmax))$"
if (is.character(x) &&
!grepl(pattern, x)) {
stop('"', x, '" is not a valid CSS unit (e.g., "100%", "400px", "auto")')
} else if (is.numeric(x)) {
x <- paste(x, "px", sep = "")
}
x
}
#' CSS string helper
#'
#' Convenience function for building CSS style declarations (i.e. the string
#' that goes into a style attribute, or the parts that go inside curly braces in
#' a full stylesheet).
#'
#' CSS uses `'-'` (minus) as a separator character in property names, but
#' this is an inconvenient character to use in an R function argument name.
#' Instead, you can use `'.'` (period) and/or `'_'` (underscore) as
#' separator characters. For example, `css(font.size = "12px")` yields
#' `"font-size:12px;"`.
#'
#' To mark a property as `!important`, add a `'!'` character to the end
#' of the property name. (Since `'!'` is not normally a character that can be
#' used in an identifier in R, you'll need to put the name in double quotes or
#' backticks.)
#'
#' Argument values will be converted to strings using
#' `paste(collapse = " ")`. Any property with a value of `NULL` or
#' `""` (after paste) will be dropped.
#'
#' @param ... Named style properties, where the name is the property name and
#' the argument is the property value. See Details for conversion rules.
#' @param collapse_ (Note that the parameter name has a trailing underscore
#' character.) Character to use to collapse properties into a single string;
#' likely `""` (the default) for style attributes, and either `"\n"`
#' or `NULL` for style blocks.
#'
#' @examples
#' padding <- 6
#' css(
#' font.family = "Helvetica, sans-serif",
#' margin = paste0(c(10, 20, 10, 20), "px"),
#' "padding!" = if (!is.null(padding)) padding
#' )
#'
#' @export
css <- function(..., collapse_ = "") {
props <- dots_list(...)
if (length(props) == 0) {
return(NULL)
}
if (is.null(names(props)) || any(names(props) == "")) {
stop("cssList expects all arguments to be named")
}
# Necessary to make factors show up as level names, not numbers
props[] <- lapply(props, paste, collapse = " ")
# Drop null args
props <- props[!sapply(props, empty)]
if (length(props) == 0) {
return(NULL)
}
# Translate camelCase, snake_case, and dot.case to kebab-case
# For standard CSS properties only, not CSS variables
is_css_var <- grepl("^--", names(props))
names(props)[!is_css_var] <- standardize_property_names(names(props)[!is_css_var])
# Create "!important" suffix for each property whose name ends with !, then
# remove the ! from the property name
important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
names(props) <- sub("!$", "", names(props), perl = TRUE)
paste0(names(props), ":", props, important, ";", collapse = collapse_)
}
empty <- function(x) {
length(x) == 0 || (is.character(x) && !any(nzchar(x)))
}
standardize_property_names <- function(x) {
# camelCase to kebab-case
x <- gsub("([A-Z])", "-\\1", x)
x <- tolower(x)
# snake_case and dot.case to kebab-case
gsub("[._]", "-", 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.