R/rd-inherit.R

Defines functions get_rd_from_help get_rd tweak_links rd2text find_field inherit_field find_sections inherit_section inherit_sections topic_params find_params get_documented_params inherit_dot_params match_param inherit_params topics_process_inherit merge.rd_section_inherit_dot_params format.rd_section_inherit_dot_params rd_section_inherit_dot_params merge.rd_section_inherit_section format.rd_section_inherit_section rd_section_inherit_section format.rd_section_inherit merge.rd_section_inherit rd_section_inherit roxy_tag_rd.roxy_tag_inheritSection roxy_tag_parse.roxy_tag_inheritSection roxy_tag_rd.roxy_tag_inheritDotParams roxy_tag_parse.roxy_tag_inheritDotParams roxy_tag_rd.roxy_tag_inheritParams roxy_tag_parse.roxy_tag_inheritParams roxy_tag_rd.roxy_tag_inherit roxy_tag_parse.roxy_tag_inherit

# Tags --------------------------------------------------------------------

#' @export
roxy_tag_parse.roxy_tag_inherit <- function(x) tag_inherit(x)
#' @export
roxy_tag_rd.roxy_tag_inherit <- function(x, base_path, env) {
  rd_section_inherit(x$val$source, list(x$val$fields))
}

#' @export
roxy_tag_parse.roxy_tag_inheritParams <- function(x) tag_value(x)
#' @export
roxy_tag_rd.roxy_tag_inheritParams <- function(x, base_path, env) {
  rd_section_inherit(x$val, list("params"))
}

#' @export
roxy_tag_parse.roxy_tag_inheritDotParams <- function(x) {
  tag_two_part(x, "source", "args", required = FALSE, markdown = FALSE)
}
#' @export
roxy_tag_rd.roxy_tag_inheritDotParams <- function(x, base_path, env) {
  rd_section_inherit_dot_params(x$val$source, x$val$args)
}

#' @export
roxy_tag_parse.roxy_tag_inheritSection <- function(x) tag_name_description(x)
#' @export
roxy_tag_rd.roxy_tag_inheritSection <- function(x, base_path, env) {
  rd_section_inherit_section(x$val$name, x$val$description)
}


# Fields ------------------------------------------------------------------

# For each unique source, list which fields it inherits from
rd_section_inherit <- function(source, fields) {
  stopifnot(is.character(source), is.list(fields))
  stopifnot(!anyDuplicated(source))
  stopifnot(length(source) == length(fields))

  rd_section("inherit", list(source = source, fields = fields))
}

#' @export
merge.rd_section_inherit <- function(x, y, ...) {
  stopifnot(identical(class(x), class(y)))

  dedup <- collapse(
    c(x$value$source, y$value$source),
    c(x$value$fields, y$value$fields),
    function(x) Reduce(union, x)
  )

  rd_section("inherit", list(source = dedup$key, fields = dedup$value))
}

#' @export
format.rd_section_inherit <- function(x, ...) NULL

rd_section_inherit_section <- function(source, title) {
  stopifnot(is.character(source), is.character(title))
  stopifnot(length(source) == length(title))

  rd_section("inherit_section", list(source = source, title = title))
}

#' @export
format.rd_section_inherit_section <- function(x, ...) NULL

#' @export
merge.rd_section_inherit_section <- function(x, y, ...) {
  stopifnot(identical(class(x), class(y)))
  rd_section_inherit_section(c(x$value$source, y$value$source), c(x$value$title, y$value$title))
}

rd_section_inherit_dot_params <- function(source, args) {
  stopifnot(is.character(source), is.character(args))
  stopifnot(length(source) == length(args))

  rd_section("inherit_dot_params", list(source = source, args = args))
}

#' @export
format.rd_section_inherit_dot_params <- function(x, ...) NULL

#' @export
merge.rd_section_inherit_dot_params <- function(x, y, ...) {
  stopifnot(identical(class(x), class(y)))
  rd_section_inherit_dot_params(c(x$value$source, y$value$source), c(x$value$args, y$value$args))
}


# Process inheritance -----------------------------------------------------

topics_process_inherit <- function(topics, env) {
  inherits <- function(type) {
    function(x) x$inherits_from(type)
  }

  topics$topo_apply(inherits("return"), inherit_field,
    roxy_name = "return", rd_name = "value")
  topics$topo_apply(inherits("title"), inherit_field, "title")
  topics$topo_apply(inherits("description"), inherit_field, "description")
  topics$topo_apply(inherits("details"), inherit_field, "details")
  topics$topo_apply(inherits("seealso"), inherit_field, "seealso")
  topics$topo_apply(inherits("references"), inherit_field, "references")
  topics$topo_apply(inherits("examples"), inherit_field, "examples")
  topics$topo_apply(inherits("author"), inherit_field, "author")
  topics$topo_apply(inherits("source"), inherit_field, "source")
  topics$topo_apply(inherits("note"), inherit_field, "note")

  # First inherit individual sections, then all sections.
  topics$topo_apply(function(x) x$inherits_section_from(), inherit_section)
  topics$topo_apply(inherits("sections"), inherit_sections)

  topics$topo_apply(inherits("params"), inherit_params)
  # Can't inherit ... into ... so can do in any order
  topics$apply(inherit_dot_params, env = env)

  invisible()
}

