访问闪亮模块内 DT selectInput 的值

Question

我正在开发一个闪亮的应用程序，其中包含各种面板，每个面板都分为自己的模块。其中之一在各个单元格上使用带有

selectInput

的 DataTable，我需要在同一模块内访问其值。在下面的示例中，我只是尝试用

output$mySelectOutput

显示所选值。

我确信我遗漏了一些关于

ns

的内容。我尝试将其添加到

inputId

内的

selectInput

之前，但这还不够。

编辑：我仍然没有解决问题，但我发现有两件事会导致应用程序无法按预期工作。

• 我忘记为数据表添加

  preDrawCallback

  和

  drawCallback

  选项
• 使用

  as.character(selectInput(...))

  并不像我想象的那样工作，并且从我所看到的情况来看，不可能检索以这种方式生成的

  selectInput

  的 id。所以我决定回滚到我的自制生成器（称为

  mySelectInput

  ），我尝试将

  ns()

合并到其中

这是可重现的示例：

### Libraries

library(shiny)            # used to create the Shiny App
library(bslib)            # used to create the framework of the Shiny App
library(DT)               # used for creating interactive DataTable


# Create levels to choose from in the Select Input
factorOptions <- function(factor_levels) {
  optionList <- ""
  for (i in factor_levels) {optionList <- paste0(optionList, '<option value="', i, '">', i, '</option>\n')}
  return(optionList)
}

# Create the Select Input with ID and corresponding entry from the datatable
mySelectInput <- function(id_list, selected_factors, factor_levels) {
  select_input <- paste0('<select id="ns(single_select_', id_list, ')"style="width: 100%;">\n', 
                         sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors), 
                         factorOptions(factor_levels), '</select>')
  return(select_input)
}


### Server

dummy_serverModule <- function(id) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    dummy_data <- datatable(
      data = tibble(select_test = mySelectInput(1, 1, 1:4)),
      selection = 'none', escape = FALSE, rownames = FALSE,
      options = list(
        keys = TRUE,
        preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
        drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
      )
    )
    
    output$dummyDT <- renderDT({dummy_data})
    output$mySelectOutput <- renderText({input$single_select_1})
  })
}

server <- function(input, output, session) {
  dummy_serverModule(id = "dummyId")
  
  session$onSessionEnded(function() {
    stopApp()
  })
}


### UI

dummy_uiModule <- function(id) {
  ns <- NS(id)
  
  page_fluid(
    card_body(DTOutput(ns("dummyDT"))),
    card(verbatimTextOutput(ns("mySelectOutput")))
  )
}

ui <- page_navbar(
  nav_panel(
    title = "Dashboard",
    dummy_uiModule(id = "dummyId")
  )
)


### App

shinyApp(ui, server)

Answer 1

好吧，我实际上有正确的想法，但执行错误。由于

ns()

充当函数，在输入/输出ID之前添加模块ID，因此将其放入生成

selectInput

的字符串中，因为字符串没有执行任何操作。

但是，由于

ns

基本上是模块 ID 和输入/输出 ID 的

paste0

，我可以通过在

mySelectInput

中添加 id_module 参数并进行编辑来复制它，如下所示：

mySelectInput <- function(id_module, id_list, selected_factors, factor_levels) {
  select_input <- paste0('<select id="', id_module, '-single_select_', id_list, '"style="width: 100%;">\n', 
                         sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors), 
                         factorOptions(factor_levels), '</select>')
  return(select_input)
}

这样，DataTable 中生成的每个

selectInput

都会链接到模块，并且可以正确提取它们的值。

这是完整的更正代码：

### Libraries

library(shiny)            # used to create the Shiny App
library(bslib)            # used to create the framework of the Shiny App
library(DT)               # used for creating interactive DataTable


# Create levels to choose from in the Select Input
factorOptions <- function(factor_levels) {
  optionList <- ""
  for (i in factor_levels) {optionList <- paste0(optionList, '<option value="', i, '">', i, '</option>\n')}
  return(optionList)
}

# Create the Select Input with ID and corresponding entry from the datatable
mySelectInput <- function(id_module, id_list, selected_factors, factor_levels) {
  select_input <- paste0('<select id="', id_module, '-single_select_', id_list, '"style="width: 100%;">\n', 
                         sprintf('<option value="%s" selected>%s</option>\n', selected_factors, selected_factors), 
                         factorOptions(factor_levels), '</select>')
  return(select_input)
}


### Server

dummy_serverModule <- function(id) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    dummy_data <- datatable(
      data = tibble(select_test = mySelectInput(id, 1, 1, 1:4)),
      selection = 'none', escape = FALSE, rownames = FALSE,
      options = list(
        keys = TRUE,
        preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
        drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
      )
    )
    
    output$dummyDT <- renderDT({dummy_data})
    output$mySelectOutput <- renderText({input$single_select_1})
  })
}

server <- function(input, output, session) {
  dummy_serverModule(id = "dummyId")
  
  session$onSessionEnded(function() {
    stopApp()
  })
}


### UI

dummy_uiModule <- function(id) {
  ns <- NS(id)
  
  page_fluid(
    card_body(DTOutput(ns("dummyDT"))),
    card(verbatimTextOutput(ns("mySelectOutput")))
  )
}

ui <- page_navbar(
  nav_panel(
    title = "Dashboard",
    dummy_uiModule(id = "dummyId")
  )
)


### App

shinyApp(ui, server)