Using Shiny's updateSelectInput within nested modules

问题

Background

The application is of the following structure:

.
├── R
│   ├── mod_observationSelector.R
│   ├── mod_previewTable.R
│   └── mod_summaryTable.R
└── app.R

With the files fulling the respective functions:

• mod_observationSelector.R - provides an updateSelectInput mechanism facilitating selction of integere or real columns in mtcars data
• mod_previewTable.R - generates head for selected column
• mod_summaryTable.R - generates summary for selected column

Design assumptions

• mod_observationSelector.R linked interface elements available in this module should be usable across remaining modules providing a selection mechanism

Problem

After nesting, the drop-down selection does no longer update.

Working version

Prior to nesting.

mod_observationSelector.R

observationSelectorUI <- function(id) {
    ns <- NS(id)
    fluidPage(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = character(0)
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })
                 })
}

app.R

library("shiny")
library("tidyverse")


 ui <- fluidPage(


     titlePanel("Nested Modules"),
     observationSelectorUI("colChooser")
 )

 # Define server logic required to draw a histogram
 server <- function(input, output) {
     observationSelectorServer("colChooser")
 }

 # Run the application
 shinyApp(ui = ui, server = server)

Broken version

Problems

1. Previously working updateSelect is now broken

app.R

library("shiny")
library("tidyverse")


ui <- fluidPage(titlePanel("Nested Modules"),
                tabsetPanel(summaryUI("modSummary"),
                            previewUI("modPreview")
                            ))

# Define server logic required to draw a histogram
server <- function(input, output) {
    summaryServer("modSummary")
    previewServer("modPreview")
}

# Run the application
shinyApp(ui = ui, server = server)

mod_observationSelector.R

In effect, no change.

observationSelectorUI <- function(id) {
    ns <- NS(id)
    fluidPage(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = character(0)
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })
                 })
}

mod_summaryTable.R

summaryUI <- function(id) {
    ns <- NS(id)
    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('summaryTable'))))
}

summaryServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {
                     output$summaryTable <-
                         renderTable(summary(mtcars[, input$selectColumn]))
                 })
}

mod_previewTable

previewUI <-     function(id) {
    ns <- NS(id)
    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('headTable'))))
}

previewServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {
                     output$headTable <-
                         renderTable(head(mtcars[, input$selectColumn]))
                 })
}

Desired outcomes

• Drop-down selection updates across the modules
• Results from the in-module drop-down selection can be used in "outer" module to produce summaries, etc.

---

For convenience, the code is also available on GitHub: konradzdeb/nestedModule.

回答1:

For posterity, the solution is as follows

mod_observationSelector.R

Reactive element is returned.

observationSelectorUI <- function(id) {
    ns <- NS(id)

    tagList(
        selectInput(
            inputId = ns("varTypes"),
            label = h3("Variable types"),
            choices = list("Integer" = TRUE,
                           "Real" = FALSE),
            selectize = FALSE,
            multiple = FALSE
        ),

        selectInput(
            inputId = ns("selectColumn"),
            label = h4("Selected Column"),
            choices = c("cyl", "hp", "vs", "am", "gear", "carb")
        )
    )
}

observationSelectorServer <- function(id, data) {
    moduleServer(id,
                 function(input, output, session) {
                     observeEvent(eventExpr = input$varTypes,
                                  handlerExpr = {
                                      all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
                                      selected_cols <-
                                          names(all_cols[all_cols == input$varTypes])
                                      updateSelectInput(
                                          session = session,
                                          inputId = "selectColumn",
                                          label = paste(
                                              "Selected",
                                              ifelse(input$varTypes, "integer", "real"),
                                              "columns"
                                          ),
                                          choices = selected_cols
                                      )
                                  })

                     # Return the selection result
                     return(reactive({
                         validate(need(input$selectColumn, FALSE))
                         input$selectColumn
                     }))
                 })
}

Using module inputs

As with any other reactive, I'm bringing the results from the nested module and then call them innerResult().

previewUI <-     function(id) {

    ns <- NS(id)

    tabPanel("Summary table",
             column(4, observationSelectorUI(ns("colChooser"))),
             column(8, tableOutput(ns('headTable'))))
}

previewServer <- function(id) {
    moduleServer(id,
                 function(input, output, session) {

                     innerResult <- observationSelectorServer("colChooser")

                     output$headTable <- renderTable(head(mtcars[, innerResult()]))
                 })
}

Full app

Available on GitHub: b25758b.

来源：https://stackoverflow.com/questions/62648298/using-shinys-updateselectinput-within-nested-modules