[Sciviews-commits] r373 - pkg/svMisc/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun May 8 14:50:31 CEST 2011
Author: prezez
Date: 2011-05-08 14:50:31 +0200 (Sun, 08 May 2011)
New Revision: 373
Modified:
pkg/svMisc/R/captureAll.R
Log:
svMisc:captureAll rewritten from scratch. Code is much simplified, makes the most of R's native message routines (error/warning printing).
New functionalities:
- allows for subsequent traceback'ing,
- can handle user interrupts (Ctrl+C or ESC, previously it broke connection with the client completely: Bug #354)
Requires: R >= 2.13.0 (TODO: add dependency in DESCRIPTION)
Modified: pkg/svMisc/R/captureAll.R
===================================================================
--- pkg/svMisc/R/captureAll.R 2011-03-30 19:41:55 UTC (rev 372)
+++ pkg/svMisc/R/captureAll.R 2011-05-08 12:50:31 UTC (rev 373)
@@ -1,204 +1,103 @@
-captureAll <- function (expr, split = FALSE, file = NULL)
-{
- ## If expr is NA, just return it
- if (!is.language(expr))
- if (identical(expr, NA))
- return(NA) else stop("'expr' must be an expression or NA")
- ## Ensure split is always a boolean
- split <- isTRUE(split)
+# inspired by 'capture.output' and utils:::.try_silent
+# Requires: R >= 2.13.0 [??]
+`captureAll` <- function(expr, split = FALSE, file = NULL) {
+ # TODO: support for 'file' and 'split'
- ## captureAll() is inspired from capture.output(), but it captures
- ## both the output and the message streams (without redirecting
- ## the message stream, but by using a withCallingHandlers() construct).
- rval <- NULL # Just to avoid a note during code analysis
- if (is.null(file)) file <- textConnection("rval", "w", local = TRUE)
- sink(file, type = "output", split = split)
+ last.warning <- list()
+ Traceback <- list()
+ warnLevel <- getOption('warn')
+ Nframe <- sys.nframe() # frame of reference (used in traceback)
- ## This is a hack to display warning(..., immediate.) correctly
- ## (except from base objects) because there is no way to detect it
- ## in our handler with the current warning() function
- assign("warning", function(..., call. = TRUE, immediate. = FALSE,
- domain = NULL) {
- args <- list(...)
- if (length(args) == 1 && inherits(args[[1]], "condition")) {
- base::warning(..., call. = call., immediate. = immediate.,
- domain = domain)
- } else {
- ## Deal with immediate warnings
- oldwarn <- getOption("warn")
- if (immediate. && oldwarn < 1) {
- options(warn = 1)
- on.exit(options(warn = oldwarn))
- }
- .Internal(warning(as.logical(call.), as.logical(immediate.),
- .makeMessage(..., domain = domain)))
- }
- }, envir = TempEnv())
+ rval <- NULL
+ tconn <- textConnection("rval", "w", local = TRUE)
+ sink(tconn, type = "output"); sink(tconn, type = "message")
on.exit({
- sink(type = "output")
- close(file)
- if (exists("warning", envir = TempEnv(), inherits = FALSE))
- rm("warning", envir = TempEnv())
+ sink(type = "message"); sink(type = "output")
+ close(tconn)
})
- evalVis <- function (Expr)
- {
- ## We need to install our own warning handling
- ## and also, we use a customized interrupt handler
- owarns <- getOption("warning.expression")
- ## Inactivate current warning handler
- options(warning.expression = expression())
- ## ... and make sure it is restored at the end
- on.exit({
- ## Check that the warning.expression was not changed
- nwarns <- getOption("warning.expression")
- if (!is.null(nwarns) && length(as.character(nwarns)) == 0)
- options(warning.expression = owarns)
- })
- ## Evaluate instruction(s) in the user workspace (.GlobalEnv)
- res <- try(withCallingHandlers(withVisible(eval(Expr, .GlobalEnv)),
- warning = function (e) {
- msg <- conditionMessage(e)
- call <- conditionCall(e)
+ `evalVis` <- function(x) withVisible(eval(x, .GlobalEnv))
- ## Possibly truncate it
- wl <- getOption("warning.length")
- if (is.null(wl)) wl <- 1000 # Default value
- if (nchar(msg) > wl)
- msg <- paste(substr(msg, 1, wl), .gettext("[... truncated]"))
+ `restartError` <- function(e, calls) {
+ # remove call (eval(expr, envir, enclos)) from the message
+ ncls <- length(calls)
+ nn <- Nframe + 22
+ if(isTRUE(all.equal(calls[[nn]], e$call, check.attributes=FALSE)))
+ e$call <- NULL
- ## Result depends upon 'warn'
- Warn <- getOption("warn")
+ Traceback <<- rev(calls[-c(seq.int(nn), (ncls - 1L):ncls)])
+ cat(.makeMessage(e))
+ if(warnLevel == 0L && length(last.warning) > 0L)
+ cat(gettext("In addition: ", domain="R"))
+ }
- ## If warning generated in eval environment, make it NULL
- try(if (!is.null(call) && !is.symbol(call) &&
- identical(call[[1L]], quote(eval)))
- e$call <- NULL, silent = TRUE)
+ res <- tryCatch(withRestarts(withCallingHandlers({
+ # TODO: allow for multiple expressions and calls (like in
+ # 'capture.output'). The problem here is how to tell 'expression'
+ # from 'call' without evaluating it?
+ list(evalVis(expr))
+ },
- if (Warn < 0) { # Do nothing!
- return()
- } else if (Warn == 0) { # Delayed display of warnings
- if (exists("warns", envir = TempEnv())) {
- lwarn <- get("warns", envir = TempEnv())
- } else lwarn <- list()
- ## Do not add more than 50 warnings
- if (length(lwarn) >= 50) return()
+ error = function(e) invokeRestart("grmbl", e, sys.calls()),
+ warning = function(e) {
+ # remove call (eval(expr, envir, enclos)) from the message
+ nn <- Nframe + 22
+ if(isTRUE(all.equal(sys.call(nn), e$call, check.attributes=FALSE)))
+ e$call <- NULL
- ## Add the warning to this list and save in TempEnv()
- assign("warns", append(lwarn, list(e)), envir = TempEnv())
+ last.warning <<- c(last.warning, structure(list(e$call), names=e$message))
- return()
- } else if (Warn > 1) { # Generate an error!
- msg <- .gettextf("(converted from warning) %s", msg)
- stop(simpleError(msg, call = call))
- } else {
- ## warn = 1
- ## Print the warning message immediately
- ## Format the warning message
-
- ## This is modified code from base::try
- if (!is.null(call)) {
- dcall <- deparse(call)[1L]
- prefix <- paste(.gettext("Warning in"), dcall, ": ")
- LONG <- 75L
- sm <- strsplit(msg, "\n")[[1L]]
- w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
- if (is.na(w))
- w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b")
- if (w > LONG)
- prefix <- paste(prefix, "\n ", sep = "")
- } else prefix <- .gettext("Warning : ")
-
- msg <- paste(prefix, msg, "\n", sep="")
- cat(msg)
- }
+ if(warnLevel != 0L) {
+ .Internal(.signalCondition(e, conditionMessage(e), conditionCall(e)))
+ .Internal(.dfltWarn(conditionMessage(e), conditionCall(e)))
}
- , interrupt = function (i) cat(.gettext("<INTERRUPTED!>\n"))
- ## This is modified code from base::try
- , error = function(e) {
- call <- conditionCall(e)
- msg <- conditionMessage(e)
+ invokeRestart("muffleWarning")
- ## Patch up the call to produce nicer result for testing as
- ## try(stop(...)). This will need adjusting if the
- ## implementation of tryCatch changes.
- ## Use identical() since call[[1]] can be non-atomic.
- try(if (!is.null(call) && !is.symbol(call) &&
- identical(call[[1L]], quote(eval)))
- call <- NULL, silent = TRUE)
- if (!is.null(call)) {
- dcall <- deparse(call)[1L]
- prefix <- paste(.gettext("Error in "), dcall, ": ")
- LONG <- 75L
- sm <- strsplit(msg, "\n")[[1L]]
- w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
- if (is.na(w))
- w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b")
- if (w > LONG)
- prefix <- paste(prefix, "\n ", sep = "")
- } else prefix <- .gettext("Error : ")
+ }),
+ # Restarts:
- msg <- paste(prefix, msg, "\n", sep = "")
- ## Store the error message for legacy uses of try() with
- ## geterrmessage().
- .Internal(seterrmessage(msg[1L]))
- if (identical(getOption("show.error.messages"), TRUE))
- cat(msg)
- }
- , message = function(e) {
- signalCondition(e)
- cat(conditionMessage(e))
- }
- ), silent = TRUE)
- ## Possibly add 'last.warning' as attribute to res
- if (exists("warns", envir = TempEnv())) {
- warns <- get("warns", envir = TempEnv())
+ # Handling user interrupts. Currently it works only from within R.
+ #TODO: how to trigger interrupt via socket connection?
+ abort = function(...) {
+ cat("<aborted!>\n") #DEBUG
+ },
- ## Reshape the warning list
- last.warning <- lapply(warns, "[[", "call")
- names(last.warning) <- sapply(warns, "[[", "message")
+ interrupt = function(...) cat("<interrupted!>\n"), #DEBUG: this does not seem to be ever called.
- attr(res, "last.warning") <- last.warning
- rm("warns", envir = TempEnv())
- }
- return(res)
- }
+ muffleWarning = function() NULL,
+ grmbl = restartError),
+ error = function(e) {
+ #XXX: this is called by warnLevel=2
+ cat(.makeMessage(e))
+ e #identity
+ },
+ finally = { }
+ )
- ## This is my own function to display delayed warnings
- WarningMessage <- function (last.warning)
- {
- assign("last.warning", last.warning, envir = baseenv())
- n.warn <- length(last.warning)
- if (n.warn < 11) { # If less than 11 warnings, print them
- ## For reasons I don't know, R append a white space to the warning
- ## messages... we replicate this behaviour here.
- print.warnings(warnings(" ", sep = ""))
- } else if (n.warn >= 50) {
- cat(.gettext("There were 50 or more warnings (use warnings() to see the first 50)\n"))
+ lapply(res, function(x) {
+ if(inherits(x, "list") && x$visible) {
+ print(x$value)
+ } #else { cat('<invisible>\n') }
+ })
+
+ if(warnLevel == 0) {
+ nwarn <- length(last.warning)
+ assign("last.warning", last.warning, envir=baseenv())
+ if(nwarn <= 10) {
+ print.warnings(last.warning)
+ } else if (nwarn < 50) {
+ cat(gettextf("There were %d warnings (use warnings() to see them)\n", nwarn, domain="R"))
} else {
- cat(.gettextf("There were %d warnings (use warnings() to see them)\n",
- n.warn))
+ cat(gettext("There were 50 or more warnings (use warnings() to see the first 50)\n", domain="R"))
}
- return(invisible(n.warn))
}
- for (i in 1:length(expr)) {
- tmp <- evalVis(expr[[i]])
- if (inherits(tmp, "try-error")) {
- last.warning <- attr(tmp, "last.warning")
- if (!is.null(last.warning)) {
- cat(.gettext("In addition : "))
- WarningMessage(last.warning)
- }
- break
- } else { # No error
- if (tmp$visible) print(tmp$value)
- last.warning <- attr(tmp, "last.warning")
- if (!is.null(last.warning))
- WarningMessage(last.warning)
- }
- }
- cat("\n") # In case last line does not end with \n, I add it!
+ sink(type = "message"); sink(type = "output")
+ close(tconn)
+ on.exit()
+
+ # allow for tracebacks of this call stack:
+ assign(".Traceback", lapply(Traceback, deparse), envir = baseenv())
+
return(rval)
}
-
More information about the Sciviews-commits
mailing list