在模块化闪亮应用程序中捕获编辑数据 table 输出时出现问题

Question

我有一个闪亮的应用程序，它利用数据 table 和下拉菜单来控制 select 列的更新。当我模块化闪亮的应用程序时，我无法再捕获更新后的结果 table。我对下拉菜单所采用的方法是基于我收到的对先前问题 (@ismirsehregal) 的回复。

<

下面我提供了我的应用程序的两个版本，nonmod2_app 和 mod2_app。第一个没有模块，可以按需要工作。第二个是模块化版本，我在输出中得到 NULL。

当用户运行应用程序时，他们会看到一个加载数据按钮，该按钮将汽车数据加载为 cars_df 并创建一个新的 table I使用三个值调用 cars_meta。然后它创建一个名为 cars_object 的列表，其中 cars_df 和 cars_meta 添加。然后这是一个反应值，cars_reactive.

然后向用户呈现一个 editable 数据 table (initTbl) 反应 cars_reactive$cars_meta 他们可以通过下拉菜单更新两个字段的值。当用户完成更新并 select 按下提交按钮时，select 离子的结果将保存为 cars_reactive$cars_meta.我将更新后的 cars_reactive$cars_meta 显示为 verbatimTextOutput，这样人们就可以看到它是如何更新的。

在这两个示例中，我将第一个 class 值从“数字”更新为“字符”，然后 select 提交。在 nonmod2_app 版本中，结果 table 保留原始值并反映我更新的值。

在 mod2_app 版本中，两个 selectable 字段的所有值都为 NULL .

我怀疑它与名称空间有关，但我不知道缺少什么。

这是非模块化版本的 ui 和服务器代码。


#------- LIBRARIES ---------------------

library(dplyr)
library(tidyselect)
library(stringr)
library(purrr)
library(shinyjs)
library(DT)


# ------  UI  ------------------

shiny_ui <- function() {
    fluidPage(
        actionButton("new_data", "Load Data"),
        br(),
        DT::dataTableOutput("main_table"),
        br(),
        actionButton("commit_meta", "Commit"),
        br(),
        verbatimTextOutput("cars_meta")
    )
}




# -------- SERVER  ---------------

shiny_server <- function(input, output, session) {
    
    v <- reactiveValues()
    
    #place holders
    selectInputIDclass <- "class"
    selectInputIDusage <- "usage"
    
    observeEvent(input$new_data, once = TRUE, {

        
        cars_df <- mtcars
        
        #simulate creating meta table
        cars_meta <- dplyr::tibble(variable = names(cars_df), class = sapply(cars_df, class), usage = c("val1", "val2", "val3","val1", "val2", "val3","val1", "val2", "val3","val1", "val2"))
        cars_meta$class <- factor(cars_meta$class,  c("numeric", "character", "factor"))
        cars_meta$usage <- factor(cars_meta$usage,  c("val1", "val2", "val3"))
        
        #simulate creating the cars_object
        cars_object <- list()
        cars_object$cars_df <- cars_df
        cars_object$cars_meta <- cars_meta
        

        #make initTbl
        selectInputIDclass <<- paste0("sel_class", 1:nrow(cars_object$cars_meta))
        selectInputIDusage <<- paste0("sel_usage", 1:nrow(cars_object$cars_meta))
        
        v$initTbl <- dplyr::tibble(
            variable = cars_object$cars_meta$variable,
            class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor"),
                                                                                    selected = cars_object$cars_meta$class[which(selectInputIDclass == x)]))}),
            usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"),
                                                                                    selected = cars_object$cars_meta$usage[which(selectInputIDusage == x)]))})
        )

        
        v$cars_reactive <- reactive({
            cars_object
        })
    })
    
    
    displayTbl <- reactive({
        dplyr::tibble(
            variable = v$cars_reactive()$cars_meta$variable,
            class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor"), selected = input[[x]]))}),
            usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"), selected = input[[x]]))})
        )
    })
    
    
    resultTbl <- reactive({
        dplyr::tibble(
            variable = v$cars_reactive()$cars_meta$variable,
            class = sapply(selectInputIDclass, function(x){input[[x]]}),
            usage = sapply(selectInputIDusage, function(x){input[[x]]})
        )
    })
    
    
    output$main_table = DT::renderDataTable({
        req(isTruthy(input$new_data))
        DT::datatable(
            v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
            options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                           preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                           drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
            )
        )
    }, server = TRUE)
    
    
    main_table_proxy <- DT::dataTableProxy(outputId = "main_table", session = session)
    
    
    observeEvent({sapply(selectInputIDclass, function(x){input[[x]]})}, {
        replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
    }, ignoreInit = TRUE)
    
    
    observeEvent({sapply(selectInputIDusage, function(x){input[[x]]})}, {
        replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
    }, ignoreInit = TRUE)
    
    
    observeEvent(input$commit_meta, {  
        object = v$cars_reactive()
        table = resultTbl()
        object$cars_meta <- table
        v$cars_reactive <- reactive({object})
    })
    
    
    
    
    output$cars_meta <- renderPrint({
        req (input$commit_meta > 0)
        isolate({v$cars_reactive()$cars_meta})
    })
}



# ------- APP ----------

