r - 在 R Shiny 中跨多个模块使用 reactiveValues

Question

我正在尝试在 R Shiny 的应用程序中跨多个模块使用 reactiveValues。

我已经建立了一个例子来说明我的问题。它由一个包含 react 值的主应用程序组成， react 值是一个包含 3 列的数据框和 3 个模块，旨在“读取”、“写入”和“读取和写入” react 值。

阅读:应用程序 -> 模块

写入:模块 -> 应用程序

读写:应用程序<->模块

我得到错误:

Warning: Error in <-: object of type 'closure' is not subsettable

请注意，如果 reactiveValue 只是一个简单的变量，例如，代码就可以工作。整数，但不适用于需要更新组件的数据框，而不是整个数据框。

我发现以下链接非常有用。不确定它是否涵盖我的情况。
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在启动时忽略它们。

随意通过一一取出我的补充来测试这些以了解该过程。如果有任何需要澄清的地方，请在下方评论。