R shiny：在模块中插入UI和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
        )
    })
}

应用程序

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 object。

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的逻辑/UI

---

编辑

谢谢你的评论。 实际上，在模块中创建多个具有相同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)