Using Shiny's updateSelectInput within nested modules - r

Question

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
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.

Answer 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.