Add filename and line number fields (#4)

R/parse.R

@@ -2,30 +2,47 @@ parse_log <- function(filename) {
     stopifnot(is.character(filename))
     stopifnot(length(filename) == 1L)
     if (!file.exists(filename))
-        stop(sprintf("'%s' does not exists.", filename))
+        stop(sprintf("File '%s' does not exists.", filename))
     proflog <- scan(filename, what = "character", quote = "\"", sep = "\n",
-                     strip.white = TRUE, multi.line = FALSE, quiet = TRUE)
+                    strip.white = TRUE, multi.line = FALSE, quiet = TRUE)
     if (length(proflog) < 2L)
         stop(sprintf("'%s' file is empty.", filename))
-    first <- proflog[1L]
+    metadata <- get_prof_info(proflog[1L])
     proflog <- proflog[-1L]
-    interval <- as.numeric(strsplit(first, "=", fixed = TRUE)[[1L]][2L]) / 1e06
     calls <- unique(proflog, fromLast = TRUE)
-    if (grepl("line profiling", first, fixed = TRUE))
-        calls <- calls[!grepl("#File ", calls, fixed = TRUE)]
-    real.time <- tabulate(match(proflog, calls)) * interval
+    if (metadata$line.profiling) {
+        ind <- grep("#File ", calls, fixed = TRUE)
+        fnames <- strsplit(calls[ind], ": ", fixed = TRUE)
+        fnames <- vapply(fnames, .subset2, 2L, FUN.VALUE = "")
+        calls <- calls[-ind]
+        tmp <- strsplit(gsub(".*(\\d#\\d).*", "\\1", calls), "#", fixed = TRUE)
+        tmp <- lapply(tmp, as.integer)
+        fnums <- vapply(tmp, .subset2, 1L, FUN.VALUE = 1L)
+        files <- fnames[fnums]
+        lines <- vapply(tmp, .subset2, 2L, FUN.VALUE = 1L)
+    }
+    real.time <- tabulate(match(proflog, calls)) * metadata$interval
     total.time <- sum(real.time)
     pct.time <- real.time / total.time
-    calls <- remove_extra_info(calls, first)
+    calls <- remove_extra_info(calls, metadata)
     calls <- remove_source_frame(calls)
     calls <- lapply(strsplit(calls, split = " ", fixed = TRUE), rev)
     calls <- vapply(calls, function(x) paste(c(" \u00B0", x), collapse = "/"), character(1L))
     res <- list(pathString = calls, real = real.time, percent = pct.time)
+    if (metadata$line.profiling)
+        res <- append(res, list(file = files, line = lines))
     class(res) <- "data.frame"
     attr(res, "row.names") <- .set_row_names(length(calls))
     res
 }
 
+get_prof_info <- function(firstline) {
+    list(line.profiling = grepl("line profiling", firstline, fixed = TRUE),
+         memory.profiling = grepl("memory profiling", firstline, fixed = TRUE),
+         gc.profiling = grepl("gc profiling", firstline, fixed = TRUE),
+         interval = as.numeric(strsplit(firstline, "=", fixed = TRUE)[[1L]][2L]) / 1e6)
+}
+
 remove_source_frame <- function(calls) {
     pattern <- " eval eval withVisible source$"
     ind <- grep(pattern, calls)
@@ -35,13 +52,13 @@ remove_source_frame <- function(calls) {
 }
 
 remove_extra_info <- function(calls, meta) {
-    if (!grepl("profiling", meta, fixed = TRUE))
+    if (!any(unlist(meta[-4])))
         return(calls)
-    if (grepl("line profiling", meta, fixed = TRUE))
+    if (meta$line.profiling)
         calls <- gsub("\\d+#\\d+", "", calls)
-    if (grepl("memory profiling", meta, fixed = TRUE))
+    if (meta$memory.profiling)
         calls <- gsub("^:.*:", "", calls)
-    if (grepl("GC profiling", meta, fixed = TRUE))
+    if (meta$gc.profiling)
         calls <- gsub("<GC>", "", calls, fixed = TRUE)
     calls <- calls[nzchar(calls)]
     gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", calls, perl = TRUE)

R/prof-tree.R

@@ -1,10 +1,11 @@
 #' @title Summarise Output of R Sampling Profiler
 #' @description Summarise the output of the \code{\link{Rprof}} function to show the amount of time used by different R functions as tree structure.
 #' @param filename Name of a file produced by \code{Rprof()}.
+#' @return An object of \code{ProfTree} and \code{Node} classes.
 #' @include parse.R env.R
 #' @importFrom data.tree FromDataFrameTable isNotRoot isNotLeaf Aggregate SetFormat FormatPercent
 #' @export
-#' @seealso \code{\link{Rprof}} \code{\link{summaryRprof}}  \code{\link[data.tree]{plot.Node}}
+#' @seealso \code{\link{Rprof}} \code{\link{summaryRprof}} \code{\link[data.tree]{plot.Node}}
 #' @examples
 #' Rprof(tmp <- tempfile())
 #' example(glm)
@@ -23,6 +24,12 @@ prof.tree <- function(filename = "Rprof.out") {
             traversal = "post-order", filterFun = isNotLeaf)
     tree$Do(function(node) node$env <- get_envname(node$name), filterFun = isNotRoot)
     tree$Do(function(node) node$name <- sprintf("`%s`", node$name), filterFun = isNotRoot)
+    if ("line" %in% res$fieldsAll) {
+        tree$Do(function(node) node$file <- node$parent$file,
+                traversal = "pre-order", filterFun = function(node) is.null(node$file))
+        tree$Do(function(node) node$line <- node$parent$line,
+                traversal = "pre-order", filterFun = function(node) is.null(node$line))
+    }
     SetFormat(tree, "percent", function(x) FormatPercent(x, digits = 1))
     class(tree) <- c("ProfTree", class(tree))
     return(tree)
@@ -35,6 +42,10 @@ prof.tree <- function(filename = "Rprof.out") {
 #' @export
 #'
 print.ProfTree <- function(x, limit = 25, ...) {
-    NextMethod("print", x, "real", "percent", "env",
-               pruneMethod = "dist", limit = limit)
+    if ("line" %in% res$fieldsAll)
+        NextMethod("print", x, "real", "percent", "env", "file", "line",
+                   pruneMethod = "dist", limit = limit)
+    else
+        NextMethod("print", x, "real", "percent", "env",
+                   pruneMethod = "dist", limit = limit)
 }