Использование реактивных значений в нескольких модулях в R Shiny

Question

Я пытаюсь использовать реактивные значения для нескольких модулей в блестящем приложении R.

Я создал пример, чтобы проиллюстрировать мою проблему. Он состоит из основного приложения, содержащего реактивное значение, которое представляет собой фрейм данных из 3 столбцов и 3 модулей, предназначенных для «чтения», «записи» и «чтения и записи» реактивного значения.

• Чтение: приложение -> Модуль
• Запись: Модуль -> Приложение
• Чтение и запись: Приложение <-> Модуль

Я получаю сообщение об ошибке:

Предупреждение: ошибка в <-: объект типа 'замыкание' не может быть подмножеством </p>

Обратите внимание, что код работает, если responsetiveValue является простой переменной, например целым числом, но не с фреймом данных где компоненты должны быть обновлены, а не весь фрейм данных.

Я нашел следующую ссылку очень полезной. Не уверен, что это покрывает мой случай. https://www.ardata.fr/en/post/2019/04/26/share-reactive-among-shiny-modules/

Есть идеи, как решить эту проблему?

Вот мой код:

library(shiny)
library(shinydashboard)

readUI <- function(id, label = "Read") {

  ns <- NS(id)

  tagList(
    valueBoxOutput(ns("showX"))
  )
}

read <- function(input, output, session, x) {

  ns <- session$ns

  output$showX <- renderValueBox({
    valueBox(x(), "x")
  })

}

writeUI <- function(id, label = "Write") {

  ns <- NS(id)

  tagList(
    selectizeInput(ns("selectX"), "Select a value for x", choices = 1:10),
    actionButton(ns("submit"), "Submit")
  )
}

write <- function(input, output, session) {

  ns <- session$ns

  toReturn <- reactiveValues(x = data.frame(a=c(1), b=c(2), c=c(3)), trigger = NULL)

  observeEvent(input$submit, {
    toReturn$x$a <- as.numeric(input$selectX)
    toReturn$trigger <- toReturn$trigger + 1
  })

  return(toReturn)

}

readAndWriteUI <- function(id, label = "ReadAndWrite") {

  ns <- NS(id)

  tagList(
    valueBoxOutput(ns("showX")),
    selectizeInput(ns("selectX"), "Select a value for x", choices = 1:10),
    actionButton(ns("submit"), "Submit")
  )

}

readAndWrite <- function(input, output, session, x) {

  ns <- session$ns

  toReturn <- reactiveValues(x = x, trigger = NULL)

  output$showX <- renderValueBox({
    valueBox(x(), "x")
  })

  observeEvent(input$submit, {
    toReturn$x$a <- as.numeric(input$selectX)
    toReturn$trigger <- toReturn$trigger + 1
  })

  return(toReturn)

}

ui <- dashboardPage(

  dashboardHeader(title = "Example"),

  dashboardSidebar(),

  dashboardBody(
    tabsetPanel(id = "mainTabSetPanel",
      tabPanel("Read", readUI("Read")),
      tabPanel("Write", writeUI("Write")),
      tabPanel("ReadAndWrite", readAndWriteUI("ReadAndWrite"))
    )
  )
)

server <- function(input, output, session) {

  rv <- reactiveValues(x = data.frame(a=c(1), b=c(2), c=c(3)))

  callModule(read, "Read", reactive(rv$x))
  output_Write <- callModule(write, "Write")
  output_ReadAndWrite <- callModule(readAndWrite, "ReadAndWrite", reactive(rv$x))

  observeEvent(output_Write$trigger, {
    print("Updating x from Write")
    rv$x <- output_Write$x
    #updateTabsetPanel(session, "mainTabSetPanel", selected = "Read")
  })

  observeEvent(output_ReadAndWrite$trigger, {
    print("Updating x from ReadAndWrite")
    rv$x <- output_ReadAndWrite$x
    #updateTabsetPanel(session, "mainTabSetPanel", selected = "Read")
  })
}

