Menu
How could you either approximate the reactive environment/behavior established by shiny functions or possibly even use these very functions in a non-shiny context in order to create "reactive" variables?
I'm absolutely fascinated by the shiny framework and its underlying paradigms. In particular with respect to the established overall reactive environment. Just for the pure fun of it, I wondered if one could transfer this reactive programming paradigm to a non-shiny context - i.e. a regular R application/project/package or however you want to call it.
Maybe think options: you might want option_2 to depend on the value of option_1 to ensure
consistent data states. If option_1 changes, option_2 should change as well.
I guess I'm idealy looking for something as efficient as possible, i.e. option_2 should only be updated when necessary, i.e. when option_1 actually changes (as opposed to computing the current state of option_2 each time I query the option).
I played around a bit with the following functions:
shiny::reactiveValuesshiny::reactive shiny::observeshiny::isolateBut AFAIU, they are closely tailord to the shiny context, of course.
This is a very simple solution based on environments. It works, but
Definition of set function:
setValue <- function(
id,
value,
envir,
observe = NULL,
binding = NULL,
...
) {
## Auxiliary environments //
if (!exists(".bindings", envir, inherits = FALSE)) {
assign(".bindings", new.env(), envir)
}
if (!exists(".hash", envir, inherits = FALSE)) {
assign(".hash", new.env(), envir)
}
if (!exists(".observe", envir, inherits = FALSE)) {
assign(".observe", new.env(), envir)
}
if (!exists(id, envir$.hash, inherits = FALSE)) {
assign(id, new.env(), envir$.hash)
}
## Decide what type of variable we have //
if (!is.null(observe) && !is.null(binding)) {
has_binding <- TRUE
} else {
has_binding <- FALSE
}
## Set //
if (has_binding) {
## Value with binding //
## Get and transfer hash value of observed variable:
assign(id, get(observe, envir$.hash[[observe]]), envir$.hash[[observe]])
## Compute actual value based on the binding contract/function:
out <- binding(x = get(observe, envir))
## Store actual value:
assign(id, out, envir)
## Store hash value:
assign(id, digest::digest(out), envir$.hash[[id]])
## Store binding:
assign(id, binding, envir$.bindings)
## Store name of observed variable:
assign(id, observe, envir$.observe)
} else {
## Regular variable without binding //
## Store actual value:
out <- assign(id, value, envir)
## Store hash value:
assign(id, digest::digest(value), envir$.hash[[id]])
}
return(out)
}
Definition of get function:
getValue <- function(
id,
envir,
...
) {
## Check if variable observes another variable //
observe <- envir$.observe[[id]]
## Get //
if (!is.null(observe)) {
## Check if any of observed variables have changed //
## Note: currently only tested with bindings that only
## take one observed variable
idx <- sapply(observe, function(ii) {
hash_0 <- get(ii, envir$.hash[[ii]], inherits = FALSE)
hash_1 <- get(id, envir$.hash[[ii]], inherits = FALSE)
hash_0 != hash_1
})
## Update required //
if (any(idx)) {
out <- setValue(
id = id,
envir = envir,
binding = get(id, envir$.bindings, inherits = FALSE),
observe = observe
)
} else {
out <- get(id, envir, inherits = FALSE)
}
} else {
out <- get(id, envir, inherits = FALSE)
}
return(out)
}
Apply:
##------------------------------------------------------------------------------
## Apply //
##------------------------------------------------------------------------------
require("digest")
envir <- new.env()
## Set regular variable value //
setValue(id = "x_1", value = Sys.time(), envir = envir)
[1] "2014-09-17 23:15:38 CEST"
getValue(id = "x_1", envir = envir)
# [1] "2014-09-17 23:15:38 CEST"
## Set variable with binding to observed variable 'x_1' //
setValue(
id = "x_2",
envir = envir,
binding = function(x) {
x + 60*60*24
},
observe = "x_1"
)
# [1] "2014-09-18 23:15:38 CEST"
## As long as observed variable does not change,
## value of 'x_2' will also not change
getValue(id = "x_2", envir = envir)
# [1] "2014-09-18 23:15:38 CEST"
## Change value of observed variable 'x_1' //
setValue(id = "x_1", value = Sys.time(), envir = envir)
# [1] "2014-09-17 23:16:52 CEST"
## Value of 'x_2' will change according to binding contract/function:
getValue(id = "x_2", envir = envir)
# [1] "2014-09-18 23:16:52 CEST"
Profiling:
##------------------------------------------------------------------------------
## Profiling //
##------------------------------------------------------------------------------
require(microbenchmark)
envir <- new.env()
binding <- function(x) {
x + 60*60*24
}
microbenchmark(
"1" = setValue(id = "x_1", value = Sys.time(), envir = envir),
"2" = getValue(id = "x_1", envir = envir),
"3" = setValue(id = "x_2", envir = envir,
binding = binding, observe = "x_1"),
"4" = getValue(id = "x_2", envir = envir),
"5" = setValue(id = "x_1", value = Sys.time(), envir = envir),
"6" = getValue(id = "x_2", envir = envir)
)
# Unit: microseconds
# expr min lq median uq max neval
# 1 108.620 111.8275 115.4620 130.2155 1294.881 100
# 2 4.704 6.4150 6.8425 7.2710 17.106 100
# 3 178.324 183.6705 188.5880 247.1735 385.300 100
# 4 43.620 49.3925 54.0965 92.7975 448.591 100
# 5 109.047 112.0415 114.1800 159.2945 223.654 100
# 6 43.620 47.6815 50.8895 100.9225 445.169 100
749
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.
where and where_watch). 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.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! :-)
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()
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
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
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
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
See ?setReactive and ?setReactive_bare.
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
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")
)
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:
reactiveValuesreactiveobserveisolatecan 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)
})
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With
