tagQuery(): Rename$root() to $allTags(), $selected() to $selectedTags(); Print $selectedTags() like a list()

NAMESPACE

@@ -27,6 +27,7 @@ S3method(print,html_dependency)
 S3method(print,htmltools.selector)
 S3method(print,htmltools.selector.list)
 S3method(print,htmltools.tag.env)
+S3method(print,htmltools.tag.list.visible)
 S3method(print,htmltools.tag.query)
 S3method(print,shiny.tag)
 S3method(print,shiny.tag.list)

R/tag_query.R

@@ -339,6 +339,21 @@ assertNotTagEnvLike <- function(x, fnName) {
 }
 
 
+# Shim in a class so that the print method of tagList() is not used
+# Yet knit print methods will work as if they are tagList objects.
+visibleTagList <- function(...) {
+  y <- tagList(...)
+  oldClass(y) <- c("htmltools.tag.list.visible", oldClass(y))
+  y
+}
+
+#' @export
+print.htmltools.tag.list.visible <- function(x, ...) {
+  class(x) <- setdiff(class(x), c("htmltools.tag.list.visible", "shiny.tag.list"))
+  print(x)
+}
+
+
 shinyTagEnvStr <- "<!-- htmltools.tag.env -->"
 
 #' @export
@@ -490,9 +505,7 @@ as.character.htmltools.tag.query <- function(x, ...) {
 #'   An error should be thrown. Instead, please call `$selected()` to retrieve the
 #'   tag structures of the selected tag elements or root element respectively.
 #'
-#' @param tags Any standard tag object or `tagList()`. If a `list()` or
-#'   `tagList()` is provided, a `tagList()` will be returned when calling
-#'   `$selected()`.
+#' @param tags Any standard tag object or `tagList()`.
 #' @return A `tagQuery()` object. The `tag` supplied will be considered the
 #'   `root` object. At the time of initialization, the `root` is also considered
 #'   the single selected item. If any selections are made, the selected elements
@@ -866,11 +879,10 @@ tagQuery_ <- function(
 
         #' ## Tag Query methods
         #'
-        #' * `$root()`: Converts the top level tag
+        #' * `$root()`: Converts the top level (root) tag
         #' elements (and their descendants) from tag environments to
-        #' standard [`tag`] objects. If there is more than one element being
-        #' returned, a [`tagList()`] will be used to hold all of the
-        #' tags.
+        #' standard [`tag`] objects. All root tags will be returned in a
+        #' [`tagList()`].
         root = function() {
           rebuild_()
           tagQueryRootAsTags(root)
@@ -985,17 +997,11 @@ wrapWithRootTag <- function(x) {
 # Return a tag env, tagList(tag envs), or NULL
 tagQueryGetRoot <- function(root) {
   children <- root$children
-  len <- length(children)
-  if (len == 1) {
-    children[[1]]
-  } else if (len > 1) {
-    do.call(tagList, children)
-  } else {
-    # no children?
-    NULL
-  }
+  do.call(visibleTagList, children)
 }
 
+
+
 # Return a list of the manually selected elements
 tagQuerySelected <- function(selected) {
   if (length(selected) == 1 && isRootTag(selected[[1]])) {
@@ -1020,7 +1026,7 @@ tagQueryRootAsTags <- function(root) {
 
 tagQuerySelectedAsTags <- function(selected) {
   # return as tagList
-  do.call(tagList, lapply(selected, tagEnvToTags))
+  do.call(visibleTagList, lapply(selected, tagEnvToTags))
 }
 
 tagQueryPrint <- function(root, selected) {
@@ -1032,7 +1038,7 @@ tagQueryPrint <- function(root, selected) {
   if (length(selected) == 0) {
     cat(" (Empty)\n")
   } else {
-    if (length(selected) == 1 && isRootTag(selected[[1]])) {
+    if (identical(root$children, selected)) {
       cat(" (Root)\n")
     } else {
       cat("\n")
@@ -1502,7 +1508,7 @@ cssSelectorToSelector <- function(cssSelector) {
       selectorList <- asSelectorList(cssSelector)
       if (length(selectorList) > 1) {
         stop(
-          "Can only match a single element selector. ",
+          "Can only match using a simple CSS selector. ",
           "Looking for descendant elements is not allowed."
         )
       }

tests/testthat/test-tag-query.R

@@ -435,7 +435,7 @@ test_that("tagQuery()$append()", {
   x$append(newa)
   expect_equal_tags(
     x$root(),
-    div(span("child"), newa)
+    visibleTagList(div(span("child"), newa))
   )
 
   new1 <- div("new1")
@@ -444,7 +444,7 @@ test_that("tagQuery()$append()", {
 
   expect_equal_tags(
     x$root(),
-    div(span("child"), newa, new1, new2)
+    visibleTagList(div(span("child"), newa, new1, new2))
   )
 })
 
@@ -456,7 +456,7 @@ test_that("tagQuery()$prepend()", {
   x$prepend(newa)
   expect_equal_tags(
     x$root(),
-    div(newa, span("child"))
+    visibleTagList(div(newa, span("child")))
   )
 
   new1 <- div("new1")
@@ -465,7 +465,7 @@ test_that("tagQuery()$prepend()", {
 
   expect_equal_tags(
     x$root(),
-    div(new1, new2, newa, span("child"))
+    visibleTagList(div(new1, new2, newa, span("child")))
   )
 })
 
@@ -486,7 +486,7 @@ test_that("tagQuery()$each()", {
 
   expect_equal_tags(
     x$root(),
-    div(span("A"), h1("title"), span("B"))
+    visibleTagList(div(span("A"), h1("title"), span("B")))
   )
 })
 
@@ -503,7 +503,7 @@ test_that("tagQuery()$root() & tagQuery()$rebuild()", {
   })
 
   # retrieve the root (and direct children) from graph
-  rootChildren <- x$root()$children
+  rootChildren <- x$root()[[1]]$children
   lastChild <- rootChildren[[length(rootChildren)]]
 
   # make sure the last child is a tag env (not a standard tag)
@@ -530,15 +530,15 @@ test_that("tagQuery()$remove()", {
 
   expect_equal_tags(
     x$root(),
-    div(span("a"), span("c"), span("e"))
+    visibleTagList(div(span("a"), span("c"), span("e")))
   )
 
   x <- x$reset()$find("span")
   expect_length(x$selected(), 3)
   x <- x$remove()
   expect_equal_tags(
     x$root(),
-    div()
+    visibleTagList(div())
   )
 })
 
@@ -551,7 +551,7 @@ test_that("tagQuery()$after()", {
   x$after(newa)
   expect_equal_tags(
     x$root(),
-    tagList(xTags, newa)
+    visibleTagList(xTags, newa)
   )
 
   new1 <- div("new1")
@@ -560,7 +560,7 @@ test_that("tagQuery()$after()", {
 
   expect_equal_tags(
     x$root(),
-    tagList(xTags, new1, new2, newa)
+    visibleTagList(xTags, new1, new2, newa)
   )
 })
 
@@ -572,7 +572,7 @@ test_that("tagQuery()$before()", {
   x$before(newa)
   expect_equal_tags(
     x$root(),
-    tagList(newa, xTags)
+    visibleTagList(newa, xTags)
   )
 
   new1 <- div("new1")
@@ -581,7 +581,7 @@ test_that("tagQuery()$before()", {
 
   expect_equal_tags(
     x$root(),
-    tagList(newa, new1, new2, xTags)
+    visibleTagList(newa, new1, new2, xTags)
   )
 })
 
@@ -599,7 +599,7 @@ test_that("tagQuery(x)$root()", {
 
   expect_equal_tags(
     x$root(),
-    xTags
+    do.call(visibleTagList, xTags)
   )
 })
 
@@ -620,12 +620,12 @@ test_that("tagQuery() objects inherit from each other objects", {
 
   y$addClass("extra")
 
-  expected <- div(span(class="extra", "text"))
+  expected <- visibleTagList(div(span(class="extra", "text")))
 
-  expect_equal_tags(x$selected(), tagList(expected$children[[1]]))
-  expect_equal_tags(y$selected(), tagList(expected$children[[1]]))
-  expect_equal_tags(z$selected(), tagList(expected$children[[1]]))
-  expect_equal_tags(w$selected(), tagList(expected$children[[1]]))
+  expect_equal_tags(x$selected(), visibleTagList(expected[[1]]$children[[1]]))
+  expect_equal_tags(y$selected(), visibleTagList(expected[[1]]$children[[1]]))
+  expect_equal_tags(z$selected(), visibleTagList(expected[[1]]$children[[1]]))
+  expect_equal_tags(w$selected(), visibleTagList(expected[[1]]$children[[1]]))
 
   expect_equal_tags(x$root(), expected)
   expect_equal_tags(y$root(), expected)