[Rd] how to determine if a function's result is invisible
Duncan Murdoch
murdoch at stats.uwo.ca
Sun Oct 29 02:53:09 CEST 2006
On 10/28/2006 6:03 PM, Philippe Grosjean wrote:
> 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?
As I said, that's not needed. Use evalq(withVisible(x), envir=.GlobalEnv).
> 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.
No, it's not.
Duncan Murdoch
>
> 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).
I
>
> 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