[Sciviews-commits] r375 - in pkg/svMisc: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 11 15:20:59 CEST 2011
Author: prezez
Date: 2011-05-11 15:20:59 +0200 (Wed, 11 May 2011)
New Revision: 375
Modified:
pkg/svMisc/DESCRIPTION
pkg/svMisc/NEWS
pkg/svMisc/R/captureAll.R
pkg/svMisc/R/parseText.R
Log:
captureAll, parseText: small fixes
captureAll: added 'markStdErr' argument
Modified: pkg/svMisc/DESCRIPTION
===================================================================
--- pkg/svMisc/DESCRIPTION 2011-05-08 13:26:35 UTC (rev 374)
+++ pkg/svMisc/DESCRIPTION 2011-05-11 13:20:59 UTC (rev 375)
@@ -2,11 +2,11 @@
Type: Package
Title: SciViews GUI API - Miscellaneous functions
Imports: utils, methods, tools
-Depends: R (>= 2.6.0)
+Depends: R (>= 2.13.0)
Suggests: svUnit
Description: Supporting functions for the GUI API (various utilitary functions)
-Version: 0.9-61
-Date: 2010-10-03
+Version: 0.9-62
+Date: 2011-05-11
Author: Philippe Grosjean, Romain Francois & Kamil Barton
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/svMisc/NEWS
===================================================================
--- pkg/svMisc/NEWS 2011-05-08 13:26:35 UTC (rev 374)
+++ pkg/svMisc/NEWS 2011-05-11 13:20:59 UTC (rev 375)
@@ -1,5 +1,9 @@
= svMisc News
+== Changes in svMisc **Working version**
+
+* captureAll() now handles user interrupts and allows for traceback() afterwards.
+
== Changes in svMisc 0.9-61
* Better handling of non syntactically correct names in objList().
Modified: pkg/svMisc/R/captureAll.R
===================================================================
--- pkg/svMisc/R/captureAll.R 2011-05-08 13:26:35 UTC (rev 374)
+++ pkg/svMisc/R/captureAll.R 2011-05-11 13:20:59 UTC (rev 375)
@@ -1,13 +1,21 @@
# inspired by 'capture.output' and utils:::.try_silent
# Requires: R >= 2.13.0 [??]
-`captureAll` <- function(expr, split = FALSE, file = NULL) {
+`captureAll` <- function(expr, split = FALSE, file = NULL, markStdErr=FALSE) {
# TODO: support for 'file' and 'split'
+ # markStdErr: if TRUE, stderr is separated from sddout by STX/ETX character
+
last.warning <- list()
Traceback <- list()
- warnLevel <- getOption('warn')
- Nframe <- sys.nframe() # frame of reference (used in traceback)
+ NframeOffset <- sys.nframe() + 20L # frame of reference (used in traceback) +
+ # length of the call stack when a condition
+ # occurs
+ # Note: if 'expr' is a call not expression, 'NframeOffset' is lower by 2
+ # (i.e. 21): -1 for lapply, -1 for unwrapping 'expression()'
+ getWarnLev <- function() options('warn')[[1L]] # this may change in course of
+ # evaluation, so must be retrieved dynamically
+
rval <- NULL
tconn <- textConnection("rval", "w", local = TRUE)
sink(tconn, type = "output"); sink(tconn, type = "message")
@@ -16,18 +24,48 @@
close(tconn)
})
+ inStdOut <- TRUE
+
+ if (markStdErr) {
+ putMark <- function(to.stdout, id) {
+ if (inStdOut) {
+ if (!to.stdout) {
+ cat("\x03")
+ inStdOut <<- FALSE
+ }} else { # in StdErr stream
+ if (to.stdout) {
+ cat("\x02")
+ inStdOut <<- TRUE
+ }}
+ #cat("<", id, inStdOut, ">")
+ }
+ } else {
+ putMark <- function(to.stdout, id) {}
+ }
+
`evalVis` <- function(x) withVisible(eval(x, .GlobalEnv))
`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)))
+
+ cat("n calls: ", ncls, "NframeOffset: ", NframeOffset, "\n")
+
+
+ if(isTRUE(all.equal(calls[[NframeOffset]], e$call, check.attributes=FALSE)))
e$call <- NULL
- Traceback <<- rev(calls[-c(seq.int(nn), (ncls - 1L):ncls)])
+ Traceback <<- rev(calls[-c(seq.int(NframeOffset), (ncls - 1L):ncls)])
+
+#> cat(captureAll(expression(1:10, log(-1),log(""),1:10)), sep="\n")
+#Error in calls[[NframeOffset]]: subscript out of bounds
+#Warning message:
+#In log(-1) : NaNs produced
+
+
+ putMark(FALSE, 1)
cat(.makeMessage(e))
- if(warnLevel == 0L && length(last.warning) > 0L)
+ if(getWarnLev() == 0L && length(last.warning) > 0L)
cat(gettext("In addition: ", domain="R"))
}
@@ -35,21 +73,23 @@
# 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))
+ #list(evalVis(expr))
+ lapply(expr, evalVis)
},
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)))
+ if(isTRUE(all.equal(sys.call(NframeOffset), e$call, check.attributes=FALSE)))
e$call <- NULL
last.warning <<- c(last.warning, structure(list(e$call), names=e$message))
- if(warnLevel != 0L) {
+ if(getWarnLev() != 0L) {
+ putMark(FALSE, 2)
.Internal(.signalCondition(e, conditionMessage(e), conditionCall(e)))
.Internal(.dfltWarn(conditionMessage(e), conditionCall(e)))
+ putMark(TRUE, 3)
}
invokeRestart("muffleWarning")
@@ -59,15 +99,16 @@
# Handling user interrupts. Currently it works only from within R.
#TODO: how to trigger interrupt via socket connection?
abort = function(...) {
+ putMark(FALSE, 4)
cat("<aborted!>\n") #DEBUG
},
- interrupt = function(...) cat("<interrupted!>\n"), #DEBUG: this does not seem to be ever called.
+ #interrupt = function(...) cat("<interrupted!>\n"), #DEBUG: this does not seem to be ever called.
muffleWarning = function() NULL,
grmbl = restartError),
- error = function(e) {
- #XXX: this is called by warnLevel=2
+ error = function(e) { #XXX: this is called if warnLevel=2
+ putMark(FALSE, 5)
cat(.makeMessage(e))
e #identity
},
@@ -80,18 +121,22 @@
} #else { cat('<invisible>\n') }
})
- if(warnLevel == 0) {
+ if(getWarnLev() == 0L) {
nwarn <- length(last.warning)
assign("last.warning", last.warning, envir=baseenv())
- if(nwarn <= 10) {
+
+ if(nwarn > 0L) putMark(FALSE, 6)
+ if(nwarn <= 10L) {
print.warnings(last.warning)
- } else if (nwarn < 50) {
+ } else if (nwarn < 50L) {
cat(gettextf("There were %d warnings (use warnings() to see them)\n", nwarn, domain="R"))
} else {
cat(gettext("There were 50 or more warnings (use warnings() to see the first 50)\n", domain="R"))
}
}
+ putMark(TRUE, 7)
+
sink(type = "message"); sink(type = "output")
close(tconn)
on.exit()
Modified: pkg/svMisc/R/parseText.R
===================================================================
--- pkg/svMisc/R/parseText.R 2011-05-08 13:26:35 UTC (rev 374)
+++ pkg/svMisc/R/parseText.R 2011-05-11 13:20:59 UTC (rev 375)
@@ -12,17 +12,27 @@
res <- tryCatch(parse(text=text), error=identity)
if(inherits(res, "error")) {
+ # Check if this is incomplete code
+ msg <- conditionMessage(res)
+ rxUEOI <- sprintf(gsub("%d", "\\\\d", gettext("%s%d:%d: %s", domain="R")),
+ if(getOption("keep.source")) "<text>:" else "",
+ gettextf("unexpected %s", gettext("end of input", domain="R"),
+ domain="R"))
- # Check if this is incomplete code
- rxUEOI <- paste("<text>:\\d:\\d:", gettextf("unexpected %s",
- gettext("end of input", domain="R"), domain="R"))
+
if(regexpr(rxUEOI, res$message) == 1) return(NA)
- res$message <- substring(res$message, 7)
- res$call <- NULL
- e <- res
+
+ # This reformats the message as it would appear in the CLI:
+ #mess <- conditionMessage(res)
+ #errinfo <- strsplit(sub("(\\d+):(\\d+): +([^\n]+)[\\s\\S]*$", "\\1\n\\2\n\\3", mess, perl=T), "\n", fixed=TRUE)[[1]]
+ #errpos <- as.numeric(errinfo[1:2])
+ #errcode <- substr(strsplit(x, "(\r?\n|\r)")[[1]][errpos[1]], start = 0, stop = errpos[2])
+ #res <- simpleError(sprintf("%s in \"%s\"", errinfo[3], errcode))
- # for legacy uses
+ e <- res <- simpleError(mess, NULL)
+
+ # for legacy uses, make it a try-error
res <- .makeMessage(res)
class(res) <- "try-error"
attr(res, 'error') <- e
More information about the Sciviews-commits
mailing list