shinyApp(ui, server)

Answer 1

Пожалуйста, попробуйте следующее:

library(shiny)
library(shinydashboard)

readUI <- function(id, label = "Read") {

    ns <- NS(id)

    tagList(
        valueBoxOutput(ns("showX"))
    )
}

read <- function(input, output, session, x) {

    ns <- session$ns

    output$showX <- renderValueBox({
        valueBox(x(), "x")
    })

}

writeUI <- function(id, label = "Write") {

    ns <- NS(id)

    tagList(
        selectizeInput(ns("selectX"), "Select a value for x", choices = 1:10),
        actionButton(ns("submit"), "Submit")
    )
}

write <- function(input, output, session) {

    ns <- session$ns

    toReturn <- reactiveValues(x = data.frame(a=c(1), b=c(2), c=c(3)), trigger = 0)

    observeEvent(input$submit, {
        toReturn$x$a <- as.numeric(input$selectX)
        toReturn$trigger <- toReturn$trigger + 1
    })

    return(toReturn)

}

readAndWriteUI <- function(id, label = "ReadAndWrite") {

    ns <- NS(id)

    tagList(
        valueBoxOutput(ns("showX")),
        selectizeInput(ns("selectX"), "Select a value for x", choices = 1:10),
        actionButton(ns("submit"), "Submit")
    )

}

readAndWrite <- function(input, output, session, x) {

    ns <- session$ns

    toReturn <- reactiveValues(x = x, trigger = 0)

    observeEvent(toReturn, {
        toReturn$x <- toReturn$x()
    }, once = TRUE)

    output$showX <- renderValueBox({
        valueBox(x(), "x")
    })

    observeEvent(input$submit, {
        toReturn$x$a <- as.numeric(input$selectX)
        toReturn$trigger <- toReturn$trigger + 1
    })

    return(toReturn)

}

ui <- dashboardPage(

    dashboardHeader(title = "Example"),

    dashboardSidebar(),

    dashboardBody(
        tabsetPanel(id = "mainTabSetPanel",
                    tabPanel("Read", readUI("Read")),
                    tabPanel("Write", writeUI("Write")),
                    tabPanel("ReadAndWrite", readAndWriteUI("ReadAndWrite"))
        )
    )
)

server <- function(input, output, session) {

    rv <- reactiveValues(x = data.frame(a=c(1), b=c(2), c=c(3)))

    callModule(read, "Read", reactive(rv$x))
    output_Write <- callModule(write, "Write")
    output_ReadAndWrite <- callModule(readAndWrite, "ReadAndWrite", reactive(rv$x))

    observeEvent(output_Write$trigger, {
        print("Updating x from Write")
        rv$x <- output_Write$x
        #updateTabsetPanel(session, "mainTabSetPanel", selected = "Read")
    }, ignoreInit = TRUE)

    observeEvent(output_ReadAndWrite$trigger, {
        print("Updating x from ReadAndWrite")
        rv$x <- output_ReadAndWrite$x
        #updateTabsetPanel(session, "mainTabSetPanel", selected = "Read")
    }, ignoreInit = TRUE)
}

shinyApp(ui, server)

Ключ добавляется в строку toReturn$x <- toReturn$x(), когда вы имеете дело с reactives и reactiveValues, но это должно выполняться только один раз, поэтому ниже :

observeEvent(toReturn, {
    toReturn$x <- toReturn$x()
}, once = TRUE)

Независимая проблема, которую я обнаружил, заключалась в том, что ваш код работал только один раз даже для модуля write. Итак, я изменил trigger = NULL на trigger = 0 (поскольку вы не можете добавить значение NULL), но затем мне пришлось добавить ignoreInit = TRUE для observeEvents в server, чтобы игнорировать их при запуске.

Не стесняйтесь проверять их, вынимая мои дополнения один за другим, чтобы понять процесс. Комментарий ниже, если что-то нуждается в разъяснении.