Связывание активных объектов в не блестящем контексте

Ответ 1

В локации /usr/local/lib/R/site-library/shiny/tests/ имеется набор тегов test_that. Они дают вам представление о том, как функции/обертки:

• reactiveValues
• reactive
• observe
• isolate

может использоваться вне вызова shinyServer.

Ключ состоит в том, чтобы использовать flushReact, чтобы отключить реактивность. Вот, например, один из тестов в файле test-reactivity.r, и я думаю, что он уже дает вам хорошее представление о том, что вам нужно сделать:

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)
})

Ответ 2

Для тех, кого это интересует: это продолжало прослушивать меня в выходные, поэтому я собрал небольшой пакет под названием reactr, который на основе способа привязки можно определить с помощью makeActiveBinding. Вы можете найти основную идею здесь.

Основные функции

• Поддерживаемые сценарии мониторинга: пакет позволяет определять простые сценарии мониторинга, а также более сложные, такие как произвольные функциональные отношения, взаимные привязки и различные среды для "исходных" и "целевых" переменных (см. аргументы where и where_watch).
• Кэширование: этот способ создания привязок использует кешированные значения, где это возможно, по соображениям эффективности (если контролируемая переменная не изменилась, все равно использовать кешированное значение, а не повторять функцию привязки каждый раз).
• В качестве ссылки я все еще оставил решение на основе концепции в моем вопросе выше. Он доступен через binding_type = 2. Тем не менее, он не поддерживает использование синтаксических сахаров для assign() и get() (<- и <obj-name> или $<obj-name>) для сохранения значений хэша в синхронизации - поэтому я бы не использовал его я думаю.

Минус

Что мне не очень нравится в этом, так это то, что мне нужна вспомогательная среда для хранения хеш-значений, которые сравниваются, чтобы принять решение "обновить кеш или вернуть кеш". Он по умолчанию плавает в where, в настоящее время в where$._HASH (см. ensureHashRegistryState(), но по крайней мере вы можете изменить имя /ID к тому, который вам больше нравится или нужен (см. Аргумент .hash_id).

Если кто-то знает, как избавиться от этого, было бы очень благодарно!: -)

Пример

См. README.md

Load:

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

Используйте примерную среду, чтобы мы не испортили наш .GlobalEnv:

where <- new.env()

Сценарий привязки 1: простой мониторинг (идентичные значения)

Задайте переменную, которая может контролироваться:

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

Задайте переменную, которая контролирует x_1 и имеет реактивную привязку к ней:

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

Всякий раз, когда x_1 изменяется, x_2 изменяется соответственно:

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

Обратите внимание, что попытка изменить x_2 игнорируется, поскольку она может отслеживать только x_1:

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

Сценарий привязки 2: простой мониторинг (произвольное функциональное отношение)

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

Всякий раз, когда x_1 изменяется, x_3 изменяется соответственно:

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

Сценарий привязки 3: взаимное связывание (идентичное значение)

Задайте две переменные, имеющие взаимное связывание. Основное отличие от сценария привязки 1 заключается в том, что вы можете установить как x_1 и x_4, и отражены изменения.

Чтобы сделать это, необходимо reset привязку для x_1 с mutual = TRUE:

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

Всякий раз, когда x_1 изменяется, x_4 изменяется соответственно и наоборот.

Обратите внимание, что переменные с взаимными привязками просто инициализируются setThis и имеют значение по умолчанию NULL. Вы должны фактически присвоить значение одному из них через <- после установление привязки:

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

Сценарий привязки 4: взаимное связывание (действительное двунаправленное отношение)

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

Другие примеры

См. ?setReactive и ?setReactive_bare.

Профилирование

Я включил профилирование script в /inst/prof/prof_1.r. Существует "голой" метод S3 setThis_bare, который примерно на 10% быстрее.

Использование метода S4 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

Использование функции S3 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

Для тех, кто интересуется подробными подробностями

Вот как выглядит шаблон шаблона, который подается на makeActiveBinding() внутри setThis() (исключая материал message(), см. /R/getBoilerplateCode.r).

Переменная, которая может контролироваться:

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")
  )
)

Готовность к оценке:

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

Переменная, которая отслеживает:

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")
  )
)    

Готовность к оценке:

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

Переменная с взаимными привязками:

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")
  )
)    

Готовность к оценке:

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

Ответ 3

(Пытался оставить это в качестве комментария, но С.О. сказал, что он слишком длинный.)

Престижность для более пристального изучения реактивности. Вы можете найти эти две ссылки полезными:

• https://jcheng.shinyapps.io/reactivity-dsc2014
• Как реактивность Метеор работает за кулисами? (Блестящее реактивное ядро ​​было во многом вдохновлено Метеор)

Таким образом, на самом деле Блестящая реактивность может использоваться вне приложений Shiny - с двумя трюками.

• Если вы попытаетесь прочитать реактивное выражение или реактивное значение с консоли, вы получите сообщение об ошибке. Я намеренно сделал это, потому что в принципиально реактивной системе, такой как Shiny, почти всегда есть ошибка, чтобы прочитать реактивную ценность или выражение из нереактивного контекста (надеюсь, это предложение имеет смысл, если вы прочитали две ссылки выше). Однако, когда вы едете на консоли, довольно разумно хотеть обойти эту проверку. Поэтому вы можете установить options(shiny.suppressMissingContextError=TRUE), чтобы он исчез.
• Когда вы делаете что-то, что вызывает реактивность, наблюдатели фактически не выполняются до тех пор, пока вы не назовете shiny:::flushReact(). Это значит, что вы можете выполнить несколько обновлений, а затем дать ответному реактивному коду один раз, вместо пересчета с каждым обновлением. Для использования консоли вы можете попросить Shiny автоматически вызвать flushReact в каждом приглашении консоли, используя shiny:::setAutoflush(TRUE). Опять же, это необходимо только для работы наблюдателей.

