R闪亮：模块中的insertUI和observeEvent

Question

以diamonds数据集为例，按下一个按钮后，应该会出现两个pickerInput。 在第一个中，用户在diamonds 数据集的三列之间进行选择。选择值后，应用应根据所选列的唯一值更新第二个 pickertInput 的选择。

该应用程序在没有模块化的情况下运行良好。在阅读了一些关于模块的讨论之后，我仍然不清楚如何正确声明响应值以访问不同的input$...。

模块

module.UI <- function(id){
    ns <- NS(id)
    
    actionButton(inputId = ns("add"), label = "Add")
}

module <- function(input, output, session, data, variables){
    ns <- session$ns
    
    observeEvent(input$add, {
        insertUI(
            selector = "#add",
            where = "beforeBegin",
            ui = fluidRow(
                pickerInput(inputId = "picker_variable",
                            choices = variables,
                            selected = NULL
                ),
                pickerInput(inputId = "picker_value",
                            choices = NULL,
                            selected = NULL
                )
            )
        )
    })
    
    observeEvent(input$picker_variable,{
        updatePickerInput(session,
                          inputId = "picker_value",
                          choices = as.character(unlist(unique(data[, input$picker_variable]))),
                          selected = NULL
        )
    })
}

APP

ui <- fluidPage(
    mainPanel(
        module.UI(id = "myID")
    )
)

server <- function(input, output, session) {
    callModule(module = module, id = "myID", data = diamonds, variables=c("cut", "color", "clarity"))
}

shinyApp(ui = ui, server = server)

编辑 用户应该能够多次单击该按钮以创建多个 pickerInput 对。

编辑#2 根据@starja 代码，尝试返回 2 个选择器的值会导致 NULL 对象。

library(shiny)
library(shinyWidgets)
library(ggplot2)

module.UI <- function(id, variables){
  ns <- NS(id)
  
  ui = fluidRow(
    pickerInput(inputId = ns("picker_variable"),
                choices = variables,
                selected = NULL
    ),
    pickerInput(inputId = ns("picker_value"),
                choices = NULL,
                selected = NULL
    )
  )
}

module <- function(input, output, session, data, variables){
  module_out <- reactiveValues(variable=NULL, values=NULL)

  observeEvent(input$picker_variable,{
    updatePickerInput(session,
                      inputId = "picker_value",
                      choices = as.character(unlist(unique(data[, input$picker_variable]))),
                      selected = NULL
    )
  })
  
  observe({
    module_out$variable <- input$picker_variable
    module_out$values <- input$picker_value
  })

  return(module_out)
}

ui <- fluidPage(
  mainPanel(
    actionButton(inputId = "add",
                 label = "Add"),
    tags$div(id = "add_UI_here")
  )
)

list_modules <- list()
current_id <- 1

