From phgrosjean at sciviews.org  Sun Oct 29 00:03:18 2006
From: phgrosjean at sciviews.org (Philippe Grosjean)
Date: Sun, 29 Oct 2006 00:03:18 +0200
Subject: [Rd] how to determine if a function's result is invisible
In-Reply-To: <45438F9B.7000905@stats.uwo.ca>
References: <971536df0610251714u451cf80fy80bf38cb2f130734@mail.gmail.com>	<454023EA.4020403@stats.uwo.ca>	<971536df0610252002s46ef72b2n32df3e180a49e990@mail.gmail.com>	<45403561.1000808@stats.uwo.ca>	<971536df0610260226o55726354j8cbdfa5af07ae508@mail.gmail.com>
	<45438F9B.7000905@stats.uwo.ca>
Message-ID: <4543D3A6.7010900@sciviews.org>

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)
}




[Rd] how to determine if a function's result is invisible
Philippe Grosjean