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