tagQuery(): Speed enhancements and consistent tag name order

R/tag_query.R

@@ -263,9 +263,6 @@ asTagEnv_ <- function(x, parent = NULL) {
       x$envKey <- obj_address(x)
     }
 
-    # Make sure all attribs are unique
-    x$attribs <- flattenTagAttribs(x$attribs)
-
     # Recurse through children
     if (length(x$children) != 0) {
       # Possible optimization... name the children tags to the formatted values.
@@ -306,7 +303,31 @@ tagEnvToTags_ <- function(x) {
     # undo parent env and key
     x$parent <- NULL
     x$envKey <- NULL
-    # recurse through children
+
+    # Reorder the names to match a typical tag() structure that has `name`, `attribs`, and `children` first
+    # Avoid calling `setdiff()` if possible (it is slow).
+    if (!is.character(x[["name"]])) {
+      stop("A tag environment has lost its `$name`. Did you remove it?")
+    }
+    if (is.null(x[["attribs"]])) x$attribs <- setNames(list(), character(0))
+    if (is.null(x[["children"]])) x$children <- list()
+
+    xNames <- names(x)
+    newNames <- c(
+      "name", "attribs", "children",
+      if (length(xNames) > 3) {
+        setdiff(xNames, c("name", "attribs", "children"))
+      }
+    )
+    if (!identical(xNames, newNames)) {
+      # Need to preserve attributes. Must move values in two steps.
+      # Reorder values
+      x[] <- x[newNames]
+      # Reorder names
+      names(x) <- newNames
+    }
+
+    # Recurse through children
     x$children <- lapply(x$children, tagEnvToTags_)
   }
   x

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)
+}

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", {
 
@@ -166,7 +124,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 +701,42 @@ 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"
+
+  expect_error(
+    tagQuery(html)$each(function(el, i) {
+      el$name <- NULL
+    })$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) {
+        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)
+  }
+})