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

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

我举了一个例子来说明我的问题。它由一个主应用程序组成，其中包含一个reactiveValue，它是一个3列的数据帧和3个旨在“读取”、“写入”和“读写”reactiveValue的模块。

• 阅读：应用程序 -> 模块
• 写入：模块->应用程序
• 读写：应用程序 模块

我收到错误：

警告：

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

我发现以下链接非常有用。不确定它是否涵盖我的情况。https://www.ardata.fr/en/post/2019/04/26/share-reactive-among-shiny-modules/ 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)

请尝试以下操作：

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 and reactiveValues但这只能运行一次，因此如下：

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

我发现的一个独立问题是你的代码即使对于write模块。所以，我改变了trigger = NULL to trigger = 0（因为你不能添加到NULL值），但随后必须添加ignoreInit = TRUE为了observeEvents in the server在启动时忽略它们。

请随意测试这些，通过一一取出我的添加来了解该过程。如果有什么需要澄清的请在下面评论。