#' @export
roxy_tag_parse.roxy_tag_describeIn <- function(x) {
if (!is.na(x$raw) && !str_detect(x$raw, "[[:space:]]+")) {
warn_roxy_tag(x, c(
"requires a name and description",
i = "Did you want @rdname instead?"
))
NULL
} else {
tag_two_part(x, "a topic name", "a description")
}
}
topic_add_describe_in <- function(topic, block, env) {
tag <- block_get_tag(block, "describeIn")
if (is.null(tag)) {
return()
}
if (is.null(block$object)) {
warn_roxy_tag(tag, "must be used with an object")
return()
}
if (block_has_tags(block, "name")) {
warn_roxy_tag(tag, "can not be used with @name")
return()
}
if (block_has_tags(block, "rdname")) {
warn_roxy_tag(tag, "can not be used with @rdname")
return()
}
if (is.null(object_name(block$object))) {
warn_roxy_tag(tag, "not supported with this object type")
return()
}
dest <- find_object(tag$val$name, env)
metadata <- build_minidesc_metadata(block$object, dest)
topic$add(rd_section_minidesc(
name = object_name(block$object),
desc = tag$val$description,
extends = metadata$extends,
generic = metadata$generic,
class = metadata$class
))
dest$topic
}
# Field -------------------------------------------------------------------
#' Record data for minidescription sections from `@describeIn`
#'
#' @param name name of the source function.
#' @param desc description passed to `@describeIn`.
#' @param extends how the source function extends the destination function:
#' - `"generic"` if the source extends a (S3 or S4) generic in the destination,
#' - `"class"` if the source extends an informal S3 or formal S4 constructor
#' in the destination.
#' For S3, there is always only *one* class.
#' For S4, the methods' signature is used instead, to cover multiple dispatch.
#' - `""` (default) otherwise.
#' @param generic,class name of the generic and class that is being extended by
#' the method, otherwise empty string (`""`).
#' @return a dataframe with one row for each `@describeIn`, wrapped inside
#' `rd_section()`
#' @noRd
rd_section_minidesc <- function(name,
desc,
extends = c("", "generic", "class"),
generic = "",
class = "") {
stopifnot(is_string(name))
stopifnot(is_character(desc))
rlang::arg_match(extends)
stopifnot(is_string(generic))
stopifnot(is_string(class))
data <- data.frame(
name = name,
desc = desc,
extends = extends,
generic = generic,
class = class,
stringsAsFactors = FALSE
)
rd_section("minidesc", data)
}
#' @export
merge.rd_section_minidesc <- function(x, y, ..., block) {
stopifnot(identical(class(x), class(y)))
rd_section("minidesc", rbind(x$value, y$value))
}
# Rd Output -------------------------------------------------------------------
#' @export
format.rd_section_minidesc <- function(x, ...) {
order <- intersect(c("generic", "class", ""), unique(x$value$extends))
by <- factor(x$value$extends, levels = order)
subsections <- split(x$value, by)
body <- purrr::map2_chr(subsections, names(subsections), format_section)
paste0(body, collapse = "\n")
}
format_section <- function(df, type) {
title <- switch(type,
class = "Methods (by generic)",
generic = "Methods (by class)",
"Functions"
)
bullets <- paste0("\\code{", df$name, "}: ", df$desc, "\n")
body <- paste0(
"\\itemize{\n",
paste0("\\item ", bullets, "\n", collapse = ""),
"}"
)
paste0("\\section{", title, "}{\n", body, "}")
}
# Helpers -----------------------------------------------------------------
# Imperfect:
# * will fail with S3 methods that need manual disambiguation (rare)
# * can't use if @name overridden, but then you could just the use alias
find_object <- function(name, env) {
if (methods::isClass(name, where = env)) {
object(methods::getClass(name, where = env), NULL, "s4class")
} else if (exists(name, envir = env)) {
object_from_name(name, env, NULL)
} else {
object(NULL, name, "data")
}
}
#' Build metadata for how to present `@describeIn` tag
#' @return list of character scalars named `extends`, `generic`, `class`.
#' See rd_section_minidesc() for details.
#' @noRd
build_minidesc_metadata <- function(src, dest) {
src_type <- class(src)[1]
dest_type <- class(dest)[1]
dest_name <- as.character(dest$topic)
if (src_type == "s3method") {
generic <- attr(src$value, "s3method")[1]
class <- attr(src$value, "s3method")[2]
if (dest_type == "s3generic" && generic == dest_name) {
# src method fits dest generic
extends <- "generic"
} else if (fits_constructor(dest_name, src)) {
# src method fits informal dest constructor (heuristically)
extends <- "class"
} else {
extends <- ""
}
} else if (src_type == "s4method") {
generic <- as.character(src$value@generic)
class <- sig2class(src$value@defined)
if (dest_type == "s4generic") {
# TODO must test whether src method fits dest generic
extends <- "generic"
} else if (dest_type == "s4class") {
extends <- "class"
# TODO must test whether src method fits dest constructor
} else {
extends <- ""
}
} else {
generic <- ""
class <- ""
extends <- ""
}
list(extends = extends, generic = generic, class = class)
}
# Turn S4 signature into a string
sig2class <- function(sig) {
if (length(sig) == 1) {
as.character(sig)
} else {
paste0(names(sig), " = ", sig, collapse = ",")
}
}
# Is destination is probably constructor for src?
fits_constructor <- function(dest_name, src) {
src_class <- attr(src$value, "s3method")[2]
# simple case where class name is the same as the constructor name
if (src_class == dest_name) {
return(TRUE)
}
# more complex case where class name = package name + constructor name
evalenv <- roxy_meta_get("env") %||% parent.frame() # needed for tests
pkg_name <- utils::packageName(evalenv) %||% ""
src_class == paste0(pkg_name, "_", dest_name)
}
object_name <- function(x) {
UseMethod("object_name")
}
#' @export
object_name.default <- function(x) {
x$alias
}
#' @export
object_name.function <- function(x) {
object_name_fun(x$alias, x)
}
#' @export
object_name.s3generic <- object_name.function
#' @export
object_name.s3method <- function(x) {
method <- attr(x$value, "s3method")
as.character(function_usage(method[[1]], list(as.name(method[[2]]))))
#
# name <- paste(, collapse = ".")
# object_name_fun(name, x)
}
#' @export
object_name.s4generic <- function(x) {
object_name_fun(x$value@generic, x)
}
#' @export
object_name.s4method <- function(x) {
classes <- lapply(x$value@defined, as.name)
if (length(classes) == 1) {
names(classes) <- NULL
}
as.character(function_usage(x$value@generic, classes))
}
object_name_fun <- function(name, x, format_name = identity) {
if (is_replacement_fun(name) || is_infix_fun(name)) {
args <- formals(x$value)
} else {
args <- NULL
}
as.character(function_usage(name, args, format_name))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.