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

【问题标题】：Share editable dataframe between modules在模块之间共享可编辑的数据框
【发布时间】：2022-01-17 12:10:34
【问题描述】：

我正在尝试使用反应值在模块之间共享数据，使用this 想法，但是当它尝试传递更新的数据时，闪亮会抛出错误，rv$data 不是数据框，而是我认为的反应对象.详细地，数据表在汇总表中进行汇总，并绘制出来。编辑数据表时，我希望汇总表和绘图也更新。

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)

【问题讨论】：

在所有模块中，除了函数参数在哪里，不应该代替data、data()？例如：sum_data <- data() %>% 而不是 sum_data <- data %>%?
还有observeEvent(data_mod$trigger,{ rv$data <- data_mod }) 不应该是observeEvent(data_mod()$trigger,{ rv$data <- data_mod })？我也不明白$trigger来自哪里，所以我不确定这是否正确。
@gss 数据是一个数据框而不是一个函数，所以data() 是不正确的，我从附加的链接中得到了data_mod$trigger 方法
这可能没有什么不同，但您的ui 和server 分配没有使用正确的“callModule(data_server,"data_table", data=rv$data) 应该是 callModule(data_server,"data_table", data=reactive(rv$data)) 吗？
感谢您的建议，但没有成功

标签： r shiny module reactive

【解决方案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()
      })
    })
}

因此，您也不需要从 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，您希望它在与数据表UI 相同的命名空间中运行，这样它就可以对表的input$data_table_cell_edit 进行响应式依赖。因此使用与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)

【讨论】：