From murdoch at stats.uwo.ca  Sun Oct 29 02:53:09 2006
From: murdoch at stats.uwo.ca (Duncan Murdoch)
Date: Sat, 28 Oct 2006 20:53:09 -0400
Subject: [Rd] how to determine if a function's result is invisible
In-Reply-To: <4543D3A6.7010900@sciviews.org>
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> <4543D3A6.7010900@sciviews.org>
Message-ID: <4543FB75.7090405@stats.uwo.ca>

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




[Rd] how to determine if a function's result is invisible
Duncan Murdoch