Reactive object bindings in a non-shiny context

Question

Actual question

How could you either approximate the reactive environment/behavior established by shiny functions or possibly even use these very functions in a

Answer 1

For those interested: this kept bugging me over the weekend, so I've put together a little package called reactr that is based on the way bindings can be defined via makeActiveBinding. You can find the basic idea here.

Main features

• Supported monitoring scenarios: the package allows the definition of simple monitoring scenarios as well as more complex ones such as arbitrary functional relationships, mutual bindings and different environments for "source" and "target" variables (see arguments where and where_watch).
• Caching: this way of creating bindings uses cached values wherever possible for reasons of efficiency (if monitored variable has not changed, it's okay to use the cached value instead of re-running the binding function each time).
• As a reference, I still kept the solution based on the concept in my question above. It's available via binding_type = 2. However, it doesn't support the use of the syntactical sugars for assign() and get() (<- and or $) for keeping the hash values in sync - so I wouldn't use it I guess.

Drawback

What I don't really like about it is that I need an auxiliary environment for storing the hash values that are compared in order to make the decision "update cache or return cache". It floats around in where, currently in where$._HASH by default (see ensureHashRegistryState(), but at least you can change the name/ID to one you like better or need (see argument .hash_id).

If someone has any idea on how to get rid of that, it'd be very grateful! :-)

---

Example

See README.md

Load:

require("devtools")
devtools::install_github("Rappster/classr")
devtools::install_github("Rappster/reactr")
require("reactr")

Use an example environment so we don't mess up our .GlobalEnv:

where <- new.env()

Binding scenario 1: simple monitoring (identical values)

Set a variable that can be monitored:

setReactive(id = "x_1", value = 10, where = where)

Set a variable that monitors x_1 and has a reactive binding to it:

setReactiveid = "x_2", watch = "x_1", where = where)

Whenever x_1 changes, x_2 changes accordingly:

where$x_1 
# [1] 10
where$x_2
# [1] 10
where$x_1 <- 100 
where$x_2
# [1] 100

Note that trying to change x_2 is disregarded as it can only monitor x_1:

where$x_2 <- 1000
where$x_2
# [1] 100

Binding scenario 2: simple monitoring (arbitrary functional relationship)

setReactiveid = "x_3", watch = "x_1", where = where, binding = function(x) {x * 2})

Whenever x_1 changes, x_3 changes accordingly:

where$x_1 
# [1] 100
where$x_2
# [1] 100
where$x_3
# [1] 200
where$x_1 <- 500
where$x_2
# [1] 500
where$x_3
# [1] 1000

Binding scenario 3: mutual binding (identical value)

Set two variables that have a mutual binding. The main difference to Binding scenario 1 is, that you can set both x_1 and x_4 and have the changes reflected.

In order to do that, it is necessary to reset the binding for x_1 as well with mutual = TRUE:

setReactive(id = "x_1", watch = "x_4", where = where, mutual = TRUE)
setReactive(id = "x_4", watch = "x_1", where = where, mutual = TRUE)

Whenever x_1 changes, x_4 changes accordingly and vice versa.

Note that variables with mutual bindings are merely initialized by setThis and have a default value of NULL. You must actually assign a value to either one of them via <- after establishing the binding:

where$x_1
# NULL
where$x_4
# NULL

where$x_1 <- 100
where$x_1
# [1] 100
where$x_4
# [1] 100
where$x_2
# [1] 100
where$x_3
# [1] 200

where$x_4 <- 1000
where$x_4
# [1] 1000
where$x_1
# [1] 1000
where$x_2
# [1] 1000
where$x_3
# [1] 2000

Binding scenario 4: mutual binding (valid bi-directional relationship)

setReactive(id = "x_5", watch = "x_6", where = where, 
  binding = function(x) {x * 2}, mutual = TRUE)
setReactive(id = "x_6", watch = "x_5", where = where, 
  binding = function(x) {x / 2}, mutual = TRUE)

where$x_5 <- 100
where$x_5
# [1] 100
where$x_6
# [1] 50

where$x_6 <- 500
where$x_6
# [1] 500
where$x_5
# [1] 1000

Further examples

See ?setReactive and ?setReactive_bare.

---

Profiling

I've included a profiling script in /inst/prof/prof_1.r. There is a "bare" S3 method setThis_bare that is roughly 10 % faster.

Using S4 method setValue()

where <- new.env()  

res_1 <- microbenchmark(
  "1" = setReactive(id = "x_1", value = 10, where = where),
  "2" = getReactive(id = "x_1", where = where),
  "3" = setReactive(id = "x_2", where = where, watch = "x_1",
    binding = function(x) {x + 100}),
  "4" = getReactive(id = "x_2", where = where),
  "5" = setReactive(id = "x_1", value = 100, where = where),
  "6" = getReactive(id = "x_2", where = where),
  control = list(order = "inorder")
)

