非闪亮上下文中的反应式对象绑定 [英] Reactive object bindings in a non-shiny context
问题描述
您如何近似反应环境/行为由shiny 函数，或者甚至可能在 non-shiny 上下文中使用这些函数来创建反应性"变量?
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?
我对 shiny 框架 及其底层范式非常着迷.特别是关于已建立的整体反应环境.只是为了纯粹的乐趣，我想知道是否可以将这种反应式编程范式转移到非闪亮的上下文中——即常规的 R 应用程序/项目/包，或者你想怎么称呼它.
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.
也许认为 options:您可能希望 option_2 依赖于 option_1 的值来确保一致的数据状态.如果 option_1 改变，option_2 也应该改变.
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.
我想我正在寻找尽可能高效的东西，即 option_2 应该只在必要时更新，即当 option_1实际发生变化(而不是计算 option_2 每次我查询选项的当前状态).
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).
我使用了以下函数:
shiny::reactiveValues闪亮::反应式闪亮::观察闪亮::隔离
但是 AFAIU，当然，它们是为闪亮的环境量身定制的.
But AFAIU, they are closely tailord to the shiny context, of course.
这是一个基于environments的非常简单的解决方案.它有效，但是
This is a very simple solution based on environments. It works, but
- 我会对不同/更好的方法感兴趣，并且
- 我想也许人们真的可以以某种方式重用闪亮的代码.
set函数的定义:
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)
}
get函数的定义:
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 //
##------------------------------------------------------------------------------
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 //
##------------------------------------------------------------------------------
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
推荐答案
/usr/local/lib/R/site-library/位置有一组 .它们让您对函数/包装器的方式有一个很好的了解:test_that 单元测试闪亮/测试/
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反应式观察隔离
可以在 shinyServer 调用之外使用.
can be used outside of a shinyServer call.
关键是使用 flushReact 来触发反应性.例如，这里是文件 test-reactivity.r 中的测试之一，我认为它已经让您很好地了解了您需要做什么:
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)
})
这篇关于非闪亮上下文中的反应式对象绑定的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
