htmltools/0000755000176200001440000000000013545747370012316 5ustar liggesusershtmltools/NAMESPACE0000644000176200001440000000364013545702222013523 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(as.character,html) S3method(as.character,shiny.tag) S3method(as.character,shiny.tag.list) S3method(as.tags,character) S3method(as.tags,default) S3method(as.tags,html) S3method(as.tags,html_dependency) S3method(as.tags,shiny.tag) S3method(as.tags,shiny.tag.list) S3method(format,html) S3method(format,shiny.tag) S3method(format,shiny.tag.list) S3method(print,html) S3method(print,html_dependency) S3method(print,shiny.tag) S3method(print,shiny.tag.list) export("htmlDependencies<-") export(HTML) export(a) export(as.tags) export(attachDependencies) export(br) export(browsable) export(code) export(copyDependencyToDir) export(css) export(div) export(doRenderTags) export(em) export(extractPreserveChunks) export(findDependencies) export(h1) export(h2) export(h3) export(h4) export(h5) export(h6) export(hr) export(htmlDependencies) export(htmlDependency) export(htmlEscape) export(htmlPreserve) export(htmlTemplate) export(html_print) export(img) export(includeCSS) export(includeHTML) export(includeMarkdown) export(includeScript) export(includeText) export(is.browsable) export(is.singleton) export(knit_print.html) export(knit_print.shiny.tag) export(knit_print.shiny.tag.list) export(makeDependencyRelative) export(p) export(pre) export(renderDependencies) export(renderDocument) export(renderTags) export(resolveDependencies) export(restorePreserveChunks) export(save_html) export(singleton) export(span) export(strong) export(subtractDependencies) export(suppressDependencies) export(surroundSingletons) export(tag) export(tagAppendAttributes) export(tagAppendChild) export(tagAppendChildren) export(tagGetAttribute) export(tagHasAttribute) export(tagList) export(tagSetChildren) export(tags) export(takeSingletons) export(urlEncodePath) export(validateCssUnit) export(withTags) import(digest) import(rlang) import(utils) importFrom(Rcpp,sourceCpp) useDynLib(htmltools, .registration = TRUE) htmltools/man/0000755000176200001440000000000013545702222013054 5ustar liggesusershtmltools/man/htmlPreserve.Rd0000644000176200001440000000444713306600132016024 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{htmlPreserve} \alias{htmlPreserve} \alias{extractPreserveChunks} \alias{restorePreserveChunks} \title{Preserve HTML regions} \usage{ htmlPreserve(x) extractPreserveChunks(strval) restorePreserveChunks(strval, chunks) } \arguments{ \item{x}{A character vector of HTML to be preserved.} \item{strval}{Input string from which to extract/restore chunks.} \item{chunks}{The \code{chunks} element of the return value of \code{extractPreserveChunks}.} } \value{ \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). \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. \code{restorePreserveChunks} returns a character vector with the chunk IDs replaced with their original values. } \description{ Use "magic" HTML comments to protect regions of HTML from being modified by text processing tools. } \details{ 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. } \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 } htmltools/man/html_print.Rd0000644000176200001440000000133313306600132015513 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_print.R \name{html_print} \alias{html_print} \title{Implementation of the print method for HTML} \usage{ html_print(html, background = "white", viewer = getOption("viewer", utils::browseURL)) } \arguments{ \item{html}{HTML content to print} \item{background}{Background color for web page} \item{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.} } \value{ Invisibly returns the URL or path of the generated HTML page. } \description{ Convenience method that provides an implementation of the \code{\link[base:print]{print}} method for HTML content. } htmltools/man/makeDependencyRelative.Rd0000644000176200001440000000205413306600132017744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{makeDependencyRelative} \alias{makeDependencyRelative} \title{Make an absolute dependency relative} \usage{ makeDependencyRelative(dependency, basepath, mustWork = TRUE) } \arguments{ \item{dependency}{A single HTML dependency with an absolute path.} \item{basepath}{The path to the directory that \code{dependency} should be made relative to.} \item{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.} } \value{ 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}). } \description{ Change a dependency's absolute path to be relative to one of its parent directories. } \seealso{ \code{\link{copyDependencyToDir}} } htmltools/man/save_html.Rd0000644000176200001440000000105613306600132015317 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_print.R \name{save_html} \alias{save_html} \title{Save an HTML object to a file} \usage{ save_html(html, file, background = "white", libdir = "lib") } \arguments{ \item{html}{HTML content to print} \item{file}{File to write content to} \item{background}{Background color for web page} \item{libdir}{Directory to copy dependenies to} } \description{ Save the specified HTML object to a file, copying all of it's dependencies to the directory specified via \code{libdir}. } htmltools/man/validateCssUnit.Rd0000644000176200001440000000232513545702222016447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{validateCssUnit} \alias{validateCssUnit} \title{Validate proper CSS formatting of a unit} \usage{ validateCssUnit(x) } \arguments{ \item{x}{The unit to validate. Will be treated as a number of pixels if a unit is not specified.} } \value{ A properly formatted CSS unit of length, if possible. Otherwise, will throw an error. } \description{ Checks that the argument is valid for use as a CSS unit of length. } \details{ \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. } \examples{ validateCssUnit("10\%") validateCssUnit(400) #treated as '400px' } htmltools/man/renderTags.Rd0000644000176200001440000000315213306600132015432 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{renderTags} \alias{renderTags} \alias{doRenderTags} \title{Render tags into HTML} \usage{ renderTags(x, singletons = character(0), indent = 0) doRenderTags(x, indent = 0) } \arguments{ \item{x}{Tag object(s) to render} \item{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.)} \item{indent}{Initial indent level, or \code{FALSE} if no indentation should be used.} } \value{ \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. } } \code{doRenderTags} returns a simple \code{\link{HTML}} string. } \description{ 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.) } \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. } htmltools/man/tag.Rd0000644000176200001440000000467713545702222014134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{tag} \alias{tag} \alias{tagList} \alias{tagAppendAttributes} \alias{tagHasAttribute} \alias{tagGetAttribute} \alias{tagAppendChild} \alias{tagAppendChildren} \alias{tagSetChildren} \title{HTML Tag Object} \usage{ tagList(...) tagAppendAttributes(tag, ...) tagHasAttribute(tag, attr) tagGetAttribute(tag, attr) tagAppendChild(tag, child) tagAppendChildren(tag, ..., list = NULL) tagSetChildren(tag, ..., list = NULL) tag(`_tag_name`, varArgs, .noWS = NULL) } \arguments{ \item{...}{Unnamed items that comprise this list of tags.} \item{tag}{A tag to append child elements to.} \item{attr}{The name of an attribute.} \item{child}{A child element to append to a parent tag.} \item{list}{An optional list of elements. Can be used with or instead of the \code{...} items.} \item{_tag_name}{HTML tag name} \item{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.} \item{.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.} } \value{ An HTML tag object that can be rendered as HTML using \code{\link{as.character}()}. } \description{ \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. } \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)) } htmltools/man/findDependencies.Rd0000644000176200001440000000102013306600132016553 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{findDependencies} \alias{findDependencies} \title{Collect attached dependencies from HTML tag object} \usage{ findDependencies(tags, tagify = TRUE) } \arguments{ \item{tags}{A tag-like object to search for dependencies.} \item{tagify}{Whether to tagify the input before searching for dependencies.} } \value{ A list of \code{\link{htmlDependency}} objects. } \description{ Walks a hierarchy of tags looking for attached dependencies. } htmltools/man/htmlEscape.Rd0000644000176200001440000000077113306600132015425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_escape.R \name{htmlEscape} \alias{htmlEscape} \title{Escape HTML entities} \usage{ htmlEscape(text, attribute = FALSE) } \arguments{ \item{text}{Text to escape} \item{attribute}{Escape for use as an attribute value} } \value{ Character vector with escaped text. } \description{ 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 } htmltools/man/include.Rd0000644000176200001440000000246013306600132014760 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{include} \alias{include} \alias{includeHTML} \alias{includeText} \alias{includeMarkdown} \alias{includeCSS} \alias{includeScript} \title{Include Content From a File} \usage{ includeHTML(path) includeText(path) includeMarkdown(path) includeCSS(path, ...) includeScript(path, ...) } \arguments{ \item{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.} \item{...}{Any additional attributes to be applied to the generated tag.} } \description{ Load HTML, text, or rendered Markdown from a file and turn into HTML. } \details{ 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. } \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. The \code{includeMarkdown} function requires the \code{markdown} package. } htmltools/man/browsable.Rd0000644000176200001440000000165313306600132015320 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_print.R \name{browsable} \alias{browsable} \alias{is.browsable} \title{Make an HTML object browsable} \usage{ browsable(x, value = TRUE) is.browsable(x) } \arguments{ \item{x}{The object to make browsable or not.} \item{value}{Whether the object should be considered browsable.} } \value{ \code{browsable} returns \code{x} with an extra attribute to indicate that the value is browsable. \code{is.browsable} returns \code{TRUE} if the value is browsable, or \code{FALSE} if not. } \description{ 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. } \details{ You can override the default browsability of an HTML object by explicitly passing \code{browse = TRUE} (or \code{FALSE}) to the \code{print} function. } htmltools/man/renderDependencies.Rd0000644000176200001440000000164113306600132017123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{renderDependencies} \alias{renderDependencies} \title{Create HTML for dependencies} \usage{ renderDependencies(dependencies, srcType = c("href", "file"), encodeFunc = urlEncodePath, hrefFilter = identity) } \arguments{ \item{dependencies}{A list of \code{htmlDependency} objects.} \item{srcType}{The type of src paths to use; valid values are \code{file} or \code{href}.} \item{encodeFunc}{The function to use to encode the path part of a URL. The default should generally be used.} \item{hrefFilter}{A function used to transform the final, encoded URLs of script and stylsheet files. The default should generally be used.} } \value{ An \code{\link{HTML}} object suitable for inclusion in the head of an HTML document. } \description{ Create the appropriate HTML markup for including dependencies in an HTML document. } htmltools/man/singleton.Rd0000644000176200001440000000120713306600132015335 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{singleton} \alias{singleton} \alias{is.singleton} \title{Include content only once} \usage{ singleton(x, value = TRUE) is.singleton(x) } \arguments{ \item{x}{A \code{\link{tag}}, text, \code{\link{HTML}}, or list.} \item{value}{Whether the object should be a singleton.} } \description{ 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. } htmltools/man/singleton_tools.Rd0000644000176200001440000000235513306600132016562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{singleton_tools} \alias{singleton_tools} \alias{surroundSingletons} \alias{takeSingletons} \title{Singleton manipulation functions} \usage{ surroundSingletons(ui) takeSingletons(ui, singletons = character(0), desingleton = TRUE) } \arguments{ \item{ui}{Tag object or lists of tag objects. See \link{builder} topic.} \item{singletons}{Character vector of singleton signatures that have already been encountered (i.e. returned from previous calls to \code{takeSingletons}).} \item{desingleton}{Logical value indicating whether singletons that are encountered should have the singleton attribute removed.} } \value{ \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. \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). } \description{ Functions for manipulating \code{\link{singleton}} objects in tag hierarchies. Intended for framework authors. } htmltools/man/css.Rd0000644000176200001440000000323213306600132014123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{css} \alias{css} \title{CSS string helper} \usage{ css(..., collapse_ = "") } \arguments{ \item{...}{Named style properties, where the name is the property name and the argument is the property value. See Details for conversion rules.} \item{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.} } \description{ 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). } \details{ 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. } \examples{ padding <- 6 css( font.family = "Helvetica, sans-serif", margin = paste0(c(10, 20, 10, 20), "px"), "padding!" = if (!is.null(padding)) padding ) } htmltools/man/urlEncodePath.Rd0000644000176200001440000000061713306600132016074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{urlEncodePath} \alias{urlEncodePath} \title{Encode a URL path} \usage{ urlEncodePath(x) } \arguments{ \item{x}{A character vector.} } \description{ Encode characters in a URL path. This is the same as \code{\link[utils]{URLencode}} with \code{reserved = TRUE} except that \code{/} is preserved. } htmltools/man/builder.Rd0000644000176200001440000000540713545702222014777 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{builder} \alias{builder} \alias{tags} \alias{p} \alias{h1} \alias{h2} \alias{h3} \alias{h4} \alias{h5} \alias{h6} \alias{a} \alias{br} \alias{div} \alias{span} \alias{pre} \alias{code} \alias{img} \alias{strong} \alias{em} \alias{hr} \title{HTML Builder Functions} \usage{ tags p(..., .noWS = NULL) h1(..., .noWS = NULL) h2(..., .noWS = NULL) h3(..., .noWS = NULL) h4(..., .noWS = NULL) h5(..., .noWS = NULL) h6(..., .noWS = NULL) a(..., .noWS = NULL) br(..., .noWS = NULL) div(..., .noWS = NULL) span(..., .noWS = NULL) pre(..., .noWS = NULL) code(..., .noWS = NULL) img(..., .noWS = NULL) strong(..., .noWS = NULL) em(..., .noWS = NULL) hr(..., .noWS = NULL) } \arguments{ \item{...}{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)} \item{.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.} } \description{ Simple functions for constructing HTML documents. } \details{ 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}()}. } \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)) } \references{ \itemize{ \item W3C html specification about boolean attributes \url{https://www.w3.org/TR/html5/infrastructure.html#sec-boolean-attributes} } } htmltools/man/htmlTemplate.Rd0000644000176200001440000000210113306600132015765 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/template.R \name{htmlTemplate} \alias{htmlTemplate} \title{Process an HTML template} \usage{ htmlTemplate(filename = NULL, ..., text_ = NULL, document_ = "auto") } \arguments{ \item{filename}{Path to an HTML template file. Incompatible with \code{text_}.} \item{...}{Variable values to use when processing the template.} \item{text_}{A string to use as the template, instead of a file. Incompatible with \code{filename}.} \item{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.} } \description{ 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. } \seealso{ \code{\link{renderDocument}} } htmltools/man/resolveDependencies.Rd0000644000176200001440000000146213306600132017324 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{resolveDependencies} \alias{resolveDependencies} \title{Resolve a list of dependencies} \usage{ resolveDependencies(dependencies, resolvePackageDir = TRUE) } \arguments{ \item{dependencies}{A list of \code{\link{htmlDependency}} objects.} \item{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.} } \value{ dependencies A list of \code{\link{htmlDependency}} objects with redundancies removed. } \description{ 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. } htmltools/man/withTags.Rd0000644000176200001440000000206613306600132015131 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{withTags} \alias{withTags} \title{Evaluate an expression using \code{tags}} \usage{ withTags(code) } \arguments{ \item{code}{A set of tags.} } \description{ 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()}. } \details{ 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()}. } \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") ) ) } htmltools/man/knitr_methods.Rd0000644000176200001440000000104113306600132016201 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{knitr_methods} \alias{knitr_methods} \alias{knit_print.shiny.tag} \alias{knit_print.html} \alias{knit_print.shiny.tag.list} \title{Knitr S3 methods} \usage{ knit_print.shiny.tag(x, ...) knit_print.html(x, ...) knit_print.shiny.tag.list(x, ...) } \arguments{ \item{x}{Object to knit_print} \item{...}{Additional knit_print arguments} } \description{ These S3 methods are necessary to allow HTML tags to print themselves in knitr/rmarkdown documents. } htmltools/man/print.html.Rd0000644000176200001440000000137013306600132015433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{print.shiny.tag} \alias{print.shiny.tag} \alias{print.html} \title{Print method for HTML/tags} \usage{ \method{print}{shiny.tag}(x, browse = is.browsable(x), ...) \method{print}{html}(x, ..., browse = is.browsable(x)) } \arguments{ \item{x}{The value to print.} \item{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.} \item{...}{Additional arguments passed to print.} } \description{ S3 method for printing HTML that prints markup or renders HTML in a web browser. } htmltools/man/HTML.Rd0000644000176200001440000000107213306600132014077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{HTML} \alias{HTML} \title{Mark Characters as HTML} \usage{ HTML(text, ...) } \arguments{ \item{text}{The text value to mark with HTML} \item{...}{Any additional values to be converted to character and concatenated together} } \value{ The same value, but marked as HTML. } \description{ Marks the given text as HTML, which means the \link{tag} functions will know not to perform HTML escaping on it. } \examples{ el <- div(HTML("I like turtles")) cat(as.character(el)) } htmltools/man/htmlDependency.Rd0000644000176200001440000000726513351030577016322 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{htmlDependency} \alias{htmlDependency} \title{Define an HTML dependency} \usage{ htmlDependency(name, version, src, meta = NULL, script = NULL, stylesheet = NULL, head = NULL, attachment = NULL, package = NULL, all_files = TRUE) } \arguments{ \item{name}{Library name} \item{version}{Library version} \item{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.} \item{meta}{Named list of meta tags to insert into document head} \item{script}{Script(s) to include within the document head (should be specified relative to the \code{src} parameter).} \item{stylesheet}{Stylesheet(s) to include within the document (should be specified relative to the \code{src} parameter).} \item{head}{Arbitrary lines of HTML to insert into the document head} \item{attachment}{Attachment(s) to include within the document head. See Details.} \item{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}}).} \item{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.} } \value{ An object that can be included in a list of dependencies passed to \code{\link{attachDependencies}}. } \description{ 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. } \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. } htmltools/man/copyDependencyToDir.Rd0000644000176200001440000000265113306600132017252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{copyDependencyToDir} \alias{copyDependencyToDir} \title{Copy an HTML dependency to a directory} \usage{ copyDependencyToDir(dependency, outputDir, mustWork = TRUE) } \arguments{ \item{dependency}{A single HTML dependency object.} \item{outputDir}{The directory in which a subdirectory should be created for this dependency.} \item{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.} } \value{ The dependency with its \code{src} value updated to the new location's absolute path. } \description{ 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. } \details{ 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. } \seealso{ \code{\link{makeDependencyRelative}} can be used with the returned value to make the path relative to a specific directory. } htmltools/man/renderDocument.Rd0000644000176200001440000000255613306600132016321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/template.R \name{renderDocument} \alias{renderDocument} \title{Render an html_document object} \usage{ renderDocument(x, deps = NULL, processDep = identity) } \arguments{ \item{x}{An object of class \code{html_document}, typically generated by the \code{\link{htmlTemplate}} function.} \item{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.} \item{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.} } \description{ 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. } htmltools/man/as.tags.Rd0000644000176200001440000000072213306600132014674 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{as.tags} \alias{as.tags} \title{Convert a value to tags} \usage{ as.tags(x, ...) } \arguments{ \item{x}{Object to be converted.} \item{...}{Any additional parameters.} } \description{ 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}}. } htmltools/man/htmlDependencies.Rd0000644000176200001440000000330013306600132016602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{htmlDependencies} \alias{htmlDependencies} \alias{htmlDependencies<-} \alias{attachDependencies} \title{HTML dependency metadata} \usage{ htmlDependencies(x) htmlDependencies(x) <- value attachDependencies(x, value, append = FALSE) } \arguments{ \item{x}{An object which has (or should have) HTML dependencies.} \item{value}{An HTML dependency, or a list of HTML dependencies.} \item{append}{If FALSE (the default), replace any existing dependencies. If TRUE, add the new dependencies to the existing ones.} } \description{ Gets or sets the HTML dependencies associated with an object (such as a tag). } \details{ \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}}. } \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) } htmltools/man/suppressDependencies.Rd0000644000176200001440000000121413306600132017524 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/html_dependency.R \name{suppressDependencies} \alias{suppressDependencies} \title{Suppress web dependencies} \usage{ suppressDependencies(...) } \arguments{ \item{...}{Names of the dependencies to suppress. For example, \code{"jquery"} or \code{"bootstrap"}.} } \description{ 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. } \seealso{ \code{\link{htmlTemplate}} for more information about using HTML templates. \code{\link[htmltools]{htmlDependency}} } htmltools/man/subtractDependencies.Rd0000644000176200001440000000227613306600132017500 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{subtractDependencies} \alias{subtractDependencies} \title{Subtract dependencies} \usage{ subtractDependencies(dependencies, remove, warnOnConflict = TRUE) } \arguments{ \item{dependencies}{A list of \code{\link{htmlDependency}} objects from which dependencies should be removed.} \item{remove}{A list of \code{\link{htmlDependency}} objects indicating which dependencies should be removed, or a character vector indicating dependency names.} \item{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.} } \value{ A list of \code{\link{htmlDependency}} objects that don't intersect with \code{remove}. } \description{ 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. } htmltools/DESCRIPTION0000644000176200001440000000130713545747370014025 0ustar liggesusersPackage: htmltools Type: Package Title: Tools for HTML Version: 0.4.0 Author: RStudio, Inc. Maintainer: Joe Cheng Description: Tools for HTML generation and output. Depends: R (>= 2.14.1) Imports: utils, digest, Rcpp, rlang Suggests: markdown, testthat, withr Enhances: knitr License: GPL (>= 2) URL: https://github.com/rstudio/htmltools BugReports: https://github.com/rstudio/htmltools/issues RoxygenNote: 6.1.1 LinkingTo: Rcpp Encoding: UTF-8 Collate: 'RcppExports.R' 'html_dependency.R' 'html_escape.R' 'html_print.R' 'shim.R' 'utils.R' 'tags.R' 'template.R' NeedsCompilation: yes Packaged: 2019-10-04 17:43:48 UTC; jcheng Repository: CRAN Date/Publication: 2019-10-04 23:00:08 UTC htmltools/tests/0000755000176200001440000000000013100230764013435 5ustar liggesusershtmltools/tests/test-all.R0000644000176200001440000000007613100230764015310 0ustar liggesuserslibrary(testthat) library(htmltools) test_check("htmltools") htmltools/tests/testthat/0000755000176200001440000000000013545702222015303 5ustar liggesusershtmltools/tests/testthat/test-print.R0000644000176200001440000000274313545702222017545 0ustar liggesuserstest_that("print.html preserves dependencies for HTML()", { # Regression test for issue #125 dep <- htmlDependency("dummytestdep", "1.0", c(href="http://example.com/"), script = "test.js" ) url <- NULL op <- options(viewer = function(url) { url <<- url }) on.exit(options(op), add = TRUE) print(attachDependencies(HTML("test"), list(dep) ), browse = TRUE) result_contents <- readLines(url) expect_true(any(grepl("http://example.com/test.js", result_contents))) }) test_that("CRLF is properly handled", { txt <- paste(c("x", "y", ""), collapse = "\r\n") tmp <- tempfile(fileext = ".txt") on.exit(unlink(tmp), add = TRUE) writeBin(charToRaw(txt), tmp) obj <- tagList( includeHTML(tmp), includeCSS(tmp), includeMarkdown(tmp), includeScript(tmp), includeText(tmp), txt, HTML(txt) ) out <- tempfile(fileext = ".html") on.exit(unlink(out), add = TRUE) wd <- getwd() save_html(obj, out) # Verify that save_html doesn't alter working dir expect_identical(getwd(), wd) chr <- readChar(out, file.size(out)) expect_false(grepl("\r\r\n", chr)) expect_false(grepl("\r\r\n", as.character(obj))) }) test_that("Special characters are not re-encoded", { skip_on_cran() # https://github.com/rstudio/htmltools/pull/117 f <- tempfile(fileext = ".html") withr::with_options( list(encoding = "UTF-8"), { save_html(div("brûlée"), f) expect_true(any(grepl("brûlée", readLines(f)))) } ) }) htmltools/tests/testthat/test-template.R0000644000176200001440000002021413545702222020215 0ustar liggesuserscontext("templates") # Searches for an html dependency of format name[version], as in "d3[3.5.10]", # within the html-dependencies script tag findDep <- function(x, name, version) { deps <- sub( '.*.*', "\\1", x ) grepl(paste0(name, "[", version, "]"), deps, fixed = TRUE) } test_that("Code blocks are evaluated and rendered correctly", { template <- htmlTemplate("template-document.html", x = div(class = "foo", "bar") ) html <- renderDocument(template) expect_true(grepl('
bar
', html)) # With text_ argument template <- htmlTemplate(text_ = "a {{ foo + 1 }} b", foo = 10) expect_identical(as.character(as.character(template)), "a \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(']+jquery[^>]+>', html)) # Add dependency via a renderDocument template <- htmlTemplate("template-document.html", x = "") html <- renderDocument(template, dep) expect_true(findDep(html, "jquery", "9999")) expect_false(grepl(']+jquery[^>]+>', html)) }) test_that("Errors for mismatched brackets", { # Error if unmatched opening brackets expect_error(htmlTemplate(text_ = "text {{ code")) # No error if we didn't open a code block expect_identical( as.character(htmlTemplate(text_ = "code }} text")), "code }} text" ) # Error if unmatched brackets, when no leading or trailing space expect_error(htmlTemplate(text_ = "{{ code")) # No error if we didn't open a code block expect_identical( as.character(htmlTemplate(text_ = "code }}")), "code }}" ) }) test_that("Brackets at start or end of text", { # Code and text expect_identical( as.character(htmlTemplate(text_ = "text {{ code }} text", code = 1)), "text \n1\n text" ) expect_identical( as.character(htmlTemplate(text_ = "text{{code}}text", code = 1)), "text\n1\ntext" ) # No brackets expect_identical( as.character(htmlTemplate(text_ = "text", code = 1)), "text" ) # No leading or trailing text expect_identical( as.character(htmlTemplate(text_ = "{{ code }}", code = 1)), "1" ) expect_identical( as.character(htmlTemplate(text_ = " {{ code }}", code = 1)), " \n1" ) expect_identical( as.character(htmlTemplate(text_ = "{{ code }} ", code = 1)), "1\n " ) # Edge cases expect_identical(as.character(htmlTemplate(text_ = "")), "") expect_identical(as.character(htmlTemplate(text_ = "X")), "X") expect_identical(as.character(htmlTemplate(text_ = " ")), " ") expect_identical(as.character(htmlTemplate(text_ = "{{}}")), "") expect_identical(as.character(htmlTemplate(text_ = " {{}} ")), " \n ") expect_identical(as.character(htmlTemplate(text_ = "{{ }}")), "") expect_identical(as.character(htmlTemplate(text_ = "{{}}{{}}")), "") expect_identical(as.character(htmlTemplate(text_ = "{{1}}{{2}}")), "1\n2") expect_error(as.character(htmlTemplate(text_ = "{{"))) expect_error(as.character(htmlTemplate(text_ = " {{"))) expect_error(as.character(htmlTemplate(text_ = "{{ "))) expect_identical(as.character(htmlTemplate(text_ = "}}")), "}}") expect_identical(as.character(htmlTemplate(text_ = " }}")), " }}") expect_identical(as.character(htmlTemplate(text_ = "}} ")), "}} ") }) test_that("Template DFA edge cases", { # Single quotes expect_identical(as.character(htmlTemplate(text_ = "{{ '' }}")), "") expect_identical(as.character(htmlTemplate(text_ = " {{ '' }} ")), " \n\n ") expect_identical(as.character(htmlTemplate(text_ = "{{ '\\'' }}")), "'") expect_identical(as.character(htmlTemplate(text_ = "{{ '\\\\' }}")), "\\") expect_identical(as.character(htmlTemplate(text_ = "{{ '}}' }}")), "}}") # Double quotes expect_identical(as.character(htmlTemplate(text_ = '{{ "" }}')), '') expect_identical(as.character(htmlTemplate(text_ = ' {{ "" }} ')), ' \n\n ') expect_identical(as.character(htmlTemplate(text_ = '{{ "\\"" }}')), '"') expect_identical(as.character(htmlTemplate(text_ = '{{ "\\\\" }}')), '\\') expect_identical(as.character(htmlTemplate(text_ = '{{ "}}" }}')), '}}') # Backticks in code expect_identical(as.character(htmlTemplate(text_ = "{{ `}}`<-1 }}")), "1") expect_identical(as.character(htmlTemplate(text_ = "{{ `x\\`x`<-1 }}")), "1") # Percent operator - various delimiters in percent operator expect_identical( as.character(htmlTemplate(text_ = "a{{ `%'%` <- function(x, y) 1; 2 %'% 3 }}b")), "a\n1\nb" ) expect_identical( as.character(htmlTemplate(text_ = "a{{ `%}}%` <- function(x, y) 1; 2 %}}% 3 }}b")), "a\n1\nb" ) # Comments expect_identical( as.character(htmlTemplate(text_ = "a{{ 1 #2 }}b")), "a\n1\nb" ) expect_identical( as.character(htmlTemplate(text_ = "a{{ 1 #2\n3 }}b")), "a\n3\nb" ) expect_identical( as.character(htmlTemplate(text_ = "a{{ 1 #2'3 }}b")), "a\n1\nb" ) expect_identical( as.character(htmlTemplate(text_ = "a{{ 1 #2}3 }}b")), "a\n1\nb" ) }) htmltools/tests/testthat/test-tags.r0000644000176200001440000005703313545702222017411 0ustar liggesuserscontext("tags") test_that("Basic tag writing works", { expect_equal(as.character(tagList("hi")), "hi") expect_equal( as.character(tagList("one", "two", tagList("three"))), "one\ntwo\nthree") expect_equal( as.character(tags$b("one")), "one") expect_equal( as.character(tags$b("one", "two")), "\n one\n two\n") expect_equal( as.character(tagList(list("one"))), "one") expect_equal( as.character(tagList(list(tagList("one")))), "one") expect_equal( as.character(tagList(tags$br(), "one")), "
\none") }) test_that("Hanging commas don't break things", { expect_equal(as.character(tagList("hi",)), "hi") expect_equal(as.character(div("one",)), "
one
") # Multiple commas still throw expect_error(as.character(div("one",,)), "is empty") # Non-trailing commas still throw expect_error(as.character(div(,"one",)), "is empty") }) test_that("withTags works", { output_tags <- tags$div(class = "myclass", tags$h3("header"), tags$p("text here") ) output_withhtml <- withTags( div(class = "myclass", h3("header"), p("text here") ) ) expect_identical(output_tags, output_withhtml) # Check that current environment is searched x <- 100 expect_identical(tags$p(x), withTags(p(x))) # Just to make sure, run it in a function, which has its own environment foo <- function() { y <- 100 withTags(p(y)) } expect_identical(tags$p(100), foo()) }) test_that("HTML escaping in tags", { # Regular text is escaped expect_equivalent(format(div("")), "
<a&b>
") # Text in HTML() isn't escaped expect_equivalent(format(div(HTML(""))), "
") # Text in a property is escaped expect_equivalent(format(div(class = "", "text")), '
text
') # HTML() has no effect in a property like 'class' expect_equivalent(format(div(class = HTML(""), "text")), '
text
') }) test_that("Adding child tags", { tag_list <- list(tags$p("tag1"), tags$b("tag2"), tags$i("tag3")) # Creating nested tags by calling the tag$div function and passing a list t1 <- tags$div(class="foo", tag_list) expect_equal(length(t1$children), 1) expect_equal(length(t1$children[[1]]), 3) expect_equal(t1$children[[1]][[1]]$name, "p") expect_equal(t1$children[[1]][[1]]$children[[1]], "tag1") expect_equal(t1$children[[1]][[2]]$name, "b") expect_equal(t1$children[[1]][[2]]$children[[1]], "tag2") expect_equal(t1$children[[1]][[3]]$name, "i") expect_equal(t1$children[[1]][[3]]$children[[1]], "tag3") # div tag used as starting point for tests below div_tag <- tags$div(class="foo") # Appending each child t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChild(t2, tag_list[[2]]) t2 <- tagAppendChild(t2, tag_list[[3]]) t2a <- do.call(tags$div, c(tag_list, class="foo")) expect_identical(t2a, t2) # tagSetChildren, using list argument t2 <- tagSetChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagSetChildren, using ... arguments t2 <- tagSetChildren(div_tag, tag_list[[1]], tag_list[[2]], tag_list[[3]]) expect_identical(t2a, t2) # tagSetChildren, using ... and list arguments t2 <- tagSetChildren(div_tag, tag_list[[1]], list = tag_list[2:3]) expect_identical(t2a, t2) # tagSetChildren overwrites existing children t2 <- tagAppendChild(div_tag, p("should replace this tag")) t2 <- tagSetChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagAppendChildren, using list argument t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, list = tag_list[2:3]) expect_identical(t2a, t2) # tagAppendChildren, using ... arguments t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, tag_list[[2]], tag_list[[3]]) expect_identical(t2a, t2) # tagAppendChildren, using ... and list arguments t2 <- tagAppendChild(div_tag, tag_list[[1]]) t2 <- tagAppendChildren(t2, tag_list[[2]], list = list(tag_list[[3]])) expect_identical(t2a, t2) # tagAppendChildren can start with no children t2 <- tagAppendChildren(div_tag, list = tag_list) expect_identical(t2a, t2) # tagSetChildren preserves attributes x <- tagSetChildren(div(), HTML("text")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) # tagAppendChildren preserves attributes x <- tagAppendChildren(div(), HTML("text")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) }) test_that("Creating simple tags", { # Empty tag expect_identical( div(), structure( list(name = "div", attribs = dots_list(), children = list()), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # Tag with text expect_identical( div("text"), structure( list(name = "div", attribs = dots_list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # NULL attributes are dropped expect_identical( div(a = NULL, b = "value"), div(b = "value") ) # length-0 attributes are dropped expect_identical( div(a = character(), b = "value"), div(b = "value") ) # NULL children are dropped expect_identical( renderTags(div("foo", NULL, list(NULL, list(NULL, "bar"))))$html, renderTags(div("foo", "bar"))$html ) # length-0 children are dropped expect_identical( renderTags(div("foo", character(), list(character(), list(list(), "bar"))))$html, renderTags(div("foo", "bar"))$html ) # Numbers are coerced to strings expect_identical( renderTags(div(1234))$html, renderTags(div("1234"))$html ) }) test_that("Creating nested tags", { # Simple version # Note that the $children list should not have a names attribute expect_identical( div(class="foo", list("a", "b")), structure( list(name = "div", attribs = structure(list(class = "foo"), .Names = "class"), children = list(list("a", "b"))), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) ) # More complex version t1 <- withTags( div(class = "foo", p("child tag"), list( p("in-list child tag 1"), "in-list character string", p(), p("in-list child tag 2") ), "character string", 1234 ) ) # t1 should be identical to this data structure. # The nested list should be flattened, and non-tag, non-strings should be # converted to strings t1_full <- structure( list( name = "div", attribs = list(class = "foo"), children = list( structure(list(name = "p", attribs = list(), children = list("child tag")), class = "shiny.tag" ), structure(list(name = "p", attribs = list(), children = list("in-list child tag 1")), class = "shiny.tag" ), "in-list character string", structure(list(name = "p", attribs = list(), children = list()), class = "shiny.tag" ), structure(list(name = "p", attribs = list(), children = list("in-list child tag 2")), class = "shiny.tag" ), "character string", "1234" ) ), class = "shiny.tag" ) expect_identical(renderTags(t1)$html, renderTags(t1_full)$html) }) # The .noWS option was added in 0.3.6.9003; we may still encounter tags created # in an older version (perhaps saved to an RDS file and restored). They would # lack this element in their structure. test_that("Old tags without the .noWS option can still be rendered", { oldTag <- structure( list(name = "div", attribs = dots_list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) w <- WSTextWriter() tagWrite(oldTag, w) expect_identical( w$readAll(), "
text
\n" ) }) # We moved to rlang::dots_list in 0.3.6; we may still encounter tags created # in an older version (perhaps saved to an RDS file and restored). They would # use old-school lists. test_that("Old tags predating rlang::list2 can still be rendered", { oldTag <- structure( list(name = "div", attribs = list(), children = list("text")), .Names = c("name", "attribs", "children"), class = "shiny.tag" ) w <- WSTextWriter() tagWrite(oldTag, w) expect_identical( w$readAll(), "
text
\n" ) }) test_that("tag with noWS works",{ oneline <- tag("span", list(tag("strong", "Super strong", .noWS="outside"))) expect_identical(as.character(oneline), "Super strong") }) test_that("tag/s with invalid noWS fails fast", { expect_error(tag("span", .noWS="wrong")) expect_error(tags$a(.noWS="wrong")) }) test_that("Attributes are preserved", { # HTML() adds an attribute to the data structure (note that this is # different from the 'attribs' field in the list) x <- HTML("&&") expect_identical(attr(x, "html", TRUE), TRUE) expect_equivalent(format(x), "&&") # Make sure attributes are preserved when wrapped in other tags x <- div(HTML("&&")) expect_equivalent(x$children[[1]], HTML("&&")) expect_identical(attr(x$children[[1]], "html", TRUE), TRUE) expect_equivalent(format(x), "
&&
") # Deeper nesting x <- div(p(HTML("&&"))) expect_equivalent(x$children[[1]]$children[[1]], HTML("&&")) expect_identical(attr(x$children[[1]]$children[[1]], "html", TRUE), TRUE) expect_equivalent(format(x), "
\n

&&

\n
") }) test_that("Adding attributes to tags", { t1 <- tags$div("foo") # Adding attributes to empty tag expect_identical(t1$attribs, dots_list()) expect_identical( tagAppendAttributes(t1, class = "c1")$attribs, list(class = "c1") ) # Adding attribute with multiple values expect_identical( tagAppendAttributes(t1, class = "c1 c2")$attribs, list(class = "c1 c2") ) # Adding two different attributes expect_identical( tagAppendAttributes(t1, class = "c1", id = "foo")$attribs, list(class = "c1", id = "foo") ) # Adding attributes in two successive calls expect_identical( tagAppendAttributes( tagAppendAttributes(t1, class = "c1 c2"), class = "c3")$attribs, list(class = "c1 c2", class = "c3") ) t2 <- tags$div("foo", class = "c1") # Adding attributes on a tag with other attributes expect_identical( tagAppendAttributes(t2, id = "foo")$attribs, list(class = "c1", id = "foo") ) # Adding attributes on a tag with the same attribute expect_identical( tagAppendAttributes(t2, class = "c2")$attribs, list(class = "c1", class = "c2") ) }) test_that("Testing for attributes on tags", { t1 <- tags$div("foo", class = "c1", class = "c2", id = "foo") # Testing for attribute that does not exist expect_identical( tagHasAttribute(t1, "nope"), FALSE ) # Testing for an attribute that exists once expect_identical( tagHasAttribute(t1, "id"), TRUE ) # Testing for an attribute that exists multiple times expect_identical( tagHasAttribute(t1, "class"), TRUE ) # Testing for substring of an attribute that exists expect_identical( tagHasAttribute(t1, "clas"), FALSE ) # Testing for superstring of an attribute that exists expect_identical( tagHasAttribute(t1, "classes"), FALSE ) # Testing for attribute with empty value t2 <- tags$div("foo", foo = "") expect_identical( tagHasAttribute(t2, "foo"), TRUE ) # Testing for attribute with NULL value t3 <- tags$div("foo", foo = NULL) expect_identical( tagHasAttribute(t3, "foo"), FALSE ) }) test_that("Getting attributes from tags", { # Getting an attribute from a tag with no attributes t1 <- tags$div("foo") expect_identical( tagGetAttribute(t1, "class"), NULL ) t2 <- tags$div("foo", class = "c1") # Getting an attribute from a tag without the correct attribute expect_identical( tagGetAttribute(t2, "id"), NULL ) # Getting an attribute from a tag with the a single value for the attribute expect_identical( tagGetAttribute(t2, "class"), "c1" ) # Getting an attribute from a tag with multiple matching attributes t3 <- tags$div("foo", class = "c1", id = "foo", class = "c2") expect_identical( tagGetAttribute(t3, "class"), "c1 c2" ) # Getting an attribute from a tag where the attributes were factors t4 <- tags$div("foo", class = as.factor("c1"), class = as.factor("c2")) expect_identical( tagGetAttribute(t4, "class"), "c1 c2" ) # Getting a numeric attribute from a tag t5 <- tags$div("foo", class = 78) expect_identical( tagGetAttribute(t5, "class"), "78" ) }) test_that("NA attributes are rendered correctly", { expect_identical( as.character(tags$div("text", foo = NA)), '
text
' ) expect_identical( as.character(tags$div("text", class = "a", foo = NA)), '
text
' ) expect_identical( as.character(tags$div("text", class = "a", foo = NA, class = "b")), '
text
' ) # Multiple NA's are coalesced expect_identical( as.character(tags$div("text", class = "a", foo = NA, class = "b", foo = NA)), '
text
' ) # A non-NA value supersedes NA expect_identical( as.character(tags$div("text", class = "a", foo = NA, foo = "b")), '
text
' ) expect_identical( as.character(tags$div("text", class = "a", foo = "b", foo = NA, foo = "c")), '
text
' ) expect_identical( as.character(tags$div("text", class = "a", foo = "b", foo = NA, foo = NA, foo = "c")), '
text
' ) }) test_that("Flattening a list of tags", { # Flatten a nested list nested <- list( "a1", list( "b1", list("c1", "c2"), list(), "b2", list("d1", "d2") ), "a2" ) flat <- list("a1", "b1", "c1", "c2", "b2", "d1", "d2", "a2") expect_identical(flattenTags(nested), flat) # no-op for flat lists expect_identical(flattenTags(list(a="1", "b")), list(a="1", "b")) # numbers are coerced to character expect_identical(flattenTags(list(a=1, "b")), list(a="1", "b")) # empty list results in empty list expect_identical(flattenTags(list()), list()) # preserve attributes nested <- list("txt1", list(structure("txt2", prop="prop2"))) flat <- list("txt1", structure("txt2", prop="prop2")) expect_identical(flattenTags(nested), flat) }) test_that("Head and singleton behavior", { result <- renderTags(tagList( tags$head(singleton("hello")) )) expect_identical(result$html, HTML("")) expect_identical(result$head, HTML(" hello")) expect_identical(result$singletons, "089cce0335cf2bae2bcb08cc753ba56f8e1ea8ed") # Ensure that "hello" actually behaves like a singleton result2 <- renderTags(tagList( tags$head(singleton("hello")) ), singletons = result$singletons) expect_identical(result$singletons, result2$singletons) expect_identical(result2$head, HTML("")) expect_identical(result2$html, HTML("")) result3 <- renderTags(tagList( tags$head(singleton("hello"), singleton("hello")) )) expect_identical(result$singletons, result3$singletons) expect_identical(result3$head, HTML(" hello")) # Ensure that singleton can be applied to lists, not just tags result4 <- renderTags(list(singleton(list("hello")), singleton(list("hello")))) expect_identical(result4$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") expect_identical(result4$html, renderTags(HTML("hello"))$html) result5 <- renderTags(tagList(singleton(list(list("hello"))))) expect_identical(result5$html, renderTags("hello")$html) }) test_that("Factors are treated as characters, not numbers", { myfactors <- factor(LETTERS[1:3]) expect_identical( as.character(tags$option(value=myfactors[[1]], myfactors[[1]])), '' ) expect_identical( as.character(tags$option(value=myfactors[[1]], value='B', value=3, myfactors[[1]])), '' ) }) test_that("Unusual list contents are rendered correctly", { expect_identical(renderTags(list(NULL)), renderTags(HTML(""))) expect_identical(renderTags(list(100)), renderTags(HTML("100"))) expect_identical(renderTags(list(list(100))), renderTags(HTML("100"))) expect_identical(renderTags(list(list())), renderTags(HTML(""))) expect_identical(renderTags(NULL), renderTags(HTML(""))) }) test_that("Low-level singleton manipulation methods", { # Default arguments drop singleton duplicates and strips the # singletons it keeps of the singleton bit result1 <- takeSingletons(tags$div( singleton(tags$head(tags$script("foo"))), singleton(tags$head(tags$script("foo"))) )) expect_identical(result1$ui$children[[2]], NULL) expect_false(is.singleton(result1$ui$children[[1]])) # desingleton=FALSE means drop duplicates but don't strip the # singleton bit result2 <- takeSingletons(tags$div( singleton(tags$head(tags$script("foo"))), singleton(tags$head(tags$script("foo"))) ), desingleton=FALSE) expect_identical(result2$ui$children[[2]], NULL) expect_true(is.singleton(result2$ui$children[[1]])) result3 <- surroundSingletons(tags$div( singleton(tags$script("foo")), singleton(tags$script("foo")) )) expect_identical( renderTags(result3)$html, HTML("
") ) }) test_that("Indenting can be controlled/suppressed", { expect_identical( renderTags(tags$div("a", "b"))$html, HTML("
\n a\n b\n
") ) expect_identical( format(tags$div("a", "b")), "
\n a\n b\n
" ) expect_identical( renderTags(tags$div("a", "b"), indent = 2)$html, HTML("
\n a\n b\n
") ) expect_identical( format(tags$div("a", "b"), indent = 2), "
\n a\n b\n
" ) expect_identical( renderTags(tags$div("a", "b"), indent = FALSE)$html, HTML("
\na\nb\n
") ) expect_identical( format(tags$div("a", "b"), indent = FALSE), "
\na\nb\n
" ) expect_identical( renderTags(tagList(tags$div("a", "b")), indent = FALSE)$html, HTML("
\na\nb\n
") ) expect_identical( format(tagList(tags$div("a", "b")), indent = FALSE), "
\na\nb\n
" ) }) test_that("cssList tests", { expect_identical("", css()) expect_identical("", css()) expect_identical( css( font.family = 'Helvetica, "Segoe UI"', font_size = "12px", `font-style` = "italic", font.variant = NULL, "font-weight!" = factor("bold"), padding = c("10px", "9px", "8px") ), "font-family:Helvetica, \"Segoe UI\";font-size:12px;font-style:italic;font-weight:bold !important;padding:10px 9px 8px;" ) # Unnamed args not allowed expect_error(css("10")) expect_error(css(1, b=2)) # NULL and empty string are dropped expect_identical(css(a="", b = NULL, "c!" = NULL, d = character()), "") # We are dumb about duplicated properties. Probably don't do that. expect_identical(css(a=1, a=2), "a:1;a:2;") }) test_that("Non-tag objects can be coerced", { .GlobalEnv$as.tags.testcoerce1 <- function(x) { list(singleton(list("hello"))) } on.exit(rm("as.tags.testcoerce1", pos = .GlobalEnv), add = TRUE) # Make sure tag-coerceable objects are tagified result1 <- renderTags(structure(TRUE, class = "testcoerce1")) expect_identical(result1$html, HTML("hello")) expect_identical(result1$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") # Make sure tag-coerceable objects are tagified before singleton handling # occurs, but that over-flattening doesn't happen result2 <- renderTags(tagList( singleton(list("hello")), structure(TRUE, class = "testcoerce1") )) expect_identical(result2$html, HTML("hello")) expect_identical(result2$singletons, "110d1f0ef6762db2c6863523a7c379a697b43ea3") }) test_that("Latin1 and system encoding are converted to UTF-8", { #Sys.setlocale(, "Chinese") latin1_str <- rawToChar(as.raw(0xFF)) Encoding(latin1_str) <- "latin1" divLatin1 <- as.character(tags$div(latin1_str)) expect_identical( charToRaw(divLatin1), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0xc3, 0xbf, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e)) ) expect_identical(Encoding(divLatin1), "UTF-8") expect_identical(Encoding("\u4E11"), "UTF-8") divUTF8 <- as.character(tags$div("\u4E11")) expect_identical( charToRaw(divUTF8), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0xe4, 0xb8, 0x91, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e)) ) expect_identical(Encoding(divUTF8), "UTF-8") divMixed <- format(tags$div( "\u4E11", latin1_str, tags$span(a="\u4E11", latin1_str), tags$span(b=latin1_str, HTML("\u4E11")) )) expect_identical( charToRaw(divMixed), as.raw(c(0x3c, 0x64, 0x69, 0x76, 0x3e, 0x0a, 0x20, 0x20, 0xe4, 0xb8, 0x91, 0x0a, 0x20, 0x20, 0xc3, 0xbf, 0x0a, 0x20, 0x20, 0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x61, 0x3d, 0x22, 0xe4, 0xb8, 0x91, 0x22, 0x3e, 0xc3, 0xbf, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e, 0x0a, 0x20, 0x20, 0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x62, 0x3d, 0x22, 0xc3, 0xbf, 0x22, 0x3e, 0xe4, 0xb8, 0x91, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e, 0x0a, 0x3c, 0x2f, 0x64, 0x69, 0x76, 0x3e )) ) expect_identical(Encoding(divMixed), "UTF-8") # Encoding(HTML(latin1_str)) is "UTF-8" on Linux; even just # paste(latin1_str) returns a UTF-8 encoded string #expect_identical(Encoding(HTML(latin1_str)), "latin1") expect_identical(Encoding(format(HTML(latin1_str))), "UTF-8") expect_identical(Encoding(format(tagList(latin1_str))), "UTF-8") # ensure the latin1 attribute returns correctly after escaping latin1_str2 <- rawToChar(as.raw(c(0xff, 0x0d, 0x0a))) Encoding(latin1_str2) <- "latin1" spanLatin <- as.character(tags$span(latin1_str2, title = latin1_str2)) expect_identical(Encoding(spanLatin), "UTF-8") expect_identical( charToRaw(spanLatin), as.raw(c(0x3c, 0x73, 0x70, 0x61, 0x6e, 0x20, 0x74, 0x69, 0x74, 0x6c, 0x65, 0x3d, 0x22, 0xc3, 0xbf, 0x26, 0x23, 0x31, 0x33, 0x3b, 0x26, 0x23, 0x31, 0x30, 0x3b, 0x22, 0x3e, 0xc3, 0xbf, 0x0d, 0x0a, 0x3c, 0x2f, 0x73, 0x70, 0x61, 0x6e, 0x3e )) ) }) test_that("paste8 in Chinese locale works", { loc <- "Chinese" testthat::skip_if_not(is_locale_available(loc), "Chinese locale not available") withr::with_locale(c(LC_COLLATE=loc, LC_CTYPE=loc, LC_MONETARY=loc, LC_TIME=loc), { x <- "\377" Encoding(x) <- "latin1" expect_identical(x, "\Uff") expect_identical(Encoding(x), "latin1") y <- "\U4E2d" # Using \Uxxxx always is encoded as UTF-8 expect_identical(y, "\U4E2d") expect_identical(Encoding(y), "UTF-8") xy <- paste8(x, y) xy expect_identical(xy, "\Uff \U4E2d") expect_identical(Encoding(xy), "UTF-8") xy <- paste8(c(x, y), collapse = "") expect_identical(xy, "\Uff\U4E2d") expect_identical(Encoding(xy), "UTF-8") }) }) test_that("Printing tags works", { expect_identical( capture.output(print(tags$a(href = "#", "link"))), 'link' ) }) test_that("htmlEscape will try to coerce inputs to characters", { x <- list(a1 = "b", a2 = list("b1", "b2")) expect_identical( htmlEscape(x), as.character(x) ) }) htmltools/tests/testthat/template-document.html0000644000176200001440000000030013100230764021603 0ustar liggesusers {{ suppressDependencies("jquery") }} {{ headContent() }}
{{ x }}
UTF-8 chars:Δ★😎 htmltools/tests/testthat/test-deps.r0000644000176200001440000000651713545702222017407 0ustar liggesuserscontext("dependencies") format.html_dependency <- function(x, ...) { sprintf("%s v%s @ %s", x$name, x$version, format(x$src)) } print.html_dependency <- function(x, ...) { cat(format(x), "\n") invisible(x) } test_that("Dependency resolution works", { a1.1 <- htmlDependency("a", "1.1", c(href="/")) a1.2 <- htmlDependency("a", "1.2", c(href="/")) a1.2.1 <- htmlDependency("a", "1.2.1", c(href="/")) b1.0.0 <- htmlDependency("b", "1.0.0", c(href="/")) b1.0.1 <- htmlDependency("b", "1.0.1", c(href="/")) c1.0 <- htmlDependency("c", "1.0", c(href="/")) result1 <- resolveDependencies( list(a1.1, b1.0.0, b1.0.1, a1.2, a1.2.1, b1.0.0, b1.0.1, c1.0) ) expect_identical(result1, list(a1.2.1, b1.0.1, c1.0)) result2 <- subtractDependencies(result1, list(a1.1), warnOnConflict = FALSE) expect_identical(result2, list(b1.0.1, c1.0)) expect_warning(subtractDependencies(result1, list(a1.1))) }) test_that("Inline dependencies", { # Test out renderTags and findDependencies when tags are inline a1.1 <- htmlDependency("a", "1.1", c(href="/")) a1.2 <- htmlDependency("a", "1.2", c(href="/")) # tagLists ---------------------------------------------------------- x <- tagList(a1.1, div("foo"), "bar") expect_identical(findDependencies(x), dots_list(a1.1)) expect_identical(as.character(renderTags(x)$html), "
foo
\nbar") x <- tagList(a1.1, div("foo"), a1.2, "bar") expect_identical(findDependencies(x), dots_list(a1.1, a1.2)) expect_identical(as.character(renderTags(x)$html), "
foo
\nbar") # Mixing inline and attribute dependencies x <- attachDependencies(tagList(a1.1, div("foo"), "bar"), a1.2, append = TRUE) expect_identical(findDependencies(x), dots_list(a1.1, a1.2)) expect_identical(as.character(renderTags(x)$html), "
foo
\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), "
\n
foo
\n bar\n
") x <- div(div("foo"), a1.2, "bar", a1.1) expect_identical(findDependencies(x), list(a1.2, a1.1)) expect_identical(as.character(renderTags(x)$html), "
\n
foo
\n bar\n
") x <- attachDependencies(div(a1.1, div("foo"), "bar"), a1.2, append = TRUE) expect_identical(findDependencies(x), list(a1.1, a1.2)) expect_identical(as.character(renderTags(x)$html), "
\n
foo
\n bar\n
") # Passing normal lists to tagLists and tag functions --------------- x <- tagList(list(a1.1, div("foo")), "bar") expect_identical(findDependencies(x), dots_list(a1.1)) x <- div(list(a1.1, div("foo")), "bar") expect_identical(findDependencies(x), list(a1.1)) }) test_that("Modifying children using dependencies", { a1.1 <- htmlDependency("a", "1.1", c(href="/")) a1.2 <- htmlDependency("a", "1.2", c(href="/")) x <- tagAppendChild(div(a1.1), a1.2) expect_identical(findDependencies(x), list(a1.1, a1.2)) x <- tagAppendChild(div(a1.1), list(a1.2)) expect_identical(findDependencies(x), list(a1.1, a1.2)) x <- tagAppendChildren(div(), a1.1, list(a1.2)) expect_identical(findDependencies(x), list(a1.1, a1.2)) x <- tagSetChildren(div("foo", a1.1), a1.2) expect_identical(findDependencies(x), list(a1.2)) }) htmltools/tests/testthat/test-whitespace.r0000644000176200001440000000344613545702222020606 0ustar liggesuserscontext("whitespace") with(tags, { test_that("Whitespace directives basic tests", { # Default expect_identical( as.character( div( span( strong() ) ) ), paste(collapse = "\n", c( "
", " ", " ", " ", "
" )) ) expect_identical( as.character( div( span(.noWS = "before", strong() ) ) ), paste(collapse = "\n", c( "
", " ", " ", "
" )) ) expect_identical( as.character( div( span(.noWS = "after", strong() ) ) ), paste(collapse = "\n", c( "
", " ", " ", "
" )) ) expect_identical( as.character( div( span(.noWS =c("before", "after"), strong() ) ) ), paste(collapse = "\n", c( "
", " ", "
" )) ) expect_identical( as.character( div( span(.noWS = c("after-begin", "before-end"), strong() ) ) ), paste(collapse = "\n", c( "
", " ", "
" )) ) expect_identical( as.character( div(.noWS = c("after-begin", "before-end"), span(.noWS = "before", strong() ) ) ), paste(collapse = "\n", c( "
", " ", "
" )) ) }) }) htmltools/tests/testthat/helper-locale.R0000644000176200001440000000032113545702222020136 0ustar liggesusersis_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.html0000644000176200001440000000011413100230764021051 0ustar liggesusers {{ headContent() }} {{ body }} htmltools/tests/testthat/test-textwriter.r0000644000176200001440000000520713545702222020670 0ustar liggesuserscontext("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/0000755000176200001440000000000013545702324013073 5ustar liggesusershtmltools/src/init.c0000644000176200001440000000067213306600132014174 0ustar liggesusers#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.cpp0000644000176200001440000000673113100230764015410 0ustar liggesusers#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.cpp0000644000176200001440000000103613306600132016055 0ustar liggesusers// 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/NEWS0000644000176200001440000001101413545702222012775 0ustar liggesusershtmltools 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/0000755000176200001440000000000013545702222012502 5ustar liggesusershtmltools/R/html_print.R0000644000176200001440000000672113545702222015013 0ustar liggesusers#' 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.R0000644000176200001440000001235313100232533014432 0ustar liggesusers#' 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.R0000644000176200001440000001045013545702222013765 0ustar liggesusers# 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.R0000644000176200001440000000437313545702222013574 0ustar liggesusers# 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.R0000644000176200001440000013147313545702222013574 0ustar liggesusers#' @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]]), "")) } 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("")) } } 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(">")) } } 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.R0000644000176200001440000000241413306600132015102 0ustar liggesusers #' 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.R0000644000176200001440000004267513426136411016004 0ustar liggesusers#' 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.R0000644000176200001440000000031013306600132015100 0ustar liggesusers# 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/MD50000644000176200001440000000555313545747370012636 0ustar liggesusersdf990db30af45356fc973305d819f4d4 *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