在模块之间共享可编辑的数据框

Question

我正在尝试使用反应值在模块之间共享数据，使用 this 想法，但是闪亮在尝试传递更新数据时抛出错误，rv$data 不是数据框但我认为是一个反应对象。详细来说，数据table在summarytable中进行了总结，也绘制出来了。编辑数据 table 时，我希望摘要 table 和绘图也能更新。

library(shiny)
library(DT)
library(tidyverse)

#summary modules----
summary_ui <- function(id){
    ns <- NS(id)
    DT::dataTableOutput(ns("summary_table"))
}

summary_server <- function(id,data){
    shiny::moduleServer(
        id,
        function(input, output, session) {
            output$summary_table <- DT::renderDataTable({
                sum_data <- data %>%
                    group_by(Brand) %>%
                    summarise_all(list(sum))
                
                DT::datatable(sum_data, editable = TRUE)
            })
        })
}

#data table modules----
data_ui <- function(id) {
    ns <- NS(id)
    DT::dataTableOutput(ns("data_table"))
}


data_server <- function(input, output, session, data,reset) {
    
    print(isolate(colnames(data)))
    output$data_table <- DT::renderDataTable({
        DT::datatable(data, editable = TRUE)
    })
}

#edit datatable----
edit_server <- function(input, output, session, data) {
    
    ns <- session$ns
    
    proxy = dataTableProxy("data_table")

    observeEvent(input$data_table_cell_edit, {
        print(names(data))
        info = input$data_table_cell_edit
        str(info)
        i = info$row
        j = info$col
        k = info$value
        str(info)

        isolate(
            if (j %in% match(c("ratio","cost","updated_price"), names(data))) {
                print(match(c("ratio","cost", "updated_price"), names(data)))
                data[i, j] <<- DT::coerceValue(k, data[i, j])
                print(data)

                if (j %in% match("cost", names(data))) {
                    data$updated_price <<- data$cost * data$ratio
                }
                if (j %in% match("ratio", names(data))) {
                    data$updated_price <<- data$cost * data$ratio
                }
            } else {
                stop("You are not supposed to change this column.") # check to stop the user from editing only few columns
            }
        )
        replaceData(proxy, data, resetPaging = FALSE)  # replaces data displayed by the updated table
    })

    result <- reactiveValues(
        data=NULL,
        trigger=NULL
    )

    result$data <- data
    result$trigger <- 1
    
    return(result)
}

#plot modules----
plot_ui <- function(id){
    ns <- NS(id)
    plotOutput(ns(id))
}

plot_server <- function(id,data){
    moduleServer(
        id,
        function(input,output,session){
            
            output$price_plot <- renderPlot({
                ns <- NS(id)
                data %>%
                    ggplot()+
                    aes(x=cost,y=updated_price)+
                    geom_point()
            })
        })
}

#dataset-----------------------
input_data <- data.frame(Brand = c("Brand1", "Brand2","Brand3","Brand1", "Brand2","Brand3","Brand1", "Brand2","Brand3"),
                         ratio = rep(0.5,9),
                         cost = seq(from=100,to=1000,length.out=9)) %>%
    mutate(updated_price = cost * ratio)

#ui----------------------------------------
ui = fluidPage(
    fluidRow(
        column(6,data_ui(id="data_table")),
        column(6,plot_ui(id="price_plot"))
    ),
    fluidRow(
        column(6,summary_ui(id="summary_table"))
    ),
)

#server-----------------------------------------
server = function(input, output, session) {
    
    rv <- reactiveValues(data = input_data,trigger=NULL)
    observe({  rv$data <- input_data  })
    
    #data table----------------------
    callModule(data_server,"data_table", data=rv$data)
    
    #edit table----
    data_mod <- callModule(module = edit_server, id = "mod",data = reactive(rv$data))
    observeEvent(data_mod$trigger,{
        #error: rv reactiveValue not being updated correctly
        rv$data <- data_mod$data
        })
    
    #summary table----
    summary_server("summary_table",data=rv$data)
    
    #plot----
    plot_server(id="price_plot",data=rv$data)
}    

#app-----
shinyApp(ui = ui, server = server)

Answer 1

这归结为两件事：

使用反应式而不是数据
使用正确的命名空间

不过，首先，我只是做了一些家务管理：

更新了 data_server 和 edit_server 以使用 moduleServer 格式。这消除了服务器中对 callModule 的需要，并且与其他模块一致
在服务器函数中删除 observe({ rv$data <- input_data })。它什么都不做，因为 input_data 永远不会改变，并且在 reactiveValues 对象初始化时已经分配
在 edit_server 中，您经常查找列名，所以我创建了一个变量 dataNames

除此之外，不要尝试仅将 reactiveValues 列表的 data 元素传递给您的模块，而是传递整个对象。它打破了函数式编程的本质，但简化了编码。我将所有 data 参数重命名为 rv 以突出显示更改。例如：

plot_server <- function(id, rv){
  moduleServer(
    id,
    function(input,output,session){
      
      output$price_plot <- renderPlot({
        ns <- NS(id)
        rv$data %>%
          ggplot()+
          aes(x=cost,y=updated_price)+
          geom_point()
      })
    })
}

因此，您也不需要 return 来自 edit_server 的值，因为您可以直接修改对象，因为反应对象（即 R6 对象）通过引用传递。模块的服务器函数变成这样：

edit_server <- function(id, rv){
  moduleServer(
    id,
    function(input, output, session) {
      
      ns <- session$ns
      
      proxy <- dataTableProxy("data_table")
      
      observeEvent(input$data_table_cell_edit, {
        
        dataNames <- names(rv$data)
        
        print(dataNames)
        info = input$data_table_cell_edit
        str(info)
        i = info$row
        j = info$col
        k = info$value
        str(info)
        
        isolate(
          if (j %in% match(c("ratio","cost","updated_price"), dataNames)) {
            print(match(c("ratio","cost", "updated_price"), dataNames))
            rv$data[i, j] <- DT::coerceValue(k, rv$data[i, j])
            print(rv$data)
            
            if (j %in% match("cost", dataNames)) {
              rv$data$updated_price <- rv$data$cost * rv$data$ratio
            }
            if (j %in% match("ratio", dataNames)) {
              rv$data$updated_price <- rv$data$cost * rv$data$ratio
            }
          } else {
            stop("You are not supposed to change this column.") # check to stop the user from editing only few columns
          }
        )
        replaceData(proxy, rv$data, resetPaging = FALSE)  # replaces data displayed by the updated table
        
      })
    }
  )
}

然而，可能最重要的是记住模块的 input 有一个命名空间，该名称空间基于您从服务器调用模块时传递的 id 参数。在 edit_server 的情况下，您希望它在与数据 table UI 相同的命名空间中运行，因此它可以对 table 的 [=31] 产生反应性依赖=].因此使用与 data_server:

相同的 id

  #data table----------------------
  data_server(id = "data_table", data = rv$data)
  
  #edit table----
  edit_server(id = "data_table", rv = rv)

全部代码：

library(shiny)
library(DT)
library(tidyverse)

#summary modules----
summary_ui <- function(id){
  ns <- NS(id)
  DT::dataTableOutput(ns("summary_table"))
}

summary_server <- function(id, rv){
  shiny::moduleServer(
    id,
    function(input, output, session) {
      
      output$summary_table <- DT::renderDataTable({
        sum_data <- rv$data %>%
          group_by(Brand) %>%
          summarise_all(list(sum))
        
        DT::datatable(sum_data, editable = TRUE)
      })
    })
}

#data table modules----
data_ui <- function(id) {
  ns <- NS(id)
  DT::dataTableOutput(ns("data_table"))
}


data_server <- function(id, data, reset){
  moduleServer(
    id,
    function(input, output, session) {
      
      print(isolate(colnames(data)))
      output$data_table <- DT::renderDataTable({
        DT::datatable(data, editable = TRUE)
      })
    }
  )
} 

#edit datatable----
edit_server <- function(id, rv){
  moduleServer(
    id,
    function(input, output, session) {
      
      ns <- session$ns
      
      proxy <- dataTableProxy("data_table")
      
      observeEvent(input$data_table_cell_edit, {
        
        dataNames <- names(rv$data)
        
        print(dataNames)
        info = input$data_table_cell_edit
        str(info)
        i = info$row
        j = info$col
        k = info$value
        str(info)
        
        isolate(
          if (j %in% match(c("ratio","cost","updated_price"), dataNames)) {
            print(match(c("ratio","cost", "updated_price"), dataNames))
            rv$data[i, j] <- DT::coerceValue(k, rv$data[i, j])
            print(rv$data)
            
            if (j %in% match("cost", dataNames)) {
              rv$data$updated_price <- rv$data$cost * rv$data$ratio
            }
            if (j %in% match("ratio", dataNames)) {
              rv$data$updated_price <- rv$data$cost * rv$data$ratio
            }
          } else {
            stop("You are not supposed to change this column.") # check to stop the user from editing only few columns
          }
        )
        replaceData(proxy, rv$data, resetPaging = FALSE)  # replaces data displayed by the updated table
        
      })
    }
  )
}

#plot modules----
plot_ui <- function(id){
  ns <- NS(id)
  plotOutput(ns(id))
}

plot_server <- function(id, rv){
  moduleServer(
    id,
    function(input,output,session){
      
      output$price_plot <- renderPlot({
        ns <- NS(id)
        rv$data %>%
          ggplot()+
          aes(x=cost,y=updated_price)+
          geom_point()
      })
    })
}

#dataset-----------------------
input_data <- data.frame(Brand = c("Brand1", "Brand2","Brand3","Brand1", "Brand2","Brand3","Brand1", "Brand2","Brand3"),
                         ratio = rep(0.5,9),
                         cost = seq(from=100,to=1000,length.out=9)) %>%
  mutate(updated_price = cost * ratio)

#ui----------------------------------------
ui = fluidPage(
  fluidRow(
    column(6, data_ui(id="data_table")),
    column(6, plot_ui(id="price_plot"))
  ),
  fluidRow(
    column(6, summary_ui(id="summary_table"))
  ),
)

#server-----------------------------------------
server = function(input, output, session) {
  
  rv <- reactiveValues(data = input_data, trigger=NULL)
  
  #data table----------------------
  data_server(id = "data_table", data = rv$data)
  
  #edit table----
  edit_server(id = "data_table", rv = rv)
  
  #summary table----
  summary_server(id = "summary_table", rv = rv)
  
  #plot----
  plot_server(id = "price_plot", rv=rv)
}    

#app-----
shinyApp(ui = ui, server = server)

在模块之间共享可编辑的数据框

Share editable dataframe between modules

r

shiny

module

reactive