src/library/tools/R/Rprof.R

#  File src/library/tools/R/Rprof.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2017 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

.Rprof <- function(args = NULL, no.q = FALSE)
{
    do_exit <-
	if(no.q)
	    function(status) (if(status) stop else message)(
		".Rprof() exit status ", status)
	else
	    function(status) q("no", status = status, runLast = FALSE)

    Usage <- function() {
        cat("Usage: R CMD Rprof [options] [file]",
            "",
            "Post-process profiling information in file generated by Rprof().",
            "",
            "Options:",
            "  -h, --help       print short help message and exit",
            "  -v, --version    print version info and exit",
            "  --lines          print line information",
            "  --total          print only by total",
            "  --self           print only by self",
            "  --linesonly      print only by line (implies --lines)",
            "  --min%total=     minimum % to print for 'by total'",
            "  --min%self=      minimum % to print for 'by self'",
            "",
            "If 'file' is omitted 'Rprof.out' is used",
            "",
            "Report bugs at <https://bugs.R-project.org>.", sep = "\n")
    }

    if (is.null(args)) {
        args <- commandArgs(TRUE)
        ## it seems that splits on spaces, so try harder.
        args <- paste(args, collapse=" ")
        args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]
    }

    files <- character()
    bytotal <- byself <- bylines <- TRUE
    lines <- FALSE
    mintotal <- minself <- -1L
    while(length(args)) {
        a <- args[1L]
        if (a %in% c("-h", "--help")) {
            Usage()
            do_exit(0L)
        }
        else if (a %in% c("-v", "--version")) {
            cat("R profiling post-processor: ",
                R.version[["major"]], ".",  R.version[["minor"]],
                " (r", R.version[["svn rev"]], ")\n", sep = "")
            cat("",
                "Copyright (C) 1997-2014 The R Core Team.",
                "This is free software; see the GNU General Public License version 2",
                "or later for copying conditions.  There is NO warranty.",
                sep = "\n")
            do_exit(0L)
        } else if (a == "--total") {
            bytotal <- TRUE
            byself <- FALSE
            bylines <- FALSE
        } else if (a == "--self") {
            bytotal <- FALSE
            byself <- TRUE
            bylines <- FALSE
        } else if (a == "--linesonly") {
            lines <- TRUE
            byself <- FALSE
            bytotal <- FALSE
            bylines <- TRUE
        } else if (a == "--lines") {
            lines <- TRUE
        } else if (substr(a, 1, 12)  == "--min%total=") {
            mintotal <- as.integer(substr(a, 13, 1000))
        } else if (substr(a, 1, 11)  == "--min%self=") {
            minself <- as.integer(substr(a, 12, 1000))
        } else files <- c(files, a)
        args <- args[-1L]
    }
    file <- if (!length(files)) "Rprof.out" else files[1L]

    res <- utils::summaryRprof(file, lines = if (lines) "show" else "hide")

    cat("\nEach sample represents", format(res$sample.interval), "seconds.\n")
    cat("Total run time:", format(res$sampling.time), "seconds.\n")
    cat("\nTotal seconds: time spent in function and callees.\n")
    cat("Self seconds: time spent in function alone.\n\n")

    printed <- FALSE
    if (bytotal) {
        m <- data.frame(res$by.total[c(2,1,4,3)], row.names(res$by.total))
        if(mintotal > 0) m <- m[m[,1L] >= mintotal,,drop = FALSE]
        writeLines(c("   %       total       %        self",
                     " total    seconds     self    seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
        printed <- TRUE
    }
    if(byself) {
        if (printed) cat("\n\n")
        m <- data.frame(res$by.self[c(2,1,4,3)], row.names(res$by.self))
        if(minself > 0) m <- m[m[,1L] >= minself,,drop = FALSE]
        writeLines(c("   %        self       %      total",
                     "  self    seconds    total   seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
        printed <- TRUE
    }
    if(lines && bylines) {
        if (printed) cat("\n\n")
        m <- data.frame(res$by.line[c(2,1,4,3)], row.names(res$by.line))
        if(minself > 0) m <- m[m[,1L] >= minself,,drop = FALSE]
        if(mintotal > 0) m <- m[m[,1L] >= mintotal,,drop = FALSE]
        writeLines(c("   %        self       %      total",
                     "  self    seconds    total   seconds    name",
                     sprintf("%6.1f%10.2f%10.1f%10.2f     %s",
                             m[,1L], m[,2L], m[,3L], m[,4L], m[,5L])))
    }
    do_exit(0L)
}