nonmod2_app <- function(...) {
    app <- shiny::shinyApp(
        ui = shiny_ui,
        server = shiny_server
    )
    
    shiny::runApp(app, ...)
}

这里是模块化版本的代码。

#------- LIBRARIES ---------------------

library(dplyr)
library(tidyselect)
library(stringr)
library(purrr)
library(shinyjs)
library(DT)



# ------  UI MODULE ------------------

mod_ui <- function(id) {
    fluidPage(
        actionButton(NS(id,"new_data"), "Load Data"),
        br(),
        DT::dataTableOutput(NS(id, 'main_table')),
        br(),
        actionButton(NS(id, "commit_meta"), "Commit"),
        br(),
        verbatimTextOutput(NS(id, "cars_meta"))
    )
}


# -------- SERVER MODULE ---------------

mod_server <- function(id) {
    shiny::moduleServer(id, function(input, output,session){
        
        v <- reactiveValues()
        
        #place holders
        selectInputIDclass <- "class"
        selectInputIDusage <- "usage"
        
        observeEvent(input$new_data, once = TRUE, {
            
            
            cars_df <- mtcars
            
            #simulate creating meta table
            cars_meta <- dplyr::tibble(variable = names(cars_df), class = sapply(cars_df, class), usage = c("val1", "val2", "val3","val1", "val2", "val3","val1", "val2", "val3","val1", "val2"))
            cars_meta$class <- factor(cars_meta$class,  c("numeric", "character", "factor"))
            cars_meta$usage <- factor(cars_meta$usage,  c("val1", "val2", "val3"))
            
            #simulate creating the cars_object
            cars_object <- list()
            cars_object$cars_df <- cars_df
            cars_object$cars_meta <- cars_meta
            
            
            #make initTbl
            selectInputIDclass <<- paste0("sel_class", 1:nrow(cars_object$cars_meta))
            selectInputIDusage <<- paste0("sel_usage", 1:nrow(cars_object$cars_meta))
            
            v$initTbl <- dplyr::tibble(
                variable = cars_object$cars_meta$variable,
                class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor"),
                                                                                        selected = cars_object$cars_meta$class[which(selectInputIDclass == x)]))}),
                usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"),
                                                                                        selected = cars_object$cars_meta$usage[which(selectInputIDusage == x)]))})
            )
            
            
            v$cars_reactive <- reactive({
                cars_object
            })
        })
        
        
        displayTbl <- reactive({
            dplyr::tibble(
                variable = v$cars_reactive()$cars_meta$variable,
                class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor"), selected = input[[x]]))}),
                usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = x, label = "", choices = c("val1", "val2", "val3"), selected = input[[x]]))})
            )
        })
        
        
        resultTbl <- reactive({
            dplyr::tibble(
                variable = v$cars_reactive()$cars_meta$variable,
                class = sapply(selectInputIDclass, function(x){input[[x]]}),
                usage = sapply(selectInputIDusage, function(x){input[[x]]})
            )
        })
        
        
        output$main_table = DT::renderDataTable({
            req(isTruthy(input$new_data))
            DT::datatable(
                v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
                options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                               preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                               drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
                )
            )
        }, server = TRUE)
        
        
        main_table_proxy <- DT::dataTableProxy(outputId = "main_table", session = session)
        
        
        observeEvent({sapply(selectInputIDclass, function(x){input[[x]]})}, {
            replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
        }, ignoreInit = TRUE)
        
        
        observeEvent({sapply(selectInputIDusage, function(x){input[[x]]})}, {
            replaceData(proxy = main_table_proxy, data = displayTbl(), rownames = FALSE)
        }, ignoreInit = TRUE)
        
        
        observeEvent(input$commit_meta, {  
            object = v$cars_reactive()
            table = resultTbl()
            object$cars_meta <- table
            v$cars_reactive <- reactive({object})
        })
        
        
        
        
        output$cars_meta <- renderPrint({
            req (input$commit_meta > 0)
            isolate({v$cars_reactive()$cars_meta})
        })
    })
}



# ------- UI SERVER APP ----------

shiny_ui <- function() {
    
    fluidPage(
        mod_ui("data")
    )
    
}


shiny_server <- function(input, output, session) {
    
    sv <- mod_server("data")
    
}



mod2_app <- function(...) {
    app <- shiny::shinyApp(
        ui = shiny_ui,
        server = shiny_server
    )
    
    shiny::runApp(app, ...)
}

非常感谢您的帮助。

Answer 1

在你的新 mod_server 中试试这个，它对我有用。

  ns <- session$ns
  v$initTbl <- dplyr::tibble(
    variable = cars_object$cars_meta$variable,
    class = sapply(selectInputIDclass, function(x){as.character(selectInput(inputId = ns(x), label = "", choices = c("character","numeric", "factor"),
                                                                            selected = cars_object$cars_meta$class[which(selectInputIDclass == x)]))}),
    usage = sapply(selectInputIDusage, function(x){as.character(selectInput(inputId = ns(x), label = "", choices = c("val1", "val2", "val3"),
                                                                            selected = cars_object$cars_meta$usage[which(selectInputIDusage == x)]))})
  )

在模块化闪亮应用程序中捕获编辑数据 table 输出时出现问题

Problem capturing edited data table output in modularized shiny app

module

r

shiny

dt