[Roxygen-commits] r131 - in pkg: R sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 30 06:48:51 CEST 2008
Author: pcd
Date: 2008-07-30 06:48:51 +0200 (Wed, 30 Jul 2008)
New Revision: 131
Modified:
pkg/R/Rd.R
pkg/R/callgraph.R
pkg/R/roclet.R
pkg/sandbox/callgraph.R
Log:
guess.name abstraction; discover subcalls with eval hack
Modified: pkg/R/Rd.R
===================================================================
--- pkg/R/Rd.R 2008-07-29 04:31:24 UTC (rev 130)
+++ pkg/R/Rd.R 2008-07-30 04:48:51 UTC (rev 131)
@@ -203,12 +203,7 @@
#' @param partitum the pre-parsed elements
#' @return \code{NULL}
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)
+ name <- guess.name(partitum)
if (is.null(name) && !is.null(subdir)) {
filename <- partitum$srcref$filename
first.line <- car(partitum$srcref$lloc)
Modified: pkg/R/callgraph.R
===================================================================
--- pkg/R/callgraph.R 2008-07-29 04:31:24 UTC (rev 130)
+++ pkg/R/callgraph.R 2008-07-30 04:48:51 UTC (rev 131)
@@ -1,8 +1,177 @@
#' @include roxygen.R
#' @include roclet.R
-roclet()
+#' @include functional.R
+roxygen()
-make.callgraph.roclet <- function(outfile='',
+#' @importFrom Rgraphviz toFile
+make.callgraph.roclet <- function(dir='.',
verbose=TRUE) {
- ## Need to abstract some parse.name stuff out of Rd
+ DEFAULT.DEPTH <- 2
+
+ do.callgraph <- FALSE
+ do.callgraph.primitives <- FALSE
+ depth <- DEFAULT.DEPTH
+
+ parse.default <- function(key, expression) NULL
+
+ reset.state <- function(partitum) {
+ do.callgraph <- FALSE
+ do.callgraph.primitives <- FALSE
+ depth <- DEFAULT.DEPTH
+ call.stack <- make.stack()
+ subcalls <- new.env(parent=emptyenv())
+ calls <- NULL
+ }
+
+ post.parse <- function(partitum) {
+ if (is.null(name <- guess.name(partitum)))
+ stop('Nameless callgraph')
+ else {
+ if (do.callgraph || do.callgraph.primitives) {
+ env <- new.env()
+ eval(parse(text=src.lines(partitum)),
+ envir=env)
+ e <- parse(text=src.lines(partitum))
+ preorder.walk.expression(discover.subcalls,
+### expression(eval(parse(text=src.lines(partitum))))
+### parse(as.expression(call(name)))
+### expression(append)
+### as.expression(call(get(name, env)))
+### as.expression(call(name))
+ e
+ )
+ graphviz(subcalls)
+ }
+ }
+ }
+
+ make.stack <- function() {
+ stack <- new.env(parent=emptyenv())
+ stack$top <- 0
+ stack$max.depth <- 0
+ stack$elements <- NULL
+ stack$is.empty <- function() stack$top == 0
+ stack$push <- function(x) {
+ stack$top <- stack$top + 1
+ stack$max.depth <- max(stack$max.depth,
+ stack$top)
+ stack$elements[stack$top] <- x
+ }
+ stack$pop <- function() {
+ if (stack$is.empty())
+ stop('Stack underflow')
+ stack$top <- stack$top - 1
+ stack$elements[[stack$top + 1]]
+ }
+ stack$peek <- function() {
+ if (stack$is.empty())
+ stop('Stack underflow')
+ stack$elements[[stack$top]]
+ }
+ stack
+ }
+
+ call.stack <- make.stack()
+
+ subcalls <- new.env(parent=emptyenv())
+
+ calls <- NULL
+
+ is.callable <- function(name, include.primitives) {
+ f <- tryCatch(get(name, mode='function'), error=function(e) NULL)
+ !is.null(f) && ifelse(include.primitives, TRUE, !is.primitive(f))
+ }
+
+ discover.subcalls <- function(exprofundum)
+ if (is.name(exprofundum)) {
+ subcall <- as.character(exprofundum)
+ if (is.callable(subcall, do.callgraph.primitives) &&
+ call.stack$top < depth) {
+ supercall <-
+ if (call.stack$is.empty())
+ NULL
+ else
+ call.stack$peek()
+ if (!is.null(supercall)) {
+ subsupercalls <- subcalls[[supercall]]
+ if (!subcall %in% subsupercalls)
+ subcalls[[supercall]] <<-
+ append(subsupercalls, subcall)
+ }
+ if (!subcall %in% calls) {
+ call.stack$push(subcall)
+ calls <<- append(subcall, calls)
+ subcalls[[subcall]] <<- NULL
+ body <- tryCatch(body(subcall), error=function(e) NULL)
+ if (!is.null(body))
+ preorder.walk.expression(discover.subcalls, body)
+ call.stack$pop()
+ }
+ }
+ }
+
+ remove.edge.separators <- function(string)
+ gsub('\\|', '|', string)
+
+ PHI <- (1 + sqrt(5)) / 2
+
+ formals(toFile) <- alist(graph=,
+ layoutType=c("dot", "neato", "twopi",
+ "circo", "fdp"),
+ filename=,
+ fileType=c("canon", "dot", "xdot",
+ "dia", "fig", "gd", "gd2", "gif", "hpgl",
+ "imap", "cmapx", "ismap", "mif", "mp", "pcl",
+ "pdf", "pic", "plain", "plain-ext", "png", "ps",
+ "ps2", "svg", "svgz", "vrml", "vtx", "wbmp"))
+
+ graphviz <- function(subcalls) {
+ supercalls <- ls(subcalls)
+ ## Check for is.null(supercalls)
+ graph <- new('graphNEL', nodes=unlist(Map(remove.edge.separators,
+ supercalls)))
+ for (supercall in supercalls)
+ for (subsupercall in subcalls[[supercall]])
+ try(graph <- addEdge(remove.edge.separators(supercall),
+ remove.edge.separators(subsupercall),
+ graph))
+ ag <- agopenSimple(graph, 'roxygenize')
+ graphDataDefaults(ag, 'ratio') <- PHI
+ graphDataDefaults(ag, 'splines') <- 'true'
+ nodeDataDefaults(ag, 'fontname') <- 'monospace'
+ edgeDataDefaults(ag, 'arrowtail') <- 'normal'
+ toFile(ag,
+ layoutType='fdp',
+ filename='test.pdf',
+ fileType='pdf')
+ }
+
+ roclet <- make.roclet(parse.default,
+ pre.parse=reset.state,
+ post.parse=post.parse)
+
+ parse.callgraph <- function(key, expression)
+ do.callgraph <<- TRUE
+
+ parse.callgraph.primitives <- function(key, expression)
+ do.callgraph.primitives <<- TRUE
+
+ parse.callgraph.depth <- function(key, expression) {
+ depth <- tryCatch(as.numeric(expression),
+ warning=function(e) NULL,
+ error=function(e) NULL)
+ if (is.null(depth))
+ warning('@callGraphDepth should be a number; resorting to default.')
+ else
+ assign.parent('depth', depth, environment())
+ }
+
+ roclet$register.parser('callGraph',
+ parse.callgraph)
+ roclet$register.parser('callGraphPrimitives',
+ parse.callgraph.primitives)
+ roclet$register.parser('callGraphDepth',
+ parse.callgraph.depth)
+
+ roclet
}
Modified: pkg/R/roclet.R
===================================================================
--- pkg/R/roclet.R 2008-07-29 04:31:24 UTC (rev 130)
+++ pkg/R/roclet.R 2008-07-30 04:48:51 UTC (rev 131)
@@ -108,3 +108,21 @@
#' @return The first non-null argument
first.non.null <- function(...)
append(NULL, c(...))[[1]]
+
+#' Pluck name from a hierarchy of candidates; viz. name,
+#' assignee, S4class, S4method, S4generic.
+#' @param partitum the parsed elements
+#' @return The guessed name (possibly \code{NULL})
+guess.name <- function(partitum)
+ first.non.null(partitum$name,
+ partitum$assignee,
+ partitum$S4class,
+ partitum$S4method,
+ partitum$S4generic)
+
+src.lines <- function(partitum) {
+ srcfile <- srcfile(partitum$srcref$filename)
+ first.line <- car(partitum$srcref$lloc)
+ last.line <- caddr(partitum$srcref$lloc)
+ getSrcLines(srcfile, first.line, last.line)
+}
Modified: pkg/sandbox/callgraph.R
===================================================================
--- pkg/sandbox/callgraph.R 2008-07-29 04:31:24 UTC (rev 130)
+++ pkg/sandbox/callgraph.R 2008-07-30 04:48:51 UTC (rev 131)
@@ -49,11 +49,11 @@
!is.null(f) && ifelse(include.primitives, TRUE, !is.primitive(f))
}
-exprofundum <- expression(append)
exprofundum <- expression(roxygenize)
+exprofundum <- as.expression(call('roxygenize'))
discover.subcalls <- function(exprofundum,
- depth=3,
+ depth=2,
include.primitives=FALSE)
if (is.name(exprofundum)) {
subcall <- as.character(exprofundum)
@@ -105,6 +105,7 @@
graphviz <- function(subcalls) {
supercalls <- ls(subcalls)
+ ## Check for is.null(supercalls)
graph <- new('graphNEL', nodes=unlist(Map(remove.edge.separators,
supercalls)))
for (supercall in supercalls)
More information about the Roxygen-commits
mailing list