Nothing
topic_add_r6_methods <- function(rd, block, env) {
r6data <- block_get_tag_value(block, ".r6data")
self <- r6data$self
methods <- self[self$type == "method", ]
methods <- methods[order(methods$file, methods$line), ]
methods$tags <- replicate(nrow(methods), list(), simplify = FALSE)
r6_tags <- c("description", "details", "param", "return", "examples")
del <- integer()
for (i in seq_along(block$tags)) {
tag <- block$tags[[i]]
# Not inline?
if (is.na(tag$line) || tag$line < block$line) next
# Not a method tag?
if (! tag$tag %in% r6_tags) next
del <- c(del, i)
meth <- find_method_for_tag(methods, tag)
if (is.na(meth)) {
warn_roxy_tag(tag, "Cannot find matching R6 method")
next
}
midx <- which(meth == methods$name)
methods$tags[[midx]] <- c(methods$tags[[midx]], list(tag))
del <- c(del, i)
}
methods <- add_default_methods(methods, block)
nodoc <- map_int(methods$tags, length) == 0
if (any(nodoc)) {
warn_roxy_block(block, "Undocumented R6 method{?s}: {methods$name[nodoc]}")
}
block$tags[del] <- NULL
# Now do the main tags first. We leave out the param tags, those are
# for the methods
for (tag in block$tags) {
if (! tag$tag %in% c("param", "field")) {
rd$add(roxy_tag_rd(tag, env = env, base_path = base_path))
}
}
# We need to add the whole thing as a big section.
rd_lines <- c(
r6_superclass(block, r6data, env),
r6_fields(block, r6data),
r6_active_bindings(block, r6data),
r6_methods(block, r6data, methods)
)
rd$add(rd_section("rawRd", paste(rd_lines, collapse = "\n")))
# Dump all method examples at the end of the examples block
ex_lines <- r6_all_examples(block, methods)
if (length(ex_lines) > 0) {
ex_txt <- paste0(r6_all_examples(block, methods), collapse = "\n")
rd$add(rd_section("examples", ex_txt), overwrite = FALSE)
}
}
add_default_methods <- function(methods, block) {
defaults <- list(
clone = list(
roxy_generated_tag(
block,
"description",
"The objects of this class are cloneable with this method."
),
roxy_generated_tag(
block,
"param",
list(name = "deep", description = "Whether to make a deep clone.")
)
)
)
for (mname in names(defaults)) {
mline <- match(mname, methods$name)
if (is.na(mline)) next
if (length(methods$tags[[mline]]) > 0) next
methods$tags[[mline]] <- defaults[[mname]]
}
methods
}
r6_superclass <- function(block, r6data, env) {
super <- r6data$super
cls <- unique(super$classes$classname)
if (length(cls) == 0) return()
lines <- character()
push <- function(...) lines <<- c(lines, ...)
title <- if (length(cls) > 1) "Super classes" else "Super class"
push(paste0("\\section{", title, "}{"))
pkgs <- super$classes$package[match(cls, super$classes$classname)]
has_topic <- purrr::map2_lgl(cls, pkgs, has_topic)
path <- ifelse(
has_topic,
sprintf("\\code{\\link[%s:%s]{%s::%s}}", pkgs, cls, pkgs, cls),
sprintf("\\code{%s::%s}", pkgs, cls)
)
me <- sprintf("\\code{%s}", block$object$value$classname)
push(paste(c(rev(path), me), collapse = " -> "))
push("}")
lines
}
r6_fields <- function(block, r6data) {
self <- r6data$self
fields <- self$name[self$type == "field"]
active <- self$name[self$type == "active"]
tags <- purrr::keep(
block$tags,
function(t) t$tag == "field" && ! t$val$name %in% active
)
labels <- gsub(",", ", ", map_chr(tags, c("val", "name")))
docd <- str_trim(unlist(strsplit(labels, ",")))
# Check for missing fields
miss <- setdiff(fields, docd)
if (length(miss) > 0) {
warn_roxy_block(block, "Undocumented R6 field{?s}: {miss}")
}
# Check for duplicate fields
dup <- unique(docd[duplicated(docd)])
if (length(dup) > 0) {
warn_roxy_block(block, "R6 field{?s} documented multiple times: {dup}")
}
# Check for extra fields
xtra <- setdiff(docd, fields)
if (length(xtra) > 0) {
warn_roxy_block(block, "Unknown R6 field{?s}: {xtra}")
}
if (length(docd) == 0) return()
# We keep the order of the documentation
vals <- map_chr(tags, c("val", "description"))
c("\\section{Public fields}{",
"\\if{html}{\\out{<div class=\"r6-fields\">}}",
"\\describe{",
paste0("\\item{\\code{", labels, "}}{", vals, "}", collapse = "\n\n"),
"}",
"\\if{html}{\\out{</div>}}",
"}"
)
}
r6_active_bindings <- function(block, r6data) {
self <- r6data$self
fields <- self$name[self$type == "field"]
active <- self$name[self$type == "active"]
tags <- purrr::keep(
block$tags,
function(t) t$tag == "field" && ! t$val$name %in% fields
)
labels <- gsub(",", ", ", map_chr(tags, c("val", "name")))
docd <- str_trim(unlist(strsplit(labels, ",")))
# Check for missing bindings
miss <- setdiff(active, docd)
if (length(miss) > 0) {
warn_roxy_block(block, "Undocumented R6 active binding{?s}: {miss}")
}
# Check for duplicate bindings
dup <- unique(docd[duplicated(docd)])
if (length(dup) > 0) {
warn_roxy_block(block, "R6 active binding{?s} documented multiple times: {dup}")
}
if (length(docd) == 0) return()
# We keep the order of the documentation
vals <- map_chr(tags, c("val", "description"))
c("\\section{Active bindings}{",
"\\if{html}{\\out{<div class=\"r6-active-bindings\">}}",
"\\describe{",
paste0("\\item{\\code{", labels, "}}{", vals, "}", collapse = "\n\n"),
"}",
"\\if{html}{\\out{</div>}}",
"}"
)
}
r6_methods <- function(block, r6data, methods) {
# And then the methods, if any
if (nrow(methods) == 0) return()
lines <- character()
push <- function(...) lines <<- c(lines, ...)
push("\\section{Methods}{")
push(r6_method_list(block, methods))
push(r6_inherited_method_list(block, r6data))
for (i in seq_len(nrow(methods))) {
push(r6_method_begin(block, methods[i,]))
push(r6_method_description(block, methods[i,]))
push(r6_method_usage(block, methods[i,]))
push(r6_method_params(block, methods[i,]))
push(r6_method_details(block, methods[i,]))
push(r6_method_return(block, methods[i,]))
push(r6_method_examples(block, methods[i,]))
push(r6_method_end(block, methods[i,]))
}
push("}")
lines
}
find_method_for_tag <- function(methods, tag) {
w <- which(
basename(methods$file) == basename(tag$file) &
methods$line > tag$line
)[1]
methods$name[w]
}
# vectorized
r6_show_name <- function(names) {
ifelse(names == "initialize", "new", names)
}
r6_method_list <- function(block, methods) {
nms <- r6_show_name(methods$name)
c("\\subsection{Public methods}{",
"\\itemize{",
sprintf(
"\\item \\href{#method-%s-%s}{\\code{%s$%s()}}",
methods$class,
nms,
block$object$alias,
nms
),
"}",
"}"
)
}
r6_inherited_method_list <- function(block, r6data) {
super <- r6data$super
if (is.null(super)) return()
# drop methods that were shadowed in a subclass
super_meth <- super$members[super$members$type == "method", ]
self <- r6data$self
super_meth <- super_meth[! super_meth$name %in% self$name, ]
super_meth <- super_meth[! duplicated(super_meth$name), ]
if (nrow(super_meth) == 0) {
return()
}
super_meth <- super_meth[rev(seq_len(nrow(super_meth))), ]
details <- paste0(
"<details",
if (nrow(super_meth) <= 5) " open",
"><summary>Inherited methods</summary>"
)
c("\\if{html}{\\out{", details,
"<ul>",
sprintf(
paste0(
"<li>",
"<span class=\"pkg-link\" data-pkg=\"%s\" data-topic=\"%s\" data-id=\"%s\">",
"<a href='../../%s/html/%s.html#method-%s-%s'><code>%s::%s$%s()</code></a>",
"</span>",
"</li>"
),
super_meth$package,
super_meth$classname,
super_meth$name,
super_meth$package,
super_meth$classname,
super_meth$classname,
super_meth$name,
super_meth$package,
super_meth$classname,
super_meth$name
),
"</ul>",
"</details>",
"}}"
)
}
r6_method_begin <- function(block, method) {
nm <- r6_show_name(method$name)
c(
"\\if{html}{\\out{<hr>}}",
paste0("\\if{html}{\\out{<a id=\"method-", method$class, "-", nm, "\"></a>}}"),
paste0("\\if{latex}{\\out{\\hypertarget{method-", method$class, "-", nm, "}{}}}"),
paste0("\\subsection{Method \\code{", nm, "()}}{")
)
}
r6_method_description <- function(block, method) {
det <- purrr::keep(method$tags[[1]], function(t) t$tag == "description")
# Add an empty line between @description tags, if there isn't one
# there already
txt <- map_chr(det, "val")
c(
sub("\n?\n?$", "\n\n", head(txt, -1)),
utils::tail(txt, 1)
)
}
r6_method_usage <- function(block, method) {
name <- paste0(block$object$alias, "$", r6_show_name(method$name))
fake <- paste(rep("X", nchar(name)), collapse = "")
usage <- format(function_usage(fake, method$formals[[1]]))
c(
"\\subsection{Usage}{",
paste0(
"\\if{html}{\\out{<div class=\"r\">}}",
"\\preformatted{", sub(paste0("^", fake), name, usage),
"}",
"\\if{html}{\\out{</div>}}"
),
"}\n"
)
}
r6_method_details <- function(block, method) {
det <- purrr::keep(method$tags[[1]], function(t) t$tag == "details")
# Add an empty line between @details tags, if there isn't one
# there already
txt <- map_chr(det, "val")
if (length(txt) == 0) return()
c(
"\\subsection{Details}{",
sub("\n?\n?$", "\n\n", head(txt, -1)),
utils::tail(txt, 1),
"}\n"
)
}
r6_method_params <- function(block, method) {
par <- purrr::keep(method$tags[[1]], function(t) t$tag == "param")
nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
# Each arg should appear exactly once
mnames <- str_trim(unlist(strsplit(nms, ",")))
dup <- unique(mnames[duplicated(mnames)])
for (m in dup) {
warn_roxy_block(block, c(
"Must use one @param for each argument",
x = "${method$name}({m}) is documented multiple times"
))
}
# Now add the missing ones from the class
fnames <- names(method$formals[[1]])
miss <- setdiff(fnames, mnames)
is_in_cls <- map_lgl(
block$tags,
function(t) {
!is.na(t$line) && t$line < block$line && t$tag == "param" &&
t$val$name %in% miss
}
)
par <- c(par, block$tags[is_in_cls])
# Check if anything is missing
nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
mnames <- str_trim(unlist(strsplit(nms, ",")))
miss <- setdiff(fnames, mnames)
for (m in miss) {
warn_roxy_block(block, c(
"Must use one @param for each argument",
x = "${method$name}({m}) is not documented"
))
}
if (length(par) == 0) return()
# Order them according to formals
firstnames <- str_trim(
map_chr(strsplit(map_chr(par, c("val", "name")), ","), 1)
)
par <- par[order(match(firstnames, fnames))]
val <- map_chr(par, c("val", "description"))
nms <- gsub(",", ", ", map_chr(par, c("val", "name")))
# Ready to go
c(
"\\subsection{Arguments}{",
"\\if{html}{\\out{<div class=\"arguments\">}}",
"\\describe{",
paste0("\\item{\\code{", nms, "}}{", val, "}", collapse = "\n\n"),
"}",
"\\if{html}{\\out{</div>}}",
"}"
)
}
r6_method_return <- function(block, method) {
ret <- purrr::keep(method$tags[[1]], function(t) t$tag == "return")
if (length(ret) == 0) return()
if (length(ret) > 1) {
warn_roxy_block(block, "Must use one @return per R6 method")
}
ret <- ret[[1]]
c(
"\\subsection{Returns}{",
ret$val,
"}"
)
}
r6_method_examples <- function(block, method) {
exa <- purrr::keep(method$tags[[1]], function(t) t$tag == "examples")
if (length(exa) == 0) return()
txt <- map_chr(exa, "val")
c("\\subsection{Examples}{",
paste0(
"\\if{html}{\\out{<div class=\"r example copy\">}}\n",
"\\preformatted{", txt, "\n",
"}\n",
"\\if{html}{\\out{</div>}}\n",
collapse = "\n"
),
"}\n"
)
}
r6_method_end <- function(block, method) {
c(
"}"
)
}
r6_all_examples <- function(block, methods) {
unlist(lapply(
seq_len(nrow(methods)),
function(i) {
exa <- purrr::keep(methods$tags[[i]], function(t) t$tag == "examples")
if (length(exa) == 0) return()
name <- paste0(block$object$alias, "$", r6_show_name(methods$name[i]))
c(
"\n## ------------------------------------------------",
paste0("## Method `", name, "`"),
"## ------------------------------------------------\n",
paste(map_chr(exa, "val"), collapse = "\n")
)
}))
}
first_five <- function(x) {
x <- encodeString(x, quote = "`")
if (length(x) > 5) x <- c(x[1:5], "...")
paste(x, 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.