1#' @importFrom fastmap fastmap faststack
2NULL
3
4# TODO-barret followup PR
5# * onRender(x, fn) - tagFunction(x, fn)
6
7## Methods not implemented
8# * `$set_selected(selected)` & `$set(selected_item, pos)` - These methods are
9# not available in jQuery and is very brittle in implementation. Do not pursue!
10# * With `$set(selected, pos)` not implemented, `[[<-.tagQuery` should not be
11# implemented
12# * With `$set(selected, pos_vector)` not implemented, `[<-.tagQuery` should not
13# be implemented
14# * If not doing, `[[<-.tagQuery` or `[<-.tagQuery`, then `[[.tagQuery` and
15# `[.tagQuery` should not be implemented. Same with `length.tagQuery`
16# * `$set_children(...)` - jQuery does not have this. Instead, you can call
17# `$empty()$append(...)`
18# * jQuery.val() - Get the current value of the first element in the set of
19# matched elements or set the value of every matched element.
20# * jQuery.text() - Get the combined text contents of each element in the set of
21# matched elements, including their descendants, or set the text contents of the
22# matched elements.
23# * jQuery.css() - Get the value of a computed style property for the first
24# element in the set of matched elements or set one or more CSS properties for
25# every matched element.
26# * jQuery.prop() - Get the value of a property for the first element in the set
27# of matched elements or set one or more properties for every matched element.
28
29
30
31
32## Skip these implementations for now as the tagQuery methods are small and composable.
33## Instead write them where they are needed since they are small.
34## (Just like we don't wrap dplyr code)
35# tagAppendAttributesAt <- function(tag, cssSelector, ...) {
36#   tagQuery(tag)$find(cssSelector)$addAttrs(...)$allTags()
37# }
38# tagAddClassAt <- function(tag, cssSelector, class) {
39#   tagQuery(tag)$find(cssSelector)$addClass(class)$allTags()
40# }
41# tagMutateAt <- function(x, cssSelector, fn) {
42#   tagQuery(tag)$find(cssSelector)$each(fn)$allTags()
43# }
44# tagFindAt <- function(x, cssSelector) {
45#   tagQuery(tag)$find(cssSelector)$selectedTags()
46# }
47
48
49# # Design notes for tagQuery:
50# ## Using stock R objects
51#
52# Advantages of standard R objects recursion
53# * Environments must be handled with care as they are pass by reference
54# * It is easy to alter the current object in place
55# * Difficult to create a new search path while altering in place
56#
57# Disadvantages of standard R objects recursion
58# * Asking for a grandparent element is difficult.
59#   * Altering a grandparent element and having the change stay is impossible
60# * Searching would need to be done at each stage, every time
61
62# ## Using environments elements
63#
64# Advantages
65# * Fast to convert to a "linked list" of tag environments
66# * Access to parents
67# * Calculations on siblings can now be done, even after alterations have been completed
68# * Once a `find(".x")` has been completed, a set of element environment pointers can be stored.
69#   * This makes followup alterations have the minimal O(k) complexity (where k
70#   is _found_ elements), not O(n) + O(k) graph search + reconstruction and k
71#   _found_ element alterations
72#
73# Disadvantages
74# * MUST be careful not alter the environment object before converting back to a
75# list. (Ex: Do not remove the element environment's children)
76# * The item returned is a set of environments that will alter in place. We will
77# need to be careful about documenting and/or safeguarding this
78
79
80# ## Final design choice:
81# Use environment elements
82# * Being able to search and have a list of eles to immediately look at and
83# alter in place is AMAZING!
84# * Being able to ask for a grandparent (or obj$parent$parent) and be able to
85# alter it in place is AMAZING! This has a strongly influenced by jquery.
86
87# ----------
88
89# # Current design decisions
90# * tagQuery objects or tag environments can NOT be used in UI. These objects
91# MUST be converted back to standard tag objects.
92# * tagFunctions will not be altered in place
93#   * To alter tagFunction()s, use the `onRender(x)` method to register a method
94#   to be called after `as.tags(x)` is called.
95#   * `onRender(x, expr)` will wrap create a tag function that will resolve the
96#   tags before running the expr.
97
98
99## rlang::obj_address()
100# Use to get a unique key for stacks
101# Use `env$envKey` over `rlang::obj_address()`; 10x speed improvement
102
103# Use for `has()` functionality
104envirMap <- function() {
105  map <- fastmap()
106  list(
107    keys = map$keys,
108    asList = function() {
109      unname(map$as_list())
110    },
111    has = function(envir) {
112      map$has(envir$envKey)
113    },
114    add = function(envir) {
115      map$set(envir$envKey, TRUE)
116    },
117    remove = function(envir) {
118      map$remove(envir$envKey)
119    }
120  )
121}
122# Use for consistent `asList()` order
123envirStack <- function() {
124  stack <- faststack()
125  list(
126    push = stack$push,
127    asList = stack$as_list,
128    uniqueList = function() {
129      unique(stack$as_list())
130    }
131  )
132}
133
134# (Used for `unique_envirStack()` only. Do not use directly!)
135# Provides same interface as `envirStack()`, but checks for duplicates when
136# when items are on their way in (with `push()`) instead of on the way out
137# (with `uniqueList()`). This is faster when size is ~500 and above.
138envirStackUni_ <- function() {
139  map <- fastmap()
140  stack <- faststack()
141  list(
142    push = function(env) {
143      key <- env$envKey
144      if (!map$has(key)) {
145        # mark the key as _seen_
146        map$set(key, TRUE)
147        # add the env
148        stack$push(env)
149      }
150    },
151    uniqueList = stack$as_list
152  )
153}
154# Use to retrieve unique environments (eg: `tq$parent()`)
155# Provides same interface as `envirStack()`, but switches to the faster
156# `envirStackUni_()` implementation when size hits 500.
157envirStackUnique <- function() {
158  stack <- envirStack()
159  count <- 0
160  list(
161    push = function(env) {
162      count <<- count + 1
163      if (count == 500) {
164        # convert the current stack to a `envirStackUni_()`
165        newStack <- envirStackUni_()
166        walk(stack$asList(), newStack$push)
167        stack <<- newStack
168      }
169      stack$push(env)
170    },
171    uniqueList = function() {stack$uniqueList()}
172  )
173}
174
175
176
177
178# Copy all attributes that can be manually set
179# ?attr
180# Note that some attributes (namely ‘class’, ‘comment’, ‘dim’,
181# ‘dimnames’, ‘names’, ‘row.names’ and ‘tsp’) are treated specially
182# and have restrictions on the values which can be set.
183copyAttributes <- function(from, to) {
184  attrVals <- attributes(from)
185  attrNames <- names(attrVals)
186  for (i in seq_along(attrNames)) {
187    attrName <- attrNames[i]
188    switch(
189      attrName,
190      class = , comment =, dim =, dimnames =, names =, row.names =, tsp = NULL,
191      {
192        # Copy over the attribute
193        attr(to, attrName) <- attrVals[[i]]
194      }
195    )
196  }
197
198  to
199}
200
201# Convert a list to an environment and keep class and attribute information
202safeListToEnv <- function(x, classToAdd = NULL) {
203  xList <- x
204  ret <- list2env(xList, new.env(parent = emptyenv()))
205  ret <- copyAttributes(from = xList, to = ret)
206  oldClass(ret) <- c(classToAdd, oldClass(xList))
207  ret
208}
209
210
211# Convert any mixture of standard tag structures and tag environments into just
212# tag environments.
213#
214# This method is heavily used within `tagQuery()$rebuild()` to enforce all
215# standard tag objects are upgraded to tag environments.
216#
217# If the object is already a tag environment, it will recurse the conversion for
218# each of the children
219#
220# Extras done:
221# * Flatten all attributes by combining duplicate keys
222# * Flatten the tag's children to a single list * Check for circular
223# dependencies of tag environments
224#
225# (Do not export to encourage direct use of `tagQuery()`)
226asTagEnv <- function(x) {
227  if (isTagQuery(x)) {
228    stop("`tagQuery()` object can not be provided to `asTagEnv()`")
229  }
230
231  if (!isTagEnv(x) && !isTag(x)) {
232    # force all methods to send in tags, lists / tagLists are not allowed
233    stop("`asTagEnv()` can only accept tag envs or tag objects. It does not accept `lists()` or `tagLists()`")
234  }
235  asTagEnv_(x, parent = x$parent)
236}
237# Checking for cycles is not performed as it is slow. With tagQuery methods not really
238# opening the door for cycles to occur, it would be the user doing dangerous things.
239# At this point, they should understand when a stack overflow occurs.
240asTagEnv_ <- function(x, parent = NULL) {
241  isTagVal <- isTag(x)
242  isTagEnvVal <- isTagEnv(x)
243
244  if (isTagVal || isTagEnvVal) {
245    if (!isTagEnvVal) {
246      xList <- x
247      x <- safeListToEnv(xList, "shiny.tag.env")
248      # add parent env and key
249      x$parent <- parent
250      x$envKey <- obj_address(x)
251    }
252
253    if (!is.character(x[["name"]])) {
254      stop("A tag environment has lost its `$name`. Did you remove it?")
255    }
256    # This alters the env, but these fields should exist!
257    if (is.null(x[["attribs"]])) x$attribs <- list(placeholder = NULL)[0] # Empty named list
258    if (is.null(x[["children"]])) x$children <- list()
259
260    # Recurse through children
261    if (length(x$children) != 0) {
262      # Possible optimization... name the children tags to the formatted values.
263      # * Allows for faster child look up later.
264      # * Comes with the cost of always formatting the env values even if children names are not needed.
265      # Attributes may be dropped
266      # * Could replace with `x$children[] <- ....`
267      # * Leaving as is to see if people mis-use the children field
268
269      # Simplify the structures by flatting the tags
270      # Does NOT recurse to grand-children etc.
271      children <- flattenTagsRaw(x$children)
272      # Use a `for-loop` over `lapply` to avoid `lapply` overhead
273      for (i in seq_along(children)) {
274        child <- children[[i]]
275        if (!is.null(child)) {
276          children[[i]] <- asTagEnv_(child, parent = x)
277        }
278      }
279      x$children <- children
280    }
281  }
282  x
283}
284
285# This method MUST undo everything done in `asTagEnv(x)`
286# Do not export to encourage direct use of `tagQuery()$selectedTags()`
287# Only allow for tag environments to be passed in.
288tagEnvToTags <- function(x) {
289  if (!isTagEnv(x)) {
290    stop("`tagEnvToTags(x)` must start with a tag environment")
291  }
292  tagEnvToTags_(x)
293}
294# Allows for all types of objects that can be put in a tag environment's `$children` field.
295# Ex: tag environment, "text", 5, tagFunctions, etc.
296tagEnvToTags_ <- function(x) {
297  if (isTagEnv(x)) {
298
299    xEl <- x
300
301    # Pull the names `name`, `attribs`, and `children` first to match `tag()` name order
302    envNames <- ls(envir = xEl, all.names = TRUE, sorted = FALSE)
303    newNames <- c(
304      "name", "attribs", "children",
305      if (length(envNames) > 5) {
306        # Pull remaining names if they exist
307        removeFromSet(envNames, c("name", "attribs", "children", "parent", "envKey"))
308      }
309    )
310
311    # Use mget to pull names in order to avoid always shuffling the values
312    x <- mget(newNames, xEl)
313    x <- copyAttributes(from = xEl, to = x)
314    oldClass(x) <- removeFromSet(oldClass(xEl), "shiny.tag.env")
315
316    # Recurse through children
317    children <- x$children
318    # Use a `for-loop` over `lapply` to avoid overhead
319    for (i in seq_along(children)) {
320      child <- children[[i]]
321      if (!is.null(child)) {
322        children[[i]] <- tagEnvToTags_(child)
323      }
324    }
325    x$children <- children
326  }
327  x
328}
329
330
331isTagEnv <- function(x) {
332  inherits(x, "shiny.tag.env")
333}
334isTagQuery <- function(x) {
335  inherits(x, "shiny.tag.query")
336}
337assertNotTagEnvLike <- function(x, fnName) {
338  if (isTagEnv(x)) {
339    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 `$root()` or `$selected()`?", call. = FALSE)
340  }
341  if (isTagQuery(x)) {
342    stop("`tagQuery()` objects are not allowed to be used as if they are regular `tag()` objects. Did you forget to call `$root()` or `$selected()`?", call. = FALSE)
343  }
344  invisible()
345}
346
347
348shinyTagEnvStr <- "<!-- shiny.tag.env -->"
349
350#' @export
351as.tags.shiny.tag.env <- function(x, ...) {
352  stop("Method not allowed", call. = TRUE)
353  # as.tags(tagEnvToTags(x), ...)
354}
355#' @export
356print.shiny.tag.env <- function(x, ...) {
357  cat(shinyTagEnvStr, "\n")
358  print(tagEnvToTags(x), ...)
359}
360#' @export
361format.shiny.tag.env <- function(x, ...) {
362  format(tagEnvToTags(x), ...)
363}
364#' @export
365as.character.shiny.tag.env <- function(x, ...) {
366  as.character(tagEnvToTags(x), ...)
367}
368#' @export
369str.shiny.tag.env <- function(object, ...) {
370  cat(shinyTagEnvStr, "\n")
371  str(tagEnvToTags(object), ...)
372}
373
374#' @export
375as.tags.shiny.tag.query <- function(x, ...) {
376  tagQueryAsTagErr()
377}
378#' @export
379print.shiny.tag.query <- function(x, ...) {
380  tagQ <- x
381  cat("`$allTags()`:\n")
382  allTags <- tagQ$allTags()
383  print(allTags)
384
385  selectedTags <- tagQ$selectedTags()
386
387  cat("\n`$selectedTags()`:")
388
389  if (length(selectedTags) == 0) {
390    cat(" (Empty selection)\n")
391  } else {
392    # Convert allTags to same style of object as selected tags
393    if (!isTagList(allTags)) allTags <- tagList(allTags)
394    allTags <- tagListPrintAsList(!!!allTags)
395
396    if (identical(allTags, selectedTags)) {
397      cat(" `$allTags()`\n")
398    } else {
399      cat("\n")
400      print(selectedTags)
401    }
402  }
403
404  invisible(x)
405}
406#' @export
407format.shiny.tag.query <- function(x, ...) {
408  tagQueryAsTagErr()
409}
410#' @export
411as.character.shiny.tag.query <- function(x, ...) {
412  tagQueryAsTagErr()
413}
414
415tagQueryAsTagErr <- function() {
416  stop(
417    "`tagQuery()` objects can not be written directly as HTML tags.",
418    "Call either `$allTags()` or `$selectedTags()` to extract the tags of interest.",
419    call. = FALSE
420  )
421}
422
423
424#' Query and modify HTML tags
425#'
426#' `r lifecycle::badge("experimental")`\cr\cr `tagQuery()` provides a
427#' [`jQuery`](https://jquery.com/) inspired interface for querying and modifying
428#' [tag()] (and [tagList()]) objects.
429#'
430#' @param tags A [tag()], [tagList()], or [list()] of tags.
431#' @return A class with methods that are described below. This class can't be
432#'   used directly inside other [tag()] or a [renderTags()] context, but
433#'   underlying HTML tags may be extracted via `$allTags()` or
434#'   `$selectedTags()`. Note: The returned tags will have their `$children`
435#'   fields flattened to a single `list()`, which may not be the same shape
436#'   that was provided to `tagQuery()`.
437#' @export
438tagQuery <- function(tags) {
439
440  if (isTagQuery(tags)) {
441    # Return tag query object as is
442    return(tags)
443  }
444
445  # Make a new tag query object from the root element of `tags`
446  # * Set the selected to `list(tags)`
447  if (isTagEnv(tags)) {
448    # Rebuild pseudo root tag
449    pseudoRoot <- asTagEnv(
450      findPseudoRootTag(tags)
451    )
452    return(
453      tagQuery_(pseudoRoot, list(tags))
454    )
455  }
456
457  # If `tags` is a list of tagEnvs...
458  # * Make sure they share the same root element and
459  # * Set the selected elements to `tags`
460  if (!isTag(tags) && (is.list(tags) || isTagList(tags))) {
461    # If it is a list, flatten them for easier/consisten inspection
462    tags <- flattenTagsRaw(tags)
463    tagsIsTagEnv <- vapply(tags, isTagEnv, logical(1))
464
465    # If one of the elements is a tag env, verify that all tagEnvs share the same root.
466    if (any(tagsIsTagEnv)) {
467      if (any(!tagsIsTagEnv)) {
468        notTagEnvPos <- which(!tagsIsTagEnv)
469        # It is not known how a middle of the tree tagEnv should be combined with a standard tag
470        stop(
471          "`tagQuery(tags=)` can not be a mix of tag environments and standard tag objects.\n",
472          "Items at positions `c(", paste0(notTagEnvPos, collapse = ", "), ")` ",
473          "are not tag environments."
474        )
475      }
476      pseudoRootStack <- envirStackUnique()
477      walk(tags, function(el) {
478        pseudoRootStack$push(findPseudoRootTag(el))
479      })
480      pseudoRoots <- pseudoRootStack$uniqueList()
481      if (length(pseudoRoots) != 1) {
482        stop("All tag environments supplied to `tagQuery()` must share the same root element.")
483      }
484      # Rebuild pseudo root tag
485      pseudoRoot <- asTagEnv(pseudoRoots[[1]])
486      return(
487        tagQuery_(pseudoRoot, tags)
488      )
489    }
490  }
491
492  # Convert standard tags to tag envs
493  root <- asTagEnv(
494    wrapWithPseudoRootTag(tags)
495  )
496  # Select the top level tags
497  selected <- tagQueryFindResetSelected(root)
498  if (length(selected) == 0) {
499    stop(
500      "The initial set of tags supplied to `tagQuery()` must have at least 1 standard tag object.",
501      " Ex: `div()`"
502    )
503  }
504  tagQuery_(root, selected)
505}
506
507#' @rdname tagQuery
508#' @aliases NULL
509#' @usage NULL
510tagQuery_ <- function(
511  pseudoRoot,
512  # Using a trailing `_` to avoid name collisions
513  selected_
514) {
515  if (!isPseudoRootTag(pseudoRoot)) {
516    stop("`tagQuery_(pseudoRoot=)` must be a pseudoRoot tag environment")
517  }
518
519  # Use `var_` names to avoid namespace collision
520  # Make sure all elements are tag envs
521  rebuild_ <- function() {
522    # safe to do as `pseudoRoot` will never be turned into a standard list
523    asTagEnv(pseudoRoot)
524  }
525  newTagQuery <- function(selected) {
526    tagQuery_(pseudoRoot, selected)
527  }
528
529  setSelected <- function(selected) {
530    selected <- selected %||% list()
531    if (!is.list(selected)) {
532      stop("`selected` must be a `list()`")
533    }
534    selected <- FilterI(selected, f = function(el, i) {
535      if (!isTagEnv(el)) {
536        stop(
537          "`setSelected(selected=)` received a list item at position `", i, "`",
538          " that was not a tag environment"
539        )
540      }
541      !isPseudoRootTag(el)
542    })
543    selected
544  }
545  selected_ <- setSelected(selected_)
546
547  self <-
548    structure(
549      class = "shiny.tag.query",
550      list(
551        #' @details
552        #'
553        #' # Vignette
554        #'
555        #' To get started with using `tagQuery()`, visit
556        #' <https://rstudio.github.io/htmltools/articles/tagQuery.html>.
557        #'
558        #' # Methods
559        #'
560        #' Unless otherwise stated, `tagQuery()` methods accept a character
561        #' vector as input.
562        #'
563        #' ## Query methods
564        #'
565        #' Query methods identify particular subsets of the root tag using CSS
566        #' selectors (or R functions).
567        #'
568        #' ### Children
569        #'
570        #' * `$find(cssSelector)`: Get the descendants of
571        #' each selected tag, filtered by a `cssSelector`.
572        find = function(cssSelector) {
573          newTagQuery(
574            tagQueryFindAll(selected_, cssSelector)
575          )
576        },
577        #' * `$children(cssSelector = NULL)`: Get the direct
578        #' children of each selected tag, optionally filtered by a
579        #' `cssSelector`.
580        children = function(cssSelector = NULL) {
581          newTagQuery(
582            tagQueryFindChildren(selected_, cssSelector)
583          )
584        },
585        #' ### Siblings
586        #'
587        #' * `siblings(cssSelector = NULL)`: Get the
588        #' siblings of each selected tag, optionally filtered by a
589        #' `cssSelector`.
590        siblings = function(cssSelector = NULL) {
591          newTagQuery(
592            tagQueryFindSiblings(selected_, cssSelector)
593          )
594        },
595        #' ### Parents
596        #'
597        #' * `$parent(cssSelector = NULL)`: Get the parent
598        #' of each selected tag, optionally filtered by a `cssSelector`.
599        parent = function(cssSelector = NULL) {
600          newTagQuery(
601            tagQueryFindParent(selected_, cssSelector)
602          )
603        },
604        #' * `$parents(cssSelector = NULL)`: Get the
605        #' ancestors of each selected tag, optionally filtered by a
606        #' `cssSelector`.
607        parents = function(cssSelector = NULL) {
608          newTagQuery(
609            tagQueryFindParents(selected_, cssSelector)
610          )
611        },
612        #' * `$closest(cssSelector = NULL)`: For each selected tag, get the closest
613        #' ancestor tag (including itself) satisfying a `cssSelector`. If
614        #' `cssSelector = NULL`, it is equivalent to calling `$selectedTags()`.
615        closest = function(cssSelector = NULL) {
616          newTagQuery(
617            tagQueryFindClosest(selected_, cssSelector)
618          )
619        },
620        #' ### Custom filter
621        #'
622        #' * `$filter(fn)`: Filter the selected tags to those for which `fn(x,
623        #' i)` returns `TRUE`. In addition to an R function with two arguments
624        #' (the selected tag `x` and the index `i`), `fn` may also be a valid
625        #' CSS selector.
626        filter = function(fn) {
627          newSelected <- tagQueryFindFilter(selected_, fn)
628          rebuild_()
629          newTagQuery(newSelected)
630        },
631        #' ### Length
632        #'
633        #' * `$length()`: Number of tags that have been selected.
634        length = function() {
635          length(selected_)
636        },
637        #' ### Reset
638        #'
639        #' * `$resetSelected()`: Reset selected tags to the `$root()` tag. Useful
640        #' in combination with `$replaceWith()` since it empties the selection.
641        resetSelected = function() {
642          newTagQuery(
643            tagQueryFindResetSelected(pseudoRoot)
644          )
645        },
646
647        #' ## Modify methods
648        #'
649        #' Unlike query methods, modify methods modify the `tagQuery()` object.
650        #'
651        #' ### Attributes
652        #'
653        #' * `$addClass(class)`: Adds class(es) to each selected tag.
654        addClass = function(class) {
655          tagQueryClassAdd(selected_, class)
656          self
657        },
658        #' * `$removeClass(class)`: Removes class(es) to each selected tag.
659        removeClass = function(class) {
660          tagQueryClassRemove(selected_, class)
661          self
662        },
663        #' * `$toggleClass(class)`: Adds class(es) that don't already exist and
664        #' removes class(es) that do already exist (for each selected tag).
665        toggleClass = function(class) {
666          tagQueryClassToggle(selected_, class)
667          self
668        },
669        #' * `$hasClass(class)`: Does each selected tag have all the provided
670        #' class(es)?
671        hasClass = function(class) {
672          tagQueryClassHas(selected_, class)
673        },
674        #' * `$addAttrs(...)`: Add a set of attributes to each selected tag.
675        addAttrs = function(...) {
676          tagQueryAttrsAdd(selected_, ...)
677          self
678        },
679        #' * `$removeAttrs(attrs)`: Remove a set of attributes from each
680        #' selected tag.
681        removeAttrs = function(attrs) {
682          tagQueryAttrsRemove(selected_, attrs)
683          self
684        },
685        #' * `$hasAttrs(attr)`: Do each selected tags have all of the attributes?
686        hasAttrs = function(attrs) {
687          tagQueryAttrsHas(selected_, attrs)
688        },
689        #' ### Children
690        #'
691        #' * `$append(...)`: For each selected tag, insert `...` **after** any
692        #' existing children.
693        append = function(...) {
694          tagQueryChildrenAppend(selected_, ...)
695          self
696        },
697        #' * `$prepend(...)`: For each selected tag, insert `...` **before** any
698        #' existing children.
699        prepend = function(...) {
700          tagQueryChildrenPrepend(selected_, ...)
701          self
702        },
703        #' ### Siblings
704        #'
705        #' * `$after(...)`: Add all `...` objects as siblings after each of the
706        #' selected tags.
707        after = function(...) {
708          tagQuerySiblingAfter(selected_, ...)
709          self
710        },
711        #' * `$before(...)`: Add all `...` objects as siblings before each of
712        #' the selected tags.
713        before = function(...) {
714          tagQuerySiblingBefore(selected_, ...)
715          self
716        },
717        #' ### Custom
718        #'
719        #' * `$each(fn)`: Modify each selected tag with a function `fn`. `fn`
720        #' should accept two arguments: the first is the selected tag and second
721        #' is the selected tags position index. Since the selected tag is a
722        #' reference, any modifications to it will also modify the `tagQuery()`
723        #' object.
724        each = function(fn) {
725          if (length(selected_) > 0) {
726            tagQueryEach(selected_, fn)
727            rebuild_()
728          }
729          self
730        },
731
732        #' ## Replace methods
733        #'
734        #' * `$replaceWith(...)`: Replace all selected tags with `...` in the
735        #' root tag and clear the selection.
736        replaceWith = function(...) {
737          tagQuerySiblingReplaceWith(selected_, ...)
738          newTagQuery(list())
739        },
740        #' * `$remove(...)`: Remove all selected tags from the root tag and
741        #' clear the current selection.
742        remove = function() {
743          tagQuerySiblingRemove(selected_)
744          # Remove items from selected info
745          newTagQuery(list())
746        },
747        #' * `$empty()`: Remove any children of each selected tag. Use this
748        #' method before calling `$append(...)` to replace the children of
749        #' each selected tag, with other content.
750        empty = function() {
751          tagQueryChildrenEmpty(selected_)
752          self
753        },
754
755        #' ## Extract HTML tags
756        #'
757        #' * `$allTags()`: Return the (possibly modified) root `tags`.
758        allTags = function() {
759          tagQueryTopLevelTags(pseudoRoot)
760        },
761        #' * `$selectedTags()`: Return a [tagList()] of the currently selected
762        #' tags.
763        selectedTags = function() {
764          tagQuerySelectedAsTags(selected_)
765        }
766        #' @examples
767        #' tagQ <- tagQuery(div(a()))
768        #' tagQ$find("a")$addClass("foo")
769        #' tagQ
770        #'
771        #' # To learn more, visit https://rstudio.github.io/htmltools/articles/tagQuery.html
772      )
773    )
774  self
775}
776
777
778validatePosition <- function(position, selected) {
779  if (!is.numeric(position)) {
780    stop("`position` must be a numeric value")
781  }
782  if (length(position) != 1) {
783    stop("`position` must have a length equal to 1")
784  }
785  if (position <= 0) {
786    stop("`position` must be greater than 0")
787  }
788  if (position > length(selected)) {
789    stop(
790      "`position` must be less than or equal to the length of the selected elements: ",
791      length(selected)
792    )
793  }
794}
795
796validateFnCanIterate <- function(fn) {
797  if (!is.function(fn)) {
798    stop("`fn` must be a function")
799  }
800  fnFormals <- formals(fn)
801  if (! ("..." %in% names(fnFormals))) {
802    if (length(fnFormals) < 2) {
803      stop(
804        "`fn(selected_i, i)` must be a function that accepts at least two arguments: ",
805        "`selected[[i]]` and `i` "
806      )
807    }
808  }
809}
810
811isPseudoRootTag <- function(x) {
812  name <- x$name
813  isTag(x) && !is.null(name) && isTRUE(name == "TagQueryPseudoRoot")
814}
815
816findPseudoRootTag <- function(el) {
817  while (!is.null(el$parent)) {
818    el <- el$parent
819  }
820  el
821}
822
823# Wrap the top level tags in the tagQuery() in a `tagQuery` tag object.
824# This allows for appending and prepending elements to the top level tags.
825# (Don't fight the structures... embrace them!)
826wrapWithPseudoRootTag <- function(x) {
827  tagSetChildren(
828    tag("TagQueryPseudoRoot", list()),
829    x
830  )
831}
832
833
834# Return a tag env, tagList(tag envs), or NULL
835tagQueryGetRoot <- function(root) {
836  children <- root$children
837  len <- length(children)
838  if (len == 1) {
839    children[[1]]
840  } else if (len > 1) {
841    tagList(!!!children)
842  } else {
843    # no children?
844    NULL
845  }
846}
847
848# Return a list of the manually selected elements
849tagQuerySelected <- function(selected) {
850  if (length(selected) == 1 && isPseudoRootTag(selected[[1]])) {
851    list()
852  } else {
853    selected
854  }
855}
856
857# # Return the `i`th position of the manually selected elements
858# tagQueryGet <- function(selected, position) {
859#   selected <- tagQuerySelected(selected)
860#   validatePosition(position, selected)
861
862#   selected[[position]]
863# }
864
865# Return the top level tags as a tagList or a single tag
866tagQueryTopLevelTags <- function(pseudoRoot) {
867  children <- tagEnvToTags(pseudoRoot)$children
868  len <- length(children)
869  if (len == 1) {
870    # single top level tag
871    children[[1]]
872  } else {
873    # 0 or >1 top leve tags
874    tagList(!!!children)
875  }
876}
877
878tagListPrintAsList <- function(...) {
879  x <- tagList(...)
880  attr(x, "print.as.list") <- TRUE
881  x
882}
883tagQuerySelectedAsTags <- function(selected) {
884  # return as a `tagList()` with a special attr that will cause it to print like a list
885  tagListPrintAsList(!!!lapply(selected, tagEnvToTags))
886}
887
888
889as_character2 <- function(...) {
890  as.character(
891    # MUST call `unlist()` to allow for vector items in `list2()`
892    unlist(
893      list2(...),
894      use.names = FALSE
895    )
896  )
897}
898FilterI <- function (f, x) {
899  ind <- as.logical(
900    Map(x, seq_along(x), f = f)
901  )
902  x[which(ind)]
903}
904# Call `.f(x[[i]], ...)` for all values of i
905walk <- function(.x, .f, ...) {
906  for (i in seq_along(.x)) {
907    .f(.x[[i]], ...)
908  }
909  NULL
910}
911walk2 <- function(.x, .y, .f, ...) {
912  if (length(.x) != length(.y)) {
913    stop(".x and .y must be the same length.")
914  }
915  for (i in seq_along(.x)) {
916    .f(.x[[i]], .y[[i]], ...)
917  }
918  NULL
919}
920# Call `.f(x[[i]])` in reverse order
921# walk_rev <- function(.x, .f, ...) {
922#   for (i in rev(seq_along(.x))) {
923#     .f(.x[[i]], ...)
924#   }
925#   NULL
926# }
927# Calls `.f(x[[i]], i, ...)`
928walkI <- function(.x, .f, ...) {
929  for (i in seq_along(.x)) {
930    .f(.x[[i]], i, ...)
931  }
932  NULL
933}
934# Calls `.f(x[[i]], i, ...)` in reverse order
935walkIRev <- function(.x, .f, ...) {
936  for (i in rev(seq_along(.x))) {
937    .f(.x[[i]], i, ...)
938  }
939  NULL
940}
941
942
943# Return function that will verify elements before performing `func(els, fn)`
944selectedWalkGen <- function(func) {
945  force(func)
946  function(els, fn) {
947    if (is.null(els)) return(list())
948    if (!is.list(els)) {
949      stop("A list() must be supplied")
950    }
951    if (!is.function(fn)) {
952      stop("`fn` must be a function")
953    }
954
955    # Make sure each item in list is a tag env
956    walkI(els, function(el, i) {
957      if (!is.null(el)) {
958        if (isTag(el) && !isTagEnv(el)) {
959          str(el)
960          stop(
961            "Object in position `", i, "` is a regular `tag()` and not a tag environment.",
962            "\nDid you forget to call `$rebuild()`?"
963          )
964        }
965      }
966    })
967
968    func(els, fn)
969  }
970}
971tagQueryWalk <- selectedWalkGen(walk)
972# selectedWalkRev <- selectedWalkGen(walkRev)
973selectedWalkI <- selectedWalkGen(walkI)
974selectedWalkIRev <- selectedWalkGen(walkIRev)
975tagQueryLapply <- selectedWalkGen(lapply)
976
977
978# Perform `fn` on each el in els
979tagQueryEach <- function(els, fn) {
980  validateFnCanIterate(fn)
981  selectedWalkI(els, fn)
982}
983
984
985# For each el in els, go to el parent and find el's position
986# Then call `fn(parent, el, elPos)`
987# Perform this matching in reverse order
988tagQueryMatchChildRev <- function(els, func) {
989  tagQueryWalk(els, function(el) {
990    if (!isTagEnv(el)) return()
991    elKey <- el$envKey
992    elParent <- el$parent
993    # Walk in reverse to be able to remove all matches in a single pass
994    selectedWalkIRev(elParent$children, function(child, childPos) {
995      if (!isTagEnv(el)) return()
996      childKey <- child$envKey
997      if (elKey == childKey) {
998        func(elParent, el, childPos)
999        # Make sure to rebuild the parent tag into tag envs
1000        # Their internal structures will have changed
1001        asTagEnv(elParent)
1002      }
1003    })
1004  })
1005}
1006# Remove each el in els from their parent.
1007# Also remove parent pointer from within el
1008tagQuerySiblingRemove <- function(els) {
1009  tagQueryMatchChildRev(els, function(elParent, el, childPos) {
1010    # remove parent / child relationship
1011    el$parent <- NULL
1012    elParent$children[[childPos]] <- NULL
1013  })
1014}
1015# Add siblings after each el
1016tagQuerySiblingAfter <- function(els, ...) {
1017  tagQueryMatchChildRev(els, function(elParent, el, childPos) {
1018    tagInsertChildren(elParent, after = childPos, ...)
1019  })
1020}
1021# Add siblings before each el
1022tagQuerySiblingBefore <- function(els, ...) {
1023  tagQueryMatchChildRev(els, function(elParent, el, childPos) {
1024    tagInsertChildren(elParent, after = childPos - 1, ...)
1025  })
1026}
1027# Replace all `el` objects with `...`
1028tagQuerySiblingReplaceWith <- function(els, ...) {
1029  tagQueryMatchChildRev(els, function(elParent, el, childPos) {
1030    # Remove the current element
1031    el$parent <- NULL
1032    elParent$children[[childPos]] <- NULL
1033    # Replace with ... content where the child was
1034    tagInsertChildren(elParent, after = childPos - 1, ...)
1035  })
1036}
1037
1038
1039tagQueryChildrenSet <- function(els, ...) {
1040  tagQueryWalk(els, function(el) {
1041    if (!isTagEnv(el)) return()
1042    tagSetChildren(el, ...)
1043    # Make sure to rebuild the el and its children
1044    asTagEnv(el)
1045  })
1046}
1047tagQueryChildrenEmpty <- function(els) {
1048  # Do not include any arguments.
1049  # `dots_list()` returns an empty named list()
1050  tagQueryChildrenSet(els)
1051}
1052tagQueryChildrenAppend <- function(els, ...) {
1053  tagQueryWalk(els, function(el) {
1054    if (!isTagEnv(el)) return()
1055    tagInsertChildren(el, after = length(el$children), ...)
1056    # Make sure to rebuild the el and its children
1057    asTagEnv(el)
1058  })
1059}
1060tagQueryChildrenPrepend <- function(els, ...) {
1061  tagQueryChildrenInsert(els, after = 0, ...)
1062}
1063tagQueryChildrenInsert <- function(els, after, ...) {
1064  tagQueryWalk(els, function(el) {
1065    if (!isTagEnv(el)) return()
1066    tagInsertChildren(el, after = after, ...)
1067    # Make sure to rebuild the el and its children
1068    asTagEnv(el)
1069  })
1070}
1071
1072
1073tagEnvRemoveAttribs <- function(el, attrs) {
1074  el$attribs[names(el$attribs) %in% attrs] <- NULL
1075  el
1076}
1077# Add attribute values
1078tagQueryAttrsAdd <- function(els, ...) {
1079  tagQueryWalk(els, function(el) {
1080    if (!isTagEnv(el)) return()
1081    tagAppendAttributes(el, ...)
1082  })
1083}
1084# Remove attribute values
1085tagQueryAttrsRemove <- function(els, attrs) {
1086  attrs <- as_character2(attrs)
1087  if (length(attrs) < 1) return()
1088  if (!is.character(attrs)) {
1089    stop("`attrs` must be a charcter vector of attributes to remove")
1090  }
1091  tagQueryWalk(els, function(el) {
1092    if (!isTagEnv(el)) return()
1093    tagEnvRemoveAttribs(el, attrs)
1094  })
1095}
1096# Check if els have attributes
1097tagQueryAttrsHas <- function(els, attrs) {
1098  attrs <- as_character2(attrs)
1099  if ((length(attrs) == 0) || (!is.character(attrs))) {
1100    stop("`attrs` must be a character vector", call. = FALSE)
1101  }
1102  unlist(
1103    tagQueryLapply(els, function(el) {
1104      if (!isTagEnv(el)) return(FALSE)
1105
1106      for (attr in attrs) {
1107        if (!tagHasAttribute(el, attr)) {
1108          return(FALSE)
1109        }
1110      }
1111      # All attrs found
1112      return(TRUE)
1113    }),
1114    use.names = FALSE
1115  )
1116}
1117
1118prepCssClass <- function(class) {
1119  class <- as_character2(class)
1120  if (length(class) == 0 || !is.character(class)) {
1121    stop("`class` must resolve to a character value with a length of at least 1")
1122  }
1123  class
1124}
1125getCssClass <- function(class) {
1126  splitCssClass(prepCssClass(class))
1127}
1128splitCssClass <- function(class) {
1129  if (!is.character(class)) {
1130    stop("tagGetAttribute(x, \"class\") did not return a character value")
1131  }
1132  if (length(class) > 1) {
1133    class <- paste0(class, collapse = " ")
1134  }
1135  strsplit(class, "\\s+")[[1]]
1136}
1137joinCssClass <- function(classes) {
1138  if (length(classes) == 0) {
1139    NULL
1140  } else {
1141    paste0(classes, collapse = " ")
1142  }
1143}
1144# return list of logical values telling if the classes exists
1145tagQueryClassHas <- function(els, class) {
1146  # Quit early if class == NULL | character(0)
1147  if (length(class) == 0) {
1148    return(rep(FALSE, length(els)))
1149  }
1150
1151  classes <- getCssClass(class)
1152  unlist(
1153    tagQueryLapply(els, function(el) {
1154      if (!isTagEnv(el)) return(FALSE)
1155      classVal <- tagGetAttribute(el, "class")
1156      if (isNonConformClassValue(classVal)) {
1157        return(FALSE)
1158      }
1159      elClasses <- splitCssClass(classVal)
1160      all(classes %in% elClasses)
1161    }),
1162    use.names = FALSE
1163  )
1164}
1165removeFromSet <- function(set, vals) {
1166  # removes the call to `unique()` with `setdiff`
1167  set[match(set, vals, 0L) == 0L]
1168}
1169isNonConformClassValue <- function(classVal) {
1170  length(classVal) == 0 ||
1171  (!is.character(classVal)) ||
1172  anyNA(classVal)
1173}
1174tagEnvSetClassAttrib <- function(el, classes) {
1175  class <- joinCssClass(classes)
1176
1177  classAttribPos <- which(names(el$attribs) == "class")
1178  isClassLen <- length(classAttribPos)
1179
1180  if (isClassLen == 0) {
1181    # Store new class value
1182    return(
1183      tagAppendAttributes(el, class = class)
1184    )
1185  }
1186
1187  # isClassLen > 0
1188  if (isClassLen > 1) {
1189    # Remove other occurrences of class
1190    el$attribs[classAttribPos[-1]] <- NULL
1191  }
1192  # Overwrite "class" attrib
1193  el$attribs[[classAttribPos[1]]] <- class
1194  el
1195}
1196# add classes that don't already exist
1197tagQueryClassAdd <- function(els, class) {
1198  # Quit early if class == NULL | character(0)
1199  if (length(class) == 0) return()
1200
1201  classes <- getCssClass(class)
1202  tagQueryWalk(els, function(el) {
1203    if (!isTagEnv(el)) return()
1204    classVal <- tagGetAttribute(el, "class")
1205    if (isNonConformClassValue(classVal)) {
1206      tagAppendAttributes(el, class = joinCssClass(classes))
1207    } else {
1208      elClasses <- splitCssClass(classVal)
1209      newClasses <- c(elClasses, removeFromSet(classes, elClasses))
1210      tagEnvSetClassAttrib(el, newClasses)
1211    }
1212  })
1213}
1214# remove classes that exist
1215tagQueryClassRemove <- function(els, class) {
1216  # Quit early if class == NULL | character(0)
1217  if (length(class) == 0) return()
1218
1219  classes <- getCssClass(class)
1220  tagQueryWalk(els, function(el) {
1221    if (!isTagEnv(el)) return()
1222    classVal <- tagGetAttribute(el, "class")
1223    if (isNonConformClassValue(classVal)) return()
1224    elClasses <- splitCssClass(classVal)
1225    newClasses <- removeFromSet(elClasses, classes)
1226    tagEnvSetClassAttrib(el, newClasses)
1227  })
1228}
1229# toggle class existence depending on if they already exist or not
1230tagQueryClassToggle <- function(els, class) {
1231  # Quit early if class == NULL | character(0)
1232  if (length(class) == 0) return()
1233
1234  classes <- getCssClass(class)
1235  tagQueryWalk(els, function(el) {
1236    if (!isTagEnv(el)) return()
1237    classVal <- tagGetAttribute(el, "class")
1238    if (isNonConformClassValue(classVal)) return()
1239
1240    elClasses <- splitCssClass(classVal)
1241    hasClass <- (classes %in% elClasses)
1242    if (any(hasClass)) {
1243      elClasses <- removeFromSet(elClasses, classes)
1244    }
1245    if (any(!hasClass)) {
1246      elClasses <- c(elClasses, classes[!hasClass])
1247    }
1248    tagEnvSetClassAttrib(el, elClasses)
1249  })
1250}
1251
1252
1253# Return a list of `root$children`.
1254# This may change if root ends up becoming a list of elements
1255tagQueryFindResetSelected <- function(pseudoRoot) {
1256  if (!isTagEnv(pseudoRoot)) {
1257    stop("`pseudoRoot` must be a tag environment")
1258  }
1259  Filter(pseudoRoot$children, f = isTagEnv)
1260}
1261# Return a list of the unique set of parent elements
1262tagQueryFindParent <- function(els, cssSelector = NULL) {
1263  parentStack <- envirStackUnique()
1264  pushFn <- pushFnWrapper(parentStack, cssSelector)
1265  tagQueryWalk(els, function(el) {
1266    if (!isTagEnv(el)) return()
1267    pushFn(el$parent)
1268  })
1269  parentStack$uniqueList()
1270}
1271# Return a list of the unique set of ancestor elements
1272
1273# * By only looking for elements that have not been seen before, searching is as
1274# lazy as possible
1275# * Must traverse all parents; If cssSelector exists, only return found parents
1276# that match selector.
1277# * Search using depth-first. This does not match jQuery's implementation.
1278tagQueryFindParents <- function(els, cssSelector = NULL) {
1279  # Use the map for `has()` and stack for `values()`
1280  ancestorsMap <- envirMap()
1281  ancestorsStack <- envirStackUnique()
1282
1283  # func to add to the ancestor stack
1284  pushFn <- pushFnWrapper(ancestorsStack, cssSelector)
1285
1286  # For every element
1287  tagQueryWalk(els, function(el) {
1288    # Make sure it is a tag environment
1289    if (!isTagEnv(el)) return()
1290
1291    # While traversing up the parents...
1292    while (!is.null(el <- el$parent)) {
1293      # If the element has been seen before...
1294      if (ancestorsMap$has(el)) {
1295        # Stop traversing, as any matching parent found would be removed
1296        # (unique info only)
1297        return()
1298      }
1299      # Mark the ancestor as visited
1300      ancestorsMap$add(el)
1301      # Add the element to the return set
1302      pushFn(el)
1303    }
1304  })
1305  ancestorsStack$uniqueList()
1306}
1307# Return a unique list of the closest ancestor elements that match the css selector
1308# Should behave VERY similarly to $parents()
1309tagQueryFindClosest <- function(els, cssSelector = NULL) {
1310  if (is.null(cssSelector)) {
1311    return(els)
1312  }
1313  selector <- cssSelectorToSelector(cssSelector)
1314  # use the map for `has()` and stack for `values()`
1315  ancestorsMap <- envirMap()
1316  closestStack <- envirStackUnique()
1317
1318  # For every element
1319  tagQueryWalk(els, function(el) {
1320    # Make sure it is a tag environment
1321    if (!isTagEnv(el)) return()
1322
1323    # While traversing up the parents...
1324    while (!is.null(el)) {
1325      # If the element has been seen before...
1326      if (ancestorsMap$has(el)) {
1327        # Stop traversing, as any matching parent found would be removed
1328        # (unique info only)
1329        return()
1330      }
1331      # Mark the ancestor as visited
1332      ancestorsMap$add(el)
1333      # If it is a match...
1334      if (elMatchesSelector(el, selector)) {
1335        # Add to return value
1336        closestStack$push(el)
1337        return()
1338      }
1339      # set to parent element and repeat
1340      el <- el$parent
1341    }
1342  })
1343
1344  closestStack$uniqueList()
1345}
1346# Get all unique children tag envs
1347tagQueryFindChildren <- function(els, cssSelector = NULL) {
1348  childrenStack <- envirStackUnique()
1349  pushFn <- pushFnWrapper(childrenStack, cssSelector)
1350  tagQueryWalk(els, function(el) {
1351    if (!isTagEnv(el)) return()
1352    tagQueryWalk(el$children, pushFn)
1353  })
1354  childrenStack$uniqueList()
1355}
1356
1357# Return all unique siblings of each el in els
1358tagQueryFindSiblings <- function(els, cssSelector = NULL) {
1359  siblingStack <- envirStackUnique()
1360  pushFn <- pushFnWrapper(siblingStack, cssSelector)
1361  tagQueryWalk(els, function(el) {
1362    if (!isTagEnv(el)) return()
1363    elKey <- el$envKey
1364    tagQueryWalk(el$parent$children, function(sibling) {
1365      if (!isTagEnv(sibling)) return()
1366      siblingKey <- sibling$envKey
1367      if (elKey != siblingKey) {
1368        pushFn(sibling)
1369      }
1370    })
1371  })
1372  siblingStack$uniqueList()
1373}
1374
1375# Filter the selected elements using a function
1376# The answer of `fn(el, i)` should work in an `if` block
1377tagQueryFindFilter <- function(els, fn) {
1378  if (is.character(fn)) {
1379    selector <- cssSelectorToSelector(fn)
1380    fn <- function(el, i) {
1381      elMatchesSelector(el, selector)
1382    }
1383  }
1384  validateFnCanIterate(fn)
1385
1386  filterStack <- envirStackUnique()
1387  selectedWalkI(els, function(el, i) {
1388    if (fn(el, i)) {
1389      filterStack$push(el)
1390    }
1391  })
1392
1393  filterStack$uniqueList()
1394}
1395
1396
1397# Convert a CSS selection character value to a selector object
1398# @param cssSelector A character value representing a CSS search pattern
1399# @return A single item of a selector list. (See `asSelectorList()`).
1400#   A single-element CSS selector object with full CSS element match information.
1401#   (Child selectors are not allowed in single-element selectors)
1402cssSelectorToSelector <- function(cssSelector) {
1403  selector <-
1404    if (isSelector(cssSelector)) {
1405      cssSelector
1406    } else {
1407      selectorList <- asSelectorList(cssSelector)
1408      if (length(selectorList) > 1) {
1409        stop(
1410          "Can only match using a simple CSS selector. ",
1411          "Looking for descendant elements is not allowed."
1412        )
1413      }
1414      selectorList[[1]]
1415    }
1416
1417  selector
1418}
1419
1420pushFnWrapper <- function(stack, cssSelector) {
1421  if (is.null(cssSelector)) {
1422    stack$push
1423  } else {
1424    selector <- cssSelectorToSelector(cssSelector)
1425    function(el) {
1426      if (elMatchesSelector(el, selector)) {
1427        stack$push(el)
1428      }
1429    }
1430  }
1431}
1432
1433
1434elMatchesSelector <- function(el, selector) {
1435  if (!isTagEnv(el)) return(FALSE)
1436
1437  if (!isSelector(selector)) {
1438    stop("`elMatchesSelector(selector=)` must be an object of class `\"shinySelector\"`")
1439  }
1440
1441  if (selector$type == SELECTOR_EVERYTHING) {
1442    return(TRUE)
1443  }
1444
1445  # match on element
1446  if (!is.null(selector$element)) {
1447    # bad element match
1448    if (el$name != selector$element) {
1449      return(FALSE)
1450    }
1451  }
1452
1453  # match on id
1454  if (!is.null(selector$id)) {
1455    # bad id match
1456    if ( !identical(tagGetAttribute(el, "id"), selector$id)) {
1457      return(FALSE)
1458    }
1459  }
1460
1461  # match on class values
1462  if (!is.null(selector$classes)) {
1463    elClass <- tagGetAttribute(el, "class")
1464    if (
1465      isNonConformClassValue(elClass) ||
1466      # missing a class value in tag
1467      ! all(
1468        selector$classes %in% splitCssClass(elClass)
1469      )
1470    ) {
1471      return(FALSE)
1472    }
1473  }
1474
1475  # No other matches fail. Mark as a match
1476  TRUE
1477}
1478
1479
1480tagQueryFindDescendants <- function(els, selector) {
1481  if (!isSelector(selector)) {
1482    selector <- cssSelectorToSelector(selector)
1483  }
1484
1485  foundStack <- envirStackUnique()
1486  # For every element...
1487  tagQueryWalk(els, function(el) {
1488    if (!isTagEnv(el)) return()
1489    # Ignore the element and
1490    # Walk through each child...
1491    tagQueryWalk(el$children, function(child) {
1492      # Find descendant matching the `selector`
1493      tagQueryFindDescendants_(child, selector, foundStack$push)
1494    })
1495  })
1496  foundStack$uniqueList()
1497}
1498
1499tagQueryFindDescendants_ <- function(el, selector, fn) {
1500  if (isTagEnv(el)) {
1501
1502    isMatch <- elMatchesSelector(el, selector)
1503
1504    # If it was a match
1505    if (isMatch) {
1506      fn(el)
1507    }
1508
1509    # If there are children and remaining selectors,
1510    # Recurse through without matching
1511    # (Only allowed if `>` is not found)
1512    if (length(el$children) > 0) {
1513      walk(
1514        el$children,
1515        tagQueryFindDescendants_,
1516        fn = fn,
1517        selector = selector
1518      )
1519    }
1520
1521  } else if (is.list(el)) {
1522    # For each item in the list like object, recurse through
1523    walk(el, tagQueryFindDescendants_, fn = fn, selector = selector)
1524  } else if (is.atomic(el) || is.function(el)) {
1525    # Can not match on atomics or functions
1526    return()
1527  } else {
1528    message("tagQueryFindDescendants_() - Unknown Type! This has not happened before:")
1529    str(el)
1530    stop("Unknown type in tagQueryFindDescendants_()")
1531  }
1532
1533  invisible()
1534}
1535
1536# Find all elements within `els` that match the `selector`
1537tagQueryFindAll <- function(els, selector) {
1538  selectorList <- asSelectorList(selector)
1539
1540  curEls <- els
1541  walk(selectorList, function(selector) {
1542    curEls <<-
1543      if (selector$traversal == SELECTOR_CHILD) {
1544        tagQueryFindChildren(curEls, selector)
1545      } else {
1546        # any descendant traversal
1547        tagQueryFindDescendants(curEls, selector)
1548      }
1549  })
1550
1551  curEls
1552}
1553