htmltools/ 0000755 0001762 0000144 00000000000 15114272561 012303 5 ustar ligges users htmltools/tests/ 0000755 0001762 0000144 00000000000 14600330155 013436 5 ustar ligges users htmltools/tests/testthat/ 0000755 0001762 0000144 00000000000 15113345760 015306 5 ustar ligges users htmltools/tests/testthat/test-template.R 0000644 0001762 0000144 00000020330 14600330155 020207 0 ustar ligges users context("templates")
# Searches for an html dependency of format name[version], as in "d3[3.5.10]",
# within the html-dependencies script tag
findDep <- function(x, name, version) {
deps <- sub(
'.*.*',
"\\1",
x
)
grepl(paste0(name, "[", version, "]"), deps, fixed = TRUE)
}
test_that("Code blocks are evaluated and rendered correctly", {
template <- htmlTemplate(test_path("template-document.html"),
x = div(class = "foo", "bar")
)
html <- renderDocument(template)
expect_true(grepl('
bar
', html))
# With text_ argument
template <- htmlTemplate(text_ = "a {{ foo + 1 }} b", foo = 10)
expect_identical(as.character(as.character(template)), "a 11 b")
# Make char vectors are pasted together
template <- htmlTemplate(text_ = c("a", "{{ foo + 1 }} b"), foo = 10)
expect_identical(as.character(as.character(template)), "a\n11 b")
})
test_template <- function(){
template <- htmlTemplate(test_path("template-document.html"), x = "")
html <- renderDocument(template)
expect_identical(Encoding(html), "UTF-8")
# Create the string 'Δ★😎', making sure it's UTF-8 encoded on all platforms.
# These characters are 2, 3, and 4 bytes long, respectively.
pat <- rawToChar(as.raw(c(0xce, 0x94, 0xe2, 0x98, 0x85, 0xf0, 0x9f, 0x98, 0x8e)))
Encoding(pat) <- "UTF-8"
expect_true(grepl(pat, html))
# If template is passed text_ argument, make sure it's converted from native
# to UTF-8.
latin1_str <- rawToChar(as.raw(0xFF))
Encoding(latin1_str) <- "latin1"
text <- as.character(htmlTemplate(text_ = latin1_str))
expect_identical(charToRaw(text), as.raw(c(0xc3, 0xbf)))
}
test_that("UTF-8 characters in templates with default locale", {
# The default locale
loc <- ""
withr::with_locale(c(LC_COLLATE=loc, LC_CTYPE=loc, LC_MONETARY=loc, LC_TIME=loc), test_template())
})
test_that("UTF-8 characters in templates with Chinese locale", {
# Chinese locale
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), test_template())
})
test_that("UTF-8 characters in template head but not body", {
# On Windows, a string with "中文" will automatically be marked as UTF-8.
ui <- tagList(
tags$head(tags$script("alert('中文')")),
"test"
)
html <- htmlTemplate(test_path("template-basic.html"), body = ui)
res <- renderDocument(html)
expect_identical(Encoding(res), "UTF-8")
expect_true(grepl("中文", res, fixed = TRUE))
# On Windows, a string with "á" will automatically be marked as latin1.
ui <- tagList(
tags$head(tags$script("alert('á')")),
"test"
)
html <- htmlTemplate(test_path("template-basic.html"), body = ui)
res <- renderDocument(html)
expect_identical(Encoding(res), "UTF-8")
expect_true(grepl("á", res, fixed = TRUE))
})
test_that("Dependencies are added properly", {
dep <- htmlDependency("d3", "3.5.10", c(href="shared"), script = "d3.js")
# Add dependency by inserting a tag with a dependency
template <- htmlTemplate(test_path("template-document.html"),
x = attachDependencies(div(), dep)
)
html <- renderDocument(template)
expect_true(findDep(html, "d3", "3.5.10"))
expect_true(grepl('', html, fixed = TRUE))
# Add dependency via a renderDocument
template <- htmlTemplate(test_path("template-document.html"), x = "")
html <- renderDocument(template, dep)
expect_true(findDep(html, "d3", "3.5.10"))
expect_true(grepl('', html, fixed = TRUE))
})
test_that("Dependencies can be suppressed", {
# The template includes suppressDependencies("jquery"), so we shouldn't see
# this dependency in the final output.
dep <- htmlDependency("jquery", "1.11.3", c(href="shared"), script = "jquery.js")
# Add dependency by inserting a tag with a dependency
template <- htmlTemplate(test_path("template-document.html"),
x = attachDependencies(div(), dep)
)
html <- renderDocument(template)
expect_true(findDep(html, "jquery", "9999"))
expect_false(grepl(']+jquery[^>]+>', html))
# Add dependency via a renderDocument
template <- htmlTemplate(test_path("template-document.html"), x = "")
html <- renderDocument(template, dep)
expect_true(findDep(html, "jquery", "9999"))
expect_false(grepl(']+jquery[^>]+>', html))
})
test_that("Errors for mismatched brackets", {
# Error if unmatched opening brackets
expect_error(htmlTemplate(text_ = "text {{ code"))
# No error if we didn't open a code block
expect_identical(
as.character(htmlTemplate(text_ = "code }} text")),
"code }} text"
)
# Error if unmatched brackets, when no leading or trailing space
expect_error(htmlTemplate(text_ = "{{ code"))
# No error if we didn't open a code block
expect_identical(
as.character(htmlTemplate(text_ = "code }}")),
"code }}"
)
})
test_that("Brackets at start or end of text", {
# Code and text
expect_identical(
as.character(htmlTemplate(text_ = "text {{ code }} text", code = 1)),
"text 1 text"
)
expect_identical(
as.character(htmlTemplate(text_ = "text{{code}}text", code = 1)),
"text1text"
)
# No brackets
expect_identical(
as.character(htmlTemplate(text_ = "text", code = 1)),
"text"
)
# No leading or trailing text
expect_identical(
as.character(htmlTemplate(text_ = "{{ code }}", code = 1)),
"1"
)
expect_identical(
as.character(htmlTemplate(text_ = " {{ code }}", code = 1)),
" 1"
)
expect_identical(
as.character(htmlTemplate(text_ = "{{ code }} ", code = 1)),
"1 "
)
# Edge cases
expect_identical(as.character(htmlTemplate(text_ = "")), "")
expect_identical(as.character(htmlTemplate(text_ = "X")), "X")
expect_identical(as.character(htmlTemplate(text_ = " ")), " ")
expect_identical(as.character(htmlTemplate(text_ = "{{}}")), "")
expect_identical(as.character(htmlTemplate(text_ = " {{}} ")), " ")
expect_identical(as.character(htmlTemplate(text_ = "{{ }}")), "")
expect_identical(as.character(htmlTemplate(text_ = "{{}}{{}}")), "")
expect_identical(as.character(htmlTemplate(text_ = "{{1}}{{2}}")), "12")
expect_error(as.character(htmlTemplate(text_ = "{{")))
expect_error(as.character(htmlTemplate(text_ = " {{")))
expect_error(as.character(htmlTemplate(text_ = "{{ ")))
expect_identical(as.character(htmlTemplate(text_ = "}}")), "}}")
expect_identical(as.character(htmlTemplate(text_ = " }}")), " }}")
expect_identical(as.character(htmlTemplate(text_ = "}} ")), "}} ")
})
test_that("Template DFA edge cases", {
# Single quotes
expect_identical(as.character(htmlTemplate(text_ = "{{ '' }}")), "")
expect_identical(as.character(htmlTemplate(text_ = " {{ '' }} ")), " ")
expect_identical(as.character(htmlTemplate(text_ = "{{ '\\'' }}")), "'")
expect_identical(as.character(htmlTemplate(text_ = "{{ '\\\\' }}")), "\\")
expect_identical(as.character(htmlTemplate(text_ = "{{ '}}' }}")), "}}")
# Double quotes
expect_identical(as.character(htmlTemplate(text_ = '{{ "" }}')), '')
expect_identical(as.character(htmlTemplate(text_ = ' {{ "" }} ')), ' ')
expect_identical(as.character(htmlTemplate(text_ = '{{ "\\"" }}')), '"')
expect_identical(as.character(htmlTemplate(text_ = '{{ "\\\\" }}')), '\\')
expect_identical(as.character(htmlTemplate(text_ = '{{ "}}" }}')), '}}')
# Backticks in code
expect_identical(as.character(htmlTemplate(text_ = "{{ `}}`<-1 }}")), "1")
expect_identical(as.character(htmlTemplate(text_ = "{{ `x\\`x`<-1 }}")), "1")
# Percent operator - various delimiters in percent operator
expect_identical(
as.character(htmlTemplate(text_ = "a{{ `%'%` <- function(x, y) 1; 2 %'% 3 }}b")),
"a1b"
)
expect_identical(
as.character(htmlTemplate(text_ = "a{{ `%}}%` <- function(x, y) 1; 2 %}}% 3 }}b")),
"a1b"
)
# Comments
expect_identical(
as.character(htmlTemplate(text_ = "a{{ 1 #2 }}b")),
"a1b"
)
expect_identical(
as.character(htmlTemplate(text_ = "a{{ 1 #2\n3 }}b")),
"a3b"
)
expect_identical(
as.character(htmlTemplate(text_ = "a{{ 1 #2'3 }}b")),
"a1b"
)
expect_identical(
as.character(htmlTemplate(text_ = "a{{ 1 #2}3 }}b")),
"a1b"
)
})
htmltools/tests/testthat/test-tags.r 0000644 0001762 0000144 00000107314 14600330155 017402 0 ustar ligges users 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")),
"one")
expect_equal(
as.character(tags$b("one", "two")),
"\n one\n two\n")
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")),
" \none")
})
test_that("Hanging commas don't break things", {
expect_equal(as.character(tagList("hi",)), "hi")
expect_equal(as.character(div("one",)), "
one
")
# Multiple commas still throw
err_comma_multiple <- expect_error(as.character(div("one",,)))
# Non-trailing commas still throw
err_comma_leading <- expect_error(as.character(div(,"one",)))
# rlang > 1.0.6 changed the error message, so only run
# snapshot testing of the error message with the new version
skip_if_not_installed("rlang", "1.0.6.9000")
local_edition(3)
expect_snapshot(err_comma_multiple)
expect_snapshot(err_comma_leading)
})
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>
")
# Text in HTML() isn't escaped
expect_equivalent(format(div(HTML(""))), "
")
# Text in a property is escaped
expect_equivalent(format(div(class = "", "text")),
'
text
')
# HTML() has no effect in a property like 'class'
expect_equivalent(format(div(class = HTML(""), "text")),
'
text
')
})
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(),
"
text
\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(),
"
text
\n"
)
})
test_that("tag with noWS works",{
oneline <- tag("span", list(tag("strong", "Super strong", .noWS="outside")))
expect_identical(as.character(oneline), "Super strong")
})
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("&&")
expect_identical(attr(x, "html", TRUE), TRUE)
expect_equivalent(format(x), "&&")
# Make sure attributes are preserved when wrapped in other tags
x <- div(HTML("&&"))
expect_equivalent(x$children[[1]], HTML("&&"))
expect_identical(attr(x$children[[1]], "html", TRUE), TRUE)
expect_equivalent(format(x), "
")
})
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)),
'
'
)
})
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),
"\n
1
\n
1
"
)
})
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]])),
''
)
expect_identical(
as.character(tags$option(value=myfactors[[1]], value='B', value=3, myfactors[[1]])),
''
)
})
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("
")
)
})
test_that("Indenting can be controlled/suppressed", {
expect_identical(
renderTags(tags$div("a", "b"))$html,
HTML("
\nbar", list(a1.1, a1.2))
# tags with children ------------------------------------------------
x <- div(a1.1, div("foo"), "bar")
expect_html_deps(x, "
", list(a1.1, a1.2))
# Passing normal lists to tagLists and tag functions ---------------
x <- tagList(list(a1.1, div("foo")), "bar")
expect_html_deps(x, "
UTF-8 chars:Δ★😎
htmltools/tests/testthat/test-selector.R 0000644 0001762 0000144 00000012405 14600330155 020220 0 ustar ligges users
makeTags <- function(text1, text2) {
inputTags <- div(
class = "outer",
tagList(
div(
class = "inner",
a(href="example.com", "`a` ", list(strong(text1), em(p(text2))), " text."),
),
span(
class = "sibling",
"sibling text"
)
)
)
inputTags <- span(list(inputTags, inputTags))
inputTags
}
test_that("error checks", {
expect_error(asSelector("div, span"), "contain `,`")
expect_error(asSelector("div[foo]"), "contain `[`", fixed = TRUE)
expect_error(asSelector("div:text"), "Pseudo CSS selectors")
})
test_that("selector parses string", {
selector <- asSelector("h1#myId-value.class-name .child-class#child-id_value")
expect_equal(
format(selector),
"h1#myId-value.class-name #child-id_value.child-class"
)
})
test_that("selector parses valid names", {
verbose <- FALSE
wrapped_expect_equal <- function (object, expected, label) {
if (verbose) message(label)
expect_equal(object, expected, label = label)
}
valid_names <- list(
single_character = "a",
single_CHARACTER = "A",
multiple_characters = "abc",
multiple_cHaRaCtErS = "aBcD",
just_an_underscore = "_",
starts_with_an_underscore = "_abc",
contains_underscore = "a_abc",
contains_hyphen_and_underscore = "a_abc-def"
)
# check elements parse
for (key in names(valid_names)) {
this_time <- valid_names[[key]]
wrapped_expect_equal(
format(asSelector(this_time)),
this_time,
label = paste0("checking element ", key, " with content ", this_time)
)
}
# check ids parse
for (key in names(valid_names)) {
this_time <- paste0("#", valid_names[[key]])
wrapped_expect_equal(
format(asSelector(this_time)),
this_time,
label = paste0("checking id ", key, " with content ", this_time)
)
}
# check classes parse
for (key in names(valid_names)) {
this_time <- paste0(".", valid_names[[key]])
wrapped_expect_equal(
format(asSelector(this_time)),
this_time,
label = paste0("checking class name ", key, " with content ", this_time)
)
}
# check compounds parse
for (element_key in names(valid_names)) {
for (id_key in names(valid_names)) {
for (class_key_1 in names(valid_names)) {
for (class_key_2 in names(valid_names)) {
this_time <- paste0(
valid_names[[element_key]],
"#", valid_names[[id_key]],
".", valid_names[[class_key_1]],
".", valid_names[[class_key_2]]
)
wrapped_expect_equal(
format(asSelector(this_time)),
this_time,
label = paste0("checking compound element ", paste(element_key, id_key, class_key_1, class_key_2, sep="|"), " with content ", this_time)
)
reordered_this_time <- paste0(
valid_names[[element_key]],
".", valid_names[[class_key_1]],
"#", valid_names[[id_key]],
".", valid_names[[class_key_2]]
)
wrapped_expect_equal(
format(asSelector(reordered_this_time)),
this_time,
label = paste0("checking reordered compound element ", paste(element_key, id_key, class_key_1, class_key_2, sep="|"), " with content ", reordered_this_time)
)
}
}
}
}
})
test_that("* checks", {
expect_equal(format(asSelector(" * ")), "*")
expect_equal(format(asSelector(" *.class-name")), ".class-name")
expect_s3_class(asSelector(" * "), selectorClass)
})
test_that("> checks", {
expect_error(asSelector("> div"), "first element")
expect_error(asSelector("div >"), "last element")
expect_error(asSelectorList("> div"), "first element")
expect_error(asSelectorList("div >"), "last element")
expect_equal(format(asSelector("div>span")), "div > span")
expect_equal(format(asSelector("div>>span")), "div > * > span")
})
# x <- div(class = "foo", "text 1",
# div(class = "bar", "text 2"),
# div(class = "bar", "text 3",
# span("more text")
# )
# )
# y <- x
# x <- x[1:length(x)]
# mutate_in_place(x)
# x %>% find(".bar", function(item) { toupper(x$children); item })
# y <- x %>% el_find(".bar") %>% el_find(".x") %>% el_mutate(function(x) toupper(x$children))
# x %>% find(".bar") %>% addClass("abc")
# x %>% find(".bar") %>% removeClass("abc")
# x %>% find(".bar") %>% attr(`data-x` = 123)
# x %>% find(".bar") %>% css(color = "red")
# actionButton("x", "X") %>% removeClass("btn-default") %>% addClass("btn-primary")
# x <- actionButton("x", "X")
# x$attribs$class <- sub("btn-default", "btn-primary", x$attribs$class)
# removeClass.shiny.tag <- function(x, class) {
# ...
# }
# x <- div(
# actionButton("x", "X")
# )
# # Selection types:
# # - tags
# # - classes
# # - ID
# # - descendent ".btn .x"
# # Future:
# # - direct child ".btn > .x"
# #
# # Tag functions:
# # - delay execution, wrap them somehow
# # - need to know we have a way forward
# x %>% el_select(".btn") %>% el_remove_class("btn-default") %>% el_add_class("btn-primary")
# x %>% find(".btn") %>% { . %>% removeClass("btn") %>% addClass("btn-primary") }
# x$select(".btn")$removeClass("btn-default")$addClass("btn-primary")
# `$.shiny.tag` <- function(x, name, ...) {
# el_fns[[name]](x, ...)
# }
htmltools/tests/test-all.R 0000644 0001762 0000144 00000000076 14600330155 015311 0 ustar ligges users library(testthat)
library(htmltools)
test_check("htmltools")
htmltools/MD5 0000644 0001762 0000144 00000011526 15114272561 012620 0 ustar ligges users f2321bd1e8ea8a05f8783847a5399854 *DESCRIPTION
691f06b13a7452793fd9fc1581346b88 *NAMESPACE
4770c2d61d7dbc1816dbec77d725567d *NEWS.md
5f044fb2e9680b6c1625d182bdeda8d1 *R/colors.R
8aa66c36a0c428b1eaeaab7ae0238eb7 *R/fill.R
41d3d5c49e5ebc09d3696abdb53682ce *R/html_dependency.R
3264d8cfd71d9150f3b08b473a28847b *R/html_escape.R
99ad091935c8c7290163a264a7163f6c *R/html_print.R
2f07d7435562b3865ec234823b834bc7 *R/htmltools-package.R
3f94c4f4858f13cc7af9a59e758700e5 *R/images.R
0bddcd4bb9b19a209d1078b9ee7ef5b1 *R/known_tags.R
f093a7c50e7ee932b50e9429549edf1e *R/selector.R
5b5faeac9c5718857c41c856f84b3609 *R/staticimports.R
f313557f25e51070e8e1e2a7ca02637c *R/tag_query.R
2ae89508c5da854d891de5b882e96661 *R/tags.R
8754e24109c264ad919c72f969223085 *R/template.R
4d55ba4751614e631d3a0d5f54fb91e4 *R/utils.R
0c307b2ce7a3fa7f260a0451457c809f *inst/fill/fill.css
66c25a9fbb39e38f9d00f70e388b51ca *man/HTML.Rd
0f17d772c2a8b09646c35575510f58a9 *man/as.tags.Rd
88755a18c0ce2033778d9209cdfcd58c *man/bindFillRole.Rd
ce6cec95e6f96f39a06724bb0c04c781 *man/browsable.Rd
f4c60f8981bebc3eab34050a8f5a8d21 *man/builder.Rd
03c957ef3c77d9020c6badeb36267912 *man/capturePlot.Rd
f8a468bd5662dae651fd5320a00ce0f2 *man/copyDependencyToDir.Rd
399fc5b9debe9b58ebd9e4d20767339e *man/css.Rd
dc524c0301930e93a4efe84878ad37a7 *man/defaultPngDevice.Rd
a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg
c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg
27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg
1c1fe7a759b86dc6dbcbe7797ab8246c *man/figures/lifecycle-superseded.svg
3535309b2acb4eef2e33ee1d24d96081 *man/figures/logo.png
58529e9e64ce0f2e4582f758d2c2c525 *man/figures/plotly-taglist.png
1d408ec004842bf68e2014a0d2c9062e *man/findDependencies.Rd
d9ebaf094bf5ac589977d39993ce5176 *man/htmlDependencies.Rd
e97a1da2af5a9bf58a896fef0c4288b2 *man/htmlDependency.Rd
91c1824deb08f57376108765fd29dbaa *man/htmlEscape.Rd
e4ef52ee52d417ed12e90a188d291ffc *man/htmlPreserve.Rd
1ed6ea95e97e8e11f1bf305c9df05921 *man/htmlTemplate.Rd
6af07c0c22f52e3290cfafcde67eb29d *man/html_print.Rd
8196cb6861fed087df5bf86f48b83acd *man/htmltools-package.Rd
b20713b9e3b5208cf1df9db9561b740e *man/include.Rd
d5fe567bcd73afd46d8a6871cd8fa995 *man/knitr_methods.Rd
a10d13a4b646e7d0caaaa95a7954f344 *man/makeDependencyRelative.Rd
2d10f3203fc76c606392cc280124bf8c *man/parseCssColors.Rd
1614e94f6ef7ec32b51645faff9c2333 *man/plotTag.Rd
16159aa45a251fb364e5fd1fd144d1d7 *man/print.html.Rd
7a2cffca91021e5c404498652430fcf0 *man/renderDependencies.Rd
f701da695ed57753e86a13a2e7b60d9c *man/renderDocument.Rd
3dde546fb9ab551279ba11af4b504a2f *man/renderTags.Rd
b671fc7559090c18c3c077ae44695ad4 *man/resolveDependencies.Rd
dd23ebdf78b207176c4bdf18673866a9 *man/save_html.Rd
a8b4b505f02377daaccef0066f8e7051 *man/singleton.Rd
67133c0b221c410ce6fa114454b6b850 *man/singleton_tools.Rd
03558ea3689843ad60e5af74ce9713b8 *man/subtractDependencies.Rd
1e4baacda4939aa34b4e0cff3e570375 *man/suppressDependencies.Rd
4ce6f9bcee698e62ba04bd4d695b8903 *man/tagAddRenderHook.Rd
b588bd0eb452a44e4d228fde1fe67990 *man/tagAppendAttributes.Rd
b450d680e9744c44714f98b700245df0 *man/tagAppendChild.Rd
a492dd899372845a6159d2cd215bdcfe *man/tagFunction.Rd
4c1b47a1b4ea9c41edd40197aee66af1 *man/tagList.Rd
5eea18a9ada5591aacac72fdf737e084 *man/tagQuery.Rd
537d844bb9ca6ee662850bc84becfb5f *man/urlEncodePath.Rd
91696588d899d600bea3b1f78a991915 *man/validateCssUnit.Rd
ffda5c8f5a5c36c04d313bea6e6de0da *man/withTags.Rd
5b6c540dad8faa887f50925c167ce6e3 *src/init.c
c5b39bfd45eb9e331566c62d6c8637fb *src/template.c
d5386f261693f9f4a5dda7b6fe0aa9f0 *tests/test-all.R
81f65654f00a9808c699aa51b5c753d2 *tests/testthat/_snaps/tag-query.md
bc4287ae148918c070619d1a786f66af *tests/testthat/_snaps/tags.md
037397d065ae81eade043f3da91b9abb *tests/testthat/colors-bad.txt
8986597ca4b30709e3cc989c02439d95 *tests/testthat/colors-good-expected.txt
7d0d443e1159f7efc66cadaf467f69e7 *tests/testthat/colors-good.txt
fe57ef256876fb7bf2d9e0d293af40ee *tests/testthat/helper-locale.R
11075ccb13fe28458cf1d33923d058be *tests/testthat/helper-tags.R
4de059d582d96a7c86907beb670b819d *tests/testthat/template-basic.html
ce9c101bbebef449d432567b9a29e9f9 *tests/testthat/template-document.html
c6cc88d0969658803fe2b87090f46c9e *tests/testthat/test-colors.R
21f9cb771663db3b946d75ef7fd43c86 *tests/testthat/test-deps.r
b0eaee0845742888bccb11f95cdf7275 *tests/testthat/test-fill.R
76e589e51de5fbb218c876eb67dcc6ef *tests/testthat/test-images.R
01002f5157da1cdc6708d84a1c14e3f7 *tests/testthat/test-print.R
00e215b63d00f05bc12717510fd3cfc2 *tests/testthat/test-selector.R
c01cb9d5593ed09ecc56ec6a98ef7b9f *tests/testthat/test-tag-query.R
027ebcc332f905231a429b3154781f95 *tests/testthat/test-tags.r
236dc86c477edb3a95f882ced8d34447 *tests/testthat/test-template.R
e60a118b02ff97b60c7f250b325052dc *tests/testthat/test-textwriter.r
1d7b7c72f3937e644bca05b5272f1b39 *tests/testthat/test-whitespace.r
htmltools/R/ 0000755 0001762 0000144 00000000000 15113345760 012505 5 ustar ligges users htmltools/R/tags.R 0000644 0001762 0000144 00000170445 15113345760 013601 0 ustar ligges users # Like base::paste, but converts all string args to UTF-8 first.
paste8 <- function(..., sep = " ", collapse = NULL) {
args <- c(
lapply(list(...), enc2utf8),
list(
sep = if (is.null(sep)) sep else enc2utf8(sep),
collapse = if (is.null(collapse)) collapse else enc2utf8(collapse)
)
)
do.call(paste, args)
}
# A special case of paste8 that employs paste0. Avoids the overhead of lapply.
concat8 <- function(...) {
enc2utf8(paste0(...))
}
# Reusable function for registering a set of methods with S3 manually. The
# methods argument is a list of character vectors, each of which has the form
# c(package, genname, class).
registerMethods <- function(methods) {
lapply(methods, function(method) {
pkg <- method[[1]]
generic <- method[[2]]
class <- method[[3]]
func <- get(paste(generic, class, sep="."))
if (pkg %in% loadedNamespaces()) {
registerS3method(generic, class, func, envir = asNamespace(pkg))
}
setHook(
packageEvent(pkg, "onLoad"),
function(...) {
registerS3method(generic, class, func, envir = asNamespace(pkg))
}
)
})
}
.onLoad <- function(...) {
# htmltools provides methods for knitr::knit_print, but knitr isn't a Depends or
# Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to
# declare it as an export, not an S3method. That means that R will only know to
# use our methods if htmltools is actually attached, i.e., you have to use
# library(htmltools) in a knitr document or else you'll get escaped HTML in your
# document. This code snippet manually registers our methods with S3 once both
# htmltools and knitr are loaded.
registerMethods(list(
# c(package, genname, class)
c("knitr", "knit_print", "html"),
c("knitr", "knit_print", "shiny.tag"),
c("knitr", "knit_print", "shiny.tag.list"),
c("knitr", "knit_print", "html_dependency")
))
}
depListToNamedDepList <- function(dependencies) {
if (inherits(dependencies, "html_dependency"))
dependencies <- list(dependencies)
if (is.null(names(dependencies))) {
names(dependencies) <- sapply(dependencies, `[[`, "name")
}
return(dependencies)
}
#' Resolve a list of dependencies
#'
#' Given a list of dependencies, removes any redundant dependencies (based on
#' name equality). If multiple versions of a dependency are found, the copy with
#' the latest version number is used.
#'
#' @param dependencies A list of [htmlDependency()] objects.
#' @param resolvePackageDir Whether to resolve the relative path to an absolute
#' path via [system.file()] when the `package` attribute is
#' present in a dependency object.
#' @return dependencies A list of [htmlDependency()] objects with
#' redundancies removed.
#'
#' @export
resolveDependencies <- function(dependencies, resolvePackageDir = TRUE) {
deps <- resolveFunctionalDependencies(dependencies)
# Get names and numeric versions in vector/list form
depnames <- vapply(deps, function(x) x$name, character(1))
depvers <- numeric_version(vapply(deps, function(x) x$version, character(1)))
# Get latest version of each dependency. `unique` uses the first occurrence of
# each dependency name, which is important for inter-dependent libraries.
return(lapply(unique(depnames), function(depname) {
# Sort by depname equality, then by version. Since na.last=NA, all elements
# whose names do not match will not be included in the sorted vector.
sorted <- order(ifelse(depnames == depname, TRUE, NA), depvers,
na.last = NA, decreasing = TRUE)
# The first element in the list is the one with the largest version.
dep <- deps[[sorted[[1]]]]
if (resolvePackageDir && !is.null(dep$package)) {
dir <- dep$src$file
if (!is.null(dir)) dep$src$file <- system_file(dir, package = dep$package)
dep$package <- NULL
}
dep
}))
}
# Remove `remove` from `dependencies` if the name matches.
# dependencies is a named list of dependencies.
# remove is a named list of dependencies that take priority.
# If warnOnConflict, then warn when a dependency is being removed because of an
# older version already being loaded.
#' Subtract dependencies
#'
#' Remove a set of dependencies from another list of dependencies. The set of
#' dependencies to remove can be expressed as either a character vector or a
#' list; if the latter, a warning can be emitted if the version of the
#' dependency being removed is later than the version of the dependency object
#' that is causing the removal.
#'
#' @param dependencies A list of [htmlDependency()] objects from which
#' dependencies should be removed.
#' @param remove A list of [htmlDependency()] objects indicating which
#' dependencies should be removed, or a character vector indicating dependency
#' names.
#' @param warnOnConflict If `TRUE`, a warning is emitted for each
#' dependency that is removed if the corresponding dependency in `remove`
#' has a lower version number. Has no effect if `remove` is provided as a
#' character vector.
#'
#' @return A list of [htmlDependency()] objects that don't intersect
#' with `remove`.
#'
#' @export
subtractDependencies <- function(dependencies, remove, warnOnConflict = TRUE) {
dependencies <- resolveFunctionalDependencies(dependencies)
depnames <- vapply(dependencies, function(x) x$name, character(1))
if (is.character(remove)) {
rmnames <- remove
} else {
remove <- resolveFunctionalDependencies(remove)
rmnames <- vapply(remove, function(x) x$name, character(1))
}
matches <- depnames %in% rmnames
if (warnOnConflict && !is.character(remove)) {
for (loser in dependencies[matches]) {
winner <- remove[[head(rmnames == loser$name, 1)]]
if (compareVersion(loser$version, winner$version) > 0) {
warning(sprintf(paste("The dependency %s %s conflicts with",
"version %s"), loser$name, loser$version, winner$version
))
}
}
}
# Return only deps that weren't in remove
return(dependencies[!matches])
}
# Given a vector or list, drop all the NULL items in it
dropNulls <- function(x) {
x[!vapply(x, is.null, FUN.VALUE=logical(1))]
}
nullOrEmpty <- function(x) {
length(x) == 0
}
# Given a vector or list, drop all the NULL or length-0 items in it
dropNullsOrEmpty <- function(x) {
x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))]
}
isResolvedTag <- function(x) {
inherits(x, "shiny.tag") && length(x$.renderHooks) == 0
}
isTag <- function(x) {
inherits(x, "shiny.tag")
}
#' @rdname print.html
#' @export
print.shiny.tag <- function(x, browse = is.browsable(x), ...) {
if (browse)
html_print(x)
else
print(HTML(as.character(x)), ...)
invisible(x)
}
# indent can be numeric to indicate an initial indent level,
# or FALSE to suppress
#' @export
format.shiny.tag <- function(x, ..., singletons = character(0), indent = 0) {
as.character(renderTags(x, singletons = singletons, indent = indent)$html)
}
#' @export
as.character.shiny.tag <- function(x, ...) {
as.character(renderTags(x)$html)
}
#' @export
as.character.html <- function(x, ...) {
as.vector(enc2utf8(x))
}
#' @export
print.shiny.tag.list <- function(x, ...) {
if (isTRUE(attr(x, "print.as.list", exact = TRUE))) {
attr(x, "print.as.list") <- NULL
class(x) <- setdiff(class(x), "shiny.tag.list")
return(print(x))
}
print.shiny.tag(x, ...)
}
#' @export
format.shiny.tag.list <- format.shiny.tag
#' @export
as.character.shiny.tag.list <- as.character.shiny.tag
#' Print method for HTML/tags
#'
#' S3 method for printing HTML that prints markup or renders HTML in a web
#' browser.
#'
#' @param x The value to print.
#' @param browse If `TRUE`, the HTML will be rendered and displayed in a
#' browser (or possibly another HTML viewer supplied by the environment via
#' the `viewer` option). If `FALSE` then the HTML object's markup
#' will be rendered at the console.
#' @param ... Additional arguments passed to print.
#'
#' @export
print.html <- function(x, ..., browse = is.browsable(x)) {
if (browse)
html_print(x)
else
cat(x, "\n", sep = "")
invisible(x)
}
#' @export
format.html <- function(x, ...) {
as.character(x)
}
normalizeText <- function(text) {
if (!is.null(attr(text, "html", TRUE)))
text
else
htmlEscape(text, attribute=FALSE)
}
#' Create a list of tags
#'
#' Create a `list()` of [tag]s with methods for [print()], [as.character()],
#' etc.
#'
#' @param ... A collection of [tag]s.
#' @export
#' @examples
#' tagList(
#' h1("Title"),
#' h2("Header text", style = "color: red;"),
#' p("Text here")
#' )
tagList <- function(...) {
lst <- dots_list(...)
class(lst) <- c("shiny.tag.list", "list")
return(lst)
}
#' Tag function
#'
#' Create 'lazily' rendered HTML [tags] (and/or [htmlDependencies()]).
#'
#' When possible, use [`tagAddRenderHook()`] to provide both a tag
#' structure and utilize a render function.
#'
#' @param func a function with no arguments that returns HTML tags and/or
#' dependencies.
#' @seealso [`tagAddRenderHook()`]
#' @export
#' @examples
#' myDivDep <- tagFunction(function() {
#' if (isTRUE(getOption("useDep", TRUE))) {
#' htmlDependency(
#' name = "lazy-dependency",
#' version = "1.0", src = ""
#' )
#' }
#' })
#' myDiv <- attachDependencies(div(), myDivDep)
#' renderTags(myDiv)
#' withr::with_options(list(useDep = FALSE), renderTags(myDiv))
#'
tagFunction <- function(func) {
if (!is.function(func) || length(formals(func)) != 0) {
stop("`func` must be a function with no arguments")
}
structure(func, class = "shiny.tag.function")
}
#' Modify a tag prior to rendering
#'
#' Adds a hook to call on a [tag()] object when it is is rendered as HTML (with,
#' for example, [print()], [renderTags()], [as.tags()], etc).
#'
#' The primary motivation for [tagAddRenderHook()] is to create tags that can
#' change their attributes (e.g., change CSS classes) depending upon the context
#' in which they're rendered (e.g., use one set of CSS classes in one a page
#' layout, but a different set in another page layout). In this situation,
#' [tagAddRenderHook()] is preferable to [tagFunction()] since the latter is more a
#' "black box" in the sense that you don't know anything about the tag structure
#' until it's rendered.
#'
#' @param tag A [`tag()`] object.
#' @param func A function (_hook_) to call when the `tag` is rendered. This function
#' should have at least one argument (the `tag`) and return anything that can
#' be converted into tags via [as.tags()].
#' @param replace If `TRUE`, the previous hooks will be removed. If `FALSE`,
#' `func` is appended to the previous hooks.
#' @return A [tag()] object with a `.renderHooks` field containing a list of functions
#' (e.g. `func`). When the return value is _rendered_ (such as with [`as.tags()`]),
#' these functions will be called just prior to writing the HTML.
#' @export
#' @seealso [tagFunction()]
#' @examples
#' # Have a place holder div and return a span instead
#' obj <- div("example", .renderHook = function(x) {
#' x$name <- "span"
#' x
#' })
#' obj$name # "div"
#' print(obj) # Prints as a `span`
#'
#' # Add a class to the tag
#' # Should print a `span` with class `"extra"`
#' spanExtra <- tagAddRenderHook(obj, function(x) {
#' tagAppendAttributes(x, class = "extra")
#' })
#' spanExtra
#'
#' # Replace the previous render method
#' # Should print a `div` with class `"extra"`
#' divExtra <- tagAddRenderHook(obj, replace = TRUE, function(x) {
#' tagAppendAttributes(x, class = "extra")
#' })
#' divExtra
#'
#' # Add more child tags
#' spanExtended <- tagAddRenderHook(obj, function(x) {
#' tagAppendChildren(x, " ", tags$strong("bold text"))
#' })
#' spanExtended
#'
#' # 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")
#' # At render time, both dependencies will be found
#' renderTags(newDep)$dependencies
#'
#' # Ignore the original tag and return something completely new.
#' newObj <- tagAddRenderHook(obj, function(x) {
#' tags$p("Something else")
#' })
#' newObj
tagAddRenderHook <- function(tag, func, replace = FALSE) {
if (!is.function(func) || length(formals(func)) == 0) {
stop("`func` must be a function that accepts at least 1 argument")
}
tag$.renderHooks <-
if (isTRUE(replace)) {
list(func)
} else {
append(tag$.renderHooks, list(func))
}
tag
}
#' Append tag attributes
#'
#' Append (`tagAppendAttributes()`), check existence (`tagHasAttribute()`),
#' and obtain the value (`tagGetAttribute()`) of HTML attribute(s).
#'
#' @export
#' @param tag a [tag] object.
#' @param ... Attributes to append as named argument-value pairs. A named
#' argument with an `NA` value is rendered as a boolean attribute (see
#' example).
#' @param .cssSelector A character string containing a [CSS
#' selector](https://developer.mozilla.org/en-US/docs/Learn/CSS/Building_blocks/Selectors)
#' for targeting particular (inner) tags of interest. At the moment, only a
#' combination of
#' [type](https://www.w3.org/TR/CSS22/selector.html#type-selectors) (e.g,
#' `div`), [class](https://www.w3.org/TR/CSS22/selector.html#class-html)
#' (e.g., `.my-class`),
#' [id](https://www.w3.org/TR/CSS22/selector.html#id-selectors) (e.g.,
#' `#myID`), and
#' [universal](https://www.w3.org/TR/CSS22/selector.html#universal-selector)
#' (`*`) selectors within a given [simple
#' selector](https://www.w3.org/TR/CSS22/selector.html#selector-syntax) is
#' supported. Note, if `.cssSelector` is used, the returned tags will have
#' their `$children` fields flattened to a single `list()` via [`tagQuery()`].
#' @seealso [tagAppendChildren()], [tagQuery()]
#' @examples
#' html <- div(a())
#' tagAppendAttributes(html, class = "foo")
#' tagAppendAttributes(html, .cssSelector = "a", class = "bar")
#' tagAppendAttributes(html, contenteditable = NA)
#'
#' tagHasAttribute(div(foo = "bar"), "foo")
#' tagGetAttribute(div(foo = "bar"), "foo")
#'
tagAppendAttributes <- function(tag, ..., .cssSelector = NULL) {
throw_if_tag_function(tag)
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
addAttrs(...)$
allTags()
)
}
newAttribs <- dropNullsOrEmpty(dots_list(...))
if (any(!nzchar(names2(newAttribs)))) {
stop(
"At least one of the new attribute values did not have a name.\n",
"Did you forget to include an attribute name?"
)
}
tag$attribs <- c(tag$attribs, newAttribs)
tag
}
#' @rdname tagAppendAttributes
#' @param attr The name of an attribute.
#' @export
tagHasAttribute <- function(tag, attr) {
throw_if_tag_function(tag)
result <- attr %in% names(tag$attribs)
result
}
#' @rdname tagAppendAttributes
#' @export
tagGetAttribute <- function(tag, attr) {
throw_if_tag_function(tag)
# Find out which positions in the attributes list correspond to the given attr
attribs <- tag$attribs
attrIdx <- which(attr == names(attribs))
if (length(attrIdx) == 0) {
return (NULL)
}
result <- attribs[attrIdx]
# Remove NA values or return a single NA value
if (anyNA(result)) {
na_idx <- is.na(result)
if (all(na_idx)) {
return(NA)
}
result <- result[!na_idx]
}
if (all(vapply(result, is.atomic, logical(1)))) {
# Convert all attribs to chars explicitly; prevents us from messing up factors
# Separate multiple attributes with the same name
vals <- vapply(result, function(val) {
val <- as.character(val)
# Combine vector values if they exist
if (length(val) > 1) {
val <- paste0(val, collapse = " ")
}
val
}, character(1))
result <- paste0(vals, collapse = " ")
} else {
# When retrieving values that are not atomic, return a list of values
names(result) <- NULL
}
result
}
#' Modify tag contents
#'
#' Modify the contents (aka children) of a [tag] object.
#'
#' @inheritParams tagAppendAttributes
#' @param child A child element to append to a parent tag.
#' @export
#' @seealso [tagAppendAttributes()], [tagQuery()]
#' @examples
#' html <- div(a(), h1())
#' tagAppendChild(html, span())
#' tagAppendChild(html, .cssSelector = "a", span())
#'
#' tagAppendChildren(html, span(), p())
#' tagAppendChildren(html, .cssSelector = "a", span(), p())
#'
#' tagSetChildren(html, span(), p())
#'
#' tagInsertChildren(html, after = 1, span(), p())
#'
tagAppendChild <- function(tag, child, .cssSelector = NULL) {
throw_if_tag_function(tag)
if (!is.null(.cssSelector)) {
return(
tagAppendChildren(tag, child, .cssSelector = .cssSelector)
)
}
tag$children[[length(tag$children)+1]] <- child
tag
}
#' @rdname tagAppendChild
#' @param ... a collection of `child` elements.
#' @param list Deprecated. Use `!!!` instead to splice into `...`.
#' @export
tagAppendChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
append(!!!children)$
allTags()
)
}
tag$children <- unname(c(tag$children, children))
tag
}
#' @rdname tagAppendChild
#' @export
tagSetChildren <- function(tag, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
empty()$
append(!!!children)$
allTags()
)
}
tag$children <- children
tag
}
#' @rdname tagAppendChild
#' @param after an integer value (i.e., subscript) referring to the child position to append after.
#' @export
tagInsertChildren <- function(tag, after, ..., .cssSelector = NULL, list = NULL) {
throw_if_tag_function(tag)
children <- unname(c(dots_list(...), list))
if (!is.null(.cssSelector)) {
return(
tagQuery(tag)$
find(.cssSelector)$
each(function(x, i) {
tagInsertChildren(x, after = after, !!!children)
})$
allTags()
)
}
tag$children <- unname(append(tag$children, children, after))
tag
}
throw_if_tag_function <- function(tag) {
if (is_tag_function(tag))
stop("`tag` can not be a `tagFunction()`")
}
# Use `known_tags` from `known_tags.R`
# Then remove `known_tags` once done creating tag functions
#' @include known_tags.R
names(known_tags) <- known_tags
#' Create HTML tags
#'
#' Create an R object that represents an HTML tag. For convenience, common HTML
#' tags (e.g., `
`) can be created by calling for their tag name directly
#' (e.g., `div()`). To create less common HTML5 (or SVG) tags (e.g.,
#' ``), use the `tags` list collection (e.g., `tags$article()`). To
#' create other non HTML/SVG tags, use the lower-level `tag()` constructor.
#'
#' @name builder
#' @param ... Tag attributes (named arguments) and children (unnamed arguments).
#' A named argument with an `NA` value is rendered as a boolean attributes
#' (see example). Children may include any combination of:
#' * Other tags objects
#' * [HTML()] strings
#' * [htmlDependency()]s
#' * Single-element atomic vectors
#' * `list()`s containing any combination of the above
#' @return A `list()` with a `shiny.tag` class that can be converted into an
#' HTML string via `as.character()` and saved to a file with `save_html()`.
#' @seealso [tagList()], [withTags()], [tagAppendAttributes()], [tagQuery()]
#' @examples
#' tags$html(
#' tags$head(
#' tags$title('My first page')
#' ),
#' tags$body(
#' h1('My first heading'),
#' p('My first paragraph, with some ', strong('bold'), ' text.'),
#' div(
#' id = 'myDiv', class = 'simpleDiv',
#' 'Here is a div with some attributes.'
#' )
#' )
#' )
#'
#' # html5