[Rd] how to determine if a function's result is invisible
Philippe Grosjean
phgrosjean at sciviews.org
Sun Oct 29 00:03:18 CEST 2006
Duncan Murdoch wrote:
[...]
> I've just added this function to R-devel (to become 2.5.0 next spring):
>
> withVisible <- function(x) {
> x <- substitute(x)
> v <- .Internal(eval.with.vis(x, parent.frame(), baseenv()))
> v
> }
>
> Luke Tierney suggested simplifying the interface (no need to duplicate
> the 3 parameter eval interface, you can just wrap this in evalq() if you
> need that flexibility); the name "with.vis" was suggested, but it looks
> like an S3 method for the with() generic, so I renamed it.
>
> Duncan Murdoch
Excellent, many thanks... but I am afraid I cannot use this function
because you force evaluation on parent.frame(), where I need to evaluate
it in .GlobalEnv (which is NOT equal to parent.frame() in my context).
Would it be possible to change it to:
withVisible <- function(x, env = parent.frame()) {
x <- substitute(x)
v <- .Internal(eval.with.vis(x, env, baseenv()))
v
}
...so that we got additional flexibility?
This is one good example of problems we encounter if we want to make R
GUIs that emulate the very, very complex mechanism used by R to evaluate
a command send at the prompt.
Since we are on this topic, here is a copy of the function I am working
on. It emulates most of the mechanism (Is the code line complete or not?
Do we issue one or several warnings? When? Correct error message in case
of a stop condition or other errors? Return of results with visibility?
Etc.). As you can see, it is incredibly complex. So, do I make a mistake
somewhere, or are we really forced to make all these computations to
emulate the way R works at the command line (to put in a context, this
is part of a R socket server to be used, for instance, in Tinn-R to fork
output of R in the Tinn-R console, without blocking the original R
console, or R terminal).
Best,
Philippe Grosjean
processSocket <- function(msg) {
# This is the default R function that processes a command send
# by a socket client
# 'msg' is assumed to be R code contained in a string
# First parse code
msgcon <- textConnection(msg)
expr <- try(parse(msgcon), silent = TRUE)
close(msgcon)
# Determine if this code is correctly parsed
if (inherits(expr, "try-error")) {
results <- expr
# Determine if it is incorrect code, or incomplete line!
if (length(grep("\n2:", results)) == 1) {
### TODO: use the continue prompt from options!
results <- "\n+ " # Send just the continue prompt
# The client must manage the rest!
} else {
# Rework error message
toReplace <- "^([^ ]* )[^:]*(:.*)$"
Replace <- "\\1\\2"
results <- sub(toReplace, Replace, results)
# Add the prompt at the end to show that R is ready
# to process new commands
results <- paste(results, "> ", sep = "\n")
}
} else { # Code is correctly parsed,
# evaluate generated expression(s)
# capture.all() is inspired from capture.output(),
# but it captures both the output and the message streams
capture.all <- function(expr) {
file <- textConnection("rval", "w", local = TRUE)
sink(file, type = "output")
sink(file, type = "message")
on.exit({
sink(type = "output")
sink(type = "message")
close(file)
})
### TODO: do not erase 'last.warning',
# otherwise warnings(), etc. do not work!
evalVis <- function(Expr) {
if (getOption("warn") == 0) {
# We need to install our own warning handling
# and also, we use a customized interrupt handler
owarn <- 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
nwarn <- getOption("warning.expression")
if (!is.null(nwarn) &&
length(as.character(nwarn)) == 0)
options(warning.expression = owarn)
# If the evaluation did not generated warnings,
# restore old "last.warning"
if (!exists("last.warning",
envir = .GlobalEnv) &&
!is.null(save.last.warning))
last.warning <<- save.last.warning
})
# Save the current content of "last.warning"
# From .GlobalEnv
if (exists("last.warning", envir = .GlobalEnv)) {
save.last.warning <- get("last.warning",
envir = .GlobalEnv)
# ... and delete it
rm(last.warning, envir = .GlobalEnv)
} else {
save.last.warning <- NULL
}
myEvalEnv.. <- .GlobalEnv
res <- try(withCallingHandlers(.Internal(
eval.with.vis(Expr, myEvalEnv.., baseenv())),
# Our custom warning handler
### TODO: how to deal with immediate warnings!
# (currently, all warnings are differed!)
warning = function(w) {
if (exists("last.warning", envir =.GlobalEnv)) {
lwarn <- get("last.warning",
envir = .GlobalEnv)
} else lwarn <- list()
# Do not add more than 50 warnings
if (length(lwarn) >= 50) return()
# Add the warning to this list
nwarn <- length(lwarn)
names.warn <- names(lwarn)
Call <- conditionCall(w)
# If warning generated in eval environment,
# put it as character(0)
if (Call == "eval.with.vis(Expr, myEvalEnv..,
baseenv())")
Call <- character(0) # I don't use NULL,
# because it doesn't add to a list!
lwarn[[nwarn + 1]] <- Call
names(lwarn) <- c(names.warn,
conditionMessage(w))
# Save the modified version in .GlobalEnv
last.warning <<- lwarn
return()
},
interrupt = function(i) cat("<INTERRUPTED!>\n")),
silent = TRUE)
# Possibly add 'last.warning' as attribute to res
if (exists("last.warning", envir = .GlobalEnv))
attr(res, "last.warning") <- get("last.warning",
envir = .GlobalEnv)
} else { # We have a simpler warning handler
owarn <- 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
nwarn <- getOption("warning.expression")
if (!is.null(nwarn) &&
length(as.character(nwarn)) == 0)
options(warning.expression = owarn)
})
myEvalEnv.. <- .GlobalEnv
res <- try(withCallingHandlers(.Internal(
eval.with.vis(Expr, myEvalEnv.., baseenv())),
warning = function(w) {
Mes <- conditionMessage(w)
Call <- conditionCall(w)
# Result depends upon 'warn'
Warn <- getOption("warn")
if (Warn < 0) { # Do nothing!
return()
} else if (Warn > 1) { # Generate an error!
Mes <- paste("(converted from warning)", Mes)
stop(simpleError(Mes, call = Call))
} else { # Print the warning message
# Format the warning message
### TODO: translate this!
# If warning generated in eval
# environment, do not print call
if (Call == "eval.with.vis(Expr,
myEvalEnv.., baseenv())") {
cat("Warning message:\n", Mes,
"\n", sep = "")
} else {
cat("Warning message:\n", Mes,
" in: ", as.character(Call),
"\n", sep = "")
}
}
},
interrupt = function(i)
cat("<INTERRUPTED!>\n")), silent = TRUE)
}
return(res)
}
tmp <- list()
for (i in 1:length(expr)) {
tmp[[i]] <- evalVis(expr[[i]])
if (inherits(tmp[[i]], "try-error")) break
}
#tmp <- lapply(expr, evalVis) # This one does not stop
#on error!?
# This is my function to display delayed warnings
WarningMessage <- function(last.warning) {
n.warn <- length(last.warning)
if (n.warn < 11) { # If less than 11 warnings,
# print them
if (exists("last.warning", envir = .GlobalEnv)) {
owarn <- get("last.warning", envir = .GlobalEnv)
} else owarn <- NULL
last.warning <<- last.warning
invisible(warnings())
if (is.null(owarn)) {
rm("last.warning", envir = .GlobalEnv)
} else last.warning <<- owarn
} else {
# Generate a message similar to the one we got
# at the command line
### TODO: translation of this message!
if (n.warn >= 50) {
cat("There were 50 or more warnings (use warnings() to see the
first 50)\n")
} else {
cat("There were", n.warn, "warnings (use warnings() to see
them)\n", sep = " ")
}
}
return(invisible(n.warn))
}
# Process all generated items
for (item in tmp) {
if (inherits(item, "try-error")) {
# Rework the error message if it occurs in the
# calling environment
toReplace <- "^([^ ]*) .*eval\.with\.vis[(]Expr,
myEvalEnv\.\., baseenv[(][)][)].*:.*\n\t(.*)$"
Replace <- "\\1 : \\2"
cat(sub(toReplace, Replace, unclass(item)))
# Do we have to print 'last.warning'?
last.warning <- attr(item, "last.warning")
if (!is.null(last.warning)) {
# Add "In addition: " before warning, like at
# the command line
cat("In addition: ")
WarningMessage(last.warning)
}
} else { # No error
if (item$visible) {
print(item$value)
}
# Do we have to print 'last.warning'?
last.warning <- attr(item, "last.warning")
if (!is.null(last.warning))
WarningMessage(last.warning)
}
}
return(rval)
}
results <- capture.all(expr)
if (inherits(results, "list"))
results <- paste(results, collapse = "\n")
# Add the prompt at the end to show that R is ready to process
# new commands
results <- paste(paste(results, collapse = "\n"), "> ",
sep = "\n")
# Note: we don't use options()$prompt here... we always use a
# fixed string! It is the client that must manage
# possible change
}
return(results)
}
More information about the R-devel
mailing list