R/rd-r6.R

Defines functions r6_warning first_five r6_all_examples r6_method_end r6_method_examples r6_method_return r6_method_params r6_method_details r6_method_usage r6_method_description r6_method_begin r6_inherited_method_list r6_method_list r6_show_name find_method_for_tag r6_methods r6_active_bindings r6_fields r6_superclass add_default_methods topic_add_r6_methods

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)) {
      roxy_tag_warning(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)

  nodoc <- map_int(methods$tags, length) == 0
  r6_warning(block, "undocumented R6 method[s]: %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) {
  defaults <- list(
    clone = list(
      roxy_tag_parse(roxy_tag(
        "description",
        "The objects of this class are cloneable with this method."
      )),
      roxy_tag_parse(roxy_tag("param", "deep 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)]
  path <- sprintf("\\code{\\link[%s:%s]{%s::%s}}", pkgs, cls, 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)
  r6_warning(block, "undocumented R6 field[s]: %s", miss)

  # Check for duplicate fields
  dup <- unique(docd[duplicated(docd)])
  r6_warning(block, "R6 field[s] documented multiple times: %s", dup)

  # Check for extra fields
  xtra <- setdiff(docd, fields)
  r6_warning(block, "unknown R6 field[s]: %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)
  r6_warning(block, "undocumented R6 active binding[s]: %s", miss)

  # Check for duplicate bindings
  dup <- unique(docd[duplicated(docd)])
  r6_warning(block, "R6 active binding[s] documented multiple times: %s", 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}{\\code{%s$%s()}}",
      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), ]

  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}{",
    paste0("\\out{", details, "}"),
    "\\itemize{",
    sprintf(
      paste0(
        "\\item \\out{<span class=\"pkg-link\" data-pkg=\"%s\" ",
        "data-topic=\"%s\" data-id=\"%s\">}",
        "\\href{../../%s/html/%s.html#method-%s}{\\code{%s::%s$%s()}}",
        "\\out{</span>}"
      ),
      super_meth$package,
      super_meth$classname,
      super_meth$name,
      super_meth$package,
      super_meth$classname,
      super_meth$name,
      super_meth$package,
      super_meth$classname,
      super_meth$name
    ),
    "}",
    "\\out{</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-", nm, "\"></a>}}"),
    paste0("\\if{latex}{\\out{\\hypertarget{method-", 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) {
    roxy_warning(
      sprintf("argument `%s` documented multiple times for R6 method `%s`", m, method$name),
      file = block$file, line = method$line
    )
  }

  # 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) {
    roxy_warning(
      sprintf("argument `%s` undocumented for R6 method `%s()`", m, method$name),
      file = block$file, line = method$line
    )
  }

  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) {
    roxy_tag_warning(ret[[2]], "May only 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 = ", ")
}

r6_warning <- function(block, template, bad) {
  if (length(bad) == 0) return()
  badlist <- first_five(bad)
  template <- gsub("[s]", if (length(bad) == 1) "" else "s", template, fixed = TRUE)
  roxy_warning(sprintf(template, badlist), file = block$file, line = block$line)
}

Try the roxygen2 package in your browser

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

roxygen2 documentation built on Sept. 8, 2021, 9:08 a.m.