Пример, который работает сегодня (выполните эту строку за строкой на консоли):

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 try an observer
shiny:::setAutoflush(TRUE)
observe(print(paste("The time changed:", x_1)))
x_1 <- Sys.time()

Я бы порекомендовал еще раз взглянуть на более активное использование реактивных абстракций Shiny. Я думаю, что вы можете добиться такого синтаксиса, как это довольно просто, с помощью makeActiveBinding (если вы думаете, что это лучше, чем то, что дает вам Shiny):

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

Одним из ключевых преимуществ объявления реактивных выражений с использованием reactive(), а не setThis является то, что первое может легко и естественно моделировать выражения, которые зависят от нескольких реактивных значений/выражений сразу. Обратите внимание, что реактивные выражения кэшируются и ленивы: если вы изменяете x_1, он фактически не пересчитывает x_2, пока не попытается прочитать x_2, и если вы снова прочитаете x_2 без изменения x_1 просто верните предыдущее значение без пересчета.

Для более функционального твиста на блестящей реактивности см. новый пакет Hadley Wickham https://github.com/hadley/shinySignals, который вдохновлен Elm.

Надеюсь, что это поможет.

Ответ 4

Благодаря Rappster, Джо и Роберту, ваши разговоры действительно очень помогли мне.

Я только что написал небольшой инструмент для создания кешируемой функции, используя следующую идею:

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()

В приведенном выше примере родительская среда возвращаемой функции использовался для хранения реактивных значений и реактивных выражений.

Таким образом, возвращаемая функция будет иметь возможность кэшировать ее промежуточные результаты и не нужно пересчитывать их, если функция далее вызывается с теми же аргументами. Основные реактивные выражения обернуты внутри, и функция может быть используется как обычные функции R.

> 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

Основываясь на этой идее, я написал инструмент, помогающий сгенерировать этот тип кэшируемых со следующим синтаксисом. Вы можете увидеть мое репо на 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

Привет,

М;

Ответ 5

Благодаря указателям Joe я смог значительно упростить дизайн. Мне бы очень хотелось, чтобы не нуждался в том, чтобы беспокоиться о том, является ли какая-либо переменная реактивной переменной или нет (первая подразумевает, что вам нужно будет выполнить базовую функцию реактивного привязки через (), как в x_2() в ответе Джо выше). Поэтому я попытался объединить код Джо с makeActiveBinding().

Pros

• больше нет необходимости в хэш-среде where$._HASH, а фактическая информация о реактивности остается до shiny - это потрясающе, потому что, если кто-то знает, как справиться с реактивностью, сделанной в R, это, вероятно, RStudio.;-) Также, таким образом все это может быть даже совместимо с приложениями shiny - ну, по крайней мере, теоретически; -)
• как указал Джо, reactive() не заботится о том, сколько наблюдаемых переменных вы ему кормите, если они находятся в одной среде (arg env в reactive(), arg where в моем коде).

Против

• Я думаю, что вы теряете способность определять "взаимную зависимость" таким образом - по крайней мере, AFAICT. Теперь роли довольно ясны: есть переменная, которая может быть зависеть и может быть явно задана, а другая - действительно просто.

• Возвращаемое значение reactive() довольно сложно, поскольку оно предлагает гораздо более простой объект, чем фактически возвращается (что является ссылочным классом). Это затрудняет объединение с substitute() "как есть", поскольку это приведет к несколько статической привязке (работает для самого первого цикла, но затем статично).

  Мне нужно было использовать добрый старый обходной путь, чтобы полностью преобразовать все это в строку character:

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

  Вероятно, это немного опасно или ненадежно, но кажется, что в конце capture.output(reactive()) всегда есть это конечное пустое пространство, которое для нас является пустым, поскольку оно позволяет идентифицировать последний ).

  Кроме того, это также относится к виду Pro: поскольку where добавляется внутри setReactive, пользователю не нужно указывать where дважды - как и в противном случае:

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

Итак, здесь черновик

require("shiny")

setReactive <- function(
  id = id,
  value = NULL,
  where = .GlobalEnv,
  .tracelevel = 0,
  ...
) {
  ## Ensure shiny let 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)
}

Тестирование в .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"

Тестирование в пользовательской среде

Работает аналогично использованию .GlobalEnv, за исключением того, что вам нужно указать/использовать 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"

Несколько последующих вопросов (в основном направленных Джо, если вы все еще "слушаете" )

• Если вы не заботитесь об обрезке env с помощью строковой манипуляции, как я это делаю, как бы я мог бы получить доступ к/изменить среду фактической функции/закрытия, которая определяет реактивность (чтобы избежать необходимости дважды указать среду)?

  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: Выяснилось, что: environment(func)

• Есть ли способ реализовать "взаимные зависимости", как реализованный с моим кодом выше с существующими блестящими функциональными возможностями?

• Просто "далекая" мысль без конкретного варианта использования: можно ли иметь наблюдаемые переменные в разных средах, а также reactive() распознать их соответствующим образом?

Еще раз спасибо, Джо!