fakeJqueryDep <- htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.js") fakeTagFunction <- tagFunction(function(){ span("inner span") }) test_that("safeListToEnv and safeEnvToList undo each other", { x <- structure( list( A = 1, B = 2 ), class = "test_class", extra_dep = list(42), other_dep = "exists" ) xExpected <- x xEnv <- safeListToEnv(x, "extra_class") expect_type(xEnv, "environment") expect_s3_class(xEnv, "test_class") expect_s3_class(xEnv, "extra_class") expect_equal(names(xEnv), c("A", "B")) }) test_that("asTagEnv upgrades objects", { expect_error(asTagEnv(list()), "does not accept") expect_error(asTagEnv(tagList()), "does not accept") x <- div(class = "test_class", span(class = "inner")) xTagEnv <- asTagEnv(x) expect_s3_class(xTagEnv, "shiny.tag.env") expect_s3_class(xTagEnv, "shiny.tag") expect_null(xTagEnv$parent) expect_equal(xTagEnv$envKey, obj_address(xTagEnv)) expect_equal(xTagEnv$name, x$name) expect_equal(xTagEnv$attribs, x$attribs) expect_equal(length(xTagEnv$children), length(x$children)) lapply(xTagEnv$children, function(child) { expect_s3_class(child, "shiny.tag.env") expect_equal(child$parent$envKey, xTagEnv$envKey) }) }) ## Cycles are not tested for anymore. Keeping in case they are brought back # test_that("asTagEnv finds cycles", { # x <- div(class = "test_class", span(class = "inner")) # xTagEnv <- asTagEnv(x) # expect_error(asTagEnv(xTagEnv), NA) # testSpanEnv <- xTagEnv$children[[1]] # xTagEnv$children[[2]] <- testSpanEnv # xTagEnv$children[[3]] <- testSpanEnv # expect_error(asTagEnv(xTagEnv), "Duplicate tag environment found") # expect_equal_tags( # tagEnvToTags(xTagEnv), # div( # class = "test_class", # span(class = "inner"), # span(class = "inner"), # span(class = "inner") # ) # ) # # make a cycle # testSpanEnv$children[[1]] <- xTagEnv # expect_error(asTagEnv(xTagEnv), "Duplicate tag environment") # }) test_that("tagQuery() root values", { expect_error(tagQuery(div()), NA) expect_error(tagQuery(list()), "initial set") expect_error(tagQuery(tagList()), "initial set") expect_error(tagQuery(tagList(div())), NA) expect_error(tagQuery(5), "initial set") expect_error(tagQuery("a"), "initial set") expect_error(tagQuery(fakeJqueryDep), "initial set") expect_error(tagQuery(fakeTagFunction), "initial set") x <- tagQuery(div(span(), a()))$find("span") # expect_equal_tags(x$selectedTags(), tagListPrintAsList(span())) # expect_equal_tags(x$selectedTags(), tagListPrintAsList(div(span(), a()))) # supply a tag query object expect_equal_tags(tagQuery(x)$selectedTags(), x$selectedTags()) expect_equal_tags(tagQuery(x)$allTags(), x$allTags()) # supply a list of tag envs tagEnvs <- list() x$each(function(el, i) { tagEnvs[[length(tagEnvs) + 1]] <<- el}) expect_equal_tags(tagQuery(tagEnvs)$selectedTags(), x$selectedTags()) expect_equal_tags(tagQuery(tagEnvs)$allTags(), x$allTags()) # supply a single tag env expect_equal_tags(tagQuery(tagEnvs[[1]])$selectedTags(), x$selectedTags()) expect_equal_tags(tagQuery(tagEnvs[[1]])$allTags(), x$allTags()) }) test_that("tagQuery() structure", { x <- tagQuery(div()) expect_s3_class(x, "shiny.tag.query") lapply(x, function(xI) { expect_true(is.function(xI)) }) }) test_that("tagQuery()$find()", { x <- tagQuery(div(span("a"), span("b"))) # Make sure the found elements do not persist newX <- x$find("span") expect_failure( expect_equal_tags( x$selectedTags(), newX$selectedTags() ) ) x <- x$find("span") expect_equal(x$length(), 2) expect_length(x$selectedTags(), 2) expect_equal_tags( x$selectedTags(), tagListPrintAsList(span("a"), span("b")) ) ul <- tags$ul li <- tags$li x <- tagQuery(div(div(div(ul(li("a"), li("b"), li("c")))))) expect_equal(x$length(), 1) expect_length(x$selectedTags(), 1) x <- x$find("div") expect_equal(x$length(), 2) expect_length(x$selectedTags(), 2) x <- x$find("div") expect_equal(x$length(), 1) expect_length(x$selectedTags(), 1) x <- tagQuery( div( class = "outer", div(a(span(p("text1")))), div(a(p("text2"))) ) ) x <- x$find("a") expect_equal(x$length(), 2) expect_length(x$selectedTags(), 2) x <- x$resetSelected() x <- x$find("a > p") expect_equal(x$length(), 1) expect_length(x$selectedTags(), 1) expect_equal_tags(x$selectedTags(), tagListPrintAsList(p("text2"))) x <- x$resetSelected() x <- x$find("a > > p") expect_equal(x$length(), 1) expect_length(x$selectedTags(), 1) expect_equal_tags(x$selectedTags(), tagListPrintAsList(p("text1"))) x <- x$resetSelected() x <- x$find("div > *") expect_equal(x$length(), 2) expect_length(x$selectedTags(), 2) expect_equal_tags(x$selectedTags(), tagListPrintAsList(a(span(p("text1"))), a(p("text2")))) x <- x$resetSelected() x <- x$find("div>>p") expect_equal(x$length(), 1) expect_length(x$selectedTags(), 1) expect_equal_tags(x$selectedTags(), tagListPrintAsList(p("text2"))) }) test_that("tagQuery()$filter()", { x <- tagQuery(div(span(1), span(2), span(3), span(4), span(5))) x <- x$find("span") expect_length(x$selectedTags(), 5) # keep the even found elements x <- x$filter(function(item, i) { # is even (i %% 2) == 0 }) expect_length(x$selectedTags(), 2) # keep the filtered even elements. Should only have the 4th one remaining x <- x$filter(function(item, i) { # is even (i %% 2) == 0 }) expect_length(x$selectedTags(), 1) expect_equal_tags(x$selectedTags(), tagListPrintAsList(span(4))) }) test_that("tagQuery()$children() & tagQuery()$parent()", { x <- tagQuery( div(class="outer", div(class="a", span(class="A", "1"), span(class="B", "2")), div(class = "b", span(class = "C", "3"), span(class = "D", "4") ) ) ) x <- x$find("div") expect_length(x$selectedTags(), 2) x <- x$children() expect_length(x$selectedTags(), 4) expect_equal_tags( x$selectedTags(), tagListPrintAsList( span(class = "A", "1"), span(class = "B", "2"), span(class = "C", "3"), span(class = "D", "4") ) ) x <- x$parent() expect_length(x$selectedTags(), 2) x <- x$children(".C") expect_length(x$selectedTags(), 1) x <- x$parent() expect_length(x$selectedTags(), 1) secondDiv <- div(class = "b", span(class = "C", "3"), span(class = "D", "4")) expect_equal_tags(x$selectedTags(), tagListPrintAsList(secondDiv)) x <- x$resetSelected()$find("span")$parents(".b") expect_length(x$selectedTags(), 1) expect_equal_tags(x$selectedTags(), tagListPrintAsList(secondDiv)) }) test_that("tagQuery()$parents() && tagQuery()$closest()", { xTags <- div(class = "outer", div(class = "inner", p(class="p", span("a"), span("b"), span("c"), span("d"), span("e") ) ) ) x <- tagQuery(xTags) expect_length(x$selectedTags(), 1) xc <- x$find("span")$closest("div") expect_length(xc$selectedTags(), 1) expect_true(xc$hasClass("inner")) xc <- x$find("span")$closest() expect_length(xc$selectedTags(), 5) xc$each(function(el, i) { expect_equal(el$name, "span") }) xp <- x$find("span")$parents("div") expect_length(xp$selectedTags(), 2) expect_equal(xp$hasClass("outer"), c(FALSE, TRUE)) expect_equal(xp$hasClass("inner"), c(TRUE, FALSE)) x <- x$find("span")$parents() expect_length(x$selectedTags(), 3) expect_equal_tags( x$selectedTags(), tagListPrintAsList( xTags$children[[1]]$children[[1]], xTags$children[[1]], xTags ) ) x <- x$resetSelected()$find("span")$parents(".outer") expect_length(x$selectedTags(), 1) expect_equal_tags( x$selectedTags(), tagListPrintAsList(xTags) ) }) test_that("tagQuery()$siblings()", { xTags <- tagList( span("a"), span("b"), span("c"), span("d"), span("e") ) x <- tagQuery(xTags) expect_length(x$selectedTags(), 5) x <- x$siblings() expect_length(x$selectedTags(), 5) xTags <- tagList( span("a"), span("b"), span("c", class = "middle"), span("d"), span("e") ) x <- tagQuery(xTags) expect_length(x$selectedTags(), 5) x <- x$filter(".middle") expect_length(x$selectedTags(), 1) x <- x$siblings() expect_length(x$selectedTags(), 4) }) test_that("tagQuery()$addClass()", { xTags <- div(class = "outer", div(class = "inner", span("a"), span("b"), span("c"), span("d"), span("e") ) ) x <- tagQuery(xTags) expect_length(x$selectedTags(), 1) x <- x$find("div.inner")$addClass("test-class") expect_length(x$selectedTags(), 1) expect_equal(x$selectedTags()[[1]]$attribs$class, "inner test-class") expect_silent({ x$addClass(NULL) x$removeClass(NULL) x$toggleClass(NULL) expect_equal(x$hasClass(NULL), c(FALSE)) }) expect_silent({ x$addClass(character(0)) x$removeClass(character(0)) x$toggleClass(character(0)) expect_equal(x$hasClass(character(0)), c(FALSE)) }) expect_equal_tags( tagQuery( div(class="A", class="B", "text") )$ addClass("C")$ removeClass("B")$ allTags(), div(class = "A C", "text") ) }) test_that("tagQuery()$hasClass(), $toggleClass(), $removeClass()", { xTags <- div(class = "outer", div(class = "A B", span(class = "odd", "a"), span(class = "even", "b"), span(class = "odd", "c"), span(class = "even", "d"), span(class = "odd", "e") ) ) x <- tagQuery(xTags) x <- x$find("div.A") expect_length(x$selectedTags(), 1) expect_equal(x$hasClass("B A"), TRUE) expect_equal(x$hasClass("A B"), TRUE) expect_equal(x$hasClass("B"), TRUE) expect_equal(x$hasClass("A"), TRUE) expect_equal(x$hasClass("C"), FALSE) x <- x$resetSelected()$find("span") expect_equal(x$hasClass("even"), c(FALSE, TRUE, FALSE, TRUE, FALSE)) expect_equal(x$hasClass("odd"), c(TRUE, FALSE, TRUE, FALSE, TRUE)) x$toggleClass("even odd") expect_equal(x$hasClass("even"), c(TRUE, FALSE, TRUE, FALSE, TRUE)) expect_equal(x$hasClass("odd"), c(FALSE, TRUE, FALSE, TRUE, FALSE)) x$removeClass("even") expect_equal(x$hasClass("even"), c(FALSE, FALSE, FALSE, FALSE, FALSE)) expect_equal(x$hasClass("odd"), c(FALSE, TRUE, FALSE, TRUE, FALSE)) x$removeClass("other odd") expect_equal(x$hasClass("odd"), c(FALSE, FALSE, FALSE, FALSE, FALSE)) }) test_that("tagQuery()$addAttrs(), $removeAttrs(), $s", { xTags <- tagList( span(key = "value - a", "a"), span(key = "value - b", "b"), span( "c"), span( "d"), span(key = "value - e", "e") ) x <- tagQuery(xTags) expect_length(x$selectedTags(), 5) expect_equal(x$hasAttrs("key"), c(TRUE, TRUE, FALSE, FALSE, TRUE)) x$addAttrs(key2 = "val2", key3 = "val3") expect_equal(x$hasAttrs("key"), c(TRUE, TRUE, FALSE, FALSE, TRUE)) expect_equal(x$hasAttrs("key2"), c(TRUE, TRUE, TRUE, TRUE, TRUE)) expect_equal(x$hasAttrs("key3"), c(TRUE, TRUE, TRUE, TRUE, TRUE)) x$removeAttrs(c("key", "key3")) expect_equal(x$hasAttrs("key"), c(FALSE, FALSE, FALSE, FALSE, FALSE)) expect_equal(x$hasAttrs("key2"), c(TRUE, TRUE, TRUE, TRUE, TRUE)) expect_equal(x$hasAttrs("key3"), c(FALSE, FALSE, FALSE, FALSE, FALSE)) }) test_that("tagQuery()$append()", { xTags <- div(span("child")) x <- tagQuery(xTags) newa <- span("a") x$append(newa) expect_equal_tags( x$allTags(), div(span("child"), newa) ) new1 <- div("new1") new2 <- div("new2") x$append(new1, new2) expect_equal_tags( x$allTags(), div(span("child"), newa, new1, new2) ) }) test_that("tagQuery()$prepend()", { xTags <- div(span("child")) x <- tagQuery(xTags) newa <- span("a") x$prepend(newa) expect_equal_tags( x$allTags(), div(newa, span("child")) ) new1 <- div("new1") new2 <- div("new2") x$prepend(new1, new2) expect_equal_tags( x$allTags(), div(new1, new2, newa, span("child")) ) }) test_that("tagQuery()$each()", { xTags <- div(span("a"), h1("title"), span("b")) x <- tagQuery(xTags) x <- x$find("span") expect_error(x$each("4"), "function") expect_error(x$each(function(item) {}), "two") expect_error(x$each(function(...) {}), NA) x$each(function(el, i) { el$children <- lapply(el$children, toupper) "ignored" }) expect_equal_tags( x$allTags(), div(span("A"), h1("title"), span("B")) ) }) test_that("tagQuery()$allTags() & tagQuery()$rebuild()", { xTags <- div(span("a"), h1("title"), span("b")) x <- tagQuery(xTags) x$each(function(root, i) { # add a child to the root root$children[[length(root$children) + 1]] <- div("test") }) # retrieve the root (and direct children) from graph rootChildren <- x$allTags()$children lastChild <- rootChildren[[length(rootChildren)]] # make sure the last child is a tag env (not a standard tag) expect_false(isTagEnv(lastChild)) # make sure it equals what was manually added expect_equal_tags(lastChild, div("test")) }) test_that("tagQuery()$remove()", { xTags <- div( span("a"), span("b", class = "A"), span("c"), span("d", class = "A"), span("e") ) x <- tagQuery(xTags)$find("span") expect_equal(x$length(), 5) expect_length(x$selectedTags(), 5) x <- x$filter(".A")$remove() expect_equal(x$length(), 0) expect_length(x$selectedTags(), 0) expect_equal_tags( x$allTags(), div(span("a"), span("c"), span("e")) ) x <- x$resetSelected()$find("span") expect_equal(x$length(), 3) expect_length(x$selectedTags(), 3) x <- x$remove() expect_equal_tags( x$allTags(), div() ) # https://github.com/rstudio/htmltools/issues/346 # `isTagEnv("Barret")` is `FALSE` html <- div(tags$label("Carson"), "Barret") # Remove the label x <- tagQuery(html)$find("label")$remove() expect_equal_tags(x$allTags(), div("Barret")) }) test_that("tagQuery()$after()", { xTags <- div() x <- tagQuery(xTags) newa <- span("a") x$after(newa) expect_equal_tags( x$allTags(), tagList(xTags, newa) ) new1 <- div("new1") new2 <- div("new2") x$after(new1, new2) expect_equal_tags( x$allTags(), tagList(xTags, new1, new2, newa) ) }) test_that("tagQuery()$before()", { xTags <- div() x <- tagQuery(xTags) newa <- span("a") x$before(newa) expect_equal_tags( x$allTags(), tagList(newa, xTags) ) new1 <- div("new1") new2 <- div("new2") x$before(new1, new2) expect_equal_tags( x$allTags(), tagList(newa, new1, new2, xTags) ) }) test_that("tagQuery(x)$allTags()", { xTags <- tagList( fakeJqueryDep, div( fakeTagFunction ) ) x <- tagQuery(xTags) expect_equal_tags( x$allTags(), tagList(!!!xTags) ) }) test_that("tagQuery() objects inherit from each other objects", { xTags <- div(span("text")) x <- tagQuery(xTags)$find("span") y <- tagQuery(x) zEnv <- NULL wEnvs <- NULL x$each(function(el, i) { zEnv <<- el wEnvs <<- append(wEnvs, list(el)) }) z <- tagQuery(zEnv) w <- tagQuery(wEnvs) y$addClass("extra") expected <- div(span(class="extra", "text")) expect_equal_tags(x$selectedTags(), tagListPrintAsList(!!!expected$children)) expect_equal_tags(y$selectedTags(), tagListPrintAsList(!!!expected$children)) expect_equal_tags(z$selectedTags(), tagListPrintAsList(!!!expected$children)) expect_equal_tags(w$selectedTags(), tagListPrintAsList(!!!expected$children)) expect_equal_tags(x$allTags(), expected) expect_equal_tags(y$allTags(), expected) expect_equal_tags(z$allTags(), expected) expect_equal_tags(w$allTags(), expected) }) test_that("tagQuery() objects can not inherit from mixed objects", { xTags <- div(span("text"), span("extra")) x <- tagQuery(xTags)$find("span") y <- tagQuery(xTags)$find("span") xEnv <- NULL x$each(function(el, i) { xEnv <<- el }) yEnv <- NULL y$each(function(el, i) { yEnv <<- el }) expect_error( tagQuery(tagList( div(), xEnv )), "not be a mix" ) expect_error( tagQuery(tagList( xEnv, yEnv )), "share the same root" ) }) test_that("rebuilding tag envs after inserting children is done", { xTags <- div(div(), div()) expect_equal_tags( tagQuery(xTags)$find("div")$before(span())$allTags(), div(span(), div(), span(), div()) ) expect_equal_tags( tagQuery(xTags)$find("div")$replaceWith(span())$allTags(), div(span(), span()) ) expect_equal_tags( tagQuery(xTags)$find("div")$after(span())$allTags(), div(div(), span(), div(), span()) ) }) test_that("tagQuery() print method displays custom output for selected tags", { local_edition(3) expect_snapshot_output(print( tagQuery(div(span())) )) expect_snapshot_output(print( tagQuery(div(span()))$find("span") )) expect_snapshot_output(print( tagQuery(div(span()))$find("empty") )) }) 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) } } }) test_that("tag methods do not unexpectedly alter tag envs", { expect_equal_tags( tagEnvToTags(tagAppendAttributes(asTagEnv(div()), key = "a")), tagAppendAttributes(div(), key = "a") ) expect_equal_tags( tagHasAttribute(asTagEnv(div(key = "a")), "key"), tagHasAttribute(div(key = "a"), "key") ) expect_equal_tags( tagGetAttribute(asTagEnv(div(key = "a")), "key"), tagGetAttribute(div(key = "a"), "key") ) expect_equal_tags( tagEnvToTags(tagAppendChild(asTagEnv(div()), span())), tagAppendChild(div(), span()) ) expect_equal_tags( tagEnvToTags(tagAppendChildren(asTagEnv(div()), span(), h1())), tagAppendChildren(div(), span(), h1()) ) expect_equal_tags( tagEnvToTags(tagSetChildren(asTagEnv(div()), span(), h1())), tagSetChildren(div(), span(), h1()) ) expect_equal_tags( tagEnvToTags(tagInsertChildren(asTagEnv(div()), span(), h1(), after = 12)), tagInsertChildren(div(), span(), h1(), after = 12) ) }) test_that("adding a class does not reorder attribs", { # No class expect_equal_tags( tagQuery(div(test = "A", "text"))$addClass("foo")$allTags(), div(test = "A", class = "foo", "text") ) # One class expect_equal_tags( tagQuery(div(class = "bar", test = "A", "text"))$addClass("foo")$allTags(), div(class="bar foo", test = "A", "text") ) # Multiple classes expect_equal_tags( tagQuery(div(class = "bar", test = "A", class = "baz", "text"))$addClass("foo")$allTags(), div(class = "bar baz foo", test = "A", "text") ) }) test_that("flattenTagsRaw() and flattenTags() do not drop html deps", { emptyDiv <- div() emptySpan <- span() testSpan <- span("test") otherObj <- HTML("test") fakeDep <- function(i) { ret <- fakeJqueryDep ret$i <- i ret } # `flattenTagsRaw()` moves html deps on tag lists to children htmlRaw <- tagList( emptyDiv, tagAppendChild(emptySpan, fakeDep(1)), tagAppendChild(testSpan, fakeDep(2)), otherObj, fakeDep(3) ) htmlDependencies(emptySpan) <- list(fakeDep(1)) htmlDependencies(testSpan) <- list(fakeDep(2)) html <- tagList( emptyDiv, emptySpan, testSpan, otherObj ) htmlDependencies(html) <- list(fakeDep(3)) expect_equal(flattenTags(html), html) expect_equal(flattenTagsRaw(html), htmlRaw) }) test_that("flattenTagsRaw(): tag list html deps are not lost when tag children are squashed", { # https://github.com/rstudio/htmltools/issues/301 a_dep <- htmlDependency(name = "A", version = 1, src = "a.js") b_dep <- htmlDependency(name = "B", version = 2, src = "b.js") c_dep <- htmlDependency(name = "C", version = 3, src = "c.js") d_dep <- htmlDependency(name = "D", version = 4, src = "d.js") z <- div("Z") z$children <- list(attachDependencies(list("z1"), d_dep)) children <- attachDependencies( list( attachDependencies(list("X", "Y"), a_dep), z ), list(b_dep, c_dep) ) html <- div("test", children) tq_html <- tagQuery(html)$allTags() tq_deps <- findDependencies(tq_html$children) expect_length(tq_deps, 4) expect_equal(tq_deps, list(a_dep, d_dep, b_dep, c_dep)) }) #
Generated by dwww version 1.15 on Wed Jun 26 03:37:03 CEST 2024.