Unit: microseconds
 expr     min       lq   median       uq      max neval
    1 476.387 487.9330 494.7750 545.6640 7759.026   100
    2  25.658  26.9420  27.5835  30.5770   55.166   100
    3 644.875 657.7045 668.1820 743.6595 7343.364   100
    4  34.211  35.4950  36.3495  38.4870   86.384   100
    5 482.802 494.7750 505.4665 543.9535 2665.027   100
    6  51.744  53.0280  54.3100  58.1595   99.640   100

Using S3 function setThis_bare()

where <- new.env()

res_3 <- microbenchmark(
  "1" = setReactive_bare(id = "x_1", value = 10, where = where),
  "2" = getReactive(id = "x_1", where = where),
  "3" = setReactive_bare(id = "x_2", where = where, watch = "x_1",
    binding = function(x) {x + 100}),
  "4" = getReactive(id = "x_2", where = where),
  "5" = setReactive_bare(id = "x_1", value = 100, where = where),
  "6" = getReactive(id = "x_2", where = where),
  control = list(order = "inorder")
)

Unit: microseconds
 expr     min       lq  median       uq      max neval
    1 428.492 441.9625 453.936 567.4735 6013.844   100
    2  25.659  26.9420  27.797  33.9980   84.672   100
    3 599.546 613.0165 622.852 703.0340 2369.103   100
    4  34.211  35.9220  36.777  45.5445   71.844   100
    5 436.189 448.1630 457.571 518.5095 2309.662   100
    6  51.745  53.4550  54.952  60.5115 1131.952   100

---

For the ones interested in the nitty gritty details

This is how the boilerplate code looks like that is fed to makeActiveBinding() inside of setThis() (leaving out the message() stuff; see /R/getBoilerplateCode.r).

Variable that can be monitored:

out <- substitute(
  local({
    VALUE <- NULL
    function(v) {
      if (!missing(v)) {
        VALUE <<- v
        ## Ensure hash value //
        assign(id, digest::digest(VALUE), where[[HASH]][[id]])
      }
      VALUE
    }
  }),
  list(
    VALUE = as.name("value"),
    HASH = as.name(".hash_id")
  )
)

Ready for evaluation:

getBoilerplateCode(
  ns = classr::createInstance(cl = "Reactr.BindingContractMonitored.S3")
)

Variable that monitors:

out <- substitute(
  local({
    if (  exists(watch, envir = where_watch, inherits = FALSE) &&
          !is.null(get(watch, envir = where_watch, inherits = FALSE))
    ) {
      VALUE <- BINDING_CONTRACT
    } else {
      VALUE <- NULL
    }
    function(v) { 
      if (exists(watch, envir = where_watch, inherits = FALSE)) {  
        if (missing(v)) {
          hash_0 <- where_watch[[HASH]][[watch]][[watch]]
          hash_1 <- where_watch[[HASH]][[watch]][[id]]
          if (hash_0 != hash_1) {
            VALUE <<- BINDING_CONTRACT
            where_watch[[HASH]][[watch]][[id]] <- hash_0
            where[[HASH]][[id]][[id]] <- hash_0
            where[[HASH]][[id]][[watch]] <- hash_0
          } 
        }
      }
      VALUE
    }
  }),
  list(
    VALUE = as.name("value"), 
    BINDING_CONTRACT = substitute(.binding(x = where_watch[[watch]])),
    HASH = as.name(".hash_id")
  )
)    

Ready for evaluation:

getBoilerplateCode(
  ns = classr::createInstance(cl = "Reactr.BindingContractMonitoring.S3")
)

Variable with mutual bindings:

out <- substitute(
  local({
    if (  exists(watch, envir = where, inherits = FALSE) &&
          !is.null(get(watch, envir = where, inherits = FALSE))
    ) {
      VALUE <- BINDING_CONTRACT
    } else {
      VALUE <- NULL
    }
    function(v) {
      if (!missing(v)) {
        VALUE <<- v
        ## Update hash value //
        assign(id, digest::digest(VALUE), where[[HASH]][[id]])
      }
      if (exists(watch, envir = where, inherits = FALSE)) {
        if (missing(v)) {
          hash_0 <- where[[HASH]][[watch]][[watch]]
          hash_1 <- where[[HASH]][[watch]][[id]]
          if (hash_0 != hash_1) {
            VALUE <<- BINDING_CONTRACT
            where[[HASH]][[watch]][[id]] <- hash_0
            where[[HASH]][[id]][[id]] <- hash_0
            where[[HASH]][[id]][[watch]] <- hash_0
          }
        }
      }
      VALUE
    }
  }),
  list(
    VALUE = as.name("value"), 
    BINDING_CONTRACT = substitute(.binding(x = where[[watch]])),
    HASH = as.name(".hash_id")
  )
)    

Ready for evaluation:

getBoilerplateCode(
  ns = classr::createInstance(cl = "Reactr.BindingContractMutual.S3")
)