', html))
# With text_ argument
template <- htmlTemplate(text_ = "a {{ foo + 1 }} b", foo = 10)
expect_identical(as.character(as.character(template)), "a \n11\n 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\n\n11\n b")
})
test_template <- function(){
template <- htmlTemplate("template-document.html", x = "")
html <- renderDocument(template)
# 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("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("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("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("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("template-document.html",
x = attachDependencies(div(), dep)
)
html <- renderDocument(template)
expect_true(findDep(html, "jquery", "9999"))
expect_false(grepl('
")
)
})
test_that("Indenting can be controlled/suppressed", {
expect_identical(
renderTags(tags$div("a", "b"))$html,
HTML("
\nbar")
# tags with children ------------------------------------------------
x <- div(a1.1, div("foo"), "bar")
expect_identical(findDependencies(x), list(a1.1))
expect_identical(as.character(renderTags(x)$html),
"
"
))
)
})
})
htmltools/tests/testthat/helper-locale.R 0000644 0001762 0000144 00000000321 13545702222 020136 0 ustar ligges users is_locale_available <- function(loc){
set_locale_failed <- FALSE
tryCatch(
withr::with_locale(c(LC_COLLATE=loc), {}),
warning = function(e){ set_locale_failed <<- TRUE }
)
!set_locale_failed
}
htmltools/tests/testthat/template-basic.html 0000644 0001762 0000144 00000000114 13100230764 021051 0 ustar ligges users
{{ headContent() }}
{{ body }}
htmltools/tests/testthat/test-textwriter.r 0000644 0001762 0000144 00000005207 13545702222 020670 0 ustar ligges users context("textwriter")
describe("WSTextWriter", {
it("basically works", {
wsw <- WSTextWriter()
expect_identical(wsw$readAll(), "")
wsw$write("")
expect_identical(wsw$readAll(), "")
wsw$write("line one")
expect_identical(wsw$readAll(), "line one")
wsw$write("\nanother line")
expect_identical(wsw$readAll(), "line one\nanother line")
wsw$write("more content")
expect_identical(wsw$readAll(), "line one\nanother linemore content")
# Non-character writes
expect_error(wsw$write(1))
expect_error(wsw$write(letters[1:2]))
expect_error(WSTextWriter(bufferSize=2))
})
it("eats past and future whitespace", {
wtw <- WSTextWriter()
expect_identical(wtw$readAll(), "")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), " ")
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$eatWS()
expect_identical(wtw$readAll(), "")
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), "")
wtw$write("Hello")
expect_identical(wtw$readAll(), "Hello")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), "Hello ")
wtw$eatWS()
expect_identical(wtw$readAll(), "Hello")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), "Hello")
})
it("handles full buffers of non-WS writes", {
wtw <- WSTextWriter(bufferSize = 3)
wtw$write("a")
wtw$write("b")
wtw$write("c")
wtw$write("d")
wtw$write("e")
wtw$write("f")
expect_identical(wtw$readAll(), "abcdef")
wtw$eatWS()
expect_identical(wtw$readAll(), "abcdef")
wtw$write("g")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), "abcdefg ")
wtw$eatWS()
expect_identical(wtw$readAll(), "abcdefg")
})
it("handles full buffers of whitespace writeWS's", {
wtw <- WSTextWriter(bufferSize = 3)
# fill the buffer with whitespace that it will need to accumulate
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), " ")
wtw$eatWS()
expect_identical(wtw$readAll(), "")
wtw$write("b")
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$writeWS(" ")
wtw$writeWS(" ")
expect_identical(wtw$readAll(), "b ")
wtw$eatWS()
expect_identical(wtw$readAll(), "b")
})
})
describe("validateNoWS",{
it("basically works", {
validateNoWS(NULL)
validateNoWS(noWSOptions[1])
validateNoWS(noWSOptions[1:2])
validateNoWS(noWSOptions)
expect_error(validateNoWS("badOption"))
expect_error(validateNoWS(c(noWSOptions, "badOption")))
# capitalization matters
expect_error(validateNoWS(toupper(noWSOptions[1])))
})
})
htmltools/src/ 0000755 0001762 0000144 00000000000 13545702324 013073 5 ustar ligges users htmltools/src/init.c 0000644 0001762 0000144 00000000672 13306600132 014174 0 ustar ligges users #include
#include
#include // for NULL
#include
/* .Call calls */
extern SEXP _htmltools_template_dfa(SEXP);
static const R_CallMethodDef CallEntries[] = {
{"_htmltools_template_dfa", (DL_FUNC) &_htmltools_template_dfa, 1},
{NULL, NULL, 0}
};
void R_init_htmltools(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
R_useDynamicSymbols(dll, FALSE);
}
htmltools/src/template.cpp 0000644 0001762 0000144 00000006731 13100230764 015410 0 ustar ligges users #include
using namespace Rcpp;
// Break template text into character vector. The first element element of the
// resulting vector is HTML, the next is R code, and they continue alternating.
// [[Rcpp::export]]
std::vector template_dfa(CharacterVector x) {
enum State {
html,
code,
html_oneOpenBracket,
code_oneCloseBracket,
code_string1,
code_string1_backslash,
code_string2,
code_string2_backslash,
code_backtick,
code_backtick_backslash,
code_percentOp,
code_comment,
code_comment_oneCloseBracket
};
if (x.length() != 1) {
stop("Input HTML must be a character vector of length 1");
}
std::string input = Rcpp::as(x[0]);
std::vector pieces(0);
int pieceStartIdx = 0;
int len = input.length();
char c;
State state = html;
for (int i=0; i < len; i++) {
c = input[i];
switch (state) {
case html:
switch (c) {
case '{':
state = html_oneOpenBracket; break;
}
break;
case html_oneOpenBracket:
switch (c) {
case '{':
state = code;
pieces.push_back(input.substr(pieceStartIdx, i - pieceStartIdx - 1));
pieceStartIdx = i + 1;
break;
default:
state = html;
}
break;
case code:
switch (c) {
case '}':
state = code_oneCloseBracket; break;
case '\'':
state = code_string1; break;
case '"':
state = code_string2; break;
case '`':
state = code_backtick; break;
case '%':
state = code_percentOp; break;
case '#':
state = code_comment; break;
}
break;
case code_oneCloseBracket:
switch (c) {
case '}':
state = html;
pieces.push_back(input.substr(pieceStartIdx, i - pieceStartIdx - 1));
pieceStartIdx = i + 1;
break;
default: state = code;
}
break;
case code_string1:
switch (c) {
case '\\':
state = code_string1_backslash; break;
case '\'':
state = code; break;
}
break;
case code_string1_backslash:
state = code_string1;
break;
case code_string2:
switch (c) {
case '\\':
state = code_string2_backslash; break;
case '\"':
state = code; break;
}
break;
case code_string2_backslash:
state = code_string2;
break;
case code_backtick:
switch (c) {
case '\\':
state = code_backtick_backslash; break;
case '`':
state = code; break;
}
break;
case code_backtick_backslash:
state = code_backtick;
break;
case code_percentOp:
switch (c) {
case '%':
state = code; break;
}
break;
case code_comment:
switch (c) {
case '}':
state = code_comment_oneCloseBracket; break;
case '\n':
state = code; break;
}
break;
case code_comment_oneCloseBracket:
switch (c) {
case '}':
state = html;
pieces.push_back(input.substr(pieceStartIdx, i - pieceStartIdx - 1));
pieceStartIdx = i + 1;
break;
default:
state = code;
}
break;
}
}
if (!(state == html || state == html_oneOpenBracket)) {
stop("HTML template did not end in html state (missing closing \"}}\").");
}
// Add ending HTML piece
pieces.push_back(input.substr(pieceStartIdx, len - pieceStartIdx));
return pieces;
}
htmltools/src/RcppExports.cpp 0000644 0001762 0000144 00000001036 13306600132 016055 0 ustar ligges users // Generated by using Rcpp::compileAttributes() -> do not edit by hand
// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
#include
using namespace Rcpp;
// template_dfa
std::vector template_dfa(CharacterVector x);
RcppExport SEXP _htmltools_template_dfa(SEXP xSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< CharacterVector >::type x(xSEXP);
rcpp_result_gen = Rcpp::wrap(template_dfa(x));
return rcpp_result_gen;
END_RCPP
}
htmltools/NEWS 0000644 0001762 0000144 00000011014 13545702222 012775 0 ustar ligges users htmltools 0.4.0
--------------------------------------------------------------------------------
* Fixed #128: Added support for trailing commas in tagLists and the predefined
tags. (#135)
* Added some HTML tag functions to `tags` that were missing. (#111)
* Updated RcppExports for new version of Rcpp. (#93)
* `as.character.shiny.tags()` will handle non-ASCII attributes correctly if they
are not encoded in native encoding.
* Fixed #99: `NA` attributes were sometimes rendered as `"NA"` in the HTML,
instead of being blank. (#100)
* The error message for trailing commas in tag functions now provides context
and useful information. (#109)
* Stopped using inline styles to set background color for `save_html`, as doing so
makes it difficult to override using other CSS rules. (#123)
* Added a `.noWS` argument to `tag()` and `tags` which can be used to suppress
the automatically generated whitespace around a particular tag. (#131)
* Added a shim for `system.file()` so that htmltools works with `htmlDependency`
objects created by a package that was loaded with `devtools::load_all()`.
(#129)
* `validateCssUnit()` now accepts `ch`, `rem`, and `calc()`. (#134)
* Fixed #125: `print.html` removes html dependencies. (#126)
* Stopped extra carriage returns from being inserted by `save_html` on Windows.
(#137)
htmltools 0.3.6
--------------------------------------------------------------------------------
* `validateCssUnit()` now accepts viewport units (vw, vh, vmin, vmax). (#56)
* `restorePreserveChunks()` marks the output with the correct encoding now
(UTF-8).
* Length-0 attributes are now dropped, like NULLs. (#65)
* Fixed #69: On Windows, `renderDocument()` did not mark output as UTF-8 if the
head was UTF-8 but body was ASCII. (#71)
htmltools 0.3.5
--------------------------------------------------------------------------------
* `as.character` now returns a character vector with no other attributes.
Previously it returned a character vector of class 'html'. (#31, #41)
* `htmlTemplate` now can use a string as a template instead of requiring a
file. (#41, #43)
* HTML dependencies can now be added inline, instead of needing to use
`attachDependencies()`. (#40, #42)
* `htmlDependency()` gained a new argument `all_files` to indicate whether all
files under the src directory should be copied when rendering dependencies,
or only those specified in the dependency objects. (#48)
* `copyDependencyToDir()` will always completely overwrite the target directory
when copying HTML dependency files to make sure all dependency files are
definitely updated in the target directory when the original dependency
directory has been updated. In the past, the dependency files were not updated
if they already existed. (#36)
* The version number in the directory name of an HTML dependency can be
suppressed by setting options(htmltools.dir.version = FALSE) when the
dependency is copied via `copyDependencyToDir()`. (#37)
* Performance improvement rendering tags, by switching from `readLines` to
`readChar`.
htmltools 0.3
--------------------------------------------------------------------------------
* Add `css` function for conveniently forming CSS declaration strings.
* Add template support, with the `htmlTemplate()`, `renderDocument()`, and
`suppressDependencies()` functions.
htmltools 0.2.9
--------------------------------------------------------------------------------
* Add check that `htmlDependency()` isn't called with an absolute path when a
binary package is built. (#22)
* Allow HTML content to include UTF-8, Latin1, and system encoded content. All
will be converted to UTF-8 using enc2utf8() at render time. (#21)
* Add `tagGetAttribute()` and `tagHasAttribute()` functions.
htmltools 0.2.7
--------------------------------------------------------------------------------
* Add "append" parameter to attachDependencies, to allow adding dependencies,
instead of replacing them.
htmltools 0.2.6
--------------------------------------------------------------------------------
* Add "attachment" parameter to htmlDependency, which can be used to allow any
file in the dependency directory to be available via URL at runtime.
htmltools 0.2.5
--------------------------------------------------------------------------------
* Explicit library(htmltools) is no longer required for tags to be rendered in
knitr/rmarkdown documents.
* Added "viewer" parameter to html_print.
htmltools 0.2.4
--------------------------------------------------------------------------------
Initial release
htmltools/R/ 0000755 0001762 0000144 00000000000 13545702222 012502 5 ustar ligges users htmltools/R/html_print.R 0000644 0001762 0000144 00000006721 13545702222 015013 0 ustar ligges users #' Make an HTML object browsable
#'
#' By default, HTML objects display their HTML markup at the console when
#' printed. \code{browsable} can be used to make specific objects render as HTML
#' by default when printed at the console.
#'
#' You can override the default browsability of an HTML object by explicitly
#' passing \code{browse = TRUE} (or \code{FALSE}) to the \code{print} function.
#'
#' @param x The object to make browsable or not.
#' @param value Whether the object should be considered browsable.
#' @return \code{browsable} returns \code{x} with an extra attribute to indicate
#' that the value is browsable.
#' @export
browsable <- function(x, value = TRUE) {
attr(x, "browsable_html") <- if (isTRUE(value)) TRUE else NULL
return(x)
}
#' @return \code{is.browsable} returns \code{TRUE} if the value is browsable, or
#' \code{FALSE} if not.
#' @rdname browsable
#' @export
is.browsable <- function(x) {
return(isTRUE(attr(x, "browsable_html", exact=TRUE)))
}
#' Implementation of the print method for HTML
#'
#' Convenience method that provides an implementation of the
#' \code{\link[base:print]{print}} method for HTML content.
#'
#' @param html HTML content to print
#' @param background Background color for web page
#' @param viewer A function to be called with the URL or path to the generated
#' HTML page. Can be \code{NULL}, in which case no viewer will be invoked.
#'
#' @return Invisibly returns the URL or path of the generated HTML page.
#'
#' @export
html_print <- function(html, background = "white", viewer = getOption("viewer", utils::browseURL)) {
# define temporary directory for output
www_dir <- tempfile("viewhtml")
dir.create(www_dir)
# define output file
index_html <- file.path(www_dir, "index.html")
# save file
save_html(html, file = index_html, background = background, libdir = "lib")
# show it
if (!is.null(viewer))
viewer(index_html)
invisible(index_html)
}
#' Save an HTML object to a file
#'
#' Save the specified HTML object to a file, copying all of it's
#' dependencies to the directory specified via \code{libdir}.
#'
#' @param html HTML content to print
#' @param background Background color for web page
#' @param file File to write content to
#' @param libdir Directory to copy dependenies to
#'
#' @export
save_html <- function(html, file, background = "white", libdir = "lib") {
force(html)
force(background)
force(libdir)
# ensure that the paths to dependencies are relative to the base
# directory where the webpage is being built.
dir <- dirname(file)
oldwd <- setwd(dir)
on.exit(setwd(oldwd), add = TRUE)
rendered <- renderTags(html)
deps <- lapply(rendered$dependencies, function(dep) {
dep <- copyDependencyToDir(dep, libdir, FALSE)
dep <- makeDependencyRelative(dep, dir, FALSE)
dep
})
# build the web-page
html <- c("",
"",
"",
"",
sprintf("", htmlEscape(background)),
renderDependencies(deps, c("href", "file")),
rendered$head,
"",
"",
rendered$html,
"",
"")
if (is.character(file)) {
# Write to file in binary mode, so \r\n in input doesn't become \r\r\n
con <- base::file(file, open = "w+b")
on.exit(close(con), add = TRUE)
} else {
con <- file
}
# write it
writeLines(html, con, useBytes = TRUE)
}
htmltools/R/template.R 0000644 0001762 0000144 00000012353 13100232533 014432 0 ustar ligges users #' Process an HTML template
#'
#' Process an HTML template and return a tagList object. If the template is a
#' complete HTML document, then the returned object will also have class
#' \code{html_document}, and can be passed to the function
#' \code{\link{renderDocument}} to get the final HTML text.
#'
#' @param filename Path to an HTML template file. Incompatible with
#' \code{text_}.
#' @param ... Variable values to use when processing the template.
#' @param text_ A string to use as the template, instead of a file. Incompatible
#' with \code{filename}.
#' @param document_ Is this template a complete HTML document (\code{TRUE}), or
#' a fragment of HTML that is to be inserted into an HTML document
#' (\code{FALSE})? With \code{"auto"} (the default), auto-detect by searching
#' for the string \code{""} within the template.
#'
#' @seealso \code{\link{renderDocument}}
#' @export
#' @useDynLib htmltools, .registration = TRUE
#' @importFrom Rcpp sourceCpp
htmlTemplate <- function(filename = NULL, ..., text_ = NULL, document_ = "auto") {
if (!xor(is.null(filename), is.null(text_))) {
stop("htmlTemplate requires either `filename` or `text_`.")
}
if (!is.null(filename)) {
html <- readChar(filename, file.info(filename)$size, useBytes = TRUE)
Encoding(html) <- "UTF-8"
} else if(!is.null(text_)) {
text_ <- paste8(text_, collapse = "\n")
html <- enc2utf8(text_)
}
pieces <- template_dfa(html)
Encoding(pieces) <- "UTF-8"
# Create environment to evaluate code, as a child of the global env. This
# environment gets the ... arguments assigned as variables.
vars <- list(...)
if ("headContent" %in% names(vars)) {
stop("Can't use reserved argument name 'headContent'.")
}
vars$headContent <- function() HTML("")
env <- list2env(vars, parent = globalenv())
# All the odd-numbered pieces are HTML; all the even-numbered pieces are code
pieces <- mapply(
pieces,
rep_len(c(FALSE, TRUE), length.out = length(pieces)),
FUN = function(piece, isCode) {
if (isCode) {
eval(parse(text = piece), env)
} else if (piece == "") {
# Don't add leading/trailing '\n' if empty HTML string.
NULL
} else {
HTML(piece)
}
},
SIMPLIFY = FALSE
)
result <- tagList(pieces)
if (document_ == "auto") {
document_ = grepl("", html, ignore.case = TRUE)
}
if (document_) {
# The html.document class indicates that it's a complete document, and not
# just a set of tags.
class(result) <- c("html_document", class(result))
}
result
}
#' Render an html_document object
#'
#' This function renders \code{html_document} objects, and returns a string with
#' the final HTML content. It calls the \code{\link{renderTags}} function to
#' convert any shiny.tag objects to HTML. It also finds any any web dependencies
#' (created by \code{\link{htmlDependency}}) that are attached to the tags, and
#' inserts those. To do the insertion, this function finds the string
#' \code{""} in the document, and replaces it with the web
#' dependencies.
#'
#' @param x An object of class \code{html_document}, typically generated by the
#' \code{\link{htmlTemplate}} function.
#' @param deps Any extra web dependencies to add to the html document. This can
#' be an object created by \code{\link{htmlDependency}}, or a list of such
#' objects. These dependencies will be added first, before other dependencies.
#' @param processDep A function that takes a "raw" html_dependency object and
#' does further processing on it. For example, when \code{renderDocument} is
#' called from Shiny, the function \code{\link[shiny]{createWebDependency}} is
#' used; it modifies the href and tells Shiny to serve a particular path on
#' the filesystem.
#'
#' @export
renderDocument <- function(x, deps = NULL, processDep = identity) {
if (!inherits(x, "html_document")) {
stop("Object must be an object of class html_document")
}
if (inherits(deps, "html_dependency")) {
deps <- list(deps)
}
result <- renderTags(x)
# Figure out dependencies
deps <- c(deps, result$dependencies)
deps <- resolveDependencies(deps)
deps <- lapply(deps, processDep)
depStr <- paste(sapply(deps, function(dep) {
sprintf("%s[%s]", dep$name, dep$version)
}), collapse = ";")
depHtml <- renderDependencies(deps, "href")
# Put content in the section
head_content <- paste0(
' \n',
sprintf(' \n',
paste(result$singletons, collapse = ',')
),
sprintf(' \n',
depStr
),
depHtml,
c(result$head, recursive = TRUE)
)
# Need to mark result as UTF-8. If body is ASCII, it will be marked with
# encoding "unknown". If the head has UTF-8 characters and is marked as
# "UTF-8", the output string here will have the correct UTF-8 byte sequences,
# but will be marked as "unknown", which causes the wrong text to be
# displayed. See https://github.com/rstudio/shiny/issues/1395
res <- sub("", head_content, result$html, fixed = TRUE)
Encoding(res) <- "UTF-8"
res
}
htmltools/R/utils.R 0000644 0001762 0000144 00000010450 13545702222 013765 0 ustar ligges users # Implements a "whitespace eating" writer.
#
# WSTextWriter relies on the caller distinguishing between writes of important
# content, and writes of whitespace that may or may not be elided (`.$write()`
# vs `.$writeWS()`).
#
# At any point, `eatWS` may be called, which will cause any recent `writeWS`
# operations (i.e. those since either the beginning of time, or the most recent
# `write` operation) to be undone, AND for any future `writeWS` calls to be
# ignored. A call to `write` will be respected, and will restore normal
# behavior.
#
# Text is automatically converted to UTF-8 before being written.
#' @param bufferSize The initial size of the buffer in which writes are stored.
#' The buffer will be periodically cleared, if possible, to cache the writes
#' as a string. If the buffer cannot be cleared (because of the need to be
#' able to backtrack to fulfill an `eatWS()` call), then the buffer size will
#' be doubled.
#' @noRd
WSTextWriter <- function(bufferSize=1024) {
if (bufferSize < 3) {
stop("Buffer size must be at least 3")
}
# The buffer into which we enter all the writes.
buffer <- character(bufferSize)
# The index storing the position in the buffer of the most recent write.
marked <- 0
# The index storing the position in the buffer of the most recent write or writeWS.
position <- 0
# TRUE if we're eating whitespace right now, in which case calls to writeWS are no-ops.
suppressing <- FALSE
# Collapses the text in the buffer to create space for more writes. The first
# element in the buffer will be the concatenation of any writes up to the
# current marker. The second element in the buffer will be the concatenation
# of all writes after the marker.
collapseBuffer <- function() {
# Collapse the writes in the buffer up to the marked position into the first buffer entry
nonWS <- ""
if (marked > 0) {
nonWS <- paste(buffer[seq_len(marked)], collapse="")
}
# Collapse any remaining whitespace
ws <- ""
remaining <- position - marked
if (remaining > 0) {
# We have some whitespace to collapse. Collapse it into the second buffer entry.
ws <- paste(buffer[seq(from=marked+1,to=marked+remaining)], collapse="")
}
buffer[1] <<- nonWS
buffer[2] <<- ws
position <<- 2
marked <<- 1
}
# Logic to do the actual write
writeImpl <- function(text) {
# force `text` to evaluate and check that it's the right shape
# TODO: We could support vectors with multiple elements here and perhaps
# find some way to combine with `paste8()`. See
# https://github.com/rstudio/htmltools/pull/132#discussion_r302280588
if (length(text) != 1 || !is.character(text)) {
stop("Text to be written must be a length-one character vector")
}
# Are we at the end of our buffer?
if (position == length(buffer)) {
collapseBuffer()
}
# The text that is written to this writer will be converted to
# UTF-8 using enc2utf8. The rendered output will always be UTF-8
# encoded.
enc <- enc2utf8(text)
# Move the position pointer and store the (encoded) write
position <<- position + 1
buffer[position] <<- enc
}
# The actual object returned
list(
# Write content. Updates the marker and stops suppressing whitespace writes.
#
# @param text Single element character vector
write = function(text) {
writeImpl(text)
suppressing <<- FALSE
marked <<- position
},
# Write whitespace. If eatWS() was called and its effect has not been
# canceled, then this method no-ops.
# @param text Single element character vector containing only
# whitespace characters
writeWS = function(text) {
if (suppressing) {
return()
}
writeImpl(text)
},
# Return the contents of the TextWriter, as a single element character
# vector, from the beginning to the current writing position (normally this
# is the end of the last write or writeWS, unless eatWS() was called).
readAll = function() {
# Collapse everything in the buffer up to `position`
paste(buffer[seq_len(position)], collapse="")
},
# Removes both recent and upcoming whitespace writes
eatWS = function() {
# Reset back to the most recent marker
position <<- marked
suppressing <<- TRUE
}
)
}
htmltools/R/shim.R 0000644 0001762 0000144 00000004373 13545702222 013574 0 ustar ligges users # Borrowed from pkgload::dev_meta, with some modifications.
devtools_loaded <- function(pkg) {
ns <- .getNamespace(pkg)
if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) {
return(FALSE)
}
TRUE
}
# Borrowed from pkgload::shim_system.file, with some modifications.
system.file <- function(..., package = "base", lib.loc = NULL,
mustWork = FALSE) {
# If package wasn't loaded with devtools, pass through to base::system.file.
# If package was loaded with devtools (the package loaded with load_all)
# search for files a bit differently.
if (devtools_loaded(package)) {
pkg_path <- find.package(package)
# First look in inst/
files_inst <- file.path(pkg_path, "inst", ...)
present_inst <- file.exists(files_inst)
# For any files that weren't present in inst/, look in the base path
files_top <- file.path(pkg_path, ...)
present_top <- file.exists(files_top)
# Merge them together. Here are the different possible conditions, and the
# desired result. NULL means to drop that element from the result.
#
# files_inst: /inst/A /inst/B /inst/C /inst/D
# present_inst: T T F F
# files_top: /A /B /C /D
# present_top: T F T F
# result: /inst/A /inst/B /C NULL
#
files <- files_top
files[present_inst] <- files_inst[present_inst]
# Drop cases where not present in either location
files <- files[present_inst | present_top]
if (length(files) > 0) {
# Make sure backslahses are replaced with slashes on Windows
normalizePath(files, winslash = "/")
} else {
if (mustWork) {
stop("No file found", call. = FALSE)
} else {
""
}
}
# Note that the behavior isn't exactly the same as base::system.file with an
# installed package; in that case, C and D would not be installed and so
# would not be found. Some other files (like DESCRIPTION, data/, etc) would
# be installed. To fully duplicate R's package-building and installation
# behavior would be complicated, so we'll just use this simple method.
} else {
base::system.file(..., package = package, lib.loc = lib.loc,
mustWork = mustWork)
}
}
htmltools/R/tags.R 0000644 0001762 0000144 00000131473 13545702222 013574 0 ustar ligges users #' @import utils digest
NULL
# 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")
))
}
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 \code{\link{htmlDependency}} objects.
#' @param resolvePackageDir Whether to resolve the relative path to an absolute
#' path via \code{\link{system.file}} when the \code{package} attribute is
#' present in a dependency object.
#' @return dependencies A list of \code{\link{htmlDependency}} objects with
#' redundancies removed.
#'
#' @export
resolveDependencies <- function(dependencies, resolvePackageDir = TRUE) {
# Remove nulls
deps <- dependencies[!sapply(dependencies, is.null)]
# Get names and numeric versions in vector/list form
depnames <- sapply(deps, `[[`, "name")
depvers <- numeric_version(sapply(deps, `[[`, "version"))
# 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 \code{\link{htmlDependency}} objects from which
#' dependencies should be removed.
#' @param remove A list of \code{\link{htmlDependency}} objects indicating which
#' dependencies should be removed, or a character vector indicating dependency
#' names.
#' @param warnOnConflict If \code{TRUE}, a warning is emitted for each
#' dependency that is removed if the corresponding dependency in \code{remove}
#' has a lower version number. Has no effect if \code{remove} is provided as a
#' character vector.
#'
#' @return A list of \code{\link{htmlDependency}} objects that don't intersect
#' with \code{remove}.
#'
#' @export
subtractDependencies <- function(dependencies, remove, warnOnConflict = TRUE) {
depnames <- sapply(dependencies, `[[`, "name")
rmnames <- if (is.character(remove))
remove
else
sapply(remove, `[[`, "name")
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))]
}
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 <- print.shiny.tag
#' @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 \code{TRUE}, the HTML will be rendered and displayed in a
#' browser (or possibly another HTML viewer supplied by the environment via
#' the \code{viewer} option). If \code{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)
}
#' @name tag
#' @rdname tag
#' @import rlang
#' @export
tagList <- function(...) {
lst <- dots_list(...)
class(lst) <- c("shiny.tag.list", "list")
return(lst)
}
#' @rdname tag
#' @export
tagAppendAttributes <- function(tag, ...) {
tag$attribs <- c(tag$attribs, list(...))
tag
}
#' @param attr The name of an attribute.
#' @rdname tag
#' @export
tagHasAttribute <- function(tag, attr) {
result <- attr %in% names(tag$attribs)
result
}
#' @rdname tag
#' @export
tagGetAttribute <- function(tag, attr) {
# 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)
}
# Convert all attribs to chars explicitly; prevents us from messing up factors
result <- lapply(attribs[attrIdx], as.character)
# Separate multiple attributes with the same name
result <- paste(result, collapse = " ")
result
}
#' @rdname tag
#' @export
tagAppendChild <- function(tag, child) {
tag$children[[length(tag$children)+1]] <- child
tag
}
#' @rdname tag
#' @export
tagAppendChildren <- function(tag, ..., list = NULL) {
tag$children <- c(tag$children, c(list(...), list))
tag
}
#' @rdname tag
#' @export
tagSetChildren <- function(tag, ..., list = NULL) {
tag$children <- c(list(...), list)
tag
}
#' HTML Tag Object
#'
#' \code{tag()} creates an HTML tag definition. Note that all of the valid HTML5
#' tags are already defined in the \code{\link{tags}} environment so these
#' functions should only be used to generate additional tags.
#' \code{tagAppendChild()} and \code{tagList()} are for supporting package
#' authors who wish to create their own sets of tags; see the contents of
#' bootstrap.R for examples.
#' @param _tag_name HTML tag name
#' @param varArgs List of attributes and children of the element. Named list
#' items become attributes, and unnamed list items become children. Valid
#' children are tags, single-character character vectors (which become text
#' nodes), and raw HTML (see \code{\link{HTML}}). You can also pass lists that
#' contain tags, text nodes, and HTML.
#' @param tag A tag to append child elements to.
#' @param child A child element to append to a parent tag.
#' @param ... Unnamed items that comprise this list of tags.
#' @param list An optional list of elements. Can be used with or instead of the
#' \code{...} items.
#' @param .noWS Character vector used to omit some of the whitespace that would
#' normally be written around this tag. Valid options include \code{before},
#' \code{after}, \code{outside}, \code{after-begin}, and \code{before-end}.
#' Any number of these options can be specified.
#' @return An HTML tag object that can be rendered as HTML using
#' \code{\link{as.character}()}.
#' @export
#' @examples
#' tagList(tags$h1("Title"),
#' tags$h2("Header text"),
#' tags$p("Text here"))
#'
#' # Can also convert a regular list to a tagList (internal data structure isn't
#' # exactly the same, but when rendered to HTML, the output is the same).
#' x <- list(tags$h1("Title"),
#' tags$h2("Header text"),
#' tags$p("Text here"))
#' tagList(x)
#'
#' # suppress the whitespace between tags
#' oneline <- tag("span",
#' tag("strong", "Super strong", .noWS="outside")
#' )
#' cat(as.character(oneline))
tag <- function(`_tag_name`, varArgs, .noWS=NULL) {
validateNoWS(.noWS)
# Get arg names; if not a named list, use vector of empty strings
varArgsNames <- names(varArgs)
if (is.null(varArgsNames))
varArgsNames <- character(length=length(varArgs))
# Named arguments become attribs, dropping NULL and length-0 values
named_idx <- nzchar(varArgsNames)
attribs <- dropNullsOrEmpty(varArgs[named_idx])
# Unnamed arguments are flattened and added as children.
# Use unname() to remove the names attribute from the list, which would
# consist of empty strings anyway.
children <- unname(varArgs[!named_idx])
st <- list(name = `_tag_name`,
attribs = attribs,
children = children)
# Conditionally include the .noWS element. We do this to avoid breaking the hashes
# of existing tags that weren't leveraging .noWS.
if (!is.null(.noWS)){
st$.noWS <- .noWS
}
# Return tag data structure
structure(st, class = "shiny.tag")
}
isTagList <- function(x) {
is.list(x) && (inherits(x, "shiny.tag.list") || identical(class(x), "list"))
}
noWSOptions <- c("before", "after", "after-begin", "before-end", "outside")
# Ensure that the provided `.noWS` string contains only valid options
validateNoWS <- function(.noWS){
if (!all(.noWS %in% noWSOptions)){
stop("Invalid .noWS option(s) '", paste(.noWS, collapse="', '") ,"' specified.")
}
}
#' @include utils.R
tagWrite <- function(tag, textWriter, indent=0, eol = "\n") {
if (length(tag) == 0)
return (NULL)
# optionally process a list of tags
if (!isTag(tag) && isTagList(tag)) {
tag <- dropNullsOrEmpty(flattenTags(tag))
lapply(tag, tagWrite, textWriter, indent)
return (NULL)
}
nextIndent <- if (is.numeric(indent)) indent + 1 else indent
indent <- if (is.numeric(indent)) indent else 0
# compute indent text
indentText <- paste(rep(" ", indent*2), collapse="")
textWriter$writeWS(indentText)
# Check if it's just text (may either be plain-text or HTML)
if (is.character(tag)) {
textWriter$write(normalizeText(tag))
textWriter$writeWS(eol)
return (NULL)
}
.noWS <- tag$.noWS
if ("before" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
# write tag name
textWriter$write(concat8("<", tag$name))
# Convert all attribs to chars explicitly; prevents us from messing up factors
attribs <- lapply(tag$attribs, as.character)
# concatenate attributes
# split() is very slow, so avoid it if possible
if (anyDuplicated(names(attribs))) {
attribs <- lapply(split(attribs, names(attribs)), function(x) {
na_idx <- is.na(x)
if (any(na_idx)) {
if (all(na_idx)) {
return(NA)
}
x <- x[!na_idx]
}
paste(x, collapse = " ")
})
}
# write attributes
for (attrib in names(attribs)) {
attribValue <- attribs[[attrib]]
if (!is.na(attribValue)) {
if (is.logical(attribValue))
attribValue <- tolower(attribValue)
text <- htmlEscape(attribValue, attribute=TRUE)
textWriter$write(concat8(" ", attrib,"=\"", text, "\""))
}
else {
textWriter$write(concat8(" ", attrib))
}
}
# write any children
children <- dropNullsOrEmpty(flattenTags(tag$children))
if (length(children) > 0) {
textWriter$write(">")
# special case for a single child text node (skip newlines and indentation)
if ((length(children) == 1) && is.character(children[[1]]) ) {
textWriter$write(concat8(normalizeText(children[[1]]), "", tag$name, ">"))
}
else {
if ("after-begin" %in% .noWS || "inside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$writeWS("\n")
for (child in children)
tagWrite(child, textWriter, nextIndent)
textWriter$writeWS(indentText)
if ("before-end" %in% .noWS || "inside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$write(concat8("", tag$name, ">"))
}
}
else {
# only self-close void elements
# (see: http://dev.w3.org/html5/spec/single-page.html#void-elements)
if (tag$name %in% c("area", "base", "br", "col", "command", "embed", "hr",
"img", "input", "keygen", "link", "meta", "param",
"source", "track", "wbr")) {
textWriter$write("/>")
}
else {
textWriter$write(concat8(">", tag$name, ">"))
}
}
if ("after" %in% .noWS || "outside" %in% .noWS) {
textWriter$eatWS()
}
textWriter$writeWS(eol)
}
#' Render tags into HTML
#'
#' Renders tags (and objects that can be converted into tags using
#' \code{\link{as.tags}}) into HTML. (Generally intended to be called from web
#' framework libraries, not directly by most users--see
#' \code{\link{print.html}(browse=TRUE)} for higher level rendering.)
#'
#' @param x Tag object(s) to render
#' @param singletons A list of \link{singleton} signatures to consider already
#' rendered; any matching singletons will be dropped instead of rendered.
#' (This is useful (only?) for incremental rendering.)
#' @param indent Initial indent level, or \code{FALSE} if no indentation should
#' be used.
#'
#' @return \code{renderTags} returns a list with the following variables:
#' \describe{
#' \item{\code{head}}{An \code{\link{HTML}} string that should be included in
#' \code{}.
#' }
#' \item{\code{singletons}}{Character vector of singleton signatures that are
#' known after rendering.
#' }
#' \item{\code{dependencies}}{A list of \link[=resolveDependencies]{resolved}
#' \code{\link{htmlDependency}} objects.
#' }
#' \item{\code{html}}{An \code{\link{HTML}} string that represents the main
#' HTML that was rendered.
#' }
#' }
#'
#' @export
renderTags <- function(x, singletons = character(0), indent = 0) {
x <- tagify(x)
# Do singleton and head processing before rendering
singletonInfo <- takeSingletons(x, singletons)
headInfo <- takeHeads(singletonInfo$ui)
deps <- resolveDependencies(findDependencies(singletonInfo$ui, tagify = FALSE))
headIndent <- if (is.numeric(indent)) indent + 1 else indent
headHtml <- doRenderTags(headInfo$head, indent = headIndent)
bodyHtml <- doRenderTags(headInfo$ui, indent = indent)
return(list(head = headHtml,
singletons = singletonInfo$singletons,
dependencies = deps,
html = bodyHtml))
}
#' @details \code{doRenderTags} is intended for very low-level use; it ignores
#' singleton, head, and dependency handling, and simply renders the given tag
#' objects as HTML.
#' @return \code{doRenderTags} returns a simple \code{\link{HTML}} string.
#' @rdname renderTags
#' @export
doRenderTags <- function(x, indent = 0) {
textWriter <- WSTextWriter()
tagWrite(x, textWriter, indent)
# Strip off trailing \n (if present?)
textWriter$eatWS()
HTML(textWriter$readAll())
}
# Walk a tree of tag objects, rewriting objects according to func.
# preorder=TRUE means preorder tree traversal, that is, an object
# should be rewritten before its children.
rewriteTags <- function(ui, func, preorder) {
if (preorder)
ui <- func(ui)
if (isTag(ui)) {
ui$children[] <- lapply(ui$children, rewriteTags, func, preorder)
} else if (isTagList(ui)) {
ui[] <- lapply(ui, rewriteTags, func, preorder)
}
if (!preorder)
ui <- func(ui)
return(ui)
}
#' Singleton manipulation functions
#'
#' Functions for manipulating \code{\link{singleton}} objects in tag
#' hierarchies. Intended for framework authors.
#'
#' @rdname singleton_tools
#' @name singleton_tools
NULL
#' @param ui Tag object or lists of tag objects. See \link{builder} topic.
#' @return \code{surroundSingletons} preprocesses a tag object by changing any
#' singleton X into X'
#' where sig is the sha1 of X, and X' is X minus the singleton attribute.
#' @rdname singleton_tools
#' @export
surroundSingletons <- local({
# In the case of nested singletons, outer singletons are processed
# before inner singletons (otherwise the processing of inner
# singletons would cause the sha1 of the outer singletons to be
# different).
surroundSingleton <- function(uiObj) {
if (is.singleton(uiObj)) {
sig <- digest(uiObj, "sha1")
uiObj <- singleton(uiObj, FALSE)
return(tagList(
HTML(sprintf("", sig)),
uiObj,
HTML(sprintf("", sig))
))
} else {
uiObj
}
}
function(ui) {
rewriteTags(ui, surroundSingleton, TRUE)
}
})
#' @param singletons Character vector of singleton signatures that have already
#' been encountered (i.e. returned from previous calls to
#' \code{takeSingletons}).
#' @param desingleton Logical value indicating whether singletons that are
#' encountered should have the singleton attribute removed.
#' @return \code{takeSingletons} returns a list with the elements \code{ui} (the
#' processed tag objects with any duplicate singleton objects removed) and
#' \code{singletons} (the list of known singleton signatures).
#' @rdname singleton_tools
#' @export
takeSingletons <- function(ui, singletons=character(0), desingleton=TRUE) {
result <- rewriteTags(ui, function(uiObj) {
if (is.singleton(uiObj)) {
sig <- digest(uiObj, "sha1")
if (sig %in% singletons)
return(NULL)
singletons <<- append(singletons, sig)
if (desingleton)
uiObj <- singleton(uiObj, FALSE)
return(uiObj)
} else {
return(uiObj)
}
}, TRUE)
return(list(ui=result, singletons=singletons))
}
# Given a tag object, extract out any children of tags$head
# and return them separate from the body.
takeHeads <- function(ui) {
headItems <- list()
result <- rewriteTags(ui, function(uiObj) {
if (isTag(uiObj) && tolower(uiObj$name) == "head") {
headItems <<- append(headItems, uiObj$children)
return(NULL)
}
return(uiObj)
}, FALSE)
return(list(ui=result, head=headItems))
}
#' Collect attached dependencies from HTML tag object
#'
#' Walks a hierarchy of tags looking for attached dependencies.
#'
#' @param tags A tag-like object to search for dependencies.
#' @param tagify Whether to tagify the input before searching for dependencies.
#'
#' @return A list of \code{\link{htmlDependency}} objects.
#'
#' @export
findDependencies <- function(tags, tagify = TRUE) {
if (isTRUE(tagify)) {
tags <- tagify(tags)
}
dep <- htmlDependencies(tags)
if (!is.null(dep) && inherits(dep, "html_dependency"))
dep <- list(dep)
children <- if (is.list(tags)) {
if (isTag(tags)) {
tags$children
} else {
tags
}
}
childDeps <- unlist(lapply(children, findDependencies, tagify = FALSE), recursive = FALSE)
c(childDeps, if (!is.null(dep)) dep)
}
#' HTML Builder Functions
#'
#' Simple functions for constructing HTML documents.
#'
#' The \code{tags} environment contains convenience functions for all valid
#' HTML5 tags. To generate tags that are not part of the HTML5 specification,
#' you can use the \code{\link{tag}()} function.
#'
#' Dedicated functions are available for the most common HTML tags that do not
#' conflict with common R functions.
#'
#' The result from these functions is a tag object, which can be converted using
#' \code{\link{as.character}()}.
#'
#' @name builder
#' @param ... Attributes and children of the element. Named arguments become
#' attributes, and positional arguments become children. Valid children are
#' tags, single-character character vectors (which become text nodes), raw
#' HTML (see \code{\link{HTML}}), and \code{html_dependency} objects. You can
#' also pass lists that contain tags, text nodes, or HTML. To use boolean
#' attributes, use a named argument with a \code{NA} value. (see example)
#' @param .noWS A character vector used to omit some of the whitespace that
#' would normally be written around this tag. Valid options include
#' \code{before}, \code{after}, \code{outside}, \code{after-begin}, and
#' \code{before-end}. Any number of these options can be specified.
#' @references \itemize{
#' \item W3C html specification about boolean attributes
#' \url{https://www.w3.org/TR/html5/infrastructure.html#sec-boolean-attributes}
#' }
#' @export tags
#' @examples
#' doc <- 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.')
#' )
#' )
#' cat(as.character(doc))
#'
#' # create an html5 audio tag with controls.
#' # controls is a boolean attributes
#' audio_tag <- tags$audio(
#' controls = NA,
#' tags$source(
#' src = "myfile.wav",
#' type = "audio/wav"
#' )
#' )
#' cat(as.character(audio_tag))
#'
#' # suppress the whitespace between tags
#' oneline <- tags$span(
#' tags$strong("I'm strong", .noWS="outside")
#' )
#' cat(as.character(oneline))
NULL
known_tags <- c(
"a",
"abbr",
"address",
"area",
"article",
"aside",
"audio",
"b",
"base",
"bdi",
"bdo",
"blockquote",
"body",
"br",
"button",
"canvas",
"caption",
"cite",
"code",
"col",
"colgroup",
"command",
"data",
"datalist",
"dd",
"del",
"details",
"dfn",
"dialog",
"div",
"dl",
"dt",
"em",
"embed",
"eventsource",
"fieldset",
"figcaption",
"figure",
"footer",
"form",
"h1",
"h2",
"h3",
"h4",
"h5",
"h6",
"head",
"header",
"hgroup",
"hr",
"html",
"i",
"iframe",
"img",
"input",
"ins",
"kbd",
"keygen",
"label",
"legend",
"li",
"link",
"main",
"mark",
"map",
"menu",
"meta",
"meter",
"nav",
"noscript",
"object",
"ol",
"optgroup",
"option",
"output",
"p",
"param",
"picture",
"pre",
"progress",
"q",
"rp",
"rt",
"ruby",
"s",
"samp",
"script",
"section",
"select",
"small",
"source",
"span",
"strong",
"style",
"sub",
"summary",
"sup",
"table",
"tbody",
"td",
"template",
"textarea",
"tfoot",
"th",
"thead",
"time",
"title",
"tr",
"track",
"u",
"ul",
"var",
"video",
"wbr"
)
names(known_tags) <- known_tags
#' @rdname builder
#' @format NULL
#' @docType NULL
#' @keywords NULL
#' @import rlang
tags <- lapply(known_tags, function(tagname) {
function(..., .noWS=NULL) {
validateNoWS(.noWS)
contents <- dots_list(...)
tag(tagname, contents, .noWS=.noWS)
}
})
# known_tags is no longer needed, so remove it.
rm(known_tags)
#' Mark Characters as HTML
#'
#' Marks the given text as HTML, which means the \link{tag} functions will know
#' not to perform HTML escaping on it.
#'
#' @param text The text value to mark with HTML
#' @param ... Any additional values to be converted to character and
#' concatenated together
#' @return The same value, but marked as HTML.
#'
#' @examples
#' el <- div(HTML("I like turtles"))
#' cat(as.character(el))
#'
#' @export
HTML <- function(text, ...) {
htmlText <- c(text, as.character(list(...)))
htmlText <- paste8(htmlText, collapse=" ")
attr(htmlText, "html") <- TRUE
class(htmlText) <- c("html", "character")
htmlText
}
#' Evaluate an expression using \code{tags}
#'
#' This function makes it simpler to write HTML-generating code. Instead of
#' needing to specify \code{tags} each time a tag function is used, as in
#' \code{tags$div()} and \code{tags$p()}, code inside \code{withTags} is
#' evaluated with \code{tags} searched first, so you can simply use
#' \code{div()} and \code{p()}.
#'
#' If your code uses an object which happens to have the same name as an
#' HTML tag function, such as \code{source()} or \code{summary()}, it will call
#' the tag function. To call the intended (non-tags function), specify the
#' namespace, as in \code{base::source()} or \code{base::summary()}.
#'
#' @param code A set of tags.
#'
#' @examples
#' # Using tags$ each time
#' tags$div(class = "myclass",
#' tags$h3("header"),
#' tags$p("text")
#' )
#'
#' # Equivalent to above, but using withTags
#' withTags(
#' div(class = "myclass",
#' h3("header"),
#' p("text")
#' )
#' )
#'
#'
#' @export
withTags <- function(code) {
eval(substitute(code), envir = as.list(tags), enclos = parent.frame())
}
# Make sure any objects in the tree that can be converted to tags, have been
tagify <- function(x) {
rewriteTags(x, function(uiObj) {
if (isTag(uiObj) || isTagList(uiObj) || is.character(uiObj))
return(uiObj)
else
return(tagify(as.tags(uiObj)))
}, FALSE)
}
# Given a list of tags, lists, and other items, return a flat list, where the
# items from the inner, nested lists are pulled to the top level, recursively.
flattenTags <- function(x) {
if (isTag(x)) {
# For tags, wrap them into a list (which will be unwrapped by caller)
list(x)
} else if (isTagList(x)) {
if (length(x) == 0) {
# Empty lists are simply returned
x
} else {
# For items that are lists (but not tags), recurse
unlist(lapply(x, flattenTags), recursive = FALSE)
}
} else if (is.character(x)){
# This will preserve attributes if x is a character with attribute,
# like what HTML() produces
list(x)
} else {
# For other items, coerce to character and wrap them into a list (which
# will be unwrapped by caller). Note that this will strip attributes.
flattenTags(as.tags(x))
}
}
#' Convert a value to tags
#'
#' An S3 method for converting arbitrary values to a value that can be used as
#' the child of a tag or \code{tagList}. The default implementation simply calls
#' \code{\link[base]{as.character}}.
#'
#' @param x Object to be converted.
#' @param ... Any additional parameters.
#'
#' @export
as.tags <- function(x, ...) {
UseMethod("as.tags")
}
#' @export
as.tags.default <- function(x, ...) {
if (is.list(x) && !isTagList(x))
unclass(x)
else
tagList(as.character(x))
}
#' @export
as.tags.html <- function(x, ...) {
x
}
#' @export
as.tags.shiny.tag <- function(x, ...) {
x
}
#' @export
as.tags.shiny.tag.list <- function(x, ...) {
x
}
#' @export
as.tags.character <- function(x, ...) {
# For printing as.tags("") directly at console, without dropping any
# attached dependencies
tagList(x)
}
#' @export
as.tags.html_dependency <- function(x, ...) {
attachDependencies(tagList(), x)
}
#' Preserve HTML regions
#'
#' Use "magic" HTML comments to protect regions of HTML from being modified by
#' text processing tools.
#'
#' Text processing tools like markdown and pandoc are designed to turn
#' human-friendly markup into common output formats like HTML. This works well
#' for most prose, but components that generate their own HTML may break if
#' their markup is interpreted as the input language. The \code{htmlPreserve}
#' function is used to mark regions of an input document as containing pure HTML
#' that must not be modified. This is achieved by substituting each such region
#' with a benign but unique string before processing, and undoing those
#' substitutions after processing.
#'
#' @param x A character vector of HTML to be preserved.
#'
#' @return \code{htmlPreserve} returns a single-element character vector with
#' "magic" HTML comments surrounding the original text (unless the original
#' text was empty, in which case an empty string is returned).
#'
#' @examples
#' # htmlPreserve will prevent ""
#' # from getting an tag inserted in the middle
#' markup <- paste(sep = "\n",
#' "This is *emphasized* text in markdown.",
#' htmlPreserve(""),
#' "Here is some more *emphasized text*."
#' )
#' extracted <- extractPreserveChunks(markup)
#' markup <- extracted$value
#' # Just think of this next line as Markdown processing
#' output <- gsub("\\*(.*?)\\*", "\\1", markup)
#' output <- restorePreserveChunks(output, extracted$chunks)
#' output
#'
#' @export
htmlPreserve <- function(x) {
x <- paste(x, collapse = "\n")
if (nzchar(x))
sprintf("%s", x)
else
x
}
# Temporarily set x in env to value, evaluate expr, and
# then restore x to its original state
withTemporary <- function(env, x, value, expr, unset = FALSE) {
if (exists(x, envir = env, inherits = FALSE)) {
oldValue <- get(x, envir = env, inherits = FALSE)
on.exit(
assign(x, oldValue, envir = env, inherits = FALSE),
add = TRUE)
} else {
on.exit(
rm(list = x, envir = env, inherits = FALSE),
add = TRUE
)
}
if (!missing(value) && !isTRUE(unset))
assign(x, value, envir = env, inherits = FALSE)
else {
if (exists(x, envir = env, inherits = FALSE))
rm(list = x, envir = env, inherits = FALSE)
}
force(expr)
}
# Evaluate an expression using Shiny's own private stream of
# randomness (not affected by set.seed).
withPrivateSeed <- local({
ownSeed <- NULL
function(expr) {
withTemporary(.GlobalEnv, ".Random.seed",
ownSeed, unset=is.null(ownSeed), {
tryCatch({
expr
}, finally = {ownSeed <<- .Random.seed})
}
)
}
})
# extract_preserve_chunks looks for regions in strval marked by
# ... and replaces each such region
# with a long unique ID. The return value is a list with $value as the string
# with the regions replaced, and $chunks as a named character vector where the
# names are the IDs and the values are the regions that were extracted.
#
# Nested regions are handled appropriately; the outermost region is what's used
# and any inner regions simply have their boundaries removed before the values
# are stashed in $chunks.
#' @return \code{extractPreserveChunks} returns a list with two named elements:
#' \code{value} is the string with the regions replaced, and \code{chunks} is
#' a named character vector where the names are the IDs and the values are the
#' regions that were extracted.
#' @rdname htmlPreserve
#' @export
extractPreserveChunks <- function(strval) {
# Literal start/end marker text. Case sensitive.
startmarker <- ""
endmarker <- ""
# Start and end marker length MUST be different, it's how we tell them apart
startmarker_len <- nchar(startmarker)
endmarker_len <- nchar(endmarker)
# Pattern must match both start and end markers
pattern <- ""
# It simplifies string handling greatly to collapse multiple char elements
if (length(strval) != 1)
strval <- paste(strval, collapse = "\n")
# matches contains the index of all the start and end markers
matches <- gregexpr(pattern, strval)[[1]]
lengths <- attr(matches, "match.length", TRUE)
# No markers? Just return.
if (matches[[1]] == -1)
return(list(value = strval, chunks = character(0)))
# If TRUE, it's a start; if FALSE, it's an end
boundary_type <- lengths == startmarker_len
# Positive number means we're inside a region, zero means we just exited to
# the top-level, negative number means error (an end without matching start).
# For example:
# boundary_type - TRUE TRUE FALSE FALSE TRUE FALSE
# preserve_level - 1 2 1 0 1 0
preserve_level <- cumsum(ifelse(boundary_type, 1, -1))
# Sanity check.
if (any(preserve_level < 0) || tail(preserve_level, 1) != 0) {
stop("Invalid nesting of html_preserve directives")
}
# Identify all the top-level boundary markers. We want to find all of the
# elements of preserve_level whose value is 0 and preceding value is 1, or
# whose value is 1 and preceding value is 0. Since we know that preserve_level
# values can only go up or down by 1, we can simply shift preserve_level by
# one element and add it to preserve_level; in the result, any value of 1 is a
# match.
is_top_level <- 1 == (preserve_level + c(0, preserve_level[-length(preserve_level)]))
preserved <- character(0)
top_level_matches <- matches[is_top_level]
# Iterate backwards so string mutation doesn't screw up positions for future
# iterations
for (i in seq.int(length(top_level_matches) - 1, 1, by = -2)) {
start_outer <- top_level_matches[[i]]
start_inner <- start_outer + startmarker_len
end_inner <- top_level_matches[[i+1]]
end_outer <- end_inner + endmarker_len
id <- withPrivateSeed(
paste("preserve", paste(
format(as.hexmode(sample(256, 8, replace = TRUE)-1), width=2),
collapse = ""),
sep = "")
)
preserved[id] <- gsub(pattern, "", substr(strval, start_inner, end_inner-1))
strval <- paste(
substr(strval, 1, start_outer - 1),
id,
substr(strval, end_outer, nchar(strval)),
sep="")
substr(strval, start_outer, end_outer-1) <- id
}
list(value = strval, chunks = preserved)
}
#' @param strval Input string from which to extract/restore chunks.
#' @param chunks The \code{chunks} element of the return value of
#' \code{extractPreserveChunks}.
#' @return \code{restorePreserveChunks} returns a character vector with the
#' chunk IDs replaced with their original values.
#' @rdname htmlPreserve
#' @export
restorePreserveChunks <- function(strval, chunks) {
strval <- enc2utf8(strval)
chunks <- enc2utf8(chunks)
for (id in names(chunks))
strval <- gsub(id, chunks[[id]], strval, fixed = TRUE, useBytes = TRUE)
Encoding(strval) <- 'UTF-8'
strval
}
#' Knitr S3 methods
#'
#' These S3 methods are necessary to allow HTML tags to print themselves in
#' knitr/rmarkdown documents.
#'
#' @name knitr_methods
#' @param x Object to knit_print
#' @param ... Additional knit_print arguments
NULL
#' @rdname knitr_methods
#' @export
knit_print.shiny.tag <- function(x, ...) {
x <- tagify(x)
output <- surroundSingletons(x)
deps <- resolveDependencies(findDependencies(x, tagify = FALSE), resolvePackageDir = FALSE)
content <- takeHeads(output)
head_content <- doRenderTags(tagList(content$head))
meta <- if (length(head_content) > 1 || head_content != "") {
list(structure(head_content, class = "shiny_head"))
}
meta <- c(meta, deps)
knitr::asis_output(
htmlPreserve(format(content$ui, indent=FALSE)),
meta = meta)
}
#' @rdname knitr_methods
#' @export
knit_print.html <- function(x, ...) {
deps <- resolveDependencies(findDependencies(x, tagify = FALSE))
knitr::asis_output(htmlPreserve(as.character(x)),
meta = if (length(deps)) list(deps))
}
#' @rdname knitr_methods
#' @export
knit_print.shiny.tag.list <- knit_print.shiny.tag
#' @rdname builder
#' @export
p <- tags$p
#' @rdname builder
#' @export
h1 <- tags$h1
#' @rdname builder
#' @export
h2 <- tags$h2
#' @rdname builder
#' @export
h3 <- tags$h3
#' @rdname builder
#' @export
h4 <- tags$h4
#' @rdname builder
#' @export
h5 <- tags$h5
#' @rdname builder
#' @export
h6 <- tags$h6
#' @rdname builder
#' @export
a <- tags$a
#' @rdname builder
#' @export
br <- tags$br
#' @rdname builder
#' @export
div <- tags$div
#' @rdname builder
#' @export
span <- tags$span
#' @rdname builder
#' @export
pre <- tags$pre
#' @rdname builder
#' @export
code <- tags$code
#' @rdname builder
#' @export
img <- tags$img
#' @rdname builder
#' @export
strong <- tags$strong
#' @rdname builder
#' @export
em <- tags$em
#' @rdname builder
#' @export
hr <- tags$hr
#' Include Content From a File
#'
#' Load HTML, text, or rendered Markdown from a file and turn into HTML.
#'
#' These functions provide a convenient way to include an extensive amount of
#' HTML, textual, Markdown, CSS, or JavaScript content, rather than using a
#' large literal R string.
#'
#' @param path The path of the file to be included. It is highly recommended to
#' use a relative path (the base path being the Shiny application directory),
#' not an absolute path.
#'
#' @rdname include
#' @name include
#' @aliases includeHTML
#' @export
includeHTML <- function(path) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
return(HTML(paste8(lines, collapse='\n')))
}
#' @note \code{includeText} escapes its contents, but does no other processing.
#' This means that hard breaks and multiple spaces will be rendered as they
#' usually are in HTML: as a single space character. If you are looking for
#' preformatted text, wrap the call with \code{\link{pre}}, or consider using
#' \code{includeMarkdown} instead.
#'
#' @rdname include
#' @export
includeText <- function(path) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
return(paste8(lines, collapse='\n'))
}
#' @note The \code{includeMarkdown} function requires the \code{markdown}
#' package.
#' @rdname include
#' @export
includeMarkdown <- function(path) {
html <- markdown::markdownToHTML(path, fragment.only=TRUE)
Encoding(html) <- 'UTF-8'
return(HTML(html))
}
#' @param ... Any additional attributes to be applied to the generated tag.
#' @rdname include
#' @export
includeCSS <- function(path, ...) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
args <- list(...)
if (is.null(args$type))
args$type <- 'text/css'
return(do.call(tags$style,
c(list(HTML(paste8(lines, collapse='\n'))), args)))
}
#' @rdname include
#' @export
includeScript <- function(path, ...) {
lines <- readLines(path, warn=FALSE, encoding='UTF-8')
return(tags$script(HTML(paste8(lines, collapse='\n')), ...))
}
#' Include content only once
#'
#' Use \code{singleton} to wrap contents (tag, text, HTML, or lists) that should
#' be included in the generated document only once, yet may appear in the
#' document-generating code more than once. Only the first appearance of the
#' content (in document order) will be used.
#'
#' @param x A \code{\link{tag}}, text, \code{\link{HTML}}, or list.
#' @param value Whether the object should be a singleton.
#'
#' @export
singleton <- function(x, value = TRUE) {
attr(x, "htmltools.singleton") <- if (isTRUE(value)) TRUE else NULL
return(x)
}
#' @rdname singleton
#' @export
is.singleton <- function(x) {
isTRUE(attr(x, "htmltools.singleton"))
}
#' Validate proper CSS formatting of a unit
#'
#' Checks that the argument is valid for use as a CSS unit of length.
#'
#' \code{NULL} and \code{NA} are returned unchanged.
#'
#' Single element numeric vectors are returned as a character vector with the
#' number plus a suffix of \code{"px"}.
#'
#' Single element character vectors must be \code{"auto"} or \code{"inherit"},
#' a number, or a length calculated by the \code{"calc"} CSS function.
#' If the number has a suffix, it must be valid: \code{px},
#' \code{\%}, \code{ch}, \code{em}, \code{rem}, \code{pt}, \code{in}, \code{cm},
#' \code{mm}, \code{ex}, \code{pc}, \code{vh}, \code{vw}, \code{vmin}, or
#' \code{vmax}.
#' If the number has no suffix, the suffix \code{"px"} is appended.
#'
#'
#' Any other value will cause an error to be thrown.
#'
#' @param x The unit to validate. Will be treated as a number of pixels if a
#' unit is not specified.
#' @return A properly formatted CSS unit of length, if possible. Otherwise, will
#' throw an error.
#' @examples
#' validateCssUnit("10%")
#' validateCssUnit(400) #treated as '400px'
#' @export
validateCssUnit <- function(x) {
if (is.null(x) || is.na(x))
return(x)
if (length(x) > 1 || (!is.character(x) && !is.numeric(x)))
stop('CSS units must be a single-element numeric or character vector')
# if the input is a character vector consisting only of digits (e.g. "960"),
# coerce it to a numeric value
if (is.character(x) && nchar(x) > 0 && gsub("\\d*", "", x) == "")
x <- as.numeric(x)
pattern <-
"^(auto|inherit|calc\\(.*\\)|((\\.\\d+)|(\\d+(\\.\\d+)?))(%|in|cm|mm|ch|em|ex|rem|pt|pc|px|vh|vw|vmin|vmax))$"
if (is.character(x) &&
!grepl(pattern, x)) {
stop('"', x, '" is not a valid CSS unit (e.g., "100%", "400px", "auto")')
} else if (is.numeric(x)) {
x <- paste(x, "px", sep = "")
}
x
}
#' CSS string helper
#'
#' Convenience function for building CSS style declarations (i.e. the string
#' that goes into a style attribute, or the parts that go inside curly braces in
#' a full stylesheet).
#'
#' CSS uses \code{'-'} (minus) as a separator character in property names, but
#' this is an inconvenient character to use in an R function argument name.
#' Instead, you can use \code{'.'} (period) and/or \code{'_'} (underscore) as
#' separator characters. For example, \code{css(font.size = "12px")} yields
#' \code{"font-size:12px;"}.
#'
#' To mark a property as \code{!important}, add a \code{'!'} character to the end
#' of the property name. (Since \code{'!'} is not normally a character that can be
#' used in an identifier in R, you'll need to put the name in double quotes or
#' backticks.)
#'
#' Argument values will be converted to strings using
#' \code{paste(collapse = " ")}. Any property with a value of \code{NULL} or
#' \code{""} (after paste) will be dropped.
#'
#' @param ... Named style properties, where the name is the property name and
#' the argument is the property value. See Details for conversion rules.
#' @param collapse_ (Note that the parameter name has a trailing underscore
#' character.) Character to use to collapse properties into a single string;
#' likely \code{""} (the default) for style attributes, and either \code{"\n"}
#' or \code{NULL} for style blocks.
#'
#' @examples
#' padding <- 6
#' css(
#' font.family = "Helvetica, sans-serif",
#' margin = paste0(c(10, 20, 10, 20), "px"),
#' "padding!" = if (!is.null(padding)) padding
#' )
#'
#' @export
css <- function(..., collapse_ = "") {
props <- list(...)
if (length(props) == 0) {
return("")
}
if (is.null(names(props)) || any(names(props) == "")) {
stop("cssList expects all arguments to be named")
}
# Necessary to make factors show up as level names, not numbers
props[] <- lapply(props, paste, collapse = " ")
# Drop null args
props <- props[!sapply(props, empty)]
if (length(props) == 0) {
return("")
}
# Replace all '.' and '_' in property names to '-'
names(props) <- gsub("[._]", "-", tolower(gsub("([A-Z])", "-\\1", names(props))))
# Create "!important" suffix for each property whose name ends with !, then
# remove the ! from the property name
important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "")
names(props) <- sub("!$", "", names(props), perl = TRUE)
paste0(names(props), ":", props, important, ";", collapse = collapse_)
}
empty <- function(x) {
length(x) == 0 || (is.character(x) && !any(nzchar(x)))
}
htmltools/R/html_escape.R 0000644 0001762 0000144 00000002414 13306600132 015102 0 ustar ligges users
#' Escape HTML entities
#'
#' Escape HTML entities contained in a character vector so that it can be safely
#' included as text or an attribute value within an HTML document
#'
#' @param text Text to escape
#' @param attribute Escape for use as an attribute value
#'
#' @return Character vector with escaped text.
#'
#' @export
htmlEscape <- local({
.htmlSpecials <- list(
`&` = '&',
`<` = '<',
`>` = '>'
)
.htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|')
.htmlSpecialsAttrib <- c(
.htmlSpecials,
`'` = ''',
`"` = '"',
`\r` = '
',
`\n` = '
'
)
.htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
function(text, attribute=FALSE) {
pattern <- if(attribute)
.htmlSpecialsPatternAttrib
else
.htmlSpecialsPattern
text <- enc2utf8(as.character(text))
# Short circuit in the common case that there's nothing to escape
if (!any(grepl(pattern, text, useBytes = TRUE)))
return(text)
specials <- if(attribute)
.htmlSpecialsAttrib
else
.htmlSpecials
for (chr in names(specials)) {
text <- gsub(chr, specials[[chr]], text, fixed = TRUE, useBytes = TRUE)
}
Encoding(text) <- "UTF-8"
return(text)
}
})
htmltools/R/html_dependency.R 0000644 0001762 0000144 00000042675 13426136411 016004 0 ustar ligges users #' Define an HTML dependency
#'
#' Define an HTML dependency (i.e. CSS and/or JavaScript bundled in a
#' directory). HTML dependencies make it possible to use libraries like jQuery,
#' Bootstrap, and d3 in a more composable and portable way than simply using
#' script, link, and style tags.
#'
#' @param name Library name
#' @param version Library version
#' @param src Unnamed single-element character vector indicating the full path
#' of the library directory. Alternatively, a named character string with one
#' or more elements, indicating different places to find the library; see
#' Details.
#' @param meta Named list of meta tags to insert into document head
#' @param script Script(s) to include within the document head (should be
#' specified relative to the \code{src} parameter).
#' @param stylesheet Stylesheet(s) to include within the document (should be
#' specified relative to the \code{src} parameter).
#' @param head Arbitrary lines of HTML to insert into the document head
#' @param attachment Attachment(s) to include within the document head. See
#' Details.
#' @param package An R package name to indicate where to find the \code{src}
#' directory when \code{src} is a relative path (see
#' \code{\link{resolveDependencies}}).
#' @param all_files Whether all files under the \code{src} directory are
#' dependency files. If \code{FALSE}, only the files specified in
#' \code{script}, \code{stylesheet}, and \code{attachment} are treated as
#' dependency files.
#'
#' @return An object that can be included in a list of dependencies passed to
#' \code{\link{attachDependencies}}.
#'
#' @details Each dependency can be located on the filesystem, at a relative or
#' absolute URL, or both. The location types are indicated using the names of
#' the \code{src} character vector: \code{file} for filesystem directory,
#' \code{href} for URL. For example, a dependency that was both on disk and at
#' a URL might use \code{src = c(file=filepath, href=url)}.
#'
#' \code{attachment} can be used to make the indicated files available to the
#' JavaScript on the page via URL. For each element of \code{attachment}, an
#' element \code{} is inserted, where \code{DEPNAME} is \code{name}. The value of
#' \code{ATTACHINDEX} depends on whether \code{attachment} is named or not; if
#' so, then it's the name of the element, and if not, it's the 1-based index
#' of the element. JavaScript can retrieve the URL using something like
#' \code{document.getElementById(depname + "-" + index + "-attachment").href}.
#' Note that depending on the rendering context, the runtime value of the href
#' may be an absolute, relative, or data URI.
#'
#' \code{htmlDependency} should not be called from the top-level of a package
#' namespace with absolute paths (or with paths generated by
#' \code{system.file()}) and have the result stored in a variable. This is
#' because, when a binary package is built, R will run \code{htmlDependency}
#' and store the path from the building machine's in the package. This path is
#' likely to differ from the correct path on a machine that downloads and
#' installs the binary package. If there are any absolute paths, instead of
#' calling \code{htmlDependency} at build-time, it should be called at
#' run-time. This can be done by wrapping the \code{htmlDependency} call in a
#' function.
#'
#' @seealso Use \code{\link{attachDependencies}} to associate a list of
#' dependencies with the HTML it belongs with.
#'
#' @export
htmlDependency <- function(name,
version,
src,
meta = NULL,
script = NULL,
stylesheet = NULL,
head = NULL,
attachment = NULL,
package = NULL,
all_files = TRUE) {
# This function shouldn't be called from a namespace environment with
# absolute paths.
if (isNamespace(parent.frame()) && any(substr(src, 1, 1) == "/")) {
warning(
"htmlDependency shouldn't be called from a namespace environment",
" with absolute paths (or paths from system.file()).",
" See ?htmlDependency for more information."
)
}
version <- as.character(version)
validateScalarName(name)
validateScalarName(version)
srcNames <- names(src)
if (is.null(srcNames))
srcNames <- rep.int("", length(src))
srcNames[!nzchar(srcNames)] <- "file"
names(src) <- srcNames
src <- as.list(src)
structure(class = "html_dependency", list(
name = name,
version = as.character(version),
src = src,
meta = meta,
script = script,
stylesheet = stylesheet,
head = head,
attachment = attachment,
package = package,
all_files = all_files
))
}
validateScalarName <- function(x, name = deparse(substitute(x))) {
if (length(x) != 1 || x == "" || grepl("[/\\]", x)) stop(
"Invalid argument '", name,
"' (must be a non-empty character string and contain no '/' or '\\')"
)
}
#' HTML dependency metadata
#'
#' Gets or sets the HTML dependencies associated with an object (such as a tag).
#'
#' \code{attachDependencies} provides an alternate syntax for setting
#' dependencies. It is similar to \code{local(\{htmlDependencies(x) <- value;
#' x\})}, except that if there are any existing dependencies,
#' \code{attachDependencies} will add to them, instead of replacing them.
#'
#' As of htmltools 0.3.4, HTML dependencies can be attached without using
#' \code{attachDependencies}. Instead, they can be added inline, like a child
#' object of a tag or \code{\link{tagList}}.
#'
#' @param x An object which has (or should have) HTML dependencies.
#' @param value An HTML dependency, or a list of HTML dependencies.
#' @param append If FALSE (the default), replace any existing dependencies. If
#' TRUE, add the new dependencies to the existing ones.
#'
#' @examples
#' # Create a JavaScript dependency
#' dep <- htmlDependency("jqueryui", "1.11.4", c(href="shared/jqueryui"),
#' script = "jquery-ui.min.js")
#'
#' # A CSS dependency
#' htmlDependency(
#' "font-awesome", "4.5.0", c(href="shared/font-awesome"),
#' stylesheet = "css/font-awesome.min.css"
#' )
#'
#' # A few different ways to add the dependency to tag objects:
#' # Inline as a child of the div()
#' div("Code here", dep)
#' # Inline in a tagList
#' tagList(div("Code here"), dep)
#' # With attachDependencies
#' attachDependencies(div("Code here"), dep)
#'
#' @export
htmlDependencies <- function(x) {
attr(x, "html_dependencies", TRUE)
}
#' @rdname htmlDependencies
#' @export
`htmlDependencies<-` <- function(x, value) {
if (inherits(value, "html_dependency"))
value <- list(value)
attr(x, "html_dependencies") <- value
x
}
#' @rdname htmlDependencies
#' @export
attachDependencies <- function(x, value, append = FALSE) {
if (append) {
if (inherits(value, "html_dependency"))
value <- list(value)
old <- attr(x, "html_dependencies", TRUE)
htmlDependencies(x) <- c(old, value)
} else {
htmlDependencies(x) <- value
}
return(x)
}
#' Suppress web dependencies
#'
#' This suppresses one or more web dependencies. It is meant to be used when a
#' dependency (like a JavaScript or CSS file) is declared in raw HTML, in an
#' HTML template.
#'
#' @param ... Names of the dependencies to suppress. For example,
#' \code{"jquery"} or \code{"bootstrap"}.
#'
#' @seealso \code{\link{htmlTemplate}} for more information about using HTML
#' templates.
#' @seealso \code{\link[htmltools]{htmlDependency}}
#' @export
suppressDependencies <- function(...) {
lapply(list(...), function(name) {
attachDependencies(
character(0),
htmlDependency(name, "9999", c(href = ""))
)
})
}
#' @export
print.html_dependency <- function(x, ...) str(x)
dir_path <- function(dependency) {
if ("dir" %in% names(dependency$src))
return(dependency$src[["dir"]])
if (length(names(dependency$src)) == 0 || all(!nzchar(dependency$src)))
return(dependency$src[[1]])
return(NULL)
}
href_path <- function(dependency) {
if ("href" %in% names(dependency$src))
return(dependency$src[["href"]])
else
return(NULL)
}
#' Encode a URL path
#'
#' Encode characters in a URL path. This is the same as
#' \code{\link[utils]{URLencode}} with \code{reserved = TRUE} except that
#' \code{/} is preserved.
#'
#' @param x A character vector.
#' @export
urlEncodePath <- function(x) {
vURLEncode <- Vectorize(URLencode, USE.NAMES = FALSE)
gsub("%2[Ff]", "/", vURLEncode(x, TRUE))
}
#' Copy an HTML dependency to a directory
#'
#' Copies an HTML dependency to a subdirectory of the given directory. The
#' subdirectory name will be \emph{name}-\emph{version} (for example,
#' "outputDir/jquery-1.11.0"). You may set \code{options(htmltools.dir.version =
#' FALSE)} to suppress the version number in the subdirectory name.
#'
#' In order for disk-based dependencies to work with static HTML files, it's
#' generally necessary to copy them to either the directory of the referencing
#' HTML file, or to a subdirectory of that directory. This function makes it
#' easier to perform that copy.
#'
#' @param dependency A single HTML dependency object.
#' @param outputDir The directory in which a subdirectory should be created for
#' this dependency.
#' @param mustWork If \code{TRUE} and \code{dependency} does not point to a
#' directory on disk (but rather a URL location), an error is raised. If
#' \code{FALSE} then non-disk dependencies are returned without modification.
#'
#' @return The dependency with its \code{src} value updated to the new
#' location's absolute path.
#'
#' @seealso \code{\link{makeDependencyRelative}} can be used with the returned
#' value to make the path relative to a specific directory.
#'
#' @export
copyDependencyToDir <- function(dependency, outputDir, mustWork = TRUE) {
dir <- dependency$src$file
if (is.null(dir)) {
if (mustWork) {
stop("Dependency ", dependency$name, " ", dependency$version,
" is not disk-based")
} else {
return(dependency)
}
}
# resolve the relative file path to absolute path in package
if (!is.null(dependency$package))
dir <- system.file(dir, package = dependency$package)
if (length(outputDir) != 1 || outputDir %in% c("", "/"))
stop('outputDir must be of length 1 and cannot be "" or "/"')
if (!dir_exists(outputDir))
dir.create(outputDir)
target_dir <- if (getOption('htmltools.dir.version', TRUE)) {
paste(dependency$name, dependency$version, sep = "-")
} else dependency$name
target_dir <- file.path(outputDir, target_dir)
# completely remove the target dir because we don't want possible leftover
# files in the target dir, e.g. we may have lib/foo.js last time, and it was
# removed from the original library, then the next time we copy the library
# over to the target dir, we want to remove this lib/foo.js as well;
# unlink(recursive = TRUE) can be dangerous, e.g. we certainly do not want 'rm
# -rf /' to happen; in htmlDependency() we have made sure dependency$name and
# dependency$version are not "" or "/" or contains no / or \; we have also
# made sure outputDir is not "" or "/" above, so target_dir here should be
# relatively safe to be removed recursively
if (dir_exists(target_dir)) unlink(target_dir, recursive = TRUE)
dir.create(target_dir)
files <- if (dependency$all_files) list.files(dir) else {
unlist(dependency[c('script', 'stylesheet', 'attachment')])
}
srcfiles <- file.path(dir, files)
if (any(!file.exists(srcfiles))) {
stop(
sprintf(
"Can't copy dependency files that don't exist: '%s'",
paste(srcfiles, collapse = "', '")
)
)
}
destfiles <- file.path(target_dir, files)
isdir <- file.info(srcfiles)$isdir
destfiles <- ifelse(isdir, dirname(destfiles), destfiles)
mapply(function(from, to, isdir) {
if (!dir_exists(dirname(to)))
dir.create(dirname(to), recursive = TRUE)
if (isdir && !dir_exists(to))
dir.create(to)
file.copy(from, to, overwrite = TRUE, recursive = isdir)
}, srcfiles, destfiles, isdir)
dependency$src$file <- normalizePath(target_dir, "/", TRUE)
dependency
}
dir_exists <- function(paths) {
utils::file_test("-d", paths)
}
# given a directory and a file, return a relative path from the directory to the
# file, or the unmodified file path if the file does not appear to be in the
# directory
relativeTo <- function(dir, file) {
# ensure directory ends with a /
if (!identical(substr(dir, nchar(dir), nchar(dir)), "/")) {
dir <- paste(dir, "/", sep="")
}
# if the file is prefixed with the directory, return a relative path
if (identical(substr(file, 1, nchar(dir)), dir))
return(substr(file, nchar(dir) + 1, nchar(file)))
else
stop("The path ", file, " does not appear to be a descendant of ", dir)
}
#' Make an absolute dependency relative
#'
#' Change a dependency's absolute path to be relative to one of its parent
#' directories.
#'
#' @param dependency A single HTML dependency with an absolute path.
#' @param basepath The path to the directory that \code{dependency} should be
#' made relative to.
#' @param mustWork If \code{TRUE} and \code{dependency} does not point to a
#' directory on disk (but rather a URL location), an error is raised. If
#' \code{FALSE} then non-disk dependencies are returned without modification.
#'
#' @return The dependency with its \code{src} value updated to the new
#' location's relative path.
#'
#' If \code{baspath} did not appear to be a parent directory of the dependency's
#' directory, an error is raised (regardless of the value of \code{mustWork}).
#'
#' @seealso \code{\link{copyDependencyToDir}}
#'
#' @export
makeDependencyRelative <- function(dependency, basepath, mustWork = TRUE) {
basepath <- normalizePath(basepath, "/", TRUE)
dir <- dependency$src$file
if (is.null(dir)) {
if (!mustWork)
return(dependency)
else
stop("Could not make dependency ", dependency$name, " ",
dependency$version, " relative; it is not file-based")
}
dependency$src <- c(file=relativeTo(basepath, dir))
dependency
}
#' Create HTML for dependencies
#'
#' Create the appropriate HTML markup for including dependencies in an HTML
#' document.
#'
#' @param dependencies A list of \code{htmlDependency} objects.
#' @param srcType The type of src paths to use; valid values are \code{file} or
#' \code{href}.
#' @param encodeFunc The function to use to encode the path part of a URL. The
#' default should generally be used.
#' @param hrefFilter A function used to transform the final, encoded URLs of
#' script and stylsheet files. The default should generally be used.
#'
#' @return An \code{\link{HTML}} object suitable for inclusion in the head of an
#' HTML document.
#'
#' @export
renderDependencies <- function(dependencies,
srcType = c("href", "file"),
encodeFunc = urlEncodePath,
hrefFilter = identity) {
html <- c()
for (dep in dependencies) {
usableType <- srcType[which(srcType %in% names(dep$src))]
if (length(usableType) == 0)
stop("Dependency ", dep$name, " ", dep$version,
" does not have a usable source")
dir <- dep$src[head(usableType, 1)]
srcpath <- if (usableType == "file") {
encodeFunc(dir)
} else {
# Assume that href is already URL encoded
href_path(dep)
}
# Drop trailing /
srcpath <- sub("/$", "\\1", srcpath)
# add meta content
if (length(dep$meta) > 0) {
html <- c(html, paste(
"",
sep = ""
))
}
# add stylesheets
if (length(dep$stylesheet) > 0) {
html <- c(html, paste(
"",
sep = ""
))
}
# add scripts
if (length(dep$script) > 0) {
html <- c(html, paste(
"",
sep = ""
))
}
if (length(dep$attachment) > 0) {
if (is.null(names(dep$attachment)))
names(dep$attachment) <- as.character(1:length(dep$attachment))
html <- c(html,
sprintf("",
htmlEscape(dep$name),
htmlEscape(names(dep$attachment)),
htmlEscape(hrefFilter(file.path(srcpath, encodeFunc(dep$attachment))))
)
)
}
# add raw head content
html <- c(html, dep$head)
}
HTML(paste(html, collapse = "\n"))
}
# html_dependencies_as_character(list(
# htmlDependency("foo", "1.0",
# c(href="http://foo.com/bar%20baz/"),
# stylesheet="x y z.css"
# )
# ))
#
# html_dependencies_as_character(list(
# htmlDependency("foo", "1.0",
# c(href="http://foo.com/bar%20baz"),
# stylesheet="x y z.css"
# )
# ))
#
# html_dependencies_as_character(list(
# htmlDependency("foo", "1.0",
# "foo bar/baz",
# stylesheet="x y z.css"
# )
# ))
#
# html_dependencies_as_character(list(
# htmlDependency("foo", "1.0",
# "foo bar/baz/",
# stylesheet="x y z.css"
# )
# ))
#
htmltools/R/RcppExports.R 0000644 0001762 0000144 00000000310 13306600132 015100 0 ustar ligges users # Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
template_dfa <- function(x) {
.Call(`_htmltools_template_dfa`, x)
}
htmltools/MD5 0000644 0001762 0000144 00000005553 13545747370 012636 0 ustar ligges users df990db30af45356fc973305d819f4d4 *DESCRIPTION
086fb3802360ebc071771033cf0c5e29 *NAMESPACE
dd1baa979b938e0d51aa38c89da57ba9 *NEWS
5fe5102b0e44b178fbd2a7161e86295a *R/RcppExports.R
f3f030583f287b5228179e028df4b7d8 *R/html_dependency.R
3264d8cfd71d9150f3b08b473a28847b *R/html_escape.R
6d1092223fc65ce12e76a4703224b233 *R/html_print.R
3f7d768f6edd15ce343ad710631a1d7f *R/shim.R
703a409eb39851fbbd041fadb42f787a *R/tags.R
31064a678bc8589cfd29497262ba2110 *R/template.R
bb2cbc6345684f3516c805d698b4eefd *R/utils.R
ebcfaa458d3bdefadded43a4d64cfff9 *man/HTML.Rd
c00712c215b7bbb80a6287fee17f3c24 *man/as.tags.Rd
88494342535e91fa8972fd2fc3f1fde5 *man/browsable.Rd
ebd0327fe98bb6f981b63e78bc87573c *man/builder.Rd
bcfebb5f9577a5013fe33242fdec9645 *man/copyDependencyToDir.Rd
11bd91091ffdde442e05a6a26823a84d *man/css.Rd
83f5a6962792ba50b19b48dc1c65fd39 *man/findDependencies.Rd
b1b2d807ab611007bdf9b582b64e5f24 *man/htmlDependencies.Rd
4cc3043f0c5c76a0c5efd1b76e56c865 *man/htmlDependency.Rd
91c1824deb08f57376108765fd29dbaa *man/htmlEscape.Rd
475bf569370053b828bf69e4bb283825 *man/htmlPreserve.Rd
516afef01fac034a4e414e7515a7b71e *man/htmlTemplate.Rd
f0a6e81826dcaf3e212e70c63e67189e *man/html_print.Rd
4f34e99b07220d7a2fa41b9029a16862 *man/include.Rd
93bd5afcdac04bc4c5322122f0710e75 *man/knitr_methods.Rd
2b18a3612062f7783435b8dfd1e215f4 *man/makeDependencyRelative.Rd
16159aa45a251fb364e5fd1fd144d1d7 *man/print.html.Rd
504914f9f04e3a96f20d707b5acc341f *man/renderDependencies.Rd
dee26db7dd1d20fc2f13746ef9e9ae1d *man/renderDocument.Rd
5943238916b4b5866e49846183c95f98 *man/renderTags.Rd
3d7d639046044b164f7dabe61158c67d *man/resolveDependencies.Rd
3e8fac6287e21baa2e492fb2e581689b *man/save_html.Rd
72d8cd938a5a644116813539b07d0576 *man/singleton.Rd
0c319382fa19718f0d0da795c20501ce *man/singleton_tools.Rd
f0de725705e4f99a532bc4a9cc58664c *man/subtractDependencies.Rd
127fb8880888366a5c37c0b3b7eac069 *man/suppressDependencies.Rd
df8aedfe5f09b706b63f0ccc794e2c35 *man/tag.Rd
cd3894dd85e4d84cc4ff5dc2a567fd4b *man/urlEncodePath.Rd
7a0539a65dfed6e9800e2ad05ad23a99 *man/validateCssUnit.Rd
dec0c8e4a1f951e26daa06e9c07f986b *man/withTags.Rd
a3bc32ca1f09a635b613292beeb3e853 *src/RcppExports.cpp
87cb57c5efad396def5773f9e24fed9c *src/init.c
f7dbf02b3735f8a64fb1cc9264416713 *src/template.cpp
d5386f261693f9f4a5dda7b6fe0aa9f0 *tests/test-all.R
fe57ef256876fb7bf2d9e0d293af40ee *tests/testthat/helper-locale.R
4de059d582d96a7c86907beb670b819d *tests/testthat/template-basic.html
ce9c101bbebef449d432567b9a29e9f9 *tests/testthat/template-document.html
aeb126c7b70dbba107d1f34db7d58bd6 *tests/testthat/test-deps.r
99d991b538945a2f666a91662bb98dc9 *tests/testthat/test-print.R
08e141fd9388084eca92de7a1491ce49 *tests/testthat/test-tags.r
4d4ac07bbbe282378629573247b2d973 *tests/testthat/test-template.R
e60a118b02ff97b60c7f250b325052dc *tests/testthat/test-textwriter.r
6ab125c619567f262252383e8e1236ae *tests/testthat/test-whitespace.r