[Roxygen-commits] r77 - in pkg: R sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 23 23:57:32 CEST 2008
Author: pcd
Date: 2008-07-23 23:57:32 +0200 (Wed, 23 Jul 2008)
New Revision: 77
Modified:
pkg/R/Rd.R
pkg/R/collate.R
pkg/R/list.R
pkg/R/namespace.R
pkg/R/parse.R
pkg/sandbox/example-Rd-nlm.R
pkg/sandbox/main.R
Log:
honest parsing of srcrefs; extraction of @assignee, @formals; automatic generation of \usage, \name for Rd; expression walk;
Modified: pkg/R/Rd.R
===================================================================
--- pkg/R/Rd.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/R/Rd.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -4,10 +4,9 @@
#' @include roclet.R
roxygen()
-#' Make an Rd roclet which parses the result of \code{parse.files}
-#' and writes the Rd format to standard out (TODO: write
-#' to the file designated by \code{@@name}). Requires the \code{@@name}
-#' parameter.
+#' Make an Rd roclet which parses the given files and writes the Rd
+#' format to standard out (TODO: write to the file designated by
+#' \code{@@name}). Requires the \code{@@name} parameter.
#'
#' Contains the member function \code{parse} which parses the result
#' of \code{parse.files}.
@@ -25,19 +24,66 @@
parse.expression <- function(key, ...)
cat(Rd.expression(key, c(...)))
- pre.parse <- function(partitum)
+ first.non.null <- function(...)
+ append(NULL, c(...))[[1]]
+
+ parse.name <- function(partitum) {
+ name <- partitum$name
+ assignee <- partitum$assignee
+ S4 <- first.non.null(partitum$S4class,
+ partitum$S4method,
+ partitum$S4generic)
+ name <- first.non.null(name, assignee, S4)
+ ## sink(name)
+ if (!is.null(name))
+ parse.expression('name', name)
+ }
+
+ parse.formals <- function(partitum) {
+ formals <- partitum$formals
+ if (!is.null(formals)) {
+ name.defaults <- zip.c(names(formals), formals)
+ args <-
+ do.call(paste, c(Map(function(name.default) {
+ name <- car(name.default)
+ default <- cadr(name.default)
+ if (is.null.string(default))
+ name
+ else
+ sprintf('%s=%s', name, default)
+ },
+ name.defaults),
+ sep=', '))
+ cat(strwrap(Rd.expression('usage',
+ sprintf('%s(%s)', partitum$assignee, args)),
+ exdent=4),
+ sep='\n')
+ }
+ }
+
+ parse.usage <- function(partitum) {
+ if (is.null(partitum$usage))
+ parse.formals(partitum)
+ else
+ parse.expression('usage', partitum$usage)
+ }
+
+ pre.parse <- function(partitum) {
assign.parent('params', nil, environment())
+ parse.name(partitum)
+ parse.usage(partitum)
+ }
- post.parse <- function(partitum)
+ post.parse <- function(partitum) {
parse.arguments()
+ ## sink(NULL)
+ }
roclet <- make.roclet(parse.expression,
pre.parse,
post.parse)
- roclet$register.default.parsers('name',
- 'title',
- 'usage',
+ roclet$register.default.parsers('title',
'references',
'note',
'author',
Modified: pkg/R/collate.R
===================================================================
--- pkg/R/collate.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/R/collate.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -3,9 +3,9 @@
#' @include string.R
roxygen()
-#' Make collate roclet which parses the result of \code{parse.files},
-#' topologically sorting \code{@@include}s and writing a \code{collate} directive
-#' to standard out.
+#' Make collate roclet which parses the given files; topologically
+#' sorting \code{@@include}s and writing a \code{Collate} directive to
+#' standard out.
#'
#' Contains the member function \code{parse} which parses the result
#' of \code{parse.files}.
Modified: pkg/R/list.R
===================================================================
--- pkg/R/list.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/R/list.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -62,6 +62,13 @@
cadr(car(list))
}
+#' Composite \code{car}/\code{cdr}
+#' @param list the list from which to extract
+#' @return The extracted elements
+cdddr <- function(list) {
+ cddr(cdr(list))
+}
+
#' Is a number even?
#' @param a the number to test
#' @return Whether the number is even
Modified: pkg/R/namespace.R
===================================================================
--- pkg/R/namespace.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/R/namespace.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -3,8 +3,8 @@
#' @include string.R
roxygen()
-#' Make a namespace roclet which parses the result of \code{parse.files}
-#' and writes a list of namespace directives to standard out.
+#' Make a namespace roclet which parses the given files writes a list of
+#' namespace directives to standard out.
#'
#' Contains the member function \code{parse} which parses the result
#' of \code{parse.files}.
Modified: pkg/R/parse.R
===================================================================
--- pkg/R/parse.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/R/parse.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -64,7 +64,7 @@
#' @return \code{NULL}
#' @seealso \code{\link{register.parser}}
register.srcref.parser <- Curry(register.parser,
- table=preref.parsers)
+ table=srcref.parsers)
#' Register many parsers at once.
#' @param table the table under which to register
@@ -250,7 +250,7 @@
#' @return An list containing the class to be set
register.srcref.parser('setClass',
function(pivot, expression)
- list(class=cadr(car(expression))))
+ list(S4class=car(expression)))
#' Parse S4 \code{setGeneric} method.
#' @param pivot the parsing pivot
@@ -258,7 +258,7 @@
#' @return A list containing the generic
register.srcref.parser('setGeneric',
function(pivot, expression)
- list(generic=cadr(car(expression))))
+ list(S4generic=car(expression)))
#' Parse S4 \code{setMethod} method.
#' @param pivot the parsing pivot
@@ -266,8 +266,8 @@
#' @return A list containing the method to be set
register.srcref.parser('setMethod',
function(pivot, expression)
- list(method=cadr(car(expression)),
- signature=caddr(car(expression))))
+ list(S4method=car(expression),
+ signature=cadr(expression)))
#' Default parser-lookup; if key not found, return
#' the default parser specified.
@@ -348,22 +348,110 @@
}
}
+#' Recursively walk an expression (as returned by \code{parse}) in
+#' preorder.
+#' @param proc the procedure to apply to each subexpression
+#' @param expression the root of the expression
+#' @return NULL
+preorder.walk.expression <- function(proc, expression) {
+ if (length(expression) > 0)
+ for (i in c(1:length(expression))) {
+ member <- tryCatch(expression[[i]], error=function(e) NULL)
+ if (!is.null(member) && !identical(member, expression)) {
+ proc(member)
+ if (typeof(member) != 'pairlist')
+ preorder.walk.expression(proc, member)
+ }
+ }
+}
+
+#' Flatten a nested expression into a list, preorderly.
+#' @param expression the root of the expression to be
+#' flattened
+#' @return A list containing the flattened expression
+preorder.flatten.expression <- function(expression) {
+ flattened <- NULL
+ preorder.walk.expression(function(expression)
+ flattened <<- append(flattened, expression),
+ expression)
+ flattened
+}
+
+#' Whether the expression implies assignment by \code{<-}
+#' or \code{=}.
+#' @param expression the expression to check for assignment
+#' @return Whether or not the expression assigns by \code{<-}
+#' \code{=}
+is.assignment <- function(expression) {
+ class <- class(expression)
+ class == '<-' | class == '='
+}
+
+#' Whether the expression assigns function
+#' @param expression the expression to check for assignment
+#' @return Whether the expression assigns a function
+is.function.definition <- function(expression)
+ expression == 'function'
+
+#' Find the formal arguments associated with a given
+#' expression (may be \code{NULL}).
+#' @param expressions the expressions from which to extract
+#' formal arguments
+#' @return The formal arguments of said expression or
+#' \code{NULL}
+parse.formals <- function(expressions) {
+ formals <- NULL
+ call <- car(expressions)
+ if (is.call(call)) {
+ f <- cadr(expressions)
+ if (is.function.definition(f))
+ formals <- tryCatch(formals(eval(call)),
+ error=function(e) NULL)
+ }
+ if (is.null(formals)) formals
+ else list(formals=Map(function(formal)
+ if (is.call(formal)) capture.output(formal)
+ else as.character(formal), formals))
+}
+
+#' Find the assignee of the expression
+#' @param expression the expression in which to find the
+#' assignee
+#' @return The expression's assignee
+parse.assignee <- function(expression)
+ list(assignee=as.character(car(expression)))
+
+#' Parse a function call, paying special attention to
+#' assignments by \code{<-} or \code{=}.
+#' @param expressions the expression to search through
+#' @return List of formals and assignee in case of
+#' assignment, the processed expression in case of
+#' non-assigning function calls (see \code{parse.srcref}).
+parse.call <- function(expressions) {
+ call <- car(expressions)
+ if (is.assignment(call)) {
+ assignee <- parse.assignee(cddr(expressions))
+ formals <- parse.formals(cdddr(expressions))
+ append(assignee, formals)
+ } else {
+ lhs <- as.character(cadr(expressions))
+ parser.srcref(lhs)(lhs, cddr(expressions))
+ }
+}
+
#' Parse a srcref
#' @param ref the srcref to be parsed
#' @return List containing the parsed srcref
parse.ref.srcref <- function(ref, ...) {
srcfile <- attributes(ref)$srcfile
+ srcref <- list(srcref=list(filename=srcfile$filename,
+ lloc=as.vector(ref)))
lines <- getSrcLines(srcfile, car(ref), caddr(ref))
- expression <- parse(text=lines)
- pivot <- tryCatch(caar(expression), error=function(e) NULL)
- parsed <- list(srcref=list(filename=srcfile$filename,
- lloc=as.vector(ref)))
- if (!is.null(pivot)) {
- parser <- parser.srcref(as.character(pivot))
- parsed <- append(do.call(parser, list(pivot, expression)),
- parsed)
- }
- parsed
+ expressions <- preorder.flatten.expression(parse(text=lines))
+ parsed <- NULL
+ if (is.call(car(expressions)))
+ parsed <- parse.call(expressions)
+ append(parsed, srcref)
}
#' Parse each of a list of preref/srcref pairs.
Modified: pkg/sandbox/example-Rd-nlm.R
===================================================================
--- pkg/sandbox/example-Rd-nlm.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/sandbox/example-Rd-nlm.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -14,16 +14,10 @@
#' The functions supplied must always return finite (including not
#' \code{NA} and not \code{NaN}) values.
#'
-#' @name nlm
#' @aliases nlm
#' @title Non-Linear Minimization
#' @concept optimization
#' @author Example Author \email{author@@example.com}
-#' @usage
-#' nlm(f, p, \dots, hessian = FALSE, typsize = rep(1, length(p)),
-#' fscale = 1, print.level = 0, ndigit = 12, gradtol = 1e-6,
-#' stepmax = max(1000 * sqrt(sum((p/typsize)^2)), 1000),
-#' steptol = 1e-6, iterlim = 100, check.analyticals = TRUE)
#'
#' @param f the function to be minimized. If the function value has
#' an attribute called \code{gradient} or both \code{gradient} and
Modified: pkg/sandbox/main.R
===================================================================
--- pkg/sandbox/main.R 2008-07-22 18:29:18 UTC (rev 76)
+++ pkg/sandbox/main.R 2008-07-23 21:57:32 UTC (rev 77)
@@ -3,7 +3,7 @@
source('../R/string.R')
source('../R/parse.R')
-FILE <- 'example-S3-mcpi.R'
+FILE <- 'example-S4-person.R'
argv <- commandArgs(trailingOnly=T)
argc <- length(argv)
More information about the Roxygen-commits
mailing list