# Inherit parameters -----------------------------------------------------------

inherit_params <- function(topic, topics) {
  inheritors <- topic$inherits_from("params")
  if (length(inheritors) == 0) {
    return()
  }

  documented <- get_documented_params(topic)
  needed <- topic$get_value("formals")
  missing <- setdiff(needed, documented)
  if (length(missing) == 0) {
    cli::cli_warn(
      c(
        "@inheritParams failed in topic {.str {topic$get_name()}}.",
        x = "All parameters are already documented; none remain to be inherited."
      ),
      call = NULL
    )
    return()
  }

  # Work through inherited params seeing if any match the parameters
  # we're missing
  for (inheritor in inheritors) {
    inherited_params <- find_params(inheritor, topics, source = topic$get_name())

    for (param in inherited_params) {
      match <- match_param(param$name, missing)
      if (!is.null(match)) {
        param_val <- setNames(param$value, paste(match, collapse = ","))
        topic$add(rd_section("param", param_val))
        missing <- setdiff(missing, match)
      }
    }
    if (length(missing) == 0) break
  }

}

# Ignore . prefix since it's sometimes necessary to add because a
# function uses ...

# Match parameters ignoring dots
match_param <- function(from, to) {
  flip_dot <- function(x) {
    has_dot <- grepl("^\\.", x)
    ifelse(has_dot, gsub("^\\.", "", x), paste0(".", x))
  }

  to_std <- c(to, flip_dot(to))
  if (!all(from %in% to_std)) {
    return(NULL)
  }

  union(
    setdiff(to[match(from, to)], NA),
    setdiff(to[match(from, flip_dot(to))], NA)
  )
}

inherit_dot_params <- function(topic, topics, env) {
  inheritors <- topic$get_value("inherit_dot_params")
  if (is.null(inheritors))
    return()

  # Need to find formals for each source
  funs <- lapply(inheritors$source, function(x) eval(parse(text = x), envir = env))
  args <- map2(funs, inheritors$args, select_args_text, topic = topic)

  # Then pull out the ones we need
  docs <- lapply(inheritors$source, find_params, topics = topics)
  arg_matches <- function(args, docs) {
    match <- map_lgl(docs, function(x) all(x$name %in% args))
    matched <- docs[match]
    setNames(
      lapply(matched, "[[", "value"),
      map_chr(matched, function(x) paste(x$name, collapse = ","))
    )
  }
  docs_selected <- unlist(map2(args, docs, arg_matches))

  # Only document params under "..." that aren't otherwise documented
  documented <- get_documented_params(topic)
  non_documented_params <- setdiff(names(docs_selected), documented)
  docs_selected <- docs_selected[non_documented_params]

  # Build the Rd
  # (1) Link to function(s) that was inherited from
  src <- inheritors$source
  dest <- map_chr(src, resolve_qualified_link)
  from <- paste0("\\code{\\link[", dest, "]{", src, "}}", collapse = ", ")

  # (2) Show each inherited argument
  arg_names <- paste0("\\code{", names(docs_selected), "}")
  args <- paste0("    \\item{", arg_names, "}{", docs_selected, "}", collapse = "\n")

  rd <- paste0(
    "\n",
    "  Arguments passed on to ", from, "\n",
    "  \\describe{\n",
    args, "\n",
    "  }"
  )
  topic$add(rd_section("param", c("..." = rd)))
}


get_documented_params <- function(topic, only_first = FALSE) {
  documented <- names(topic$get_value("param"))
  if (length(documented) > 0) {
    documented <- strsplit(documented, ",")
    if (only_first)
      documented <- map_chr(documented, 1)
    else
      documented <- unlist(documented)
  }

  documented[documented == "\\dots"] <- "..."
  documented
}

find_params <- function(name, topics, source) {
  topic <- get_rd(name, topics, source = source)
  if (is.null(topic)) {
    return()
  }

  params <- topic_params(topic)
  if (is.null(params))
    return()

  param_names <- str_trim(names(params))
  param_names[param_names == "\\dots"] <- "..."

  Map(list,
    name = strsplit(param_names, ",\\s*"),
    value = unlist(params)
  )
}

topic_params <- function(x) {
  if (inherits(x, "Rd")) {
    arguments <- get_tags(x, "\\arguments")
    if (length(arguments) != 1) {
      return(list())
    }
    items <- get_tags(arguments[[1]], "\\item")

    values <- map_chr(items, function(y) rd2text(y[[2]], attr(x, "package")))
    params <- map_chr(items, function(y) rd2text(y[[1]], attr(x, "package")))

    setNames(values, params)
  } else {
    x$get_value("param")
  }
}

# Inherit sections --------------------------------------------------------

