[Sciviews-commits] r556 - komodo/SciViews-K-dev/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 5 13:38:12 CET 2015
Author: phgrosjean
Date: 2015-02-05 13:38:12 +0100 (Thu, 05 Feb 2015)
New Revision: 556
Added:
komodo/SciViews-K-dev/R/captureAll.R
komodo/SciViews-K-dev/R/parseText.R
Log:
captureAll.R/parseText.R conflict resolved in SciViews-K dev/R/
Added: komodo/SciViews-K-dev/R/captureAll.R
===================================================================
--- komodo/SciViews-K-dev/R/captureAll.R (rev 0)
+++ komodo/SciViews-K-dev/R/captureAll.R 2015-02-05 12:38:12 UTC (rev 556)
@@ -0,0 +1,261 @@
+
+# 'imports'
+if(existsFunction("getSrcFilename", where="package:utils")) {
+ getSrcFilename <- utils::getSrcFilename
+}
+
+# Replacement for 'base::as.character.error', which does not translate "Error"
+`as.character.error` <- function (x, ...) {
+ msg <- conditionMessage(x)
+ call <- conditionCall(x)
+ if (!is.null(call))
+ paste(.gettextx("Error in "), deparse(call, control = NULL)[1L], " : ",
+ msg, "\n", sep = "")
+ else paste(.gettextx("Error: "), msg, "\n", sep = "")
+}
+
+# Replacement for 'base::print.warnings'. Deparses using control=NULL to produce
+# result identical to that in console
+`print.warnings` <- function (x, ...) {
+ if (n <- length(x)) {
+ cat(ngettext(n, "Warning message:\n", "Warning messages:\n"))
+ msgs <- names(x)
+ for (i in seq_len(n)) {
+ ind <- if (n == 1L) ""
+ else paste(i, ": ", sep = "")
+ out <- if (length(x[[i]])) {
+ temp <- deparse(x[[i]], width.cutoff = 50L, nlines = 2L,
+ control = NULL) # the only modification
+ sm <- strsplit(msgs[i], "\n")[[1L]]
+ nl <- if (nchar(ind, "w") + nchar(temp[1L], "w") +
+ nchar(sm[1L], "w") <= 75L)
+ " "
+ else "\n "
+ paste(ind, "In ", temp[1L], if (length(temp) >
+ 1L)
+ " ...", " :", nl, msgs[i], sep = "")
+ }
+ else paste(ind, msgs[i], sep = "")
+ do.call("cat", c(list(out), attr(x, "dots"), fill = TRUE))
+ }
+ }
+ invisible(x)
+}
+
+
+# use ngettext instead of gettext, which fails to translate many strings in "R" domain
+# bug in R or a weird feature?
+`.gettextfx` <- function (fmt, ..., domain = "R")
+sprintf(ngettext(1, fmt, "", domain = domain), ...)
+
+`.gettextx` <- function (..., domain = "R") {
+ args <- lapply(list(...), as.character)
+ unlist(lapply(unlist(args), function(x) .Internal(ngettext(1, x, "", domain))))
+}
+
+unsink <- function() {
+# DEBUG
+sink(type="m");sink(type="o")
+#browser()
+# END DEBUG
+}
+
+
+# inspired by 'capture.output' and utils:::.try_silent
+# Requires: R >= 2.13.0 [??]
+`sv_captureAll` <- function(expr, split = FALSE, file = NULL, markStdErr=FALSE,
+ envir = .GlobalEnv) {
+ # TODO: support for 'file' and 'split'
+
+ # markStdErr: if TRUE, stderr is separated from sddout by STX/ETX character
+
+ last.warning <- list()
+ Traceback <- NULL
+ NframeOffset <- sys.nframe() + 19L + 3L # 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")
+ on.exit({
+ sink(type = "message"); sink(type = "output")
+ close(tconn)
+ })
+
+ inStdOut <- TRUE
+
+ if (markStdErr) {
+ putMark <- function(to.stdout, id) {
+ do.mark <- FALSE
+ if (inStdOut) {
+ if (!to.stdout) {
+ cat("\x03")
+ inStdOut <<- FALSE
+ do.mark <- TRUE
+ }} else { # in StdErr stream
+ if (to.stdout) {
+ cat("\x02")
+ inStdOut <<- TRUE
+ do.mark <- TRUE
+ }}
+
+ #if(do.mark)
+ #marks <<- c(marks, list(c(pos = sum(nchar(rval)), stream = to.stdout)))
+ #cat("<", id, inStdOut, ">")
+ }
+ } else putMark <- function(to.stdout, id) {}
+
+ `evalVis` <- function(x) withVisible(eval(x, envir))
+
+ `restartError` <- function(e, calls, foffset) {
+ # remove call (eval(expr, envir, enclos)) from the message
+ ncls <- length(calls)
+
+ if(identical(calls[[NframeOffset + foffset]], conditionCall(e)))
+ e$call <- NULL
+
+ cfrom <- ncls - 2L
+ cto <- NframeOffset + foffset
+
+
+ Traceback <<- if(cfrom < cto) list() else
+ calls[seq.int(cfrom, cto, by=-1L)]
+
+ putMark(FALSE, 1L)
+ #cat(.makeMessage(e, domain="R"))
+ cat(as.character.error(e))
+ if(getWarnLev() == 0L && length(last.warning) > 0L)
+ cat(.gettextx("In addition: "))
+ }
+
+ 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?
+ off <- 0L
+
+ for(i in expr) {
+ # 'off' is passed to 'restartError'
+ off <- 0L # TODO: better way to find the right sys.call...
+ res1 <- evalVis(i)
+ off <- -2L
+
+ if(res1$visible) {
+ # print/show should be evaluated also in 'envir'
+ resval <- res1$value
+ if(!missing(resval)) {
+ printfun <- as.name(if(isS4(resval)) "show" else "print")
+ if(is.language(resval)) {
+ #browser()
+ #eval(substitute(printfun(resval)), envir)
+ #utils::str(resval)
+ eval(substitute(printfun(quote(resval))), envir)
+ } else
+ eval(substitute(printfun(resval)), envir)
+ } else {
+ cat("\n")
+ }
+ }
+ }
+ },
+
+ message = function(e) {
+ putMark(FALSE, 8L)
+ cat(conditionMessage(e), sep = "")
+ putMark(TRUE, 9L)
+ invokeRestart("muffleMessage")
+ },
+ error = function(e) invokeRestart("grmbl", e, sys.calls(), off),
+ warning = function(e) {
+ # remove call (eval(expr, envir, enclos)) from the message
+ if(isTRUE(all.equal(sys.call(NframeOffset + off), e$call,
+ check.attributes = FALSE)))
+ e$call <- NULL
+
+ if(getWarnLev() != 0L) {
+ putMark(FALSE, 2L)
+ .Internal(.signalCondition(e, conditionMessage(e), conditionCall(e)))
+ .Internal(.dfltWarn(conditionMessage(e), conditionCall(e)))
+ putMark(TRUE, 3L)
+ } else {
+ last.warning <<- c(last.warning, structure(list(e$call),
+ names = e$message))
+ }
+ invokeRestart("muffleWarning")
+ }),
+ # Restarts:
+
+ # Handling user interrupts. Currently it works only from within R.
+ # TODO: how to trigger interrupt remotely?
+ abort = function(...) {
+ putMark(FALSE, 4L)
+ cat("Execution aborted. \n")
+ },
+
+ muffleMessage = function() NULL,
+ muffleWarning = function() NULL,
+ grmbl = restartError),
+ error = function(e) { #XXX: this is called if warnLevel=2
+ putMark(FALSE, 5L)
+ cat(as.character.error(e))
+ e #identity
+ }, finally = { }
+ )
+
+ if(getWarnLev() == 0L) {
+ nwarn <- length(last.warning)
+ assign("last.warning", last.warning, envir = baseenv())
+
+ if(nwarn != 0L) putMark(FALSE, 6L)
+ if(nwarn <= 10L) {
+ print.warnings(last.warning)
+ } else if (nwarn < 50L) {
+ cat(.gettextfx("There were %d warnings (use warnings() to see them)\n", nwarn))
+ } else {
+ cat(.gettextx("There were 50 or more warnings (use warnings() to see the first 50)\n"))
+ }
+ }
+ putMark(TRUE, 7L)
+
+ sink(type = "message"); sink(type = "output")
+ close(tconn)
+ on.exit()
+
+ #filename <- attr(attr(sys.function(sys.parent()), "srcref"), "srcfile")$filename
+ filename <- getSrcFilename(sys.function(sys.parent()), full.names=TRUE)
+ if(length(filename) == 0) filename <- NULL
+
+ #print(sys.function(sys.parent()))
+
+ # allow for tracebacks of this call stack:
+ if(!is.null(Traceback)) {
+ assign(".Traceback",
+ if (is.null(filename)) {
+ #lapply(Traceback, deparse, control=NULL)
+ # keep only 'srcref' attribute
+ lapply(Traceback, function(x) structure(deparse(x, control=NULL),
+ srcref=attr(x, "srcref")))
+
+ } else {
+ lapply(Traceback, function(x) {
+ srcref <- attr(x, "srcref")
+ srcfile <- if(is.null(srcref)) NULL else attr(srcref, "srcfile")
+ structure(deparse(x, control=NULL), srcref =
+ if(is.null(srcfile) || isTRUE(srcfile$filename == filename))
+ NULL else srcref)
+ })
+ }
+ , envir = baseenv())
+ }
+ return(rval)
+}
+
+
+`captureAllQ` <- function(expr, ...)
+ sv_captureAll(as.expression(substitute(expr)), ...)
\ No newline at end of file
Added: komodo/SciViews-K-dev/R/parseText.R
===================================================================
--- komodo/SciViews-K-dev/R/parseText.R (rev 0)
+++ komodo/SciViews-K-dev/R/parseText.R 2015-02-05 12:38:12 UTC (rev 556)
@@ -0,0 +1,58 @@
+
+`Parse` <- function (text)
+{
+ ## Deprecated, in favor of parseText()
+ .Deprecated("parseText")
+ return(parseText(text))
+}
+
+
+
+
+`parseText` <- function (text) {
+ ## Parse R instructions provided as a string and return the expression if it
+ ## is correct, or a 'try-error' object if it is an incorrect code, or NA if
+ ## the (last) instruction is incomplete
+
+ #text <- " <- aaaaa(ddd+)"
+
+ 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"))
+
+
+ if(regexpr(rxUEOI, msg, perl=TRUE) == 1) return(NA)
+
+ # This reformats the message as it would appear in the CLI:
+ #msg <- conditionMessage(res)
+ errinfo <-
+ strsplit(sub("(?:<text>:)?(\\d+):(\\d+): +([^\n]+)\n([\\s\\S]*)$", "\\1\n\\2\n\\3\n\\4", msg, perl=T), "\n", fixed=TRUE)[[1]]
+
+ errpos <- as.numeric(errinfo[1:2])
+ err <- errinfo[-(1:3)]
+ rx <- sprintf("^%d:", errpos[1])
+ errcode <- sub(rx, "", err[grep(rx, err)])
+ #errcode <- substr(strsplit(text, "(\r?\n|\r)")[[1]][errpos[1]], start = 0, stop = errpos[2])
+ res <- simpleError(sprintf("%s in \"%s\"", errinfo[3], errcode))
+
+ #e <- res <- simpleError(msg, NULL)
+ e <- res
+
+ # for legacy uses, make it a try-error
+ res <- .makeMessage(res)
+ class(res) <- "try-error"
+ attr(res, 'error') <- e
+ }
+
+ return(res)
+}
+
+assign("parseText", parseText, "komodoConnection")
+
More information about the Sciviews-commits
mailing list