Актуальный вопрос
Как вы могли бы либо приблизиться к реактивной среде/поведению, установленному shiny или, возможно, даже использовать эти самые функции в контексте не блестящего, чтобы создать "реактивные" переменные?
Фон
Я абсолютно очарован блестящей инфраструктурой и ее лежащими в основе парадигмами. В частности, в отношении установленной общей реактивной среды. Просто для этого было интересно, можно ли перенести эту реактивную парадигму программирования в не блестящий контекст, т.е. Обычное R-приложение/проект/пакет или, тем не менее, вы хотите его назвать.
Возможно, подумайте о вариантах: вы можете хотеть option_2 зависеть от значения option_1 для обеспечения
согласованные состояния данных. Если option_1 изменяется, option_2 также должен измениться.
Я думаю, что я идеально ищу что-то максимально эффективное, т.е. option_2 должен обновляться только при необходимости, т.е. когда option_1 фактически изменяется (в отличие от вычисления текущего состояния option_2 каждый раз запрашиваю опцию).
Due dilligence
Я немного поиграл со следующими функциями:
-
shiny::reactiveValues -
shiny::reactive -
shiny::observe -
shiny::isolate
Но AFAIU, они, конечно, тесно связаны с блестящим контекстом.
Собственный прототип
Это очень простое решение, основанное на environment s. Он работает, но
- Меня бы интересовали разные/лучшие подходы и
- Я подумал, что, возможно, можно каким-то образом использовать блестящий код.
Определение функции set:
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:
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
