R shiny: insertUI and observeEvent in module

问题

Using the diamonds dataset as an example, after a button is pressed, two pickerInput should appear. In the first one, the user chooses between three columns of the diamonds dataset. Once a value is selected the app should update the choices of the second pickertInput based on the unique values of the selected column.

The app works well without modularizing it. After reading couple of discussions about modules, I still don't clearly understand how to properly declare reactive values for accessing the different input$....

MODULE

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)

EDIT User should be able to click the button more than once in order to create several pickerInput pairs.

EDIT #2 Based on @starja code, trying to return the values of the 2 pickers leads to a 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)

EDIT #3 Still having difficulties to return the values of the 2 pickers in a list that would be convenient to access further (example below):

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"

回答1:

Your code has 2 issues:

if you insert UI elements in a module via insertUI, the ids of the UI elements need to have the correct namespace: ns(id)
because the id you use in the selector of insertUI was created in the module, it is also namespaced, so the selector argument also has to be namespaced

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)

BTW: I feel that a more natural way to modularise your code would be that the Add button is in the main app and then dynamically inserts an instance of your module, so that your module only contains the logic/UI for one combination picker_variable/picker_value

Edit

Thanks for your remark. In fact, it doesn't make much sense to create several pickerInput in the module with the same inputId. I've changed my code to reflect the pattern that the actionButton is in the main app and every module only contains one set of inputs:

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)

Edit 2

You can directly return the input from the module and use this in a reactive context in the main app:

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)

来源：https://stackoverflow.com/questions/63060605/r-shiny-insertui-and-observeevent-in-module

标签

Shiny