context("tags") test_that("Basic tag writing works", { expect_equal(as.character(tagList("hi")), "hi") expect_equal( as.character(tagList("one", "two", tagList("three"))), "one\ntwo\nthree") expect_equal( as.character(tags$b("one")), "<b>one</b>") expect_equal( as.character(tags$b("one", "two")), "<b>\n one\n two\n</b>") expect_equal( as.character(tagList(list("one"))), "one") expect_equal( as.character(tagList(list(tagList("one")))), "one") expect_equal( as.character(tagList(tags$br(), "one")), "<br/>\none") }) test_that("Hanging commas don't break things", { expect_equal(as.character(tagList("hi",)), "hi") expect_equal(as.character(div("one",)), "<div>one</div>") # Multiple commas still throw expect_error(as.character(div("one",,)), "is empty") # Non-trailing commas still throw expect_error(as.character(div(,"one",)), "is empty") }) test_that("withTags works", { output_tags <- tags$div(class = "myclass", tags$h3("header"), tags$p("text here") ) output_withhtml <- withTags( div(class = "myclass", h3("header"), p("text here") ) ) expect_identical(output_tags, output_withhtml) # Check that current environment is searched x <- 100 expect_identical(tags$p(x), withTags(p(x))) # Just to make sure, run it in a function, which has its own environment foo <- function() { y <- 100 withTags(p(y)) } expect_identical(tags$p(100), foo()) }) test_that(".noWS argument of withTags()", { get_noWS <- function(tag) tag[[".noWS"]] default <- withTags( div( class = "myclass", h3("header"), p("One", strong(span("two")), "three") ) ) expect_null(get_noWS(default)) expect_null(get_noWS(default$children[[1]])) expect_null(get_noWS(default$children[[2]])) expect_null(get_noWS(default$children[[2]]$children[[2]])) expect_null(get_noWS(default$children[[2]]$children[[2]]$children[[1]])) default_special <- withTags( div( class = "myclass", h3("header", .noWS = "after-begin"), p("One", strong(span("two")), "three", .noWS = "before-end") ) ) expect_null(get_noWS(default_special)) expect_equal(get_noWS(default_special$children[[1]]), "after-begin") expect_equal(get_noWS(default_special$children[[2]]), "before-end") expect_null(get_noWS(default_special$children[[2]]$children[[2]])) expect_null(get_noWS(default_special$children[[2]]$children[[2]]$children[[1]])) all_same_noWS <- c("outside", "inside") all_same <- withTags( div( class = "myclass", h3("header"), p("One", strong(span("two")), "three") ), .noWS = all_same_noWS ) expect_equal(get_noWS(all_same), all_same_noWS) expect_equal(get_noWS(all_same$children[[1]]), all_same_noWS) expect_equal(get_noWS(all_same$children[[2]]), all_same_noWS) expect_equal(get_noWS(all_same$children[[2]]$children[[2]]), all_same_noWS) expect_equal(get_noWS(all_same$children[[2]]$children[[2]]$children[[1]]), all_same_noWS) varied_default <- "outside" varied_special <- "inside" varied <- withTags( div( class = "myclass", h3("header"), p("One", strong(span("two"), .noWS = varied_special), "three") ), .noWS = varied_default ) expect_equal(get_noWS(varied), varied_default) expect_equal(get_noWS(varied$children[[1]]), varied_default) expect_equal(get_noWS(varied$children[[2]]), varied_default) expect_equal(get_noWS(varied$children[[2]]$children[[2]]), varied_special) expect_equal(get_noWS(varied$children[[2]]$children[[2]]$children[[1]]), varied_default) }) test_that("HTML escaping in tags", { # Regular text is escaped expect_equivalent(format(div("<a&b>")), "<div><a&b></div>") # Text in HTML() isn't escaped expect_equivalent(format(div(HTML("<a&b>"))), "<div><a&b></div>") # Text in a property is escaped expect_equivalent(format(div(class = "<a&b>", "text")), '<div class="<a&b>">text</div>') # HTML() has no effect in a property like 'class' expect_equivalent(format(div(class = HTML("<a&b>"), "text")), '<div class="<a&b>">text</div>') }) test_that("Adding child tags", { tag_list <- list(tags$p("tag1"), tags$b("tag2"), tags$i("tag3")) # Creating nested tags by calling the tag$div function and passing a list t1 <- tags$div(class="foo", tag_list) expect_equal(length(t1$children), 1) expect_equal(length(t1$children[[1]]), 3) expect_equal(t1$children[[1]][[1]]$name, "p") expect_equal(t1$children[[1]][[1]]$children[[1]], "tag1") expect_equal(t1$children[[1]][[2]]$name, "b") expect_equal(t1$children[[1]][[2]]$children[[1]], "tag2") expect_equal(t1$children[[1]][[3]]$name, "i") expect_equal(t1$children[[1]][[3]]$children[[1]], "tag3") # div tag used as starting point for tests below div_tag <- tags$div(class="foo") # Appending each child t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChild(t2, tag_list[[2]]) t2 <- tagAppendChild(t2, tag_list[[3]]) t2a <- do.call(tags$div, c(tag_list, class="foo")) expect_identical(t2a, t2) t2b <- tagAppendChildren(div_tag, `names_are_ignored` = tag_list[[1]], "ignore-this-name" = tag_list[[2]], dummyName = tag_list[[3]]) expect_identical(t2b, t2) # tagSetChildren, using list argument t2 <- tagSetChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagSetChildren, using ... arguments t2 <- tagSetChildren(div_tag, tag_list[[1]], tag_list[[2]], tag_list[[3]]) expect_identical(t2a, t2) # tagSetChildren, using named ... arguments (names should be ignored) t2 <- tagSetChildren(div_tag, ignored = tag_list[[1]], dummy = tag_list[[2]], blah = tag_list[[3]]) expect_identical(t2a, t2) # tagSetChildren, using ... and list arguments t2 <- tagSetChildren(div_tag, tag_list[[1]], list = tag_list[2:3]) expect_identical(t2a, t2) # tagSetChildren overwrites existing children t2 <- tagAppendChild(div_tag, p("should replace this tag")) t2 <- tagSetChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagAppendChildren, using list argument t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, list = tag_list[2:3]) expect_identical(t2a, t2) # tagAppendChildren, using ... arguments t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, tag_list[[2]], tag_list[[3]]) expect_identical(t2a, t2) # tagAppendChildren, using ... and list arguments t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, tag_list[[2]], list = list(tag_list[[3]])) expect_identical(t2a, t2) # tagAppendChildren can start with no children t2 <- tagAppendChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagSetChildren preserves attributes x <- tagSetChildren(div(), HTML("text")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) # tagAppendChildren preserves attributes x <- tagAppendChildren(div(), HTML("text")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) }) test_that("Creating simple tags", { # Empty tag expect_identical( div(), structure( list(name = "div", attribs = dots_list(), children = list()), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # Tag with text expect_identical( div("text"), structure( list(name = "div", attribs = dots_list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # NULL attributes are dropped expect_identical( div(a = NULL, b = "value"), div(b = "value") ) # length-0 attributes are dropped expect_identical( div(a = character(), b = "value"), div(b = "value") ) # NULL children are dropped expect_identical( renderTags(div("foo", NULL, list(NULL, list(NULL, "bar"))))$html, renderTags(div("foo", "bar"))$html ) # length-0 children are dropped expect_identical( renderTags(div("foo", character(), list(character(), list(list(), "bar"))))$html, renderTags(div("foo", "bar"))$html ) # Numbers are coerced to strings expect_identical( renderTags(div(1234))$html, renderTags(div("1234"))$html ) }) test_that("Creating nested tags", { # Simple version # Note that the $children list should not have a names attribute expect_identical( div(class="foo", list("a", "b")), structure( list(name = "div", attribs = structure(list(class = "foo"), .Names = "class"), children = list(list("a", "b"))), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # More complex version t1 <- withTags( div(class = "foo", p("child tag"), list( p("in-list child tag 1"), "in-list character string", p(), p("in-list child tag 2") ), "character string", 1234 ) ) # t1 should be identical to this data structure. # The nested list should be flattened, and non-tag, non-strings should be # converted to strings t1_full <- structure( list( name = "div", attribs = list(class = "foo"), children = list( structure(list(name = "p", attribs = list(), children = list("child tag")), class = "shiny.tag" ), structure(list(name = "p", attribs = list(), children = list("in-list child tag 1")), class = "shiny.tag" ), "in-list character string", structure(list(name = "p", attribs = list(), children = list()), class = "shiny.tag" ), structure(list(name = "p", attribs = list(), children = list("in-list child tag 2")), class = "shiny.tag" ), "character string", "1234" ) ), class = "shiny.tag" ) expect_identical(renderTags(t1)$html, renderTags(t1_full)$html) }) # The .noWS option was added in 0.3.6.9003; we may still encounter tags created # in an older version (perhaps saved to an RDS file and restored). They would # lack this element in their structure. test_that("Old tags without the .noWS option can still be rendered", { oldTag <- structure( list(name = "div", attribs = dots_list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) w <- WSTextWriter() tagWrite(oldTag, w) expect_identical( w$readAll(), "<div>text</div>\n" ) }) # We moved to rlang::dots_list in 0.3.6; we may still encounter tags created # in an older version (perhaps saved to an RDS file and restored). They would # use old-school lists. test_that("Old tags predating rlang::list2 can still be rendered", { oldTag <- structure( list(name = "div", attribs = list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) w <- WSTextWriter() tagWrite(oldTag, w) expect_identical( w$readAll(), "<div>text</div>\n" ) }) test_that("tag with noWS works",{ oneline <- tag("span", list(tag("strong", "Super strong", .noWS="outside"))) expect_identical(as.character(oneline), "<span><strong>Super strong</strong></span>") }) test_that("tag/s with invalid noWS fails fast", { expect_error(tag("span", .noWS="wrong")) expect_error(tags$a(.noWS="wrong")) }) test_that("Attributes are preserved", { # HTML() adds an attribute to the data structure (note that this is # different from the 'attribs' field in the list) x <- HTML("<tag>&&</tag>") expect_identical(attr(x, "html", TRUE), TRUE) expect_equivalent(format(x), "<tag>&&</tag>") # Make sure attributes are preserved when wrapped in other tags x <- div(HTML("<tag>&&</tag>")) expect_equivalent(x$children[[1]], HTML("<tag>&&</tag>")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) expect_equivalent(format(x), "<div><tag>&&</tag></div>") # Deeper nesting x <- div(p(HTML("<tag>&&</tag>"))) expect_equivalent(x$children[[1]]$children[[1]], HTML("<tag>&&</tag>")) expect_identical(attr(x$children[[1]]$children[[1]], "html", TRUE), TRUE) expect_equivalent(format(x), "<div>\n <p><tag>&&</tag></p>\n</div>") }) test_that("Adding attributes to tags", { t1 <- tags$div("foo") # Adding attributes to empty tag expect_identical(t1$attribs, dots_list()) expect_identical( tagAppendAttributes(t1, class = "c1")$attribs, list(class = "c1") ) # Adding attribute with multiple values expect_identical( tagAppendAttributes(t1, class = "c1 c2")$attribs, list(class = "c1 c2") ) # Adding two different attributes expect_identical( tagAppendAttributes(t1, class = "c1", id = "foo")$attribs, list(class = "c1", id = "foo") ) # Adding attributes in two successive calls expect_identical( tagAppendAttributes( tagAppendAttributes(t1, class = "c1 c2"), class = "c3")$attribs, list(class = "c1 c2", class = "c3") ) # Adding empty attributes expect_identical( tagAppendAttributes(t1, class = NULL)$attribs, list() ) expect_identical( tagAppendAttributes( tagAppendAttributes(t1, class = "hidden"), class = NULL)$attribs, list(class = "hidden") ) t2 <- tags$div("foo", class = "c1") # Adding attributes on a tag with other attributes expect_identical( tagAppendAttributes(t2, id = "foo")$attribs, list(class = "c1", id = "foo") ) # Adding attributes on a tag with the same attribute expect_identical( tagAppendAttributes(t2, class = "c2")$attribs, list(class = "c1", class = "c2") ) }) test_that("Adding unnamed attributes creates a warning", { expect_error( tagAppendAttributes( tags$div(), "value" ), "include an attribute name" ) x <- div() x$attribs[[1]] <- "value" expect_error( print(x), "name all of your attribute values" ) }) test_that("Testing for attributes on tags", { t1 <- tags$div("foo", class = "c1", class = "c2", id = "foo") # Testing for attribute that does not exist expect_identical( tagHasAttribute(t1, "nope"), FALSE ) # Testing for an attribute that exists once expect_identical( tagHasAttribute(t1, "id"), TRUE ) # Testing for an attribute that exists multiple times expect_identical( tagHasAttribute(t1, "class"), TRUE ) # Testing for substring of an attribute that exists expect_identical( tagHasAttribute(t1, "clas"), FALSE ) # Testing for superstring of an attribute that exists expect_identical( tagHasAttribute(t1, "classes"), FALSE ) # Testing for attribute with empty value t2 <- tags$div("foo", foo = "") expect_identical( tagHasAttribute(t2, "foo"), TRUE ) # Testing for attribute with NULL value t3 <- tags$div("foo", foo = NULL) expect_identical( tagHasAttribute(t3, "foo"), FALSE ) }) test_that("Getting attributes from tags", { # Getting an attribute from a tag with no attributes t1 <- tags$div("foo") expect_identical( tagGetAttribute(t1, "class"), NULL ) t2 <- tags$div("foo", class = "c1") # Getting an attribute from a tag without the correct attribute expect_identical( tagGetAttribute(t2, "id"), NULL ) # Getting an attribute from a tag with the a single value for the attribute expect_identical( tagGetAttribute(t2, "class"), "c1" ) # Getting an attribute from a tag with multiple matching attributes t3 <- tags$div("foo", class = "c1", id = "foo", class = "c2") expect_identical( tagGetAttribute(t3, "class"), "c1 c2" ) # Getting an attribute from a tag where the attributes were factors t4 <- tags$div("foo", class = as.factor("c1"), class = as.factor("c2")) expect_identical( tagGetAttribute(t4, "class"), "c1 c2" ) # Getting a numeric attribute from a tag t5 <- tags$div("foo", class = 78) expect_identical( tagGetAttribute(t5, "class"), "78" ) }) test_that("NA attributes are rendered correctly", { expect_identical( as.character(tags$div("text", foo = NA)), '<div foo>text</div>' ) expect_identical( as.character(tags$div("text", class = "a", foo = NA)), '<div class="a" foo>text</div>' ) expect_identical( as.character(tags$div("text", class = "a", foo = NA, class = "b")), '<div class="a b" foo>text</div>' ) # Multiple NA's are coalesced expect_identical( as.character(tags$div("text", class = "a", foo = NA, class = "b", foo = NA)), '<div class="a b" foo>text</div>' ) # A non-NA value supersedes NA expect_identical( as.character(tags$div("text", class = "a", foo = NA, foo = "b")), '<div class="a" foo="b">text</div>' ) expect_identical( as.character(tags$div("text", class = "a", foo = "b", foo = NA, foo = "c")), '<div class="a" foo="b c">text</div>' ) expect_identical( as.character(tags$div("text", class = "a", foo = "b", foo = NA, foo = NA, foo = "c")), '<div class="a" foo="b c">text</div>' ) }) test_that("NA attributes are retrieved correctly", { expect_foo_attr <- function(y, ...) { testTag <- tags$div("text", ...) expect_identical( tagGetAttribute(testTag, "foo"), y ) } expect_foo_attr(NA, foo = NA) expect_foo_attr(NA, class = "a", foo = NA) expect_foo_attr(NA, class = "a", foo = NA, class = "b") # Multiple NA's are coalesced expect_foo_attr(NA, class = "a", foo = NA, class = "b", foo = NA) # A non-NA value supersedes NA expect_foo_attr("b", class = "a", foo = NA, foo = "b") expect_foo_attr("b c", class = "a", foo = "b", foo = NA, foo = "c") expect_foo_attr("b c", class = "a", foo = "b", foo = NA, foo = NA, foo = "c") # Non atomic value cause a list to be returned. expect_foo_attr(list(list("b")), class = "a", foo = NA, foo = list("b")) expect_foo_attr(list(list("b"), list("c")), class = "a", foo = list("b"), foo = NA, foo = list("c")) expect_foo_attr(list("b", list("c")), class = "a", foo = "b", foo = NA, foo = NA, foo = list("c")) }) test_that("Tag list tree is rendered in DOM tree order", { # Tree order is preorder, depth-first traversal # https://dom.spec.whatwg.org/#concept-tree # # Test for preordered traversal/execution of tagFunction(). This allows one to # rely on the side-effects of executing a tag, so long as those side-effects # happen "towards the top" of the tree. Shiny implicitly assumes this # behavior: execution of bootstrapLib() introduces a (temporary) side-effect # that "down-stream" UI (i.e. sliderInput() et al) can use to inform their # Sass -> CSS compilation value <- NULL lazyDiv <- div(tagFunction(function() { value })) dom <- tagList( lazyDiv, div(tagList( tagFunction(function() { value <<- 1 }) )), lazyDiv ) expect_identical( as.character(dom), "<div></div>\n<div>1</div>\n<div>1</div>" ) }) test_that("Flattening a list of tags", { # Flatten a nested list nested <- list( "a1", list( "b1", list("c1", "c2"), list(), "b2", list("d1", "d2") ), "a2" ) flat <- list("a1", "b1", "c1", "c2", "b2", "d1", "d2", "a2") expect_identical(flattenTags(nested), flat) # no-op for flat lists expect_identical(flattenTags(list(a="1", "b")), list(a="1", "b")) # numbers are coerced to character expect_identical(flattenTags(list(a=1, "b")), list(a="1", "b")) # empty list results in empty list expect_identical(flattenTags(list()), list()) # preserve attributes nested <- list("txt1", list(structure("txt2", prop="prop2"))) flat <- list("txt1", structure("txt2", prop="prop2")) expect_identical(flattenTags(nested), flat) }) test_that("Head and singleton behavior", { result <- renderTags(tagList( tags$head(singleton("hello")) )) expect_identical(result$html, HTML("")) expect_identical(result$head, HTML(" hello")) expect_identical(result$singletons, "089cce0335cf2bae2bcb08cc753ba56f8e1ea8ed") # Ensure that "hello" actually behaves like a singleton result2 <- renderTags(tagList( tags$head(singleton("hello")) ), singletons = result$singletons) expect_identical(result$singletons, result2$singletons) expect_identical(result2$head, HTML("")) expect_identical(result2$html, HTML("")) result3 <- renderTags(tagList( tags$head(singleton("hello"), singleton("hello")) )) expect_identical(result$singletons, result3$singletons) expect_identical(result3$head, HTML(" hello")) # Ensure that singleton can be applied to lists, not just tags result4 <- renderTags(list(singleton(list("hello")), singleton(list("hello")))) expect_identical(result4$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") expect_identical(result4$html, renderTags(HTML("hello"))$html) result5 <- renderTags(tagList(singleton(list(list("hello"))))) expect_identical(result5$html, renderTags("hello")$html) }) test_that("Factors are treated as characters, not numbers", { myfactors <- factor(LETTERS[1:3]) expect_identical( as.character(tags$option(value=myfactors[[1]], myfactors[[1]])), '<option value="A">A</option>' ) expect_identical( as.character(tags$option(value=myfactors[[1]], value='B', value=3, myfactors[[1]])), '<option value="A B 3">A</option>' ) }) test_that("Unusual list contents are rendered correctly", { expect_identical(renderTags(list(NULL)), renderTags(HTML(""))) expect_identical(renderTags(list(100)), renderTags(HTML("100"))) expect_identical(renderTags(list(list(100))), renderTags(HTML("100"))) expect_identical(renderTags(list(list())), renderTags(HTML(""))) expect_identical(renderTags(NULL), renderTags(HTML(""))) }) test_that("Low-level singleton manipulation methods", { # Default arguments drop singleton duplicates and strips the # singletons it keeps of the singleton bit result1 <- takeSingletons(tags$div( singleton(tags$head(tags$script("foo"))), singleton(tags$head(tags$script("foo"))) )) expect_identical(result1$ui$children[[2]], NULL) expect_false(is.singleton(result1$ui$children[[1]])) # desingleton=FALSE means drop duplicates but don't strip the # singleton bit result2 <- takeSingletons(tags$div( singleton(tags$head(tags$script("foo"))), singleton(tags$head(tags$script("foo"))) ), desingleton=FALSE) expect_identical(result2$ui$children[[2]], NULL) expect_true(is.singleton(result2$ui$children[[1]])) result3 <- surroundSingletons(tags$div( singleton(tags$script("foo")), singleton(tags$script("foo")) )) expect_identical( renderTags(result3)$html, HTML("<div> <!--SHINY.SINGLETON[98eee9ba1f9e4ab3db75f33036bf91d4e214342b]--> <script>foo</script> <!--/SHINY.SINGLETON[98eee9ba1f9e4ab3db75f33036bf91d4e214342b]--> <!--SHINY.SINGLETON[98eee9ba1f9e4ab3db75f33036bf91d4e214342b]--> <script>foo</script> <!--/SHINY.SINGLETON[98eee9ba1f9e4ab3db75f33036bf91d4e214342b]--> </div>") ) }) test_that("Indenting can be controlled/suppressed", { expect_identical( renderTags(tags$div("a", "b"))$html, HTML("<div>\n a\n b\n</div>") ) expect_identical( format(tags$div("a", "b")), "<div>\n a\n b\n</div>" ) expect_identical( renderTags(tags$div("a", "b"), indent = 2)$html, HTML(" <div>\n a\n b\n </div>") ) expect_identical( format(tags$div("a", "b"), indent = 2), " <div>\n a\n b\n </div>" ) expect_identical( renderTags(tags$div("a", "b"), indent = FALSE)$html, HTML("<div>\na\nb\n</div>") ) expect_identical( format(tags$div("a", "b"), indent = FALSE), "<div>\na\nb\n</div>" ) expect_identical( renderTags(tagList(tags$div("a", "b")), indent = FALSE)$html, HTML("<div>\na\nb\n</div>") ) expect_identical( format(tagList(tags$div("a", "b")), indent = FALSE), "<div>\na\nb\n</div>" ) }) test_that("cssList tests", { expect_identical(NULL, css()) expect_identical(NULL, css()) expect_identical( css( font.family = 'Helvetica, "Segoe UI"', font_size = "12px", `font-style` = "italic", font.variant = NULL, "font-weight!" = factor("bold"), padding = c("10px", "9px", "8px") ), "font-family:Helvetica, \"Segoe UI\";font-size:12px;font-style:italic;font-weight:bold !important;padding:10px 9px 8px;" ) # Unnamed args not allowed expect_error(css("10")) expect_error(css(1, b=2)) # NULL and empty string are dropped expect_null(css(a="", b = NULL, "c!" = NULL, d = character())) # We are dumb about duplicated properties. Probably don't do that. expect_identical(css(a=1, a=2), "a:1;a:2;") }) test_that("Non-tag objects can be coerced", { .GlobalEnv$as.tags.testcoerce1 <- function(x) { list(singleton(list("hello"))) } on.exit(rm("as.tags.testcoerce1", pos = .GlobalEnv), add = TRUE) # Make sure tag-coerceable objects are tagified result1 <- renderTags(structure(TRUE, class = "testcoerce1")) expect_identical(result1$html, HTML("hello")) expect_identical(result1$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") # Make sure tag-coerceable objects are tagified before singleton handling # occurs, but that over-flattening doesn't happen result2 <- renderTags(tagList( singleton(list("hello")), structure(TRUE, class = "testcoerce1") )) expect_identical(result2$html, HTML("hello")) expect_identical(result2$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") }) test_that("Latin1 and system encoding are converted to UTF-8", { #Sys.setlocale(, "Chinese") latin1_str <- rawToChar(as.raw(0xFF)) Encoding(latin1_str) <- "latin1" divLatin1 <- as.character(tags$div(latin1_str)) expect_identical( charToRaw(divLatin1), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0xc3, 0xbf, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e)) ) expect_identical(Encoding(divLatin1), "UTF-8") expect_identical(Encoding("\u4E11"), "UTF-8") divUTF8 <- as.character(tags$div("\u4E11")) expect_identical( charToRaw(divUTF8), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0xe4, 0xb8, 0x91, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e)) ) expect_identical(Encoding(divUTF8), "UTF-8") divMixed <- format(tags$div( "\u4E11", latin1_str, tags$span(a="\u4E11", latin1_str), tags$span(b=latin1_str, HTML("\u4E11")) )) expect_identical( charToRaw(divMixed), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0x0a, 0x20, 0x20, 0xe4, 0xb8, 0x91, 0x0a, 0x20, 0x20, 0xc3, 0xbf, 0x0a, 0x20, 0x20, 0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x61, 0x3d, 0x22, 0xe4, 0xb8, 0x91, 0x22, 0x3e, 0xc3, 0xbf, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e, 0x0a, 0x20, 0x20, 0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x62, 0x3d, 0x22, 0xc3, 0xbf, 0x22, 0x3e, 0xe4, 0xb8, 0x91, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e, 0x0a, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e )) ) expect_identical(Encoding(divMixed), "UTF-8") # Encoding(HTML(latin1_str)) is "UTF-8" on Linux; even just # paste(latin1_str) returns a UTF-8 encoded string #expect_identical(Encoding(HTML(latin1_str)), "latin1") expect_identical(Encoding(format(HTML(latin1_str))), "UTF-8") expect_identical(Encoding(format(tagList(latin1_str))), "UTF-8") # ensure the latin1 attribute returns correctly after escaping latin1_str2 <- rawToChar(as.raw(c(0xff, 0x0d, 0x0a))) Encoding(latin1_str2) <- "latin1" spanLatin <- as.character(tags$span(latin1_str2, title = latin1_str2)) expect_identical(Encoding(spanLatin), "UTF-8") expect_identical( charToRaw(spanLatin), as.raw(c(0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x74, 0x69, 0x74, 0x6c, 0x65, 0x3d, 0x22, 0xc3, 0xbf, 0x26, 0x23, 0x31, 0x33, 0x3b, 0x26, 0x23, 0x31, 0x30, 0x3b, 0x22, 0x3e, 0xc3, 0xbf, 0x0d, 0x0a, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e )) ) }) test_that("paste8 in Chinese locale works", { loc <- "Chinese" testthat::skip_if_not(is_locale_available(loc), "Chinese locale not available") withr::with_locale(c(LC_COLLATE=loc, LC_CTYPE=loc, LC_MONETARY=loc, LC_TIME=loc), { x <- "\377" Encoding(x) <- "latin1" expect_identical(x, "\Uff") expect_identical(Encoding(x), "latin1") y <- "\U4E2d" # Using \Uxxxx always is encoded as UTF-8 expect_identical(y, "\U4E2d") expect_identical(Encoding(y), "UTF-8") xy <- paste8(x, y) xy expect_identical(xy, "\Uff \U4E2d") expect_identical(Encoding(xy), "UTF-8") xy <- paste8(c(x, y), collapse = "") expect_identical(xy, "\Uff\U4E2d") expect_identical(Encoding(xy), "UTF-8") }) }) test_that("Printing tags works", { expect_identical( capture.output(print(tags$a(href = "#", "link"))), '<a href="#">link</a>' ) }) test_that("htmlEscape will try to coerce inputs to characters", { x <- list(a1 = "b", a2 = list("b1", "b2")) expect_identical( htmlEscape(x), as.character(x) ) }) test_that("trailing commas allowed everywhere", { expect_silent({ t1 <- div("foo",) tagList(t1,) tagSetChildren(t1, "child",) tagAppendAttributes(t1, class = "bar",) tagAppendChildren(t1, "child2",) css(style = "",) }) }) test_that("extractPreserveChunks works for emoji strings", { # solaris doesn't seem to support Unicode characters with surrogate pairs # (just by creating such a string will cause a warning) # > "\U0001F937" # [1] "\U0001f937" # Warning message: # it is not known that wchar_t is Unicode on this platform skip_on_os("solaris") x <- "<!--html_preserve-->chunk1<!--/html_preserve-->\U0001F937<!--html_preserve-->chunk2<!--/html_preserve-->" out <- extractPreserveChunks(x) expect_equivalent( out$chunks, c('chunk2', 'chunk1') ) }) test_that("complicated class attributes are handled", { x <- div(class = as.factor(letters)[1], class = "b c", class = c("d", "e f")) expect_equal( tagGetAttribute(x, "class"), "a b c d e f" ) expect_identical( as.character(x), "<div class=\"a b c d e f\"></div>" ) }) test_that("html render method", { local_edition(3) # Have a place holder div and return a span instead obj <- div("example", .renderHook = function(x) { x$name <- "span" x }) expect_equal(obj$name, "div") expect_snapshot(as.character(obj)) # Add a class to the tag spanExtra <- tagAddRenderHook(obj, function(x) { tagAppendAttributes(x, class = "extra") }) expect_equal(spanExtra$name, "div") expect_equal(spanExtra$attribs$class, NULL) expect_snapshot(as.character(spanExtra)) # Replace the previous render method # Should print a `div` with class `"extra"` divExtra <- tagAddRenderHook(obj, replace = TRUE, function(x) { tagAppendAttributes(x, class = "extra") }) expect_equal(divExtra$attribs$class, NULL) expect_snapshot(as.character(divExtra)) # Add more child tags spanExtended <- tagAddRenderHook(obj, function(x) { tagAppendChildren(x, tags$strong("bold text")) }) expect_equal(spanExtended$name, "div") expect_equal(spanExtended$children, obj$children) expect_snapshot(as.character(spanExtended)) tagFuncExt <- tagAddRenderHook(obj, function(x) { tagFunction(function() tagList(x, tags$p("test")) ) }) expect_equal(tagFuncExt$name, "div") expect_equal(tagFuncExt$children, obj$children) expect_snapshot(as.character(tagFuncExt)) # Add a new html dependency newDep <- tagAddRenderHook(obj, function(x) { fa <- htmlDependency( "font-awesome", "4.5.0", c(href="shared/font-awesome"), stylesheet = "css/font-awesome.min.css") attachDependencies(x, fa, append = TRUE) }) # Also add a jqueryui html dependency htmlDependencies(newDep) <- htmlDependency( "jqueryui", "1.11.4", c(href="shared/jqueryui"), script = "jquery-ui.min.js") expect_equal(newDep$name, "div") expect_length(htmlDependencies(newDep), 1) expect_snapshot(renderTags(newDep)) # Ignore the original tag and return something completely new. newObj <- tagAddRenderHook(obj, function(x) { tags$p("Something else") }) expect_equal(newObj$name, "div") expect_snapshot(as.character(newObj)) }) test_that(".cssSelector arg only applies changes to the selected elements", { html <- div( class = "outer", div(class = "inner", "text"), span("TEXT") ) expect_equal_tags( tagAppendAttributes(html, id = "test"), div(class = "outer", id = "test", div(class="inner", "text"), span("TEXT")) ) expect_equal_tags( tagAppendAttributes(html, id = "test", .cssSelector = ".inner"), div(class = "outer", div(class = "inner", id = "test", "text"), span("TEXT")) ) expect_equal_tags( tagAppendChild(html, h1()), div(class = "outer", div(class="inner", "text"), span("TEXT"), h1()) ) expect_equal_tags( tagAppendChild(html, h1(), .cssSelector = ".inner"), div(class = "outer", div(class = "inner", "text", h1()), span("TEXT")) ) expect_equal_tags( tagAppendChildren(html, h1(), h2()), div(class = "outer", div(class="inner", "text"), span("TEXT"), h1(), h2()) ) expect_equal_tags( tagAppendChildren(html, h1(), h2(), .cssSelector = ".inner"), div(class = "outer", div(class = "inner", "text", h1(), h2()), span("TEXT")) ) expect_equal_tags( tagSetChildren(html, h1(), h2()), div(class = "outer", h1(), h2()) ) expect_equal_tags( tagSetChildren(html, h1(), h2(), .cssSelector = ".inner"), div(class = "outer", div(class = "inner", h1(), h2()), span("TEXT")) ) expect_equal_tags( tagInsertChildren(html, h1(), h2(), after = 0), div(class = "outer", h1(), h2(), div(class="inner", "text"), span("TEXT")) ) expect_equal_tags( tagInsertChildren(html, h1(), h2(), after = 0, .cssSelector = ".inner"), div(class = "outer", div(class = "inner", h1(), h2(), "text"), span("TEXT")) ) }) test_that("flattenTagAttribs", { attribs <- list( b = "1", a = "2", b = "3" ) flatAttribs <- flattenTagAttribs(attribs) # alpha sorted expect_equal(names(flatAttribs), c("a", "b")) # b values are collected expect_equal(flatAttribs, list(a = "2", b = c("1", "3"))) })
Generated by dwww version 1.15 on Sat May 18 14:15:37 CEST 2024.