[Sciviews-commits] r407 - komodo/SciViews-K-dev/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Oct 11 23:17:51 CEST 2011
Author: prezez
Date: 2011-10-11 23:17:51 +0200 (Tue, 11 Oct 2011)
New Revision: 407
Modified:
komodo/SciViews-K-dev/R/.Rprofile
komodo/SciViews-K-dev/R/captureAll.R
Log:
Sciviews-K-dev:
R/captureAll.R: evaluation of symbols fixed, recognizes messages, some special cases of expressions are now handled properly.
R/.Rprofile: loads Rgui console settings from current directory (not a standard R behaviour)
Modified: komodo/SciViews-K-dev/R/.Rprofile
===================================================================
--- komodo/SciViews-K-dev/R/.Rprofile 2011-09-30 06:59:39 UTC (rev 406)
+++ komodo/SciViews-K-dev/R/.Rprofile 2011-10-11 21:17:51 UTC (rev 407)
@@ -1,11 +1,12 @@
options(json.method="R")
+if(existsFunction("stopAllConnections")) stopAllConnections()
+if(existsFunction("stopAllServers")) stopAllServers()
+
+
if("komodoConnection" %in% search()) detach("komodoConnection")
attach(new.env(), name="komodoConnection")
-if(existsFunction("stopAllServers")) stopAllServers()
-if(existsFunction("stopAllConnections")) stopAllConnections()
-
with(as.environment("komodoConnection"), {
#`svOption` <- function (arg.name, default = NA, as.type = as.character, ...) {
@@ -109,7 +110,9 @@
if(is.numeric(getOption("ko.port")) && length(Rservers) > 0) {
cat("Server started at port", Rservers, "\n")
invisible(koCmd(paste(
- "sv.cmdout.append('R is started')",
+ "sv.cmdout.clear()",
+ #"sv.cmdout.append('R is started')",
+ sprintf("sv.cmdout.append('%s is started')", R.version.string),
"sv.command.updateRStatus(true)",
sprintf("sv.pref.setPref('sciviews.r.port', %s)", tail(Rservers, 1)),
sep = ";")))
@@ -129,7 +132,10 @@
cat("Loaded file:", rprofile, "\n")
}
+if(.Platform$GUI == "Rgui" && file.exists("Rconsole"))
+ utils:::loadRconsole("Rconsole")
+
if(!any(c("--vanilla", "--no-restore", "--no-restore-data") %in% commandArgs())
&& file.exists(".RData")) {
#sys.load.image(".RData", FALSE)
Modified: komodo/SciViews-K-dev/R/captureAll.R
===================================================================
--- komodo/SciViews-K-dev/R/captureAll.R 2011-09-30 06:59:39 UTC (rev 406)
+++ komodo/SciViews-K-dev/R/captureAll.R 2011-10-11 21:17:51 UTC (rev 407)
@@ -1,4 +1,9 @@
-# replacement for 'base::as.character.error', which does not translate "Error"
+# '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)
@@ -8,7 +13,35 @@
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")
@@ -21,7 +54,8 @@
# inspired by 'capture.output' and utils:::.try_silent
# Requires: R >= 2.13.0 [??]
-`captureAll` <- function(expr, split = FALSE, file = NULL, markStdErr=FALSE) {
+`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
@@ -70,7 +104,7 @@
putMark <- function(to.stdout, id) {}
}
- `evalVis` <- function(x) withVisible(eval(x, .GlobalEnv))
+ `evalVis` <- function(x) withVisible(eval(x, envir))
`restartError` <- function(e, calls, foffset) {
# remove call (eval(expr, envir, enclos)) from the message
@@ -101,19 +135,37 @@
off <- 0L # TODO: better way to find the right sys.call...
res1 <- evalVis(i)
off <- -2L
+
if(res1$visible) {
- #(if(isS4(res1$value)) show else print)(res1$value)
- # print/show should be evaluated also in .GlobalEnv
- do.call("eval", list(call(if(isS4(res1$value)) "show"
- else "print", res1$value)), envir=.GlobalEnv)
+ # 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))
+ eval(substitute(printfun(quote(resval))), envir)
+ else
+ eval(substitute(printfun(resval)), envir)
+ } else {
+ cat("\n")
+ }
+# DEBUG
+#sink(type="m");sink(type="o");browser()
+# END DEBUG
}
}
},
+ 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), e$call, check.attributes=FALSE)))
+ if(isTRUE(all.equal(sys.call(NframeOffset + off), e$call, check.attributes=FALSE)))
e$call <- NULL
last.warning <<- c(last.warning, structure(list(e$call), names=e$message))
@@ -133,9 +185,10 @@
# TODO: how to trigger interrupt remotely?
abort = function(...) {
putMark(FALSE, 4L)
- cat("Execution aborted. \n") #DEBUG
+ cat("Execution aborted. \n")
},
+ muffleMessage = function() NULL,
muffleWarning = function() NULL,
grmbl = restartError),
error = function(e) { #XXX: this is called if warnLevel=2
@@ -149,7 +202,7 @@
nwarn <- length(last.warning)
assign("last.warning", last.warning, envir=baseenv())
- if(nwarn > 0L) putMark(FALSE, 6L)
+ if(nwarn != 0L) putMark(FALSE, 6L)
if(nwarn <= 10L) {
print.warnings(last.warning)
} else if (nwarn < 50L) {
@@ -165,39 +218,34 @@
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)) {
+ 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")))
+ 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) || srcfile$filename == filename) NULL else 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)
}
-attr(captureAll, "srcref") <- NULL
-
-# TESTS:
-# cat(captureAll(expression(1:10, log(-1),log(""),1:10)), sep="\n")
-
-# foo <- structure(list(a=1, b=2), class="foo")
-# print.foo <- function(x, ...) stop("Foo print error!")
-# captureAll(expression(foo))
-# traceback()
-# captureAll(expression(print(foo)))
-# traceback()
-# foo
-# print(foo)
+`captureAllQ` <- function(expr, ...)
+ captureAll(as.expression(substitute(expr)), ...)
More information about the Sciviews-commits
mailing list