inherit_sections <- function(topic, topics) {
  current_secs <- topic$get_value("section")$title

  for (inheritor in topic$inherits_from("sections")) {
    inheritor <- get_rd(inheritor, topics, source = topic$get_name())
    if (is.null(inheritor)) {
      return()
    }

    sections <- find_sections(inheritor)
    needed <- !(sections$title %in% current_secs)
    if (!any(needed))
      next

    topic$add(
      rd_section_section(sections$title[needed], sections$content[needed])
    )
  }
}

inherit_section <- function(topic, topics) {
  sections <- topic$get_value("inherit_section")
  sources <- sections$source
  titles <- sections$title

  for (i in seq_along(sources)) {
    inheritor <- get_rd(sources[[i]], topics, source = topic$get_name())
    if (is.null(inheritor)) {
      return()
    }

    new_section <- find_sections(inheritor)
    selected <- new_section$title %in% titles[[i]]

    if (sum(selected) != 1) {
      cli::cli_warn(
        c(
          "@inheritSection failed in topic {.str {topic$get_name()}}.",
          x = "Can't find section {.str {titles[[i]]}} in topic {sources[[i]]}."
        ),
        call = NULL
      )
      return()
    }

    topic$add(
      rd_section_section(new_section$title[selected], new_section$content[selected])
    )
  }
}

find_sections <- function(topic) {
  if (inherits(topic, "Rd")) {
    tag <- get_tags(topic, "\\section")

    titles <- map_chr(map(tag, 1), rd2text, package = attr(topic, "package"))
    contents <- map_chr(map(tag, 2), rd2text, package = attr(topic, "package"))

    list(title = titles, content = contents)
  } else {
    topic$get_value("section")
  }
}


# Inherit from single field ----------------------------------------------------

inherit_field <- function(topic, topics, rd_name, roxy_name = rd_name) {
  # Already has the field, so don't need to inherit
  if (topic$has_section(rd_name))
    return()

  # Otherwise, try each try function listed in inherits
  for (inherit_from in topic$inherits_from(roxy_name)) {
    inherit_topic <- get_rd(inherit_from, topics, source = topic$get_name())
    if (is.null(inherit_topic)) {
      next
    }

    inheritee <- find_field(inherit_topic, rd_name)
    if (is.null(inheritee))
      next

    topic$add(rd_section(rd_name, inheritee))
    return()
  }
}

find_field <- function(topic, field_name) {
  if (inherits(topic, "Rd")) {
    tag <- get_tags(topic, paste0("\\", field_name))
    if (length(tag) == 0)
      return()

    value <- tag[[1]]
    attr(value, "Rd_tag") <- NULL

    str_trim(rd2text(value, attr(topic, "package")))
  } else {
    topic$get_value(field_name)
  }
}

rd2text <- function(x, package) {
  x <- tweak_links(x, package)
  chr <- as_character_rd(structure(x, class = "Rd"), deparse = TRUE)
  paste(chr, collapse = "")
}

# Convert relative to absolute links
tweak_links <- function(x, package) {
  tag <- attr(x, "Rd_tag")

  if (is.list(x)) {
    if (!is.null(tag) && tag == "\\link") {
      opt <- attr(x, "Rd_option")
      if (is.null(opt)) {
        if (has_topic(x[[1]], package)) {
          attr(x, "Rd_option") <- structure(package, Rd_tag = "TEXT")
        }
      } else if (is_string(opt) && substr(opt, 1, 1) == "=") {
        topic <- substr(opt, 2, nchar(opt))

        if (has_topic(topic, package)) {
          attr(x, "Rd_option") <- structure(paste0(package, ":", topic), Rd_tag = "TEXT")
        }
      }
    } else if (length(x) > 0) {
      x[] <- map(x, tweak_links, package = package)
    }
  }

  x
}


# Find info in Rd or topic ------------------------------------------------

get_rd <- function(name, topics, source) {
  if (is_namespaced(name)) {
    # External package
    parsed <- parse_expr(name)
    pkg <- as.character(parsed[[2]])
    fun <- as.character(parsed[[3]])

    get_rd_from_help(pkg, fun, source)
  } else {
    # Current package
    rd_name <- topics$find_filename(name)
    if (identical(rd_name, NA_character_)) {
      cli::cli_warn(
        c(
          "@inherits failed in topic {.str {source}}.",
          x = "Can't find topic {.str {name}}."
        ),
        call = NULL
      )
    }
    topics$get(rd_name)
  }
}

get_rd_from_help <- function(package, alias, source) {
  if (!is_installed(package)) {
    cli::cli_warn(
      c(
        "@inherits failed in topic {.str {source}}.",
        x = "Package {package} is not installed."
      ),
      call = NULL
    )
    return()
  }

  help <- utils::help((alias), (package))
  if (length(help) == 0) {
    cli::cli_warn(
      c(
        "@inherits failed in topic {.str {source}}.",
        x = "Can't find topic {package}::{alias}."
      ),
      call = NULL
    )
    return()
  }

  out <- internal_f("utils", ".getHelpFile")(help)
  attr(out, "package") <- package
  out
}

Try the roxygen2 package in your browser

Any scripts or data that you put into this service are public.

roxygen2 documentation built on Dec. 9, 2022, 1:09 a.m.