How can I check whether an expression was an assignment? (in callback passed to `addTaskCallback`)

Question

how can I check whether an expression was an assignment in a callback passed to addTaskCallback? The callback takes four arguments. The first argument passed to the callback is "the S-language expression for the top-level task". The Top-level Task Callbacks in R manual suggests that you can "examine the expression and determine if any assignments were made". But how can I do that consistently for any assignments in the global environment? I basically want to know if any objects were added or changed in the global environment and only execute my callback if that is the case. It's easy to check for basic assignment operations such as <- or = but I am not sure about loops (which are one top-level expression), if conditions or functions that use the <<- operator or possible other ways to change objects in the global environment. Here are some examples of single top-level operations that include assignments in the global environment

# loops
for (i in 1:10) x[i] <- i
for (i in 1:10) {
    x[i] <- i
    y[i] <- i
}
# if conditions
if(cond) x <- rnorm(1000)
if(cond) {
    x <- rnorm(1000)
    y <- rnorm(1000)
}
# global assignment in loop
fn = function() x <<- rnorm(1000)
fn()

And finally a very basic example that checks for simple = and <- operators:

eventHandler = function(expr, value, ok, visible) {
    if(class(expr) %in% c('=','<-'))
        print('assignment!')
    # as.character(expr)[2] should now reference the object that was changed
    TRUE
}
addTaskCallback(eventHandler)

Answer 1

So, you basically want to know if any objects were added or changed in the global environment and only execute [your] callback if that is the case..

Here's a quite simple solution making use of (currently experimental) base R function lockEnvironment, which prevents any change in a given environment. Unfortunately, there is no unlock* counterpart, so we have to execute this gist first.

# source *https://gist.github.com/wch/3280369* first


globalChange <- function (expr, envir = parent.frame()) {
   lockEnvironment(.GlobalEnv, TRUE)

   ..change <- FALSE
   tryCatch({
      eval(expr, envir=envir)
   },
   error=function(err) {
      # you may want to check whether err is "cannot add bindings to a locked environment" here
      ..change <<- TRUE
   })

   unlockEnvironment(.GlobalEnv) # see https://gist.github.com/wch/3280369

   # unlock all bindings (unlockEnvironment doesn't do that)
   for (obj in ls(envir=.GlobalEnv, all=TRUE))
      unlockBinding(obj, .GlobalEnv)

   ..change
}

This function returns TRUE if there was an error while evaluating a given expr. It runs with the global environment locked, so you will surely get TRUE if any objects were added or changed in the global environment.

Some examples:

globalChange({
   x <- 100
})
## [1] TRUE
globalChange({
  print("a")
})
## [1] "a"
## [1] FALSE
globalChange({
  f <- function() { x <<- 100 }
  f()
})
## [1] TRUE

Answer 2

To be able to know if objects have been created, modified or deleted, you could have a summary of the previous state of the .GlobalEnv - a named vector, names are objects names and values are hash values (from the digest package). The following is working but cost a lot when .GlobalEnv contains big R objects (in the get.hash function).

First a function that is calling digest, its argument is an R object name.

get.hash = function( x ){
  require( digest)
  obj = get(x, envir = .GlobalEnv )
  digest( obj, algo = "sha1" )
} # digest call 

Some objects are not interesting to be monitored

# objects to exclude from ls :
obj.exclude = c(".Random.seed") 

The callback function now. Because assign or functions that call assign could be used, I don't think scanning 'left assignment' and 'equal' symbols is enough. The names and hash value of objects will be used for tracing objects'signature.

.my.callback.fun <- function() {
  old = ls( envir= .GlobalEnv, all.names = TRUE )
  old = setdiff( old, obj.exclude )

  options( "old_desc" = sapply( old, get.hash ) )

  eventHandler <- function(...) {
    # get the previous .GlobalEnv
    old_desc = getOption( "old_desc") # get the previous .GlobalEnv
    old = names( old_desc )

    # list the current .GlobalEnv
    new = ls( envir= .GlobalEnv, all.names = TRUE )
    new = setdiff( new, obj.exclude )
    new_desc = sapply( new, get.hash )

    if (!all( is.element( old,  new ) ) )
      message("deleted objects: "
        , paste( old[!is.element( old, new )], collapse = ", " ) )

    if (!all( is.element( new, old ) ) ) 
      message("new objects: "
        , paste( new[!is.element( new, old )], collapse = ", " ) )

    common_list = intersect(old, new )
    is_equal_test = new_desc[common_list] == old_desc[common_list]
    if( !all( is_equal_test ) )
      message("modified objects: "
        , paste( common_list[!is_equal_test], collapse = ", " ) )

    options( "old_desc" = new_desc )

    TRUE
  }

  invisible(addTaskCallback(f = eventHandler, name = "my_event_handler"))
}

That's it.

> .my.callback.fun() # start the callback function
Loading required package: digest
> 
> # your R commands here
> x = 1:10
new objects: x
> y = rnorm(100)
new objects: y
> rm( x )
deleted objects: x
> for (i in 1:10) 
+   z = rep(i, 1000 )
new objects: i, z
> rm( z, y )
deleted objects: y, z
> if( TRUE )
+   h = rnorm(1000)
new objects: h
> h = rnorm(1000)
modified objects: h
> fn = function() assign( "x", rnorm(1000), envir = .GlobalEnv )
new objects: fn
> fn()
new objects: x
> 
> iris = iris
new objects: iris
> iris[5,1] = 0.0
modified objects: iris
> 
> removeTaskCallback(id = "my_event_handler" ) # stop the callback function
[1] TRUE

If I drop the 'modify' option and monitor only creations and deletions, it's far simplier and faster.

.my.callback.fun <- function() {
  .old <- ls( envir= .GlobalEnv, all.names = TRUE )
  options( "old_ls" = .old )

  eventHandler <- function(...) {
    # list the current .GlobalEnv
    new <- ls( envir= .GlobalEnv, all.names = TRUE )
    old = getOption( "old_ls") # get the previous .GlobalEnv

    if (!all( is.element( old,  new ) ) ) 
      message("deleted objects: ", paste( old[!is.element( old, new )], collapse = ", " ) )

    if (!all( is.element( new, old ) ) )
      message("new objects: ", paste( new[!is.element( new, old )], collapse = ", " ) )

    options( "old_ls" = new )

    TRUE
  }

  invisible(addTaskCallback(f = eventHandler, name = "my_event_handler"))
}