Nothing
# TODO-barret followup PR
# * onRender(x, fn) - tagFunction(x, fn)
## Methods not implemented
# * `$set_selected(selected)` & `$set(selected_item, pos)` - These methods are
# not available in jQuery and is very brittle in implementation. Do not pursue!
# * With `$set(selected, pos)` not implemented, `[[<-.tagQuery` should not be
# implemented
# * With `$set(selected, pos_vector)` not implemented, `[<-.tagQuery` should not
# be implemented
# * If not doing, `[[<-.tagQuery` or `[<-.tagQuery`, then `[[.tagQuery` and
# `[.tagQuery` should not be implemented. Same with `length.tagQuery`
# * `$set_children(...)` - jQuery does not have this. Instead, you can call
# `$empty()$append(...)`
# * jQuery.val() - Get the current value of the first element in the set of
# matched elements or set the value of every matched element.
# * jQuery.text() - Get the combined text contents of each element in the set of
# matched elements, including their descendants, or set the text contents of the
# matched elements.
# * jQuery.css() - Get the value of a computed style property for the first
# element in the set of matched elements or set one or more CSS properties for
# every matched element.
# * jQuery.prop() - Get the value of a property for the first element in the set
# of matched elements or set one or more properties for every matched element.
## Skip these implementations for now as the tagQuery methods are small and composable.
## Instead write them where they are needed since they are small.
## (Just like we don't wrap dplyr code)
# tagAppendAttributesAt <- function(tag, cssSelector, ...) {
# tagQuery(tag)$find(cssSelector)$addAttrs(...)$allTags()
# }
# tagAddClassAt <- function(tag, cssSelector, class) {
# tagQuery(tag)$find(cssSelector)$addClass(class)$allTags()
# }
# tagMutateAt <- function(x, cssSelector, fn) {
# tagQuery(tag)$find(cssSelector)$each(fn)$allTags()
# }
# tagFindAt <- function(x, cssSelector) {
# tagQuery(tag)$find(cssSelector)$selectedTags()
# }
# # Design notes for tagQuery:
# ## Using stock R objects
#
# Advantages of standard R objects recursion
# * Environments must be handled with care as they are pass by reference
# * It is easy to alter the current object in place
# * Difficult to create a new search path while altering in place
#
# Disadvantages of standard R objects recursion
# * Asking for a grandparent element is difficult.
# * Altering a grandparent element and having the change stay is impossible
# * Searching would need to be done at each stage, every time
# ## Using environments elements
#
# Advantages
# * Fast to convert to a "linked list" of tag environments
# * Access to parents
# * Calculations on siblings can now be done, even after alterations have been completed
# * Once a `find(".x")` has been completed, a set of element environment pointers can be stored.
# * This makes followup alterations have the minimal O(k) complexity (where k
# is _found_ elements), not O(n) + O(k) graph search + reconstruction and k
# _found_ element alterations
#
# Disadvantages
# * MUST be careful not alter the environment object before converting back to a
# list. (Ex: Do not remove the element environment's children)
# * The item returned is a set of environments that will alter in place. We will
# need to be careful about documenting and/or safeguarding this
# ## Final design choice:
# Use environment elements
# * Being able to search and have a list of eles to immediately look at and
# alter in place is AMAZING!
# * Being able to ask for a grandparent (or obj$parent$parent) and be able to
# alter it in place is AMAZING! This has a strongly influenced by jquery.
# ----------
# # Current design decisions
# * tagQuery objects or tag environments can NOT be used in UI. These objects
# MUST be converted back to standard tag objects.
# * tagFunctions will not be altered in place
# * To alter tagFunction()s, use the `onRender(x)` method to register a method
# to be called after `as.tags(x)` is called.
# * `onRender(x, expr)` will wrap create a tag function that will resolve the
# tags before running the expr.
## rlang::obj_address()
# Use to get a unique key for stacks
# Use `env$envKey` over `rlang::obj_address()`; 10x speed improvement
# Use for `has()` functionality
envirMap <- function() {
map <- fastmap()
list(
keys = map$keys,
asList = function() {
unname(map$as_list())
},
has = function(envir) {
map$has(envir$envKey)
},
add = function(envir) {
map$set(envir$envKey, TRUE)
},
remove = function(envir) {
map$remove(envir$envKey)
}
)
}
# Use for consistent `asList()` order
envirStack <- function() {
stack <- faststack()
list(
push = stack$push,
asList = stack$as_list,
uniqueList = function() {
unique(stack$as_list())
}
)
}
# (Used for `unique_envirStack()` only. Do not use directly!)
# Provides same interface as `envirStack()`, but checks for duplicates when
# when items are on their way in (with `push()`) instead of on the way out
# (with `uniqueList()`). This is faster when size is ~500 and above.
envirStackUni_ <- function() {
map <- fastmap()
stack <- faststack()
list(
push = function(env) {
key <- env$envKey
if (!map$has(key)) {
# mark the key as _seen_
map$set(key, TRUE)
# add the env
stack$push(env)
}
},
uniqueList = stack$as_list
)
}
# Use to retrieve unique environments (eg: `tq$parent()`)
# Provides same interface as `envirStack()`, but switches to the faster
# `envirStackUni_()` implementation when size hits 500.
envirStackUnique <- function() {
stack <- envirStack()
count <- 0
list(
push = function(env) {
count <<- count + 1
if (count == 500) {
# convert the current stack to a `envirStackUni_()`
newStack <- envirStackUni_()
walk(stack$asList(), newStack$push)
stack <<- newStack
}
stack$push(env)
},
uniqueList = function() {stack$uniqueList()}
)
}
# Copy all attributes that can be manually set
# ?attr
# Note that some attributes (namely ‘class’, ‘comment’, ‘dim’,
# ‘dimnames’, ‘names’, ‘row.names’ and ‘tsp’) are treated specially
# and have restrictions on the values which can be set.
copyAttributes <- function(from, to) {
attrVals <- attributes(from)
attrNames <- names(attrVals)
for (i in seq_along(attrNames)) {
attrName <- attrNames[i]
switch(
attrName,
class = , comment =, dim =, dimnames =, names =, row.names =, tsp = NULL,
{
# Copy over the attribute
attr(to, attrName) <- attrVals[[i]]
}
)
}
to
}
# Convert a list to an environment and keep class and attribute information
safeListToEnv <- function(x, classToAdd = NULL) {
xList <- x
ret <- list2env(xList, new.env(parent = emptyenv()))
ret <- copyAttributes(from = xList, to = ret)
oldClass(ret) <- c(classToAdd, oldClass(xList))
ret
}
# Convert any mixture of standard tag structures and tag environments into just
# tag environments.
#
# This method is heavily used within `tagQuery()$rebuild()` to enforce all
# standard tag objects are upgraded to tag environments.
#
# If the object is already a tag environment, it will recurse the conversion for
# each of the children
#
# Extras done:
# * Flatten all attributes by combining duplicate keys
# * Flatten the tag's children to a single list * Check for circular
# dependencies of tag environments
#
# (Do not export to encourage direct use of `tagQuery()`)
asTagEnv <- function(x) {
if (isTagQuery(x)) {
stop("`tagQuery()` object can not be provided to `asTagEnv()`")
}
if (!isTagEnv(x) && !isTag(x)) {
# force all methods to send in tags, lists / tagLists are not allowed
stop("`asTagEnv()` can only accept tag envs or tag objects. It does not accept `lists()` or `tagLists()`")
}
asTagEnv_(x, parent = x$parent)
}
# Checking for cycles is not performed as it is slow. With tagQuery methods not really
# opening the door for cycles to occur, it would be the user doing dangerous things.
# At this point, they should understand when a stack overflow occurs.
asTagEnv_ <- function(x, parent = NULL) {
isTagVal <- isTag(x)
isTagEnvVal <- isTagEnv(x)
if (isTagVal || isTagEnvVal) {
if (!isTagEnvVal) {
xList <- x
x <- safeListToEnv(xList, "shiny.tag.env")
# add parent env and key
x$parent <- parent
x$envKey <- obj_address(x)
}
if (!is.character(x[["name"]])) {
stop("A tag environment has lost its `$name`. Did you remove it?")
}
# This alters the env, but these fields should exist!
if (is.null(x[["attribs"]])) x$attribs <- list(placeholder = NULL)[0] # Empty named list
if (is.null(x[["children"]])) x$children <- list()
# Recurse through children
if (length(x$children) != 0) {
# Possible optimization... name the children tags to the formatted values.
# * Allows for faster child look up later.
# * Comes with the cost of always formatting the env values even if children names are not needed.
# Attributes may be dropped
# * Could replace with `x$children[] <- ....`
# * Leaving as is to see if people mis-use the children field
# Simplify the structures by flatting the tags
# Does NOT recurse to grand-children etc.
children <- flattenTagsRaw(x$children)
# Use a `for-loop` over `lapply` to avoid `lapply` overhead
for (i in seq_along(children)) {
child <- children[[i]]
if (!is.null(child)) {
children[[i]] <- asTagEnv_(child, parent = x)
}
}
x$children <- children
}
}
x
}
# This method MUST undo everything done in `asTagEnv(x)`
# Do not export to encourage direct use of `tagQuery()$selectedTags()`
# Only allow for tag environments to be passed in.
tagEnvToTags <- function(x) {
if (!isTagEnv(x)) {
stop("`tagEnvToTags(x)` must start with a tag environment")
}
tagEnvToTags_(x)
}
# Allows for all types of objects that can be put in a tag environment's `$children` field.
# Ex: tag environment, "text", 5, tagFunctions, etc.
tagEnvToTags_ <- function(x) {
if (isTagEnv(x)) {
xEl <- x
# Pull the names `name`, `attribs`, and `children` first to match `tag()` name order
envNames <- ls(envir = xEl, all.names = TRUE, sorted = FALSE)
newNames <- c(
"name", "attribs", "children",
if (length(envNames) > 5) {
# Pull remaining names if they exist
removeFromSet(envNames, c("name", "attribs", "children", "parent", "envKey"))
}
)
# Use mget to pull names in order to avoid always shuffling the values
x <- mget(newNames, xEl)
x <- copyAttributes(from = xEl, to = x)
oldClass(x) <- removeFromSet(oldClass(xEl), "shiny.tag.env")
# Recurse through children
children <- x$children
# Use a `for-loop` over `lapply` to avoid overhead
for (i in seq_along(children)) {
child <- children[[i]]
if (!is.null(child)) {
children[[i]] <- tagEnvToTags_(child)
}
}
x$children <- children
}
x
}
isTagEnv <- function(x) {
inherits(x, "shiny.tag.env")
}
isTagQuery <- function(x) {
inherits(x, "shiny.tag.query")
}
assertNotTagEnvLike <- function(x, fnName) {
if (isTagEnv(x)) {
stop("Tag environment objects (i.e., `tagQuery()`'s tag structure) are not allowed to be used as if they are regular `tag()` objects. Did you forget to call `$allTags()` or `$selectedTags()`?", call. = FALSE)
}
if (isTagQuery(x)) {
stop("`tagQuery()` objects are not allowed to be used as if they are regular `tag()` objects. Did you forget to call `$allTags()` or `$selectedTags()`?", call. = FALSE)
}
invisible()
}
shinyTagEnvStr <- "<!-- shiny.tag.env -->"
#' @export
as.tags.shiny.tag.env <- function(x, ...) {
stop("Method not allowed", call. = TRUE)
# as.tags(tagEnvToTags(x), ...)
}
#' @export
print.shiny.tag.env <- function(x, ...) {
cat(shinyTagEnvStr, "\n")
print(tagEnvToTags(x), ...)
}
#' @export
format.shiny.tag.env <- function(x, ...) {
format(tagEnvToTags(x), ...)
}
#' @export
as.character.shiny.tag.env <- function(x, ...) {
as.character(tagEnvToTags(x), ...)
}
#' @export
str.shiny.tag.env <- function(object, ...) {
cat(shinyTagEnvStr, "\n")
str(tagEnvToTags(object), ...)
}
#' @export
as.tags.shiny.tag.query <- function(x, ...) {
tagQueryAsTagErr()
}
#' @export
print.shiny.tag.query <- function(x, ...) {
tagQ <- x
cat("`$allTags()`:\n")
allTags <- tagQ$allTags()
print(allTags)
selectedTags <- tagQ$selectedTags()
cat("\n`$selectedTags()`:")
if (length(selectedTags) == 0) {
cat(" (Empty selection)\n")
} else {
# Convert allTags to same style of object as selected tags
if (!isTagList(allTags)) allTags <- tagList(allTags)
allTags <- tagListPrintAsList(!!!allTags)
if (identical(allTags, selectedTags)) {
cat(" `$allTags()`\n")
} else {
cat("\n")
print(selectedTags)
}
}
invisible(x)
}
#' @export
format.shiny.tag.query <- function(x, ...) {
tagQueryAsTagErr()
}
#' @export
as.character.shiny.tag.query <- function(x, ...) {
tagQueryAsTagErr()
}
tagQueryAsTagErr <- function() {
stop(
"`tagQuery()` objects can not be written directly as HTML tags.",
"Call either `$allTags()` or `$selectedTags()` to extract the tags of interest.",
call. = FALSE
)
}
#' Query and modify HTML tags
#'
#' `r lifecycle::badge("experimental")`\cr\cr `tagQuery()` provides a
#' [`jQuery`](https://jquery.com/) inspired interface for querying and modifying
#' [tag()] (and [tagList()]) objects.
#'
#' @section Altered Tag structure:
#'
#' For performance reasons, the input tag structure to `tagQuery()` will be
#' altered into a consistently expected shape.
#'
#' Some alterations include:
#' * tags flattening their `$children` fields into a single `list()`
#' * tags relocating any attribute `html_dependency() to be located in `$children`
#' * `tagList()`-like structures relocating any attribute html dependency to
#' be a entry in its list structure.
#'
#' While the resulting tag shape has possibly changed,
#' `tagQuery()`'s' resulting tags will still render
#' to the same HTML value (ex: [`renderTags()`]) and
#' HTML dependencies (ex: [`findDependencies()`]).
#'
#' @param tags A [tag()], [tagList()], or [list()] of tags.
#' @return A class with methods that are described below. This class can't be
#' used directly inside other [tag()] or a [renderTags()] context, but
#' underlying HTML tags may be extracted via `$allTags()` or
#' `$selectedTags()`.
#' @export
tagQuery <- function(tags) {
if (isTagQuery(tags)) {
# Return tag query object as is
return(tags)
}
# Make a new tag query object from the root element of `tags`
# * Set the selected to `list(tags)`
if (isTagEnv(tags)) {
# Rebuild pseudo root tag
pseudoRoot <- asTagEnv(
findPseudoRootTag(tags)
)
return(
tagQuery_(pseudoRoot, list(tags))
)
}
# If `tags` is a list of tagEnvs...
# * Make sure they share the same root element and
# * Set the selected elements to `tags`
if (!isTag(tags) && (is.list(tags) || isTagList(tags))) {
# If it is a list, flatten them for easier/consisten inspection
tags <- flattenTagsRaw(tags)
tagsIsTagEnv <- vapply(tags, isTagEnv, logical(1))
# If one of the elements is a tag env, verify that all tagEnvs share the same root.
if (any(tagsIsTagEnv)) {
if (any(!tagsIsTagEnv)) {
notTagEnvPos <- which(!tagsIsTagEnv)
# It is not known how a middle of the tree tagEnv should be combined with a standard tag
stop(
"`tagQuery(tags=)` can not be a mix of tag environments and standard tag objects.\n",
"Items at positions `c(", paste0(notTagEnvPos, collapse = ", "), ")` ",
"are not tag environments."
)
}
pseudoRootStack <- envirStackUnique()
walk(tags, function(el) {
pseudoRootStack$push(findPseudoRootTag(el))
})
pseudoRoots <- pseudoRootStack$uniqueList()
if (length(pseudoRoots) != 1) {
stop("All tag environments supplied to `tagQuery()` must share the same root element.")
}
# Rebuild pseudo root tag
pseudoRoot <- asTagEnv(pseudoRoots[[1]])
return(
tagQuery_(pseudoRoot, tags)
)
}
}
# Convert standard tags to tag envs
root <- asTagEnv(
wrapWithPseudoRootTag(tags)
)
# Select the top level tags
selected <- tagQueryFindResetSelected(root)
if (length(selected) == 0) {
stop(
"The initial set of tags supplied to `tagQuery()` must have at least 1 standard tag object.",
" Ex: `div()`"
)
}
tagQuery_(root, selected)
}
#' @rdname tagQuery
#' @aliases NULL
#' @usage NULL
tagQuery_ <- function(
pseudoRoot,
# Using a trailing `_` to avoid name collisions
selected_
) {
if (!isPseudoRootTag(pseudoRoot)) {
stop("`tagQuery_(pseudoRoot=)` must be a pseudoRoot tag environment")
}
# Use `var_` names to avoid namespace collision
# Make sure all elements are tag envs
rebuild_ <- function() {
# safe to do as `pseudoRoot` will never be turned into a standard list
asTagEnv(pseudoRoot)
}
newTagQuery <- function(selected) {
tagQuery_(pseudoRoot, selected)
}
setSelected <- function(selected) {
selected <- selected %||% list()
if (!is.list(selected)) {
stop("`selected` must be a `list()`")
}
selected <- FilterI(selected, f = function(el, i) {
if (!isTagEnv(el)) {
stop(
"`setSelected(selected=)` received a list item at position `", i, "`",
" that was not a tag environment"
)
}
!isPseudoRootTag(el)
})
selected
}
selected_ <- setSelected(selected_)
self <-
structure(
class = "shiny.tag.query",
list(
#' @details
#'
#' # Vignette
#'
#' To get started with using `tagQuery()`, visit
#' <https://rstudio.github.io/htmltools/articles/tagQuery.html>.
#'
#' # Methods
#'
#' Unless otherwise stated, `tagQuery()` methods accept a character
#' vector as input.
#'
#' ## Query methods
#'
#' Query methods identify particular subsets of the root tag using CSS
#' selectors (or R functions).
#'
#' ### Children
#'
#' * `$find(cssSelector)`: Get the descendants of
#' each selected tag, filtered by a `cssSelector`.
find = function(cssSelector) {
newTagQuery(
tagQueryFindAll(selected_, cssSelector)
)
},
#' * `$children(cssSelector = NULL)`: Get the direct
#' children of each selected tag, optionally filtered by a
#' `cssSelector`.
children = function(cssSelector = NULL) {
newTagQuery(
tagQueryFindChildren(selected_, cssSelector)
)
},
#' ### Siblings
#'
#' * `siblings(cssSelector = NULL)`: Get the
#' siblings of each selected tag, optionally filtered by a
#' `cssSelector`.
siblings = function(cssSelector = NULL) {
newTagQuery(
tagQueryFindSiblings(selected_, cssSelector)
)
},
#' ### Parents
#'
#' * `$parent(cssSelector = NULL)`: Get the parent
#' of each selected tag, optionally filtered by a `cssSelector`.
parent = function(cssSelector = NULL) {
newTagQuery(
tagQueryFindParent(selected_, cssSelector)
)
},
#' * `$parents(cssSelector = NULL)`: Get the
#' ancestors of each selected tag, optionally filtered by a
#' `cssSelector`.
parents = function(cssSelector = NULL) {
newTagQuery(
tagQueryFindParents(selected_, cssSelector)
)
},
#' * `$closest(cssSelector = NULL)`: For each selected tag, get the closest
#' ancestor tag (including itself) satisfying a `cssSelector`. If
#' `cssSelector = NULL`, it is equivalent to calling `$selectedTags()`.
closest = function(cssSelector = NULL) {
newTagQuery(
tagQueryFindClosest(selected_, cssSelector)
)
},
#' ### Custom filter
#'
#' * `$filter(fn)`: Filter the selected tags to those for which `fn(x,
#' i)` returns `TRUE`. In addition to an R function with two arguments
#' (the selected tag `x` and the index `i`), `fn` may also be a valid
#' CSS selector.
filter = function(fn) {
newSelected <- tagQueryFindFilter(selected_, fn)
rebuild_()
newTagQuery(newSelected)
},
#' ### Length
#'
#' * `$length()`: Number of tags that have been selected.
length = function() {
length(selected_)
},
#' ### Reset
#'
#' * `$resetSelected()`: Reset selected tags to the `$allTags()` tag. Useful
#' in combination with `$replaceWith()` since it empties the selection.
resetSelected = function() {
newTagQuery(
tagQueryFindResetSelected(pseudoRoot)
)
},
#' ## Modify methods
#'
#' Unlike query methods, modify methods modify the `tagQuery()` object.
#'
#' ### Attributes
#'
#' * `$addClass(class)`: Adds class(es) to each selected tag.
addClass = function(class) {
tagQueryClassAdd(selected_, class)
self
},
#' * `$removeClass(class)`: Removes class(es) to each selected tag.
removeClass = function(class) {
tagQueryClassRemove(selected_, class)
self
},
#' * `$toggleClass(class)`: Adds class(es) that don't already exist and
#' removes class(es) that do already exist (for each selected tag).
toggleClass = function(class) {
tagQueryClassToggle(selected_, class)
self
},
#' * `$hasClass(class)`: Does each selected tag have all the provided
#' class(es)?
hasClass = function(class) {
tagQueryClassHas(selected_, class)
},
#' * `$addAttrs(...)`: Add a set of attributes to each selected tag.
addAttrs = function(...) {
tagQueryAttrsAdd(selected_, ...)
self
},
#' * `$removeAttrs(attrs)`: Remove a set of attributes from each
#' selected tag.
removeAttrs = function(attrs) {
tagQueryAttrsRemove(selected_, attrs)
self
},
#' * `$hasAttrs(attr)`: Do each selected tags have all of the attributes?
hasAttrs = function(attrs) {
tagQueryAttrsHas(selected_, attrs)
},
#' ### Children
#'
#' * `$append(...)`: For each selected tag, insert `...` **after** any
#' existing children.
append = function(...) {
tagQueryChildrenAppend(selected_, ...)
self
},
#' * `$prepend(...)`: For each selected tag, insert `...` **before** any
#' existing children.
prepend = function(...) {
tagQueryChildrenPrepend(selected_, ...)
self
},
#' ### Siblings
#'
#' * `$after(...)`: Add all `...` objects as siblings after each of the
#' selected tags.
after = function(...) {
tagQuerySiblingAfter(selected_, ...)
self
},
#' * `$before(...)`: Add all `...` objects as siblings before each of
#' the selected tags.
before = function(...) {
tagQuerySiblingBefore(selected_, ...)
self
},
#' ### Custom
#'
#' * `$each(fn)`: Modify each selected tag with a function `fn`. `fn`
#' should accept two arguments: the first is the selected tag and second
#' is the selected tags position index. Since the selected tag is a
#' reference, any modifications to it will also modify the `tagQuery()`
#' object.
each = function(fn) {
if (length(selected_) > 0) {
tagQueryEach(selected_, fn)
rebuild_()
}
self
},
#' ## Replace methods
#'
#' * `$replaceWith(...)`: Replace all selected tags with `...` in the
#' root tag and clear the selection.
replaceWith = function(...) {
tagQuerySiblingReplaceWith(selected_, ...)
newTagQuery(list())
},
#' * `$remove(...)`: Remove all selected tags from the root tag and
#' clear the current selection.
remove = function() {
tagQuerySiblingRemove(selected_)
# Remove items from selected info
newTagQuery(list())
},
#' * `$empty()`: Remove any children of each selected tag. Use this
#' method before calling `$append(...)` to replace the children of
#' each selected tag, with other content.
empty = function() {
tagQueryChildrenEmpty(selected_)
self
},
#' ## Extract HTML tags
#'
#' * `$allTags()`: Return the (possibly modified) root `tags`.
allTags = function() {
tagQueryTopLevelTags(pseudoRoot)
},
#' * `$selectedTags()`: Return a [tagList()] of the currently selected
#' tags.
selectedTags = function() {
tagQuerySelectedAsTags(selected_)
}
#' @examples
#' tagQ <- tagQuery(div(a()))
#' tagQ$find("a")$addClass("foo")
#' tagQ
#'
#' # To learn more, visit https://rstudio.github.io/htmltools/articles/tagQuery.html
)
)
self
}
validatePosition <- function(position, selected) {
if (!is.numeric(position)) {
stop("`position` must be a numeric value")
}
if (length(position) != 1) {
stop("`position` must have a length equal to 1")
}
if (position <= 0) {
stop("`position` must be greater than 0")
}
if (position > length(selected)) {
stop(
"`position` must be less than or equal to the length of the selected elements: ",
length(selected)
)
}
}
validateFnCanIterate <- function(fn) {
if (!is.function(fn)) {
stop("`fn` must be a function")
}
fnFormals <- formals(fn)
if (! ("..." %in% names(fnFormals))) {
if (length(fnFormals) < 2) {
stop(
"`fn(selected_i, i)` must be a function that accepts at least two arguments: ",
"`selected[[i]]` and `i` "
)
}
}
}
isPseudoRootTag <- function(x) {
name <- x$name
isTag(x) && !is.null(name) && isTRUE(name == "TagQueryPseudoRoot")
}
findPseudoRootTag <- function(el) {
while (!is.null(el$parent)) {
el <- el$parent
}
el
}
# Wrap the top level tags in the tagQuery() in a `tagQuery` tag object.
# This allows for appending and prepending elements to the top level tags.
# (Don't fight the structures... embrace them!)
wrapWithPseudoRootTag <- function(x) {
tagSetChildren(
tag("TagQueryPseudoRoot", list()),
x
)
}
# Return a tag env, tagList(tag envs), or NULL
tagQueryGetRoot <- function(root) {
children <- root$children
len <- length(children)
if (len == 1) {
children[[1]]
} else if (len > 1) {
tagList(!!!children)
} else {
# no children?
NULL
}
}
# Return a list of the manually selected elements
tagQuerySelected <- function(selected) {
if (length(selected) == 1 && isPseudoRootTag(selected[[1]])) {
list()
} else {
selected
}
}
# # Return the `i`th position of the manually selected elements
# tagQueryGet <- function(selected, position) {
# selected <- tagQuerySelected(selected)
# validatePosition(position, selected)
# selected[[position]]
# }
# Return the top level tags as a tagList or a single tag
tagQueryTopLevelTags <- function(pseudoRoot) {
children <- tagEnvToTags(pseudoRoot)$children
len <- length(children)
if (len == 1) {
# single top level tag
children[[1]]
} else {
# 0 or >1 top leve tags
tagList(!!!children)
}
}
tagListPrintAsList <- function(...) {
x <- tagList(...)
attr(x, "print.as.list") <- TRUE
x
}
tagQuerySelectedAsTags <- function(selected) {
# return as a `tagList()` with a special attr that will cause it to print like a list
tagListPrintAsList(!!!lapply(selected, tagEnvToTags))
}
as_character2 <- function(...) {
as.character(
# MUST call `unlist()` to allow for vector items in `list2()`
unlist(
list2(...),
use.names = FALSE
)
)
}
FilterI <- function (f, x) {
ind <- as.logical(
Map(x, seq_along(x), f = f)
)
x[which(ind)]
}
# Call `.f(x[[i]], ...)` for all values of i
walk <- function(.x, .f, ...) {
for (i in seq_along(.x)) {
.f(.x[[i]], ...)
}
NULL
}
walk2 <- function(.x, .y, .f, ...) {
if (length(.x) != length(.y)) {
stop(".x and .y must be the same length.")
}
for (i in seq_along(.x)) {
.f(.x[[i]], .y[[i]], ...)
}
NULL
}
# Call `.f(x[[i]])` in reverse order
# walk_rev <- function(.x, .f, ...) {
# for (i in rev(seq_along(.x))) {
# .f(.x[[i]], ...)
# }
# NULL
# }
# Calls `.f(x[[i]], i, ...)`
walkI <- function(.x, .f, ...) {
for (i in seq_along(.x)) {
.f(.x[[i]], i, ...)
}
NULL
}
# Calls `.f(x[[i]], i, ...)` in reverse order
walkIRev <- function(.x, .f, ...) {
for (i in rev(seq_along(.x))) {
.f(.x[[i]], i, ...)
}
NULL
}
# Return function that will verify elements before performing `func(els, fn)`
selectedWalkGen <- function(func) {
force(func)
function(els, fn) {
if (is.null(els)) return(list())
if (!is.list(els)) {
stop("A list() must be supplied")
}
if (!is.function(fn)) {
stop("`fn` must be a function")
}
# Make sure each item in list is a tag env
walkI(els, function(el, i) {
if (!is.null(el)) {
if (isTag(el) && !isTagEnv(el)) {
str(el)
stop(
"Object in position `", i, "` is a regular `tag()` and not a tag environment.",
"\nDid you forget to call `$rebuild()`?"
)
}
}
})
func(els, fn)
}
}
tagQueryWalk <- selectedWalkGen(walk)
# selectedWalkRev <- selectedWalkGen(walkRev)
selectedWalkI <- selectedWalkGen(walkI)
selectedWalkIRev <- selectedWalkGen(walkIRev)
tagQueryLapply <- selectedWalkGen(lapply)
# Perform `fn` on each el in els
tagQueryEach <- function(els, fn) {
validateFnCanIterate(fn)
selectedWalkI(els, fn)
}
# For each el in els, go to el parent and find el's position
# Then call `fn(parent, el, elPos)`
# Perform this matching in reverse order
tagQueryMatchChildRev <- function(els, func) {
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
elKey <- el$envKey
elParent <- el$parent
# Walk in reverse to be able to remove all matches in a single pass
selectedWalkIRev(elParent$children, function(child, childPos) {
if (!isTagEnv(child)) return()
childKey <- child$envKey
if (elKey == childKey) {
func(elParent, el, childPos)
# Make sure to rebuild the parent tag into tag envs
# Their internal structures will have changed
asTagEnv(elParent)
}
})
})
}
# Remove each el in els from their parent.
# Also remove parent pointer from within el
tagQuerySiblingRemove <- function(els) {
tagQueryMatchChildRev(els, function(elParent, el, childPos) {
# remove parent / child relationship
el$parent <- NULL
elParent$children[[childPos]] <- NULL
})
}
# Add siblings after each el
tagQuerySiblingAfter <- function(els, ...) {
tagQueryMatchChildRev(els, function(elParent, el, childPos) {
tagInsertChildren(elParent, after = childPos, ...)
})
}
# Add siblings before each el
tagQuerySiblingBefore <- function(els, ...) {
tagQueryMatchChildRev(els, function(elParent, el, childPos) {
tagInsertChildren(elParent, after = childPos - 1, ...)
})
}
# Replace all `el` objects with `...`
tagQuerySiblingReplaceWith <- function(els, ...) {
tagQueryMatchChildRev(els, function(elParent, el, childPos) {
# Remove the current element
el$parent <- NULL
elParent$children[[childPos]] <- NULL
# Replace with ... content where the child was
tagInsertChildren(elParent, after = childPos - 1, ...)
})
}
tagQueryChildrenSet <- function(els, ...) {
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagSetChildren(el, ...)
# Make sure to rebuild the el and its children
asTagEnv(el)
})
}
tagQueryChildrenEmpty <- function(els) {
# Do not include any arguments.
# `dots_list()` returns an empty named list()
tagQueryChildrenSet(els)
}
tagQueryChildrenAppend <- function(els, ...) {
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagInsertChildren(el, after = length(el$children), ...)
# Make sure to rebuild the el and its children
asTagEnv(el)
})
}
tagQueryChildrenPrepend <- function(els, ...) {
tagQueryChildrenInsert(els, after = 0, ...)
}
tagQueryChildrenInsert <- function(els, after, ...) {
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagInsertChildren(el, after = after, ...)
# Make sure to rebuild the el and its children
asTagEnv(el)
})
}
tagEnvRemoveAttribs <- function(el, attrs) {
el$attribs[names(el$attribs) %in% attrs] <- NULL
el
}
# Add attribute values
tagQueryAttrsAdd <- function(els, ...) {
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagAppendAttributes(el, ...)
})
}
# Remove attribute values
tagQueryAttrsRemove <- function(els, attrs) {
attrs <- as_character2(attrs)
if (length(attrs) < 1) return()
if (!is.character(attrs)) {
stop("`attrs` must be a charcter vector of attributes to remove")
}
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagEnvRemoveAttribs(el, attrs)
})
}
# Check if els have attributes
tagQueryAttrsHas <- function(els, attrs) {
attrs <- as_character2(attrs)
if ((length(attrs) == 0) || (!is.character(attrs))) {
stop("`attrs` must be a character vector", call. = FALSE)
}
unlist(
tagQueryLapply(els, function(el) {
if (!isTagEnv(el)) return(FALSE)
for (attr in attrs) {
if (!tagHasAttribute(el, attr)) {
return(FALSE)
}
}
# All attrs found
return(TRUE)
}),
use.names = FALSE
)
}
prepCssClass <- function(class) {
class <- as_character2(class)
if (length(class) == 0 || !is.character(class)) {
stop("`class` must resolve to a character value with a length of at least 1")
}
class
}
getCssClass <- function(class) {
splitCssClass(prepCssClass(class))
}
splitCssClass <- function(class) {
if (!is.character(class)) {
stop("tagGetAttribute(x, \"class\") did not return a character value")
}
if (length(class) > 1) {
class <- paste0(class, collapse = " ")
}
strsplit(class, "\\s+")[[1]]
}
joinCssClass <- function(classes) {
if (length(classes) == 0) {
NULL
} else {
paste0(classes, collapse = " ")
}
}
# return list of logical values telling if the classes exists
tagQueryClassHas <- function(els, class) {
# Quit early if class == NULL | character(0)
if (length(class) == 0) {
return(rep(FALSE, length(els)))
}
classes <- getCssClass(class)
unlist(
tagQueryLapply(els, function(el) {
if (!isTagEnv(el)) return(FALSE)
classVal <- tagGetAttribute(el, "class")
if (isNonConformClassValue(classVal)) {
return(FALSE)
}
elClasses <- splitCssClass(classVal)
all(classes %in% elClasses)
}),
use.names = FALSE
)
}
removeFromSet <- function(set, vals) {
# removes the call to `unique()` with `setdiff`
set[match(set, vals, 0L) == 0L]
}
isNonConformClassValue <- function(classVal) {
length(classVal) == 0 ||
(!is.character(classVal)) ||
anyNA(classVal)
}
tagEnvSetClassAttrib <- function(el, classes) {
class <- joinCssClass(classes)
classAttribPos <- which(names(el$attribs) == "class")
isClassLen <- length(classAttribPos)
if (isClassLen == 0) {
# Store new class value
return(
tagAppendAttributes(el, class = class)
)
}
# isClassLen > 0
if (isClassLen > 1) {
# Remove other occurrences of class
el$attribs[classAttribPos[-1]] <- NULL
}
# Overwrite "class" attrib
el$attribs[[classAttribPos[1]]] <- class
el
}
# add classes that don't already exist
tagQueryClassAdd <- function(els, class) {
# Quit early if class == NULL | character(0)
if (length(class) == 0) return()
classes <- getCssClass(class)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
classVal <- tagGetAttribute(el, "class")
if (isNonConformClassValue(classVal)) {
tagAppendAttributes(el, class = joinCssClass(classes))
} else {
elClasses <- splitCssClass(classVal)
newClasses <- c(elClasses, removeFromSet(classes, elClasses))
tagEnvSetClassAttrib(el, newClasses)
}
})
}
# remove classes that exist
tagQueryClassRemove <- function(els, class) {
# Quit early if class == NULL | character(0)
if (length(class) == 0) return()
classes <- getCssClass(class)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
classVal <- tagGetAttribute(el, "class")
if (isNonConformClassValue(classVal)) return()
elClasses <- splitCssClass(classVal)
newClasses <- removeFromSet(elClasses, classes)
tagEnvSetClassAttrib(el, newClasses)
})
}
# toggle class existence depending on if they already exist or not
tagQueryClassToggle <- function(els, class) {
# Quit early if class == NULL | character(0)
if (length(class) == 0) return()
classes <- getCssClass(class)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
classVal <- tagGetAttribute(el, "class")
if (isNonConformClassValue(classVal)) return()
elClasses <- splitCssClass(classVal)
hasClass <- (classes %in% elClasses)
if (any(hasClass)) {
elClasses <- removeFromSet(elClasses, classes)
}
if (any(!hasClass)) {
elClasses <- c(elClasses, classes[!hasClass])
}
tagEnvSetClassAttrib(el, elClasses)
})
}
# Return a list of `root$children`.
# This may change if root ends up becoming a list of elements
tagQueryFindResetSelected <- function(pseudoRoot) {
if (!isTagEnv(pseudoRoot)) {
stop("`pseudoRoot` must be a tag environment")
}
Filter(pseudoRoot$children, f = isTagEnv)
}
# Return a list of the unique set of parent elements
tagQueryFindParent <- function(els, cssSelector = NULL) {
parentStack <- envirStackUnique()
pushFn <- pushFnWrapper(parentStack, cssSelector)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
pushFn(el$parent)
})
parentStack$uniqueList()
}
# Return a list of the unique set of ancestor elements
# * By only looking for elements that have not been seen before, searching is as
# lazy as possible
# * Must traverse all parents; If cssSelector exists, only return found parents
# that match selector.
# * Search using depth-first. This does not match jQuery's implementation.
tagQueryFindParents <- function(els, cssSelector = NULL) {
# Use the map for `has()` and stack for `values()`
ancestorsMap <- envirMap()
ancestorsStack <- envirStackUnique()
# func to add to the ancestor stack
pushFn <- pushFnWrapper(ancestorsStack, cssSelector)
# For every element
tagQueryWalk(els, function(el) {
# Make sure it is a tag environment
if (!isTagEnv(el)) return()
# While traversing up the parents...
while (!is.null(el <- el$parent)) {
# If the element has been seen before...
if (ancestorsMap$has(el)) {
# Stop traversing, as any matching parent found would be removed
# (unique info only)
return()
}
# Mark the ancestor as visited
ancestorsMap$add(el)
# Add the element to the return set
pushFn(el)
}
})
ancestorsStack$uniqueList()
}
# Return a unique list of the closest ancestor elements that match the css selector
# Should behave VERY similarly to $parents()
tagQueryFindClosest <- function(els, cssSelector = NULL) {
if (is.null(cssSelector)) {
return(els)
}
selector <- cssSelectorToSelector(cssSelector)
# use the map for `has()` and stack for `values()`
ancestorsMap <- envirMap()
closestStack <- envirStackUnique()
# For every element
tagQueryWalk(els, function(el) {
# Make sure it is a tag environment
if (!isTagEnv(el)) return()
# While traversing up the parents...
while (!is.null(el)) {
# If the element has been seen before...
if (ancestorsMap$has(el)) {
# Stop traversing, as any matching parent found would be removed
# (unique info only)
return()
}
# Mark the ancestor as visited
ancestorsMap$add(el)
# If it is a match...
if (elMatchesSelector(el, selector)) {
# Add to return value
closestStack$push(el)
return()
}
# set to parent element and repeat
el <- el$parent
}
})
closestStack$uniqueList()
}
# Get all unique children tag envs
tagQueryFindChildren <- function(els, cssSelector = NULL) {
childrenStack <- envirStackUnique()
pushFn <- pushFnWrapper(childrenStack, cssSelector)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
tagQueryWalk(el$children, pushFn)
})
childrenStack$uniqueList()
}
# Return all unique siblings of each el in els
tagQueryFindSiblings <- function(els, cssSelector = NULL) {
siblingStack <- envirStackUnique()
pushFn <- pushFnWrapper(siblingStack, cssSelector)
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
elKey <- el$envKey
tagQueryWalk(el$parent$children, function(sibling) {
if (!isTagEnv(sibling)) return()
siblingKey <- sibling$envKey
if (elKey != siblingKey) {
pushFn(sibling)
}
})
})
siblingStack$uniqueList()
}
# Filter the selected elements using a function
# The answer of `fn(el, i)` should work in an `if` block
tagQueryFindFilter <- function(els, fn) {
if (is.character(fn)) {
selector <- cssSelectorToSelector(fn)
fn <- function(el, i) {
elMatchesSelector(el, selector)
}
}
validateFnCanIterate(fn)
filterStack <- envirStackUnique()
selectedWalkI(els, function(el, i) {
if (fn(el, i)) {
filterStack$push(el)
}
})
filterStack$uniqueList()
}
# Convert a CSS selection character value to a selector object
# @param cssSelector A character value representing a CSS search pattern
# @return A single item of a selector list. (See `asSelectorList()`).
# A single-element CSS selector object with full CSS element match information.
# (Child selectors are not allowed in single-element selectors)
cssSelectorToSelector <- function(cssSelector) {
selector <-
if (isSelector(cssSelector)) {
cssSelector
} else {
selectorList <- asSelectorList(cssSelector)
if (length(selectorList) > 1) {
stop(
"Can only match using a simple CSS selector. ",
"Looking for descendant elements is not allowed."
)
}
selectorList[[1]]
}
selector
}
pushFnWrapper <- function(stack, cssSelector) {
if (is.null(cssSelector)) {
stack$push
} else {
selector <- cssSelectorToSelector(cssSelector)
function(el) {
if (elMatchesSelector(el, selector)) {
stack$push(el)
}
}
}
}
elMatchesSelector <- function(el, selector) {
if (!isTagEnv(el)) return(FALSE)
if (!isSelector(selector)) {
stop("`elMatchesSelector(selector=)` must be an object of class `\"shinySelector\"`")
}
if (selector$type == SELECTOR_EVERYTHING) {
return(TRUE)
}
# match on element
if (!is.null(selector$element)) {
# bad element match
if (el$name != selector$element) {
return(FALSE)
}
}
# match on id
if (!is.null(selector$id)) {
# bad id match
if ( !identical(tagGetAttribute(el, "id"), selector$id)) {
return(FALSE)
}
}
# match on class values
if (!is.null(selector$classes)) {
elClass <- tagGetAttribute(el, "class")
if (
isNonConformClassValue(elClass) ||
# missing a class value in tag
! all(
selector$classes %in% splitCssClass(elClass)
)
) {
return(FALSE)
}
}
# No other matches fail. Mark as a match
TRUE
}
tagQueryFindDescendants <- function(els, selector) {
if (!isSelector(selector)) {
selector <- cssSelectorToSelector(selector)
}
foundStack <- envirStackUnique()
# For every element...
tagQueryWalk(els, function(el) {
if (!isTagEnv(el)) return()
# Ignore the element and
# Walk through each child...
tagQueryWalk(el$children, function(child) {
# Find descendant matching the `selector`
tagQueryFindDescendants_(child, selector, foundStack$push)
})
})
foundStack$uniqueList()
}
tagQueryFindDescendants_ <- function(el, selector, fn) {
if (isTagEnv(el)) {
isMatch <- elMatchesSelector(el, selector)
# If it was a match
if (isMatch) {
fn(el)
}
# If there are children and remaining selectors,
# Recurse through without matching
# (Only allowed if `>` is not found)
if (length(el$children) > 0) {
walk(
el$children,
tagQueryFindDescendants_,
fn = fn,
selector = selector
)
}
} else if (is.list(el)) {
# For each item in the list like object, recurse through
walk(el, tagQueryFindDescendants_, fn = fn, selector = selector)
} else if (is.null(el) || is.atomic(el) || is.function(el) || is.language(el)) {
# Can not match on atomics or functions
return()
} else {
message("tagQueryFindDescendants_() - Unknown Type! This has not happened before:")
str(el)
stop("Unknown type in tagQueryFindDescendants_()")
}
invisible()
}
# Find all elements within `els` that match the `selector`
tagQueryFindAll <- function(els, selector) {
selectorList <- asSelectorList(selector)
curEls <- els
walk(selectorList, function(selector) {
curEls <<-
if (selector$traversal == SELECTOR_CHILD) {
tagQueryFindChildren(curEls, selector)
} else {
# any descendant traversal
tagQueryFindDescendants(curEls, selector)
}
})
curEls
}
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.