@@ -7,7 +7,7 @@ Author: Hadley Wickham <h.wickham@gmail.com> Maintainer: Hadley Wickham <h.wickham@gmail.com> Description: profr provides an alternative data structure and visual rendering for the profiling information generated by Rprof. URL: http://had.co.nz/profr -Depends: R (>= 2.6.2) +Depends: R (>= 2.6.2), digest Suggests: ggplot2 License: MIT LazyData: true \ No newline at end of file DESCRIPTION @@ -9,84 +9,75 @@ # @keyword debugging # @value \code{\link{data.frame}} of class \code{profr} # @seealso \code{\link{profr}} for profiling and parsing +#X nesting <- parse_rprof(system.file("samples", "nesting.rprof", "profr")) +#X diamonds <- parse_rprof(system.file("samples", "diamonds.rprof", "profr")) parse_rprof <- function(path, interval=0.02) { lines <- scan(path, what="character", sep="\n") - clean.lines <- lines[-grep("sample\\.interval=",lines)] - calls <- sapply(clean.lines, strsplit, split=" ", USE.NAMES = FALSE) - calls <- sapply(calls, rev) - calls <- sapply(calls, function(x) gsub("\"","", x)) - - attr(calls, "interval") <- interval - - df <- .simplify_all(.compact(calls)) - - times <- c("time", "start", "end") - df[times] <- df[times] * interval - - df[c("f", "level", times, "leaf", "source")] + clean.lines <- lines[-grep("sample\\.interval=",lines)] + calls <- sapply(clean.lines, strsplit, split=" ", USE.NAMES = FALSE) + calls <- sapply(calls, rev) + calls <- sapply(calls, function(x) gsub("\"","", x)) + + df <- .simplify(calls) + + times <- c("time", "start", "end") + df[times] <- df[times] * interval + + df[c("f", "level", times, "leaf", "source")] } -.compact <- function(s, order=TRUE,reverse=FALSE) { - .compact.row <- function(s1) data.frame(f=s1$call, level=1:s1$depth, start=s1$start, leaf=1:s1$depth == s1$depth) +.simplify <- function(calls) { + df <- .expand(calls) + + levels <- split(df, df$level) + res <- do.call(rbind, lapply(levels, .collapse_adjacent)) - depth <- sapply(s, length) - s <- data.frame( - call = array(unclass(s)), - start = 0:(length(s)-1), - depth = depth - ) - - structure( - do.call(rbind, apply(s, 1, .compact.row)), - interval = attr(s,"interval") - ) + rownames(res) <- 1:nrow(res) + res$time <- res$end - res$start + res$source <- .function_sources(res) + class(res) <- c("profr", "data.frame") + res } -.simplify <- function(df) { +.collapse_adjacent <- function(df) { # for each level, want to collapse consecutive of the same function to one # provided all previous calls are the same too - change <- c(TRUE, (diff(df$start) == 1) & (df$f[-1] != df$f[-nrow(df)])) - last_time <- max(df$start) + 1 - - df <- df[change, ] - df$time <- diff(c(df$start, last_time)) - df$end <- df$start + df$time - - df + + id <- cumsum(c(TRUE, df$hist[-1] != df$hist[-nrow(df)])) + groups <- lapply(split(df, id), function(df) { + transform(df[1, ], end = max(df$end)) + }) + do.call("rbind", groups) } -.simplify_all <- function(df) { - res <- do.call(rbind, - lapply(unique(df$level[df$level > 2] - 2), function(x) .simplify(subset(df, level==x))) - ) - rownames(res) <- 1:nrow(res) - res$leaf <- .leaves_all(res) - res$source <- .function_sources(res) - class(res) <- c("profr", "data.frame") - res +.expand <- function(calls) { + .expand.call <- function(s1) with(s1, data.frame( + f = call, + level = 1:depth, + start = start, + end = start + 1, + leaf = 1:depth == depth, + hist = sapply(1:depth, function(i) digest(call[seq_len(i)])) + )) + + depth <- sapply(calls, length) + calldf <- data.frame( + call = array(unclass(calls)), + start = 0:(length(calls)-1), + depth = depth + ) + + do.call(rbind, apply(calldf, 1, .expand.call)) } -.leaves <- function(df, x) { - lev <- subset(df, level == x) - - !sapply(1:nrow(lev), function(row) { - nrow(.relations(df, lev[row, "start"], lev[row, "end"], x+1)) > 0 - }) -} -.leaves_all <- function(df) { - unlist(lapply(1:max(df$level), function(x) .leaves(df, x))) -} -.relations <- function(df, start, end, levels) { - df[df$level %in% levels & df$start >= start & df$end <= end, ] -} .function_sources <- function(df) { - fs <- sapply(levels(df$f), function(x) do.call(getAnywhere, list(x))$where[1]) - - packaged <- grep("package", fs) - names <- sapply(strsplit(fs[packaged], ":"), "[", 2) + fs <- sapply(levels(df$f), function(x) do.call(getAnywhere, list(x))$where[1]) + + packaged <- grep("package", fs) + names <- sapply(strsplit(fs[packaged], ":"), "[", 2) - fs[-packaged] <- NA - fs[packaged] <- names - unname(fs[as.character(df$f)]) + fs[-packaged] <- NA + fs[packaged] <- names + unname(fs[as.character(df$f)]) } \ No newline at end of file R/parse.r @@ -23,4 +23,4 @@ library(reshape) Rprof("diamonds.rprof") dm <- melt(diamonds) cast(dm, cut + color + clarity ~ variable, mean) -Rprof(NULL) \ No newline at end of file +Rprof(NULL) inst/samples/generate.r @@ -1,4 +1,5 @@ # library(prof) +library(digest) FILE <- (function() { attr(body(sys.function()), "srcfile") load.r 057892c9b6889004f80252f717af0d5fea8f8c3c hadley h.wickham@gmail.com http://github.com/hadley/profr/commit/37329f45e72a32970fe99b084cd4ea07bfece5cd 37329f45e72a32970fe99b084cd4ea07bfece5cd 2008-05-01T17:56:15-07:00 2008-05-01T17:56:15-07:00 Rewrite parser. Improvement correctness and complexity. f3b6e94f9fd120ae43501521f6b5f250707d3512 hadley h.wickham@gmail.com