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

Question

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

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

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

我得到错误：

警告：

请注意，如果 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)

关键是在处理reactives 和reactiveValues 时添加toReturn$x <- toReturn$x() 行，但这只能运行一次，因此如下：

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

我发现的一个独立问题是，即使是 write 模块，您的代码也只能运行一次。因此，我将trigger = NULL 更改为trigger = 0（因为您无法添加到NULL 值），但随后必须在server 中为observeEvents 添加ignoreInit = TRUE，以便在启动时忽略它们。

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