autodoc.R

In richfitz/ring: Circular / Ring Buffers

#!/usr/bin/env Rscript

## Dirty hack to compile docs in the absence of proper Roxygen R6 support.
devtools::load_all(".")

add_usage <- function(dat) {
  capture_usage <- function(cl, name) {
    tmp <- capture.output(args(cl[[name]]))
    tmp <- strip_trailing_whitespace(paste(tmp[-length(tmp)], collapse = "\n"))
    sub("^function\\s*", name, tmp)
  }
  get_order <- function(x) {
    names(formals(x[[name]])) %||% character(0)
  }

  cl <- list(env = R6_ring_buffer_env$public_methods,
             bytes = R6_ring_buffer_bytes$public_methods,
             typed = modifyList(R6_ring_buffer_bytes$public_methods,
                                R6_ring_buffer_bytes_translate$public_methods))

  valid <- unique(unlist(lapply(cl, names)))
  extra <- setdiff(names(dat), valid)
  if (length(extra) > 0L) {
    warning(sprintf("In '%s', extra methods: %s",
                    class(object)[[1]],
                    paste(extra, collapse = ", ")),
            immediate. = TRUE, call. = FALSE)
  }

  for (name in names(dat)) {
    dat[[name]]$method_name <- name
    dat[[name]]$usage <- vcapply(cl, capture_usage, name)
    dat[[name]]$order <- lapply(cl, get_order)
  }

  dat
}

indent <- function(str, n, pad = NULL) {
  if (is.null(pad)) {
    pad <- paste(rep(" ", n), collapse = "")
  }
  p <- function(s) {
    paste(paste0(pad, s), collapse = "\n")
  }
  vapply(strsplit(str, "\n"), p, character(1))
}

format_params <- function(xp) {
  fmt1 <- "\\itemize{\n%s\n}"
  fmt2 <- "\\item{\\code{%s}: %s\n}\n"
  pars <- sprintf(fmt2, names(xp), indent(unlist(xp), 2))
  sprintf(fmt1, indent(paste(pars, collapse = "\n"), 2))
}

format_method <- function(x) {
  title <- sprintf("\\item{\\code{%s}}{", x$method_name)
  end <- "}"

  all_pars <- unique(unlist(x$order))
  p_msg   <- setdiff(all_pars, names(x$params))
  p_extra <- setdiff(names(x$params), all_pars)
  if (length(p_msg) > 0) {
    warning(sprintf("In '%s', missing parameters: %s",
                    x$method_name, paste(p_msg, collapse = ", ")),
            immediate. = TRUE, call. = FALSE)
  }
  if (length(p_extra) > 0) {
    warning(sprintf("In '%s', extra parameters: %s",
                    x$method_name, paste(p_extra, collapse = ", ")),
            immediate. = TRUE, call. = FALSE)
  }
  ## preseve order, though I'm pretty sure that the yaml package is
  ## actually preserving it.
  if (length(p_msg) == 0 && length(p_extra) == 0) {
    x$params <- x$params[all_pars]
  }

  if (length(unique(x$usage)) == 1L) {
    usage <- sprintf("\\code{%s}", x$usage[[1]])
  } else {
    drop <- duplicated(x$usage)
    keep <- !drop
    nms <- tapply(names(x$usage), x$usage, paste, collapse = ", ")
    usg <- x$usage[!duplicated(x$usage)]
    i <- nzchar(usg)
    usg[i] <- sprintf("\\code{%s}", usg[i])
    usg[!i] <- "\\emph{(not supported)}"
    usage <- sprintf("\\itemize{\n%s\n}",
                     paste(indent(sprintf("\\item{%s: %s}", nms, usg), 2),
                           collapse = "\n"))
  }
  body <- sprintf("%s\n\n\\emph{Usage:}\n%s", x$short, usage)
  if (!is.null(x$params)) {
    body <- paste0(body, "\n\n\\emph{Arguments:}\n", format_params(x$params))
  }
  if (!is.null(x$details)) {
    body <- paste0(body, "\n\n\\emph{Details:}\n", x$details)
  }
  if (!is.null(x$value)) {
    body <- paste0(body, "\n\n\\emph{Return value}:\n", x$value)
  }
  paste(title, indent(body, 2), end, sep = "\n")
}

strip_trailing_whitespace <- function(x) {
  gsub("[ \t]+(\n|$)", "\\1", x)
}

format_class <- function(x) {
  ret <- vcapply(x, format_method)
  'Note that this methods reference section is repeated verbatim between
the three main ring buffer classes; \\code{ring_buffer_env}
("env"), \\code{ring_buffer_bytes} ("bytes") and
\\code{ring_buffer_bytes_typed} ("typed").  Almost all methods have
the same arguments and behaviour, but hopefully by listing everything together,
the differences between implementations will be a bit more apparent.' -> header
  ret <- sprintf("@section Methods:\n\n%s\n\n\\describe{\n%s\n}",
                 header, paste(ret, collapse = "\n"))
  ret <- indent(ret, pad = "##' ")
  strip_trailing_whitespace(ret)
}

## From remake, rrqueue, etc, etc.
yaml_load <- function(string) {
  handlers <- list(`bool#yes` = function(x) {
    if (identical(toupper(x), "TRUE")) TRUE else x
  }, `bool#no` = function(x) {
    if (identical(toupper(x), "FALSE")) FALSE else x
  })
  yaml::yaml.load(string, handlers = handlers)
}
yaml_read <- function(filename) {
  yaml_load(paste(readLines(filename), collapse = "\n"))
}

process <- function() {
  dat <- yaml_read(file.path("man-roxygen", "ring_ref.yml"))
  dat <- add_usage(dat)
  str <- format_class(dat)
  dest <- "man-roxygen/ring_ref.R"
  message("writing ", dest)
  writeLines(str, dest)
}

vcapply <- function(X, FUN, ...) {
  vapply(X, FUN, character(1), ...)
}
`%||%` <- function(a, b) {
  if (is.null(a)) b else a
}

if (!interactive() && identical(commandArgs(TRUE), "process")) {
  process()
  ## source("autodoc.R")
  ## process()
}