Nothing
# nolint start
# This file is taken directly from https://github.com/hadley/staticdocs/blob/master/R/to-html.r
# All @export tags were removed as it is only for internal use
# to_html.examples will now just return
#
#' Convert an rdoc to a list of html components.
#'
#' All span-level tags are converted to html, and higher level blocks are
#' returned as components of the list.
#'
#' @return A list, suitable for rendering with
#' \code{\link[whisker]{whisker.render}}
#' @param x rd object to convert to html
#' @param ... other arguments passed onto to methods
#' @author Hadley Wickham from hadley/staticdocs
#' @export
to_html <- function(x, ...) {
UseMethod("to_html")
}
# Parse a complete Rd file
#' @export
to_html.Rd_doc <- function(x, ...) {
tags <- vapply(x, tag, FUN.VALUE = character(1))
get_tags <- function(tag) x[tags == tag]
get_tag <- function(tag) {
if (tag %in% tags) {
x[[which(tags == tag)]]
}
}
# Remove line breaks between sections
line_breaks <- tags == "TEXT"
x <- x[!line_breaks]
tags <- tags[!line_breaks]
out <- list()
# Capture name, title and aliasess
out$name <- to_html(get_tag("name"), ...)
out$title <- to_html(get_tag("title"), ...)
out$aliases <- vapply(get_tags("alias"), to_html, character(1), ...)
out$keywords <- vapply(get_tags("keyword"), to_html, character(1), ...)
out$usage <- to_html(get_tag("usage"), ...)
out$arguments <- to_html(get_tag("arguments"), ...)
if (length(out$arguments)) {
out$has_args <- TRUE # Work around mustache deficiency
}
out$author <- to_html(get_tag("author"), ...)
out$seealso <- to_html(get_tag("seealso"), ...)
out$examples <- to_html(get_tag("examples"), ...)
# Everything else stays in original order, and becomes a list of sections.
sections <- x[!(tags %in% c("name", "title", "alias", "keyword",
"usage", "author", "seealso", "arguments", "examples"))]
out$sections <- compact(to_html(sections, topic = out$name, ...))
out
}
# A list of elements should stay as a list
#' @export
to_html.list <- function(x, ...) {
lapply(x, to_html, ...)
}
# Elements that don't return anything ----------------------------------------
#' @export
to_html.NULL <- function(x, ...) character(0)
#' @export
to_html.COMMENT <- function(x, ...) character(0)
#' @export
to_html.dontshow <- function(x, ...) character(0)
#' @export
to_html.testonly <- function(x, ...) character(0)
#' @export
to_html.concept <- function(x, ...) character(0)
# Various types of text ------------------------------------------------------
# All components inside a text string should be collapsed into a single string
# Also need to do html escaping here and in to_html.RCODE
#' @export
to_html.TEXT <- function(x, ...) {
str_c(unlist(to_html.list(x, ...)), collapse = "")
}
#' @export
to_html.RCODE <- to_html.TEXT
#' @export
to_html.LIST <- to_html.TEXT
#' @export
to_html.VERB <- to_html.TEXT
# If it's a character vector, we've got to the leaves of the tree
#' @export
to_html.character <- function(x, ...) x
#' @export
to_html.name <- function(x, ...) to_html(x[[1]], ...)
#' @export
to_html.title <- function(x, ...) to_html.TEXT(x, ...)
#' @export
to_html.usage <- function(x, pkg, ...) {
text <- paste(to_html.TEXT(x, ...), collapse = "\n")
text <- str_trim(text)
# It's nice not to wrap in the middle of a simple "arg = default"
text <- str_replace_all(text, " = ", " = ")
# Wrap each individual function in its own div, so that text-indent
# CSS rules can be used effectively
text <- str_replace_all(text, "\n\n", "</div>\n<div>")
text <- paste0("<div>", text, "</div>")
# Collapse all hardcoded hanging indents
text <- str_replace_all(text, "\n +", " ")
src_highlight(text, pkg$rd_index)
}
#' @export
to_html.alias <- function(x, ...) unlist(to_html.list(x, ...))
#' @export
to_html.keyword <- function(x, ...) unlist(to_html.list(x, ...))
#' @export
to_html.seealso <- function(x, ...) to_html.TEXT(x, ...)
#' @export
to_html.author <- function(x, ...) to_html.TEXT(x, ...)
# Sections get a element called text and an element called content, which
# contains a list of paragraphs.
#' @export
to_html.details <- function(x, ...) parse_section(x, "Details", ...)
#' @export
to_html.description <- function(x, ...) parse_section(x, "Description", ...)
#' @export
to_html.value <- function(x, ...) {
# Note that \value is implicitly a \describe environment
class(x) <- c("describe", class(x))
text <- to_html(x, ...)
paras <- str_trim(str_split(text, "\\n\\s*\\n")[[1]])
list(title = "Value", contents = paras)
}
#' @export
to_html.references <- function(x, ...) parse_section(x, "References", ...)
#' @export
to_html.source <- function(x, ...) parse_section(x, "Source", ...)
#' @export
to_html.format <- function(x, ...) parse_section(x, "Format", ...)
#' @export
to_html.note <- function(x, ...) parse_section(x, "Note", ...)
#' @export
to_html.section <- function(x, ...) {
parse_section(x[[2]], to_html(x[[1]], ...), ...)
}
parse_section <- function(x, title, ...) {
text <- to_html.TEXT(x, ...)
paras <- str_trim(str_split(text, "\\n\\s*\\n")[[1]])
list(title = title, contents = paras)
}
# Examples ------------------------------------------------------------------
#' @importFrom evaluate evaluate
#' @export
to_html.examples <- function(x, pkg, topic = "unknown", env = new.env(parent = globalenv()), ...) {
# if (!pkg$examples)
return()
# # First element of examples tag is always empty
# text <- to_html.TEXT(x[-1], ...)
# expr <- evaluate(text, env, new_device = TRUE)
#
# replay_html(expr, pkg = pkg, name = str_c(topic, "-"))
}
# Arguments ------------------------------------------------------------------
#' @export
to_html.arguments <- function(x, ...) {
items <- Filter(function(x) tag(x) == "item", x)
to_html(items, ...)
}
#' @export
to_html.item <- function(x, ...) {
# If no subelements, then is an item from a itemise or enumerate, and
# is dealt with those methods
if (length(x) == 0) return()
list(name = to_html(x[[1]], ...), description = to_html.TEXT(x[[2]], ...))
}
# Equations ------------------------------------------------------------------
#' @export
to_html.eqn <- function(x, pkg, ...) {
stopifnot(length(x) <= 2)
ascii_rep <- x[[length(x)]]
if (pkg$mathjax){
str_c("$", to_html.TEXT(ascii_rep, ...), "$")
}else{
str_c("<code class = 'eq'>", to_html.TEXT(ascii_rep, ...), "</code>")
}
}
#' @export
to_html.deqn <- function(x, pkg, ...) {
stopifnot(length(x) <= 2)
if (pkg$mathjax){
str_c("$$", to_html.TEXT(x[[length(x)-1]], ...), "$$")
}else{
str_c("<pre class = 'eq'>", to_html.TEXT(x[[length(x)]], ...), "</pre>")
}
}
# Links ----------------------------------------------------------------------
#' @export
to_html.url <- function(x, ...) {
stopifnot(length(x) == 1)
str_c("<a href = '", to_html.TEXT(x[[1]]), "'>", to_html.TEXT(x[[1]]), "</a>")
}
#' @export
to_html.href <- function(x, ...) {
stopifnot(length(x) == 2)
str_c("<a href = '", to_html.TEXT(x[[1]]), "'>", to_html.TEXT(x[[2]]),
"</a>")
}
#' @export
to_html.email <- function(x, ...) {
stopifnot(length(x) %in% c(1L, 2L))
str_c("<a href='mailto:", x[[1]], "'>", x[[length(x)]], "</a>")
}
# If single, need to look up alias to find file name and package
#' @export
to_html.link <- function(x, pkg, ...) {
stopifnot(length(x) == 1)
opt <- attr(x, "Rd_option")
if (is.null(opt)) {
topic <- to_html.TEXT(x[[1]])
label <- topic
t_package <- NULL
} else if (str_sub(opt, 1, 1) == "=") {
topic <- str_sub(opt, 2, -1)
label <- to_html.TEXT(x[[1]])
t_package <- NULL
} else {
topic <- to_html.TEXT(x[[1]])
label <- topic
parts <- str_match(opt, '([^:]+):(.*)')[1,]
if (is.na(parts[1])) {
t_package <- opt
} else {
topic <- parts[3]
t_package <- parts[2]
}
}
loc <- find_topic(topic, t_package, pkg$rd_index)
if (is.null(loc)) {
message("Can't find help topic ", topic)
return(topic)
}
make_link(loc, label, pkg)
}
make_link <- function(loc, label, pkg = NULL) {
if (is.null(loc$package)) {
str_c("<a href='", loc$file, "'>", label, "</a>")
# } else if (loc$package %in% builtin_packages) {
# str_c("<a href='http://www.inside-r.org/r-doc/", loc$package,
# "/", loc$topic, "'>", label, "</a>")
# } else {
# str_c("<a href='http://www.inside-r.org/packages/cran/", loc$package,
# "/docs/", loc$topic, "'>", label, "</a>")
# }
} else {
# point to Data Camp's R documentation website
str_c("<a href='http://www.rdocumentation.org/packages/", loc$package,
"/topics/", loc$topic, "'>", label, "</a>")
}
}
builtin_packages <- c("base", "boot", "class", "cluster", "codetools", "compiler",
"datasets", "foreign", "graphics", "grDevices", "grid", "KernSmooth",
"lattice", "MASS", "Matrix", "methods", "mgcv", "nlme", "nnet",
"parallel", "rpart", "spatial", "splines", "stats", "stats4",
"survival", "tcltk", "tools", "utils")
# Miscellaneous --------------------------------------------------------------
# First element of enc is the encoded version (second is the ascii version)
#' @export
to_html.enc <- function(x, ...) {
to_html(x[[1]], ...)
}
#' @export
to_html.dontrun <- function(x, ...) {
if (length(x) == 1) {
str_c("## Not run: " , to_html.TEXT(x))
} else {
str_c(
"## Not run: " ,
str_replace_all(to_html.TEXT(x, ...), "\n", "\n# "),
"## End(Not run)"
)
}
}
#' @export
to_html.special <- function(x, ...) {
txt <- to_html.TEXT(x, ...)
# replace '<' and '>' with html markings avoid browser misinterpretation
txt <- str_replace_all(txt, "<", "<")
txt <- str_replace_all(txt, ">", ">")
txt <- str_replace_all(txt, "\\\\dots", "...")
stupid <- unlist(str_match_all(txt, "\\\\[a-zA-Z]*"))
for (i in seq_len(length(stupid))) {
message("Unknown tag (", stupid[i], ") found in 'special' tag")
}
str_c("<em>", txt, "</em>")
}
#' @export
to_html.method <- function(x, ...) {
str_c('"', to_html(x[[1]], ...), '"')
}
#' @export
to_html.S3method <- to_html.method
#' @export
to_html.S4method <- to_html.method
#' @export
to_html.docType <- function(...) NULL
# Conditionals and Sexprs ----------------------------------------------------
#' @export
#' @importFrom tools parse_Rd
to_html.Sexpr <- function(x, env, ...) {
code <- to_html.TEXT(x)
expr <- eval(parse(text = code), env)
con <- textConnection(expr)
on.exit(close(con))
rd <- parse_Rd(con, fragment = TRUE)
rd <- structure(set_classes(rd), class = c("Rd_doc", "Rd"))
to_html.TEXT(rd, ...)
}
#' @export
to_html.if <- function(x, ...) {
if (x[[1]] != "html") return()
x[[2]]
}
#' @export
to_html.ifelse <- function(x, ...) {
if (x[[1]] == "html") x[[2]] else x[[3]]
}
# Tables ---------------------------------------------------------------------
#' @export
to_html.tabular <- function(x, ...) {
align_abbr <- str_split(to_html(x[[1]], ...), "")[[1]][-1]
align_abbr <- align_abbr[!(align_abbr %in% c("|", ""))]
align <- unname(c("r" = "right", "l" = "left", "c" = "center")[align_abbr])
contents <- x[[2]]
row_sep <- vapply(contents, function(x) tag(x) == "cr",
FUN.VALUE = logical(1))
col_sep <- vapply(contents, function(x) tag(x) == "tab",
FUN.VALUE = logical(1))
last <- rev(which(row_sep))[1] - 1L
contents <- contents[seq_len(last)]
cell_grp <- cumsum(col_sep | row_sep)[seq_len(last)]
cells <- split(contents, cell_grp)
cell_contents <- vapply(cells, to_html.TEXT, ...,
FUN.VALUE = character(1), USE.NAMES = FALSE)
cell_contents <- str_c("<td>", cell_contents, "</td>\n")
cell_contents <- matrix(cell_contents, ncol = length(align), byrow = TRUE)
rows <- apply(cell_contents, 1, str_c, collapse = "")
str_c("<table>", str_c("<tr>", rows, "</tr>", collapse = ""), "</table>")
}
#' @export
to_html.tab <- function(x, ...) character(0)
#' @export
to_html.cr <- function(x, ...) character(0)
# List -----------------------------------------------------------------------
#' @export
to_html.itemize <- function(x, ...) {
str_c("<ul>\n", parse_items(x[-1], ...), "</ul>\n")
}
#' @export
to_html.enumerate <- function(x, ...) {
str_c("<ol>\n", parse_items(x[-1], ...), "</ol>\n")
}
#' @export
to_html.describe <- function(x, ...) {
if (attr(x, "Rd_tag") == "\\describe") {
str_c("<dl>\n", parse_descriptions(x, ...), "</dl>\n")
} else {
str_c("<dl>\n", parse_descriptions(x[-1], ...), "</dl>\n")
}
}
parse_items <- function(rd, ...) {
separator <- vapply(rd, function(x) tag(x) == "item",
FUN.VALUE = logical(1))
group <- cumsum(separator)
# remove empty first group, if present
rd <- rd[group != 0]
group <- group[group != 0]
items <- split(rd, group)
li <- vapply(items, function(x) {
str_c("<li>", to_html.TEXT(x, ...), "</li>\n")
}, FUN.VALUE = character(1))
str_c(li, collapse = "")
}
parse_descriptions <- function(rd, ...) {
is_item <- vapply(rd, function(x) tag(x) == "item",
FUN.VALUE = logical(1))
li <- character(length(rd))
for (i in seq_along(rd)) {
if (is_item[[i]])
li[i] <- str_c("<dt>", to_html.TEXT(rd[[i]][[1]], ...), "</dt><dd>", to_html.TEXT(rd[[i]][-1], ...), "</dd>\n")
else
li[i] <- to_html.TEXT(rd[i], ...)
}
str_c(li, collapse = "")
}
# Simple tags that need minimal processing -----------------------------------
#' @export
to_html.Rd_content <- function(x, ...) {
tag <- tag(x)
if (is.null(tag)) {
to_html.TEXT(x, ...)
} else if (!is.null(tag) && tag %in% names(simple_tags)) {
# If we can process tag with just prefix & suffix, do so
html <- simple_tags[[tag]]
str_c(html[1], to_html.TEXT(x, ...), html[2])
} else {
# Otherwise we don't know about this tag
message("Unknown tag: ", tag)
to_html.TEXT(x, ...)
}
}
simple_tags <- list(
"acronym" = c('<acronym>','</acronym>'),
"bold" = c("<b>", "</b>"),
"cite" = c("<cite>", "</cite>"),
"code" = c("<code>", "</code>"),
"command" = c("<code>", "</code>"),
"cr" = c("<br >", ""),
"dfn" = c("<dfn>", "</dfn>"),
"donttest" = c("", ""),
"dots" = c("...", ""),
"dquote" = c("“", "”"),
"dQuote" = c("“", "”"),
"emph" = c("<em>", "</em>"),
"env" = c('<span class = "env">', '</span>'),
"file" = c('‘<span class = "file">', '</span>’'),
"item" = c("<li>", "</li>"),
"kbd" = c("<kbd>", "</kbd>"),
"ldots" = c("...", ""),
"option" = c('<span class = "option">',"</span>"),
"out" = c("", ""),
"pkg" = c('<span class = "pkg">',"</span>"),
"preformatted" = c("<pre>","</pre>"),
"R" = c('<span style="R">R</span>', ""),
"samp" = c('<span class = "samp">',"</span>"),
"sQuote" = c("‘","’"),
"strong" = c("<strong>", "</strong>"),
"text" = c("<p>", "</p>"),
"var" = c("<var>", "</var>"),
"verb" = c("<code>", "</code>")
)
# nolint end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.