server <- function(input, output, session) {
  
  observeEvent(input$add, {
    
    new_id <- paste0("module_", current_id)
    
    list_modules[[new_id]] <<-
      callModule(module = module, id = new_id,
                 data = diamonds, variables = c("cut", "color", "clarity"))
    
    insertUI(selector = "#add_UI_here",
             ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
    
    current_id <<- current_id + 1
    
  })

  req(input$list_modules)
  print(list_modules)
  
}

shinyApp(ui = ui, server = server)

编辑#3 仍然难以返回列表中便于进一步访问的 2 个选择器的值（示例如下）：

module_out
$module_1
$module_1$variable
[1] "cut"

$module_1$values
[1] "Ideal"   "Good"

$module_2
$module_2$variable
[1] "color"

$module_2$values
[1] "E"   "J"

Answer 1

您的代码有 2 个问题：

• 如果你通过insertUI在模块中插入UI元素，UI元素的ID需要有正确的命名空间：ns(id)
• 因为你在insertUI的selector中使用的id是在模块中创建的，它也是命名空间的，所以selector参数也必须是命名空间的

library(shiny)
library(shinyWidgets)
library(ggplot2)

module.UI <- function(id){
  ns <- NS(id)
  
  actionButton(inputId = ns("add"), label = "Add")
}

module <- function(input, output, session, data, variables){
  ns <- session$ns
  
  observeEvent(input$add, {
    insertUI(
      selector = paste0("#", ns("add")),
      where = "beforeBegin",
      ui = fluidRow(
        pickerInput(inputId = ns("picker_variable"),
                    choices = variables,
                    selected = NULL
        ),
        pickerInput(inputId = ns("picker_value"),
                    choices = NULL,
                    selected = NULL
        )
      )
    )
  })
  
  observeEvent(input$picker_variable,{
    updatePickerInput(session,
                      inputId = "picker_value",
                      choices = as.character(unlist(unique(data[, input$picker_variable]))),
                      selected = NULL
    )
  })
}

ui <- fluidPage(
  mainPanel(
    module.UI(id = "myID")
  )
)

server <- function(input, output, session) {
  callModule(module = module, id = "myID", data = diamonds, variables=c("cut", "color", "clarity"))
}

shinyApp(ui = ui, server = server)

顺便说一句：我觉得将代码模块化的更自然的方法是 Add 按钮位于主应用程序中，然后动态插入模块的实例，以便您的模块仅包含用于一种组合picker_variable/picker_value

---

编辑

感谢您的评论。实际上，在模块中创建多个pickerInput 具有相同的inputId 并没有多大意义。我已更改代码以反映 actionButton 在主应用程序中的模式，并且每个模块仅包含一组输入：

library(shiny)
library(shinyWidgets)
library(ggplot2)

module.UI <- function(id, variables){
  ns <- NS(id)
  
  ui = fluidRow(
    pickerInput(inputId = ns("picker_variable"),
                choices = variables,
                selected = NULL
    ),
    pickerInput(inputId = ns("picker_value"),
                choices = NULL,
                selected = NULL
    )
  )
}

module <- function(input, output, session, data, variables){
  
  observeEvent(input$picker_variable,{
    updatePickerInput(session,
                      inputId = "picker_value",
                      choices = as.character(unlist(unique(data[, input$picker_variable]))),
                      selected = NULL
    )
  })
}

ui <- fluidPage(
  mainPanel(
    actionButton(inputId = "add",
                 label = "Add"),
    tags$div(id = "add_UI_here")
  )
)

list_modules <- list()
current_id <- 1

server <- function(input, output, session) {
  
  observeEvent(input$add, {
    
    new_id <- paste0("module_", current_id)
    
    list_modules[[new_id]] <<-
      callModule(module = module, id = new_id,
                 data = diamonds, variables = c("cut", "color", "clarity"))
    
    insertUI(selector = "#add_UI_here",
             ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
    
    current_id <<- current_id + 1
    
  })
  
}

shinyApp(ui = ui, server = server)

编辑 2

您可以直接从模块中返回 input 并在主应用程序的反应式上下文中使用它：

library(shiny)
library(shinyWidgets)
library(ggplot2)

module.UI <- function(id, variables){
  ns <- NS(id)
  
  ui = fluidRow(
    pickerInput(inputId = ns("picker_variable"),
                choices = variables,
                selected = NULL
    ),
    pickerInput(inputId = ns("picker_value"),
                choices = NULL,
                selected = NULL
    )
  )
}

module <- function(input, output, session, data, variables){
  
  observeEvent(input$picker_variable,{
    updatePickerInput(session,
                      inputId = "picker_value",
                      choices = as.character(unlist(unique(data[, input$picker_variable]))),
                      selected = NULL
    )
  })
  
  return(input)
}

ui <- fluidPage(
  mainPanel(
    actionButton(inputId = "print", label = "print inputs"),
    actionButton(inputId = "add",
                 label = "Add"),
    tags$div(id = "add_UI_here")
  )
)

list_modules <- list()
current_id <- 1

server <- function(input, output, session) {
  
  observeEvent(input$add, {
    
    new_id <- paste0("module_", current_id)
    
    list_modules[[new_id]] <<-
      callModule(module = module, id = new_id,
                 data = diamonds, variables = c("cut", "color", "clarity"))
    
    insertUI(selector = "#add_UI_here",
             ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
    
    current_id <<- current_id + 1
    
  })
  
  observeEvent(input$print, {
    lapply(seq_len(length(list_modules)), function(i) {
      print(names(list_modules)[i])
      print(list_modules[[i]]$picker_variable)
      print(list_modules[[i]]$picker_value)
    })
  })
  
  
  
}

shinyApp(ui = ui, server = server)