Prints a function with a roxygen-style header comments

print.function.R

name_of <- function(obj, private = FALSE) {
  env <- environment(obj)
  
  if (private) {
    env_name <- environmentName(env)
    names <- tryCatch({
      ns <- asNamespace(env_name)
      names(.getNamespaceInfo(ns, "exports"))
    }, error = function() names(env))
  } else {
    names <- names(env)
  }
  
  for (name in names) {
    env_obj <- get(name, envir = env, inherits = FALSE)
    if (identical(env_obj, obj)) return(name)
  }
  
  NULL
}

is_exported <- function(obj) {
  name <- name_of(obj, private = FALSE)
  !is.null(name)
}

imports_from <- function(obj) {
  ns_name <- environmentName(environment(obj))
  ns <- asNamespace(ns_name)
  imports <- .getNamespaceInfo(ns, "imports")
  imports <- lapply(imports, unname)
  imports <- unlist(imports)

  names <- NULL
  globals::walkAST(formals(obj), name = function(x) {
    names <<- c(names, as.character(x))
  })
  globals::walkAST(body(obj), name = function(x) {
    names <<- c(names, as.character(x))
  })
  names <- unique(names)

  idxs <- match(names, imports)
  idxs <- idxs[!is.na(idxs)]
  imports_from <- imports[idxs]

  namespaces <- sort(unique(names(imports_from)))
  res <- list()
  for (name in namespaces) {
    res[[name]] <- unname(imports_from[match(name, names(imports_from))])
  }
  res
}

#' Get further information on a function
#'
#' @importFrom utils capture.output
#' @export
function_info <- function(x, ...) {
  info <- list()

  info$name <- name_of(x)
  
  env <- environment(x)
  env_name <- environmentName(env)
  if (env_name == "R_GlobalEnv") env_name <- ".GlobalEnv"
  info$envir <- env
  info$envir_name <- env_name
  
  namespace <- tryCatch({
    asNamespace(env_name)
  }, error = function(ex) NULL)
  info$namespace <- namespace
  
  if (!is.null(namespace)) {
    info$namespace_name <- env_name
    info$imports_from <- imports_from(x)
    info$is_exported <- is_exported(x)
  }

  info
}


#' @importFrom utils capture.output
print.function <- function(x, useSource = TRUE, parsable = FALSE, ...) {
  info <- function_info(x)
  name <- info$name
  if (is.null(name)) {
    msg <- sprintf("An anonymous function in %s", info$envir_name)
  } else if (is.null(info$namespace)) {
    msg <- sprintf("%s$%s()", info$envir_name, name)
  } else {
    msg <- sprintf("%s::%s()", info$namespace_name, name)
  }
  msg <- c(msg, "")

  msg <- c(msg, sprintf("@param %s ...", names(formals(x))))
  msg <- c(msg, "")
  
  if (!is.null(info$namespace)) {
    imports <- info$imports_from
    imports <- lapply(imports, FUN = paste, collapse = " ")
    imports <- unlist(imports)
    msg <- c(msg, sprintf("@importsFrom %s %s", names(imports), imports))
  
    if (info$is_exported) msg <- c(msg, "@export")
  }  

  hdr <- paste0("#' ", msg)
  bfr <- capture.output(base::print.function(x, useSource = useSource, ...))
  nbfr <- length(bfr)
  if (parsable) {
    bfr <- grep("<(bytecode|environment): .*>", bfr,
                value = TRUE, invert = TRUE)
  }
  if (!is.null(info$name)) bfr[1] <- sprintf("%s <- %s", name, bfr[1])
  pathname <- utils::getSrcFilename(x, full.names = TRUE)
  pathname <- pathname[nzchar(pathname)]
  if (length(pathname) > 0L) {
    info <- sQuote(pathname)
    loc <- utils::getSrcLocation(x, which = "line")
    if (length(loc) > 0L) info <- sprintf("%s (line %s)", info, loc)
    bfr <- c(bfr, sprintf("<srcfile: %s>", info))
  }
  bfr <- c("", hdr, bfr, "")
  bfr <- paste(bfr, collapse = "\n")
  if (parsable) {
    expr <- parse(text = bfr)
  }
  cat(bfr)
}

Example:

> print(future::sessionDetails)

#' future::sessionDetails()
#' 
#' @param env ...
#' 
#' @importsFrom utils sessionInfo
#' @export
sessionDetails <- function (env = FALSE) 
{
    details <- list(`Sys.time()` = Sys.time(), `sessionInfo()` = sessionInfo(), 
        `commandArgs()` = commandArgs(), `Sys.info()` = Sys.info(), 
        `capabilities()` = capabilities(), .libPaths = .libPaths(), 
        `Sys.getenv()` = Sys.getenv(), `Sys.getlocale()` = Sys.getlocale(), 
        .Platform = .Platform, .Machine = .Machine, `getwd()` = getwd(), 
        `tempdir()` = tempdir(), `options()` = options(), `warnings()` = warnings())
    if (!env) 
        details[["Sys.getenv()"]] <- NULL
    class(details) <- c("sessionDetails", class(details))
    details
}
<bytecode: 0x55e939c146c0>
<environment: namespace:future>