1. 技术文章
  2. Reactive object bindings in a non-shiny context

Reactive object bindings in a non-shiny context

由 流过昼夜 提交于 2019-12-02 20:35:34

There is a collection of test_that unit tests in location /usr/local/lib/R/site-library/shiny/tests/. They give you a good idea of how the functions/wrappers:

  • reactiveValues
  • reactive
  • observe
  • isolate

can be used outside of a shinyServer call.

The key is to use flushReact to make the reactivity fire off. Here, for example, is one of the tests in file test-reactivity.r, and I think it already gives you a good sense of what you need to do:

test_that("overreactivity2", {
  # ----------------------------------------------
  # Test 1
  # B depends on A, and observer depends on A and B. The observer uses A and
  # B, in that order.

  # This is to store the value from observe()
  observed_value1 <- NA
  observed_value2 <- NA

  values <- reactiveValues(A=1)
  funcB  <- reactive({
    values$A + 5 
  })  
  obsC <- observe({
    observed_value1 <<-  funcB() * values$A
  })  
  obsD <- observe({
    observed_value2 <<-  funcB() * values$A
  })  

  flushReact()
  expect_equal(observed_value1, 6)   # Should be 1 * (1 + 5) = 6
  expect_equal(observed_value2, 6)   # Should be 1 * (1 + 5) = 6
  expect_equal(execCount(funcB), 1)
  expect_equal(execCount(obsC), 1)
  expect_equal(execCount(obsD), 1)

  values$A <- 2
  flushReact()
  expect_equal(observed_value1, 14)  # Should be 2 * (2 + 5) = 14
  expect_equal(observed_value2, 14)  # Should be 2 * (2 + 5) = 14
  expect_equal(execCount(funcB), 2)
  expect_equal(execCount(obsC), 2)
  expect_equal(execCount(obsD), 2)
})
Rappster

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 <obj-name> or $<obj-name>) 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")
)
Joe Cheng

(Tried to leave this as a comment but S.O. said it was too long.)

Kudos for looking more closely at reactivity. You may find these two links helpful:

So actually Shiny's reactivity can be used outside of Shiny applications--with two tricks.

  1. If you attempt to read a reactive expression or reactive value from the console, you'll get an error. I intentionally did this because in a fundamentally reactive system like Shiny it's almost always a bug to read a reactive value or expression from a non-reactive context (hopefully that sentence makes sense if you've read the two links above). However when you're driving at the console it's pretty reasonable to want to circumvent this check. So you can set options(shiny.suppressMissingContextError=TRUE) to make it go away.
  2. When you do stuff that triggers reactivity, observers aren't actually executed until you call shiny:::flushReact(). This is so that you can perform multiple updates and then let all the reactive code respond once, instead of recalculating with every update. For console use, you can ask Shiny to automatically call flushReact on every console prompt by using shiny:::setAutoflush(TRUE). Again, this is only needed for observers to work.

An example that works today (execute this line by line at the console):

library(shiny)
options(shiny.suppressMissingContextError=TRUE)

makeReactiveBinding("x_1")
x_1 <- Sys.time()
x_2 <- reactive(x_1 + 60*60*24)
x_1
x_2()
x_1 <- Sys.time()
x_1
x_2()

# Now let's try an observer
shiny:::setAutoflush(TRUE)
observe(print(paste("The time changed:", x_1)))
x_1 <- Sys.time()

I would recommend taking another look at leveraging Shiny's reactive abstractions more directly. I think you can achieve a syntax like this quite straightforwardly with makeActiveBinding (assuming you think this is better than what Shiny gives you today):

where <- new.reactr()
where$x_1 <- Sys.time()
where$x_2 <- reactive(x_1 + 60*60*24)
where$x_1  # Read x_1
where$x_2  # Read x_2

One key advantage to declaring reactive expressions using reactive() rather than setThis is that the former can easily and naturally model expressions that depend on multiple reactive values/expressions at once. Note that reactive expressions are both cached and lazy: if you modify x_1 it will not actually recalculate x_2 until you try to read x_2, and if you read x_2 again without x_1 having changed then it'll just return the previous value without recalculating.

For a more functional twist on Shiny reactivity, see Hadley Wickham's new package https://github.com/hadley/shinySignals that is inspired by Elm.

Hope that helps.

Thanks to Rappster, Joe and Robert, your conversations have really benefited me a lot.

I have just writen a small tool to build a cacheable function using the following idea:

library(shiny)
gen.f <- function () {
    reactv <- reactiveValues()

    a <- reactive({ print('getting a()'); reactv$x + 1 })
    b <- reactive({ print('getting b()'); reactv$y + 1 })
    c <- reactive({ print('getting c()'); a() + b() })

    function (x.value, y.value) {
        reactv$x <<- x.value
        reactv$y <<- y.value
        isolate(c())
    }
}
f <- gen.f()

In the above example, the parent environment of the returned function was used to store the reactive values and the reactive expressions.

By doing so, the returned function will have the ability to cache its intermediate results and do not need to recalculate them if the function is further called with the same arguments. The underlying reactive expressions are wrapped inside and the function can be used as normal R functions.

> f(6,9)
[1] "getting c()"
[1] "getting a()"
[1] "getting b()"
[1] 17
> f(6,9)
[1] 17
> f(6,7)
[1] "getting c()"
[1] "getting b()"
[1] 15

Based on this idea, I wrote a tool to help generate this kind of cacheable function with the following syntax. You can see my repo at https://github.com/marlin-na/reactFunc

myfunc <- reactFunc(
    # ARGV is the formal arguments of the returned function
    ARGV = alist(x = , y = ),

    # These are reactive expressions in the function argument form
    a = { print('getting a()'); x + 1 },
    b = { print('getting b()'); y + 1 },
    ans = { print('getting ans()'); a() + b() }
)
> myfunc(6, 9)
[1] "getting ans()"
[1] "getting a()"
[1] "getting b()"
[1] 17
> myfunc(6, 9)
[1] 17
> myfunc(6, 7)
[1] "getting ans()"
[1] "getting b()"
[1] 15

Regards,

M;

Thanks to Joe's pointers I was able to significantly simplify the design. I'd really like not needing to worry about if some variable is a reactive variable or not (the former implying that you'd have to execute the underlying reactive binding function via () as in x_2() in Joe's answer above). So that's why I tried combining Joe's code with makeActiveBinding().

Pros

  • there's no need for the hash environment where$._HASH anymore and the actual reactivity details are left up to shiny - which is awesome because if someone knows how to master reactivity done in R it's probably the RStudio guys ;-) Also, that way the whole thing might be even compatible with shiny apps - well, at least theoretically ;-)
  • as Joe pointed out, reactive() doesn't care how many observed variables you feed to it - as long as they are in the same environment (arg env in reactive(), arg where in my code).

Cons

  • I think you loose the ability to definie "mutual dependency" this way - at least AFAICT so far. The roles are pretty clear now: there's a variable that can be overserved and might be set explicitly, and the other one really just observes.

  • The return value of reactive() is quite tricky as it suggests a much simpler object than is actually returned (which is a Reference Class). This makes it hard to combine with substitute() "as is" as this would result in a somewhat static binding (works for the very first cycle, but then it's static).

    I needed to use the good old workaround of going all the way back to transforming the whole thing to a character string:

    reactive_expr <- gsub(") $", ", env = where)", capture.output(reactive(x_1 + 60*60*24))

    Probably a bit dangerous or unreliable, but it seems that the end of capture.output(reactive()) always has that trailing whitespace which is goot for us as it let's us identify the last ).

    Also, this comes with kind of a Pro as well: as where is added inside setReactive, the user does not need to specify where twice - as would otherwise be needed:

    where <- new.env()
setReactive("x_1", reactive(x_2 + 60*60*24, env = where), where = where)

So, here's the draft

require("shiny")

setReactive <- function(
  id = id,
  value = NULL,
  where = .GlobalEnv,
  .tracelevel = 0,
  ...
) {
  ## Ensure shiny let's me do this //
  shiny_opt <- getOption("shiny.suppressMissingContextError")
  if (is.null(shiny_opt) || !shiny_opt) {
    options(shiny.suppressMissingContextError = TRUE)  
  }

  ## Check if regular value assignment or reactive function //
  if (!inherits(value, "reactive")) {
    is_reactive <- FALSE
    shiny::makeReactiveBinding(symbol = id, env = where)
    value_expr <- substitute(VALUE, list(VALUE = value))
  } else {
    is_reactive <- TRUE
    ## Put together the "line of lines" //
    value_expr <- substitute(value <<- VALUE(), list(VALUE = value))
    ## --> works initially but seems to be static
    ## --> seems like the call to 'local()' needs to contain the *actual*
    ## "literate" version of 'reactive(...)'. Evaluationg it  
    ## results in the reactive object "behind" 'reactive(()' to be assigned
    ## and that seems to make it static.

    ## Workaround based character strings and re-parsing //
    reactive_expr <- gsub(") $", ", env = where)", capture.output(value))
    value_expr <- substitute(value <<- eval(VALUE)(), 
                             list(VALUE = parse(text = reactive_expr)))
  }

  ## Call to 'makeActiveBinding' //
  expr <- substitute(
    makeActiveBinding(
      id,
      local({
        value <- VALUE
        function(v) {
          if (!missing(v)) {
              value <<- v
          } else {
              VALUE_EXPR
          }
          value
        }
      }),
      env = where
    ),
    list(
      VALUE = value,
      VALUE_EXPR = value_expr
     )
  )
  if (.tracelevel == 1) {
    print(expr)
  }
  eval(expr)

  ## Return value //
  if (is_reactive) {
    out <- get(id, envir = where, inherits = FALSE)
  } else {
    out <- value
  }
  return(out)
}

Testing in .GlobalEnv

## In .GlobalEnv //
## Make sure 'x_1' and 'x_2' are removed:
suppressWarnings(rm(x_1))
suppressWarnings(rm(x_2))
setReactive("x_1", value = Sys.time())
x_1
# [1] "2014-09-24 18:35:49 CEST"
x_1 <- Sys.time()
x_1
# [1] "2014-09-24 18:35:51 CEST"

setReactive("x_2", value = reactive(x_1 + 60*60*24))
x_2
# [1] "2014-09-25 18:35:51 CEST"
x_1 <- Sys.time()
x_1
# [1] "2014-09-24 18:36:47 CEST"
x_2
# [1] "2014-09-25 18:36:47 CEST"

setReactive("x_3", value = reactive({
  message(x_1)
  message(x_2)
  out <- x_2 + 60*60*24
  message(paste0("Difference: ", out - x_1))
  out
}))
x_3
# 2014-09-24 18:36:47
# 2014-09-25 18:36:47
# Difference: 2
# [1] "2014-09-26 18:36:47 CEST"
x_1 <- Sys.time()
x_1
# [1] "2014-09-24 18:38:50 CEST"
x_2
# [1] "2014-09-25 18:38:50 CEST"
x_3
# 2014-09-24 18:38:50
# 2014-09-25 18:38:50
# Difference: 2
# [1] "2014-09-26 18:38:50 CEST"

## Setting an observer has no effect
x_2 <- 100
x_2
# [1] "2014-09-25 18:38:50 CEST"

Testing in custom environment

Works analogous to using .GlobalEnv except that you need to state/use where:

where <- new.env()
suppressWarnings(rm(x_1, envir = where))
suppressWarnings(rm(x_2, envir = where))

setReactive("x_1", value = Sys.time(), where = where)
where$x_1
# [1] "2014-09-24 18:43:18 CEST"

setReactive("x_2", value = reactive(x_1 + 60*60*24, env = where), where = where)
where$x_2
# [1] "2014-09-25 18:43:18 CEST"
where$x_1 <- Sys.time()
where$x_1
# [1] "2014-09-25 18:43:52 CEST"
where$x_2 
# [1] "2014-09-25 18:43:52 CEST"

A couple of follow up questions (mostly directed to Joe if you're still "listening")

  1. If not taking care of chipping env in via string manipulation as I do it, how would I be able to access/alter the environment of the actual function/closure that defines the reactivity (to prevent the need to state the environment twice)?

    func <- attributes(reactive(x_1 + 60*60*24))$observable$.func
func
# function () 
# x_1 + 60 * 60 * 24
# attr(,"_rs_shinyDebugPtr")
# <pointer: 0x0000000008930380>
# attr(,"_rs_shinyDebugId")
# [1] 858
# attr(,"_rs_shinyDebugLabel")
# [1] "Reactive"

    EDIT: Figured that out: environment(func)

  2. Is there any way to realize "mutual dependencies" as the one realized with my code above with existing shiny functionality?

  3. Just a "far-off" thought without a specific use case behind it: would it be possible to have the observed variables live in different environments as well and still have reactive() recognize them appropriately?

Thanks again, Joe!

标签
r
Shiny
reactive-programming
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!