Nothing
# Reference page ---------------------------------------------------------------
# For testing
usage2text <- function(x) {
rd <- rd_text(paste0("\\usage{", x, "}"), FALSE)[[1]]
strip_html_tags(as_data(rd))
}
#' @export
as_data.tag_usage <- function(x, ...) {
text <- paste(flatten_text(x, ..., escape = FALSE), collapse = "\n")
text <- str_trim(text)
# Look for single line calls to non-syntactic functions (except for `=`
# since that's probably a single argument on its own line) and then use
# deparse1 to convert to standard style. We want to avoid reparsing
# any other lines to avoid losing whitespace, comments etc. (These
# are not generated by roxygen but can be added by the user.)
lines <- strsplit(text, "\n", fixed = TRUE)[[1]]
parsed <- lapply(lines, function(x) tryCatch(parse(text = x)[[1]], error = function(e) NULL))
needs_tweak <- function(x) {
is_call(x) && !is_call(x, "=") && (is_symbol(x[[1]]) && !is_syntactic(x[[1]]))
}
to_tweak <- vapply(parsed, needs_tweak, logical(1))
lines[to_tweak] <- vapply(parsed[to_tweak], deparse1, character(1))
text <- paste(lines, collapse = "\n")
highlight_text(text)
}
#' @export
as_html.tag_method <- function(x, ...) method_usage(x, "S3")
#' @export
as_html.tag_S3method <- function(x, ...) method_usage(x, "S3")
#' @export
as_html.tag_S4method <- function(x, ...) method_usage(x, "S4")
method_usage <- function(x, type) {
# Despite these being called from the as_html() generic, the target isn't
# actually HTML, but R code, which is turned into HTML by the syntax
# highlighting in as as_data.tag_usage()
fun <- as_html(x[[1]], escape = FALSE)
class <- as_html(x[[2]], escape = FALSE)
if (x[[2]] == "default") {
method <- sprintf(tr_("# Default %s method"), type)
} else {
method <- sprintf(tr_("# %s method for class '%s'"), type, class)
}
if (!is_syntactic(fun)) {
fun <- paste0("`", fun, "`")
}
paste0(method, "\n", fun)
}
# Reference index --------------------------------------------------------------
topic_funs <- function(rd) {
funs <- parse_usage(rd)
# Remove all methods for generics documented in this file
name <- purrr::map_chr(funs, "name")
type <- purrr::map_chr(funs, "type")
gens <- name[type == "fun"]
self_meth <- (name %in% gens) & (type %in% c("s3", "s4"))
funs <- purrr::map_chr(funs[!self_meth], ~ short_name(.$name, .$type, .$signature))
unique(funs)
}
parse_usage <- function(x) {
if (!inherits(x, "tag")) {
usage <- paste0("\\usage{", x, "}")
x <- rd_text(usage, fragment = FALSE)
}
r <- usage_code(x)
if (length(r) == 0) {
return(list())
}
exprs <- tryCatch(
parse_exprs(r),
error = function(e) {
cli::cli_warn("Failed to parse usage: {.code {r}}")
list()
}
)
purrr::map(exprs, usage_type)
}
short_name <- function(name, type, signature) {
name <- escape_html(name)
qname <- auto_quote(name)
if (type == "data") {
qname
} else if (type == "fun") {
if (is_infix(name)) {
qname
} else {
paste0(qname, "()")
}
} else {
sig <- paste0("<i><", escape_html(signature), "></i>", collapse = ",")
paste0(qname, "(", sig, ")")
}
}
# Given single expression generated from usage_code, extract
usage_type <- function(x) {
if (is_symbol(x)) {
list(type = "data", name = as.character(x))
} else if (is_call(x, "data")) {
list(type = "data", name = as.character(x[[2]]))
} else if (is.call(x)) {
if (identical(x[[1]], quote(`<-`))) {
replacement <- TRUE
x <- x[[2]]
} else {
replacement <- FALSE
}
out <- fun_info(x)
out$replacement <- replacement
out$infix <- is_infix(out$name)
if (replacement) {
out$name <- paste0(out$name, "<-")
}
out
} else {
untype <- paste0(typeof(x), " (in ", as.character(x), ")")
cli::cli_abort(
"Unknown type: {.val {untype}}",
call = caller_env()
)
}
}
is_infix <- function(x) {
if (is.null(x)) {
return(FALSE)
}
x <- as.character(x)
ops <- c(
"+", "-", "*", "^", "/",
"==", ">", "<", "!=", "<=", ">=",
"&", "|",
"[[", "[", "$"
)
grepl("^%.*%$", x) || x %in% ops
}
fun_info <- function(fun) {
stopifnot(is.call(fun))
if (is.call(fun[[1]])) {
x <- fun[[1]]
if (identical(x[[1]], quote(S3method))) {
list(
type = "s3",
name = as.character(x[[2]]),
signature = as.character(x[[3]])
)
} else if (identical(x[[1]], quote(S4method))) {
list(
type = "s4",
name = as.character(x[[2]]),
signature = sub("^`(.*)`$", "\\1", as.character(as.list(x[[3]])[-1]))
)
} else if (is_call(x, c("::", ":::"))) {
# TRUE if fun has a namespace, pkg::fun()
list(
type = "fun",
name = call_name(fun)
)
} else {
cli::cli_abort(
"Unknown call: {.val {as.character(x[[1]])}}",
call = caller_env()
)
}
} else {
list(
type = "fun",
name = as.character(fun[[1]]),
signature = NULL
)
}
}
# usage_code --------------------------------------------------------------
# Transform Rd embedded inside usage into parseable R code
usage_code <- function(x) {
UseMethod("usage_code")
}
#' @export
usage_code.Rd <- function(x) {
usage <- purrr::detect(x, inherits, "tag_usage")
usage_code(usage)
}
#' @export
usage_code.NULL <- function(x) character()
# Tag without additional class use
#' @export
usage_code.tag <- function(x) {
if (!identical(class(x), "tag")) {
cli::cli_abort(
"Undefined tag in usage: {.val class(x)[[1]]}}",
call = caller_env()
)
}
paste0(purrr::flatten_chr(purrr::map(x, usage_code)), collapse = "")
}
#' @export
usage_code.tag_special <- function(x) {
paste0(purrr::flatten_chr(purrr::map(x, usage_code)), collapse = "")
}
#' @export
usage_code.tag_dots <- function(x) "..."
#' @export
usage_code.tag_ldots <- function(x) "..."
#' @export
usage_code.TEXT <- function(x) as.character(x)
#' @export
usage_code.RCODE <- function(x) as.character(x)
#' @export
usage_code.VERB <- function(x) as.character(x)
#' @export
usage_code.COMMENT <- function(x) character()
#' @export
usage_code.tag_S3method <- function(x) {
generic <- paste0(usage_code(x[[1]]), collapse = "")
class <- paste0(usage_code(x[[2]]), collapse = "")
paste0("S3method(`", generic, "`, ", class, ")")
}
#' @export
usage_code.tag_method <- usage_code.tag_S3method
#' @export
usage_code.tag_S4method <- function(x) {
generic <- paste0(usage_code(x[[1]]), collapse = "")
class <- strsplit(usage_code(x[[2]]), ",")[[1]]
class <- paste0("`", class, "`")
class <- paste0(class, collapse = ",")
paste0("S4method(`", generic, "`, list(", class, "))")
}
#' @export
usage_code.tag_usage <- function(x) {
paste0(purrr::flatten_chr(purrr::map(x, usage_code)), collapse = "")
}
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.