diff --git a/R/tag_query.R b/R/tag_query.R index 3dca86d9..6907f061 100644 --- 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 new file mode 100644 index 00000000..f04a4578 --- /dev/null +++ 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 index c1256300..49acb176 100644 --- 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) + } + } + +})