tagQuery(): Speed enhancements and consistent tag name order (#249)

Co-authored-by: Barret Schloerke <[email protected]> Co-authored-by: Winston Chang <[email protected]> Co-authored-by: Carson Sievert <[email protected]>
rstudio · May 13, 2021 · 2e3571e · 2e3571e
1 parent e12171e
commit 2e3571e
Show file tree

Hide file tree

Showing 3 changed files with 152 additions and 95 deletions.
diff --git a/R/tag_query.R b/R/tag_query.R
@@ -177,49 +177,38 @@ envirStackUnique <- function() {
 
 
 
-
-
-# Retrieve all attributes that can be manually set
+# Copy all attributes that can be manually set
 # ?attr
 # Note that some attributes (namely ‘class’, ‘comment’, ‘dim’,
 # ‘dimnames’, ‘names’, ‘row.names’ and ‘tsp’) are treated specially
 # and have restrictions on the values which can be set.
-safeAttrValues <- function(x) {
-  badElAttrs <- c("class", "comment", "dim", "dimnames", "names", "row.names", "tsp")
-  attrVals <- attributes(x)
-  attrVals[badElAttrs] <- NULL
-  attrVals
+copyAttributes <- function(from, to) {
+  attrVals <- attributes(from)
+  attrNames <- names(attrVals)
+  for (i in seq_along(attrNames)) {
+    attrName <- attrNames[i]
+    switch(
+      attrName,
+      class = , comment =, dim =, dimnames =, names =, row.names =, tsp = NULL,
+      {
+        # Copy over the attribute
+        attr(to, attrName) <- attrVals[[i]]
+      }
+    )
+  }
+
+  to
 }
 
 # Convert a list to an environment and keep class and attribute information
 safeListToEnv <- function(x, classToAdd = NULL) {
   xList <- x
-
   ret <- list2env(xList, new.env(parent = emptyenv()))
-
-  attrVals <- safeAttrValues(xList)
-  walk2(names(attrVals), attrVals, function(attrName, attrValue) {
-    attr(ret, attrName) <<- attrValue
-  })
-
+  ret <- copyAttributes(from = xList, to = ret)
   oldClass(ret) <- c(classToAdd, oldClass(xList))
   ret
 }
 
-# Convert an environment to a list and keep class and attribute information
-safeEnvToList <- function(x, classToRemove = NULL) {
-  xEnv <- x
-  ret <- as.list.environment(xEnv, all.names = TRUE)
-
-  attrVals <- safeAttrValues(xEnv)
-  walk2(names(attrVals), attrVals, function(attrName, attrValue) {
-    attr(ret, attrName) <<- attrValue
-  })
-
-  oldClass(ret) <- setdiff(oldClass(x), c(classToRemove))
-  ret
-}
-
 
 # Convert any mixture of standard tag structures and tag environments into just
 # tag environments.
@@ -263,8 +252,12 @@ asTagEnv_ <- function(x, parent = NULL) {
       x$envKey <- obj_address(x)
     }
 
-    # Make sure all attribs are unique
-    x$attribs <- flattenTagAttribs(x$attribs)
+    if (!is.character(x[["name"]])) {
+      stop("A tag environment has lost its `$name`. Did you remove it?")
+    }
+    # This alters the env, but these fields should exist!
+    if (is.null(x[["attribs"]])) x$attribs <- setNames(list(), character(0)) # Empty named list
+    if (is.null(x[["children"]])) x$children <- list()
 
     # Recurse through children
     if (length(x$children) != 0) {
@@ -274,14 +267,18 @@ asTagEnv_ <- function(x, parent = NULL) {
       # Attributes may be dropped
       # * Could replace with `x$children[] <- ....`
       # * Leaving as is to see if people mis-use the children field
-      x$children <- lapply(
-        # Simplify the structures by flatting the tags
-        # Does NOT recurse to grand-children etc.
-        flattenTagsRaw(x$children),
-        # recurse through each child
-        asTagEnv_,
-        parent = x
-      )
+
+      # Simplify the structures by flatting the tags
+      # Does NOT recurse to grand-children etc.
+      children <- flattenTagsRaw(x$children)
+      # Use a `for-loop` over `lapply` to avoid `lapply` overhead
+      for (i in seq_along(children)) {
+        child <- children[[i]]
+        if (!is.null(child)) {
+          children[[i]] <- asTagEnv_(child, parent = x)
+        }
+      }
+      x$children <- children
     }
   }
   x
@@ -300,14 +297,34 @@ tagEnvToTags <- function(x) {
 # Ex: tag environment, "text", 5, tagFunctions, etc.
 tagEnvToTags_ <- function(x) {
   if (isTagEnv(x)) {
+
     xEl <- x
-    # convert to list first to avoid altering the original env obj
-    x <- safeEnvToList(xEl, c("shiny.tag.env"))
-    # undo parent env and key
-    x$parent <- NULL
-    x$envKey <- NULL
-    # recurse through children
-    x$children <- lapply(x$children, tagEnvToTags_)
+
+    # Pull the names `name`, `attribs`, and `children` first to match `tag()` name order
+    envNames <- ls(envir = xEl, all.names = TRUE, sorted = FALSE)
+    newNames <- c(
+      "name", "attribs", "children",
+      if (length(envNames) > 5) {
+        # Pull remaining names if they exist
+        removeFromSet(envNames, c("name", "attribs", "children", "parent", "envKey"))
+      }
+    )
+
+    # Use mget to pull names in order to avoid always shuffling the values
+    x <- mget(newNames, xEl)
+    x <- copyAttributes(from = xEl, to = x)
+    oldClass(x) <- removeFromSet(oldClass(xEl), "shiny.tag.env")
+
+    # Recurse through children
+    children <- x$children
+    # Use a `for-loop` over `lapply` to avoid overhead
+    for (i in seq_along(children)) {
+      child <- children[[i]]
+      if (!is.null(child)) {
+        children[[i]] <- tagEnvToTags_(child)
+      }
+    }
+    x$children <- children
   }
   x
 }
@@ -1266,6 +1283,10 @@ tagQueryClassHas <- function(els, class) {
     use.names = FALSE
   )
 }
+removeFromSet <- function(set, vals) {
+  # removes the call to `unique()` with `setdiff`
+  set[match(set, vals, 0L) == 0L]
+}
 # add classes that don't already exist
 tagQueryClassAdd <- function(els, class) {
   # Quit early if class == NULL | character(0)
@@ -1276,7 +1297,7 @@ tagQueryClassAdd <- function(els, class) {
     if (!isTagEnv(el)) return()
     classVal <- el$attribs$class %||% ""
     elClasses <- splitCssClass(classVal)
-    newClasses <- c(elClasses, setdiff(classes, elClasses))
+    newClasses <- c(elClasses, removeFromSet(classes, elClasses))
     el$attribs$class <- joinCssClass(newClasses)
   })
 }
@@ -1291,7 +1312,7 @@ tagQueryClassRemove <- function(els, class) {
     classVal <- el$attribs$class
     if (is.null(classVal)) return()
     elClasses <- splitCssClass(classVal)
-    newClasses <- setdiff(elClasses, classes)
+    newClasses <- removeFromSet(elClasses, classes)
     el$attribs$class <- joinCssClass(newClasses)
   })
 }
@@ -1307,7 +1328,7 @@ tagQueryClassToggle <- function(els, class) {
     elClasses <- splitCssClass(classVal)
     hasClass <- (classes %in% elClasses)
     if (any(hasClass)) {
-      elClasses <- setdiff(elClasses, classes)
+      elClasses <- removeFromSet(elClasses, classes)
     }
     if (any(!hasClass)) {
       elClasses <- c(elClasses, classes[!hasClass])

diff --git a/tests/testthat/helper-tags.R b/tests/testthat/helper-tags.R
@@ -0,0 +1,26 @@
+
+# Needed to compare tags that go from lists to envs and back to lists.
+expect_equal_tags <- function(x, y) {
+  expect_equal_tags_ <- function(x, y) {
+    if (isTag(x)) {
+      expect_true(isTag(y))
+      expect_equal(x$parent, NULL)
+      expect_equal(y$parent, NULL)
+      expect_equal(x$envKey, NULL)
+      expect_equal(y$envKey, NULL)
+      # Recurse through children
+      expect_equal_tags_(x$children, y$children)
+    } else if (is.list(x)) {
+      expect_true(is.list(y))
+      expect_equal(length(x), length(y))
+      Map(x, y, f = expect_equal_tags_)
+    } else {
+      # no tags to recurse
+    }
+  }
+
+  # Should be fully equal.
+  expect_equal(x, y)
+  # Do custom checks to make sure tagQuery undid any internal changes
+  expect_equal_tags_(x, y)
+}
diff --git a/tests/testthat/test-tag-query.R b/tests/testthat/test-tag-query.R
@@ -2,48 +2,6 @@
 fakeJqueryDep <- htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.js")
 fakeTagFunction <- tagFunction(function(){ span("inner span") })
 
-sortInternalNames <- function(x) {
-  if (is.list(x) && is_named(x)) {
-    x[order(names(x))]
-  } else {
-    x
-  }
-}
-
-# Needed to compare tags that go from lists to envs and back to lists.
-# The names are alpha sorted in the final tag object
-expect_equal_tags <- function(x, y) {
-  if (isTag(x)) {
-    expect_true(isTag(y))
-    expect_equal(x$parent, NULL)
-    expect_equal(y$parent, NULL)
-    expect_equal(x$envKey, NULL)
-    expect_equal(y$envKey, NULL)
-    x <- sortInternalNames(x)
-    y <- sortInternalNames(y)
-    # compare everything but the children
-    expect_equal(
-      x[setdiff(names(x), "children")],
-      y[setdiff(names(y), "children")]
-    )
-    expect_equal_tags(x$children, y$children)
-  } else if (is.list(x)) {
-    if (isTagList(x)) {
-      expect_true(isTagList(y))
-      expect_equal(
-        attr(x, "print.as.list", exact = TRUE),
-        attr(y, "print.as.list", exact = TRUE)
-      )
-    } else {
-      expect_true(is.list(y))
-    }
-    expect_equal(length(x), length(y))
-    expect_equal(names2(x), names2(y))
-    Map(x, y, f = expect_equal_tags)
-  } else {
-    expect_equal(x, y)
-  }
-}
 
 test_that("safeListToEnv and safeEnvToList undo each other", {
 
@@ -66,9 +24,6 @@ test_that("safeListToEnv and safeEnvToList undo each other", {
   expect_s3_class(xEnv, "extra_class")
 
   expect_equal(names(xEnv), c("A", "B"))
-  expect_equal(safeAttrValues(xEnv), list(extra_dep = list(42), other_dep = "exists"))
-
-  expect_equal(safeEnvToList(xEnv, "extra_class"), xExpected)
 })
 
 
@@ -166,7 +121,7 @@ test_that("tagQuery()$find()", {
   # Make sure the found elements do not persist
   newX <- x$find("span")
   expect_failure(
-    expect_equal(
+    expect_equal_tags(
       x$selectedTags(),
       newX$selectedTags()
     )
@@ -743,6 +698,61 @@ test_that("tagQuery() print method displays custom output for selected tags", {
 })
 
 
+test_that("tagQuery() allows for tags with extra top level items and will preserve them", {
+  html <- div(span())
+  html$test <- "extra"
+  html <- c(list(first = TRUE), html)
+  class(html) <- "shiny.tag"
+
+  # Test different removal types: setting the value to NULL and removing the value from the envir completely.
+  for (removeType in c("set", "rm")) {
+    expect_error(
+      tagQuery(html)$each(function(el, i) {
+        switch(removeType,
+          set = {
+            el$name <- NULL
+          },
+          rm = {
+            rm(list = "name", envir = el)
+          }
+        )
+      })$allTags(),
+      "lost its `$name`", fixed = TRUE
+    )
+
+    for (missing_key in c("__not_a_match__", "attribs", "children")) {
+      htmlQ <- tagQuery(html)
+      if (missing_key %in% names(html)) {
+        htmlQ$each(function(el, i) {
+          switch(removeType,
+            set = {
+              el[[missing_key]] <- NULL
+            },
+            rm = {
+              rm(list = missing_key, envir = el)
+            }
+          )
+          el[[missing_key]] <- NULL
+        })
+      }
+      htmlPostQ <- htmlQ$allTags()
+      html_out <- html
+      if (missing_key == "attribs") html_out$attribs <- dots_list()
+      if (missing_key == "children") html_out$children <- list()
+      # expect first three names to be standard tag names
+      expect_equal(names(htmlPostQ)[1:3], names(div()))
+
+      # expect all other names to be included somewhere
+      expect_setequal(names(htmlPostQ), names(html_out))
+
+      # If done in the same order, it should be equal
+      back_to_orig <- htmlPostQ[names(html_out)]
+      class(back_to_orig) <- "shiny.tag"
+      expect_equal(back_to_orig, html_out)
+    }
+  }
+
+})