Calls summary for the Rprof log

proftable.R

proftable <- function(filename = "Rprof.out", return.calls = FALSE) {
    prof.data <- scan(filename, what = "character", quote = "\"", sep = "\n",
                      strip.white = TRUE, multi.line = FALSE, quiet = TRUE)
    interval <- as.numeric(strsplit(prof.data[1L], split = "=", fixed = TRUE)[[1L]][2L]) / 1e+06
    prof.data <- prof.data[-1L]
    filelines <- grep("^#File", prof.data)
    if (length(filelines)) {
        files <- prof.data[filelines]
        filenames <- gsub("^#File ", "", files)
        prof.data <- prof.data[-filelines]
    } else
        filenames <- "None"
    n.calls <- length(prof.data)
    total.time <- n.calls * interval
    calls <- unique(prof.data)
    real.time <- tabulate(match(prof.data, calls)) * interval
    pct.time <- real.time / total.time * 100L
    calls <- strsplit(calls, split = " ", fixed = TRUE)
    calls <- lapply(calls, rev)
    min.len <- min(vapply(calls, length, FUN.VALUE = numeric(1L)))
    parent.call <- Reduce(intersect, lapply(calls, .subset, seq_len(min.len)))
    calls <- lapply(calls, setdiff, parent.call)
    calls <- vapply(calls, paste, collapse = " > ", FUN.VALUE = character(1L))
    calls <- data.frame(real.time = real.time, pct.time = pct.time, call = calls, stringsAsFactors = FALSE)
    calls <- calls[order(calls$pct.time, decreasing = TRUE), ]
    rownames(calls) <- NULL
    if (length(parent.call))
        parent.call <- paste(parent.call, collapse = " > ")
    else
        parent.call <- "None"
    res <- structure(
        list(calls = calls,
             parent.call = parent.call,
             interval = interval,
             total.time = total.time,
             files = filenames),
        class = c("proftable", "list")
    )
    if (return.calls) {
        calls.data <- strsplit(prof.data, " ", fixed = TRUE)
        calls.data <- lapply(calls.data, rev)
        calls.data <- vapply(calls,data, paste, collapse = " > ", FUN.VALUE = character(1L))
        res$data <- calls.data
    }
    return(res)
}

print.proftable <- function(x, lines = 10, digits = 3, width = getOption("width")) {
    calls <- head(x$calls, n = lines)
    total.pct.time <- sum(calls$pct.time)
    cat("Calls:\n")
    print(calls, right = FALSE, digits = digits)
    cat("\n")
    if (x$files == "None") {
        cat("Files:", x$files, "\n")
    } else {
        cat("Files:\n")
        cat(x$files, sep = "\n")
    }
    cat("\n")
    cat("Parent Call:", x$parent.call, "\n")
    cat("\n")
    cat("Total Time:", format(x$total.time, digits = digits), "seconds\n")
    cat("\n")
    cat("Percent of run time represented: ", format(total.pct.time, digits = digits), "%\n", sep = "")
    invisible(x)
}