[Rd] promptFunctions() to handle multiple names

[Daniel Sabanés Bové]

-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA512

Hi all,

I wanted to set up my first (private) R-package and wondered
if there was a function to prompt() for multiple aliases in one Rd-file,
e.g. to create something like the normal distribution manual page
encompassing rnorm, dnorm,...

As I didn't find it, I modified prompt.default() and wrote a small function
to do this job, called "promptFunctions". It basically calls the helper
".promptFunction" for every name it gets and puts together the output
from each function.

It would be interesting for me if such a function already existed in R
or if something like "promptFunction" could be included in any future R 
version.
I think it would be used as many man pages document several functions at 
once,
and cutting and pasting the single prompt() files by hand could be boring.

regards,
Daniel

The Code:

## modified prompt.default to handle multiple functions correctly
promptFunctions <-
~    function (...,                      # objects to be documented
~              filename = NULL,          # file name string or NA for 
console
~              names = NULL,             # character vector of object names
~              rdname = NULL,            # name of the documentation
~              overwrite = FALSE         # overwrite existing Rd file?
~              )
{
~    ## helper functions
~    paste0 <- function(...) paste(..., sep = "")
~    is.missing.arg <- function(arg) typeof(arg) == "symbol" &&
~        deparse(arg) == ""

~    ## generate additional names from objects
~    objects <- as.list (substitute (...[]))
~    objects <- objects[seq(from = 2, to = length(objects) - 1)]
~    objects <- sapply(objects, deparse)

~    ## merge with names from call and stop if there are no usable names
~    names <- unique(c(objects, names))
~    if (is.null(names))
~        stop ("cannot determine usable names")

~    ## determine Rd name
~    if(is.null(rdname))
~        rdname <- names[1]

~    ## determine file name
~    if (is.null(filename))
~        filename <- paste0(rdname, ".Rd")

~    ## treat each name individually
~    promptList <- lapply(names, .promptFunction)
~    names(promptList) <- names

~    ## construct text
~    Rdtxt <- list()

~    Rdtxt$name <- paste0("\\name{", rdname, "}")
~    Rdtxt$aliases <- c(paste0("\\alias{", names, "}"),
~                       paste("%- Also NEED an '\\alias' for EACH other 
topic",
~                             "documented here."))
~    Rdtxt$title <- "\\title{ ~~functions to do ... ~~ }"
~    Rdtxt$description <- c("\\description{",
~                           paste("  ~~ A concise (1-5 lines) 
description of what",
~                                 "the functions"),
~                           paste("    ", paste(names, collapse = ", "),
~                                 "do. ~~"),
~                           "}")
~    Rdtxt$usage <- c("\\usage{",
~                     unlist(lapply(promptList, "[[", "usage")),
~                     "}",
~                     paste("%- maybe also 'usage' for other objects",
~                           "documented here."))
~    arguments <- unique (unlist (lapply(promptList, "[[", "arg.n")))
~    Rdtxt$arguments <- if(length(arguments))
~        c("\\arguments{",
~          paste0("  \\item{", arguments, "}{",
~                 " ~~Describe \\code{", arguments, "} here~~ }"),
~          "}")
~    Rdtxt$details <- c("\\details{",
~                       paste("  ~~ If necessary, more details than the",
~                             "description above ~~"),
~                       "}")
~    Rdtxt$value <- c("\\value{",
~                     "  ~Describe the values returned",
~                     "  If it is a LIST, use",
~                     "  \\item{comp1 }{Description of 'comp1'}",
~                     "  \\item{comp2 }{Description of 'comp2'}",
~                     "  ...",
~                     "}")
~    Rdtxt$references <- paste("\\references{ ~put references to the",
~                              "literature/web site here ~ }")
~    Rdtxt$author <- "\\author{Daniel Saban\\'es Bov\\'e}"
~    Rdtxt$note <- c("\\note{ ~~further notes~~ ",
~                    "",
~                    paste(" ~Make other sections like Warning with",
~                          "\\section{Warning }{....} ~"),
~                    "}")
~    Rdtxt$seealso <- paste("\\seealso{ ~~objects to See Also as",
~                           "\\code{\\link{help}}, ~~~ }")
~    Rdtxt$examples <- c("\\examples{",
~                        "##---- Should be DIRECTLY executable !! ----",
~                        "##-- ==>  Define data, use random,",
~                        "##--\tor do  help(data=index)  for the 
standard data sets.",
~                        "",
~                        "## The functions are currently defined as",
~                        unlist (lapply(promptList, "[[", "x.def")),
~                        "}")
~    Rdtxt$keywords <- c(paste("% Add one or more standard keywords,",
~                              "see file 'KEYWORDS' in the"),
~                        "% R documentation directory.",
~                        "\\keyword{ ~kwd1 }",
~                        "\\keyword{ ~kwd2 }% __ONLY ONE__ keyword per 
line")

~    ## and write text to console
~    if (is.na(filename))
~        return(Rdtxt)

~    ## or file
~    if(file.exists(filename) && !overwrite)
~        warning(filename, " already exists. Choose overwrite = TRUE to 
force.")
~    else {
~        cat(unlist(Rdtxt), file = filename, sep = "\n")
~        message(gettextf("Created file named '%s'.", filename), "\n",
~                gettext("Edit the file and move it to the appropriate 
directory."),
~                domain = NA)
~    }

~    ## and return the file name
~    invisible(filename)
}


## helper function for one name only
.promptFunction <- function(name, ...)
{
~    ## utility functions
~    paste0 <- function(...) paste(..., sep = "")
~    is.missing.arg <- function(arg)
~        typeof(arg) == "symbol" && deparse(arg) == ""

~    ## get object by name
~    x <- get(name, envir = parent.frame())

~    ## set up return list
~    ret <- list()

~    ## extract arguments
~    n <- length(argls <- formals(x))
~    if (n > 0) {
~        arg.names <- arg.n <- names(argls)
~        arg.n[arg.n == "..."] <- "\\dots"
~    }
~    Call <- paste0(name, "(")
~    for (i in seq_len(n)) {
~        Call <- paste0(Call, arg.names[i], if (!is.missing.arg(argls[[i]]))
~                       paste0(" = ", paste(deparse(argls[[i]], 
width.cutoff = 500),
~                                           collapse = "\n")))
~        if (i != n)
~            Call <- paste0(Call, ", ")
~    }

~    ## and definition of the function
~    x.def <- attr(x, "source")
~    if (is.null(x.def))
~        x.def <- deparse(x)
~    if (any(br <- substr(x.def, 1, 1) == "}"))
~        x.def[br] <- paste(" ", x.def[br])
~    x.def <- gsub("%", "\\\\%", x.def)
~    x.def <- c(paste("##", name), x.def)

~    ## fill return list
~    ret$usage <- paste0(Call, ")")
~    ret$x.def <- x.def
~    ret$arg.n <- if(n > 0) arg.n

~    ## return the list
~    return(ret)
}


## test this
test <- function(x){
~    x + 5
}
b <- function(y)
~    test(y)
y <- function(a, b, c){
~    print("hello")
}

promptFunctions(test, b, names = "y", rdname = "testbandy")
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v2.0.4-svn0 (GNU/Linux)
Comment: Using GnuPG with SUSE - http://enigmail.mozdev.org

iD8DBQFIAh46zHZ0x5+gF9kRCnaOAJ9MQGHjosFEFshWYxAbfQ0E7fOsGQCfX2gp
F0pJGX4/mai08ghJwj6yY18=
=7r90
-----END PGP SIGNATURE-----