Update data SelectInput in shiny modules - r

Question

I am facing an issue in updating the data selected using SelectInput and modules in Shiny. In a few words, when I select the data to be loaded into the selectInput panel, it updates it on the first selection, but if I then want to go from dataset 1 to dataset 2, the data does not update.
Below you cand find the code to reproduce the specific problem.
# Libraries
pacman::p_load(shiny, shinydashboard,
tidyverse, data.table, DT, stringr,
ggplot2, plotly,
survival, survminer, GGally, scales,
shinycssloaders)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(50, mean = 1))
men1_2.pois <<- as.numeric(rpois(50, lambda = 2))
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(data_selected)
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}
PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
x <- reactive(as.numeric(data))
output$plot <- renderPlot({
hist(x(), col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
# if(is.null(data)){return(NULL)}else{
# hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}
# server
server <- function(input, output, session){
data1 <- Panel("data1")
observeEvent(data1$data(), {
updateSelectInput(session, 'data.sel', selected = input$data.sel)
})
pnl1 <- reactive(
switch(data1$data(),
"Data 1" = "1",
"Data 2" = "2")
)
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = pnl1())
# Plot
# menu1
output$plot <- PlotServer("hist_norm1", data = d1$norm())
output$plot <- PlotServer("hist_pois1", data = d1$pois())
}
shinyApp(ui, server)
Thanks!

Answer 1

Try this
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 500
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
men1_1.norm <<- as.numeric(rnorm(50))
men1_1.pois <<- as.numeric(rpois(50, lambda = 1))
men1_2.norm <<- as.numeric(rnorm(150, mean = 1))
men1_2.pois <<- as.numeric(rpois(150, lambda = 2))
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1','Data 2')){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
tagList(
plotOutput(ns("plot"))
)
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu, data_selected
){
moduleServer(
id,
function(input, output, session){
dt <- reactive(
switch(data_selected(),
"Data 1" = "1",
"Data 2" = "2")
)
observe({print(dt())})
data <- reactiveValues(norm = NULL,
pois = NULL)
data$norm <- reactive({get(paste0(menu(),"_", dt(), ".norm"), envir = .GlobalEnv)})
data$pois <- reactive({get(paste0(menu(),"_", dt(), ".pois"), envir = .GlobalEnv)})
return(
data
)
}
)
}
PlotServer <- function(id,data){
moduleServer(
id,
function(input, output, session) {
#x <- reactive(as.numeric(data))
output$plot <- renderPlot({
x <- as.numeric(data())
hist(x, col = 'darkgray', border = 'white')
})
# output$plot <- renderPlot({
# if(is.null(data)){return(NULL)}else{
# hist(data, col = 'darkgray', border = 'white')}
# })
}
)
}
# server
server <- function(input, output, session){
data1 <- Panel("data1")
# observeEvent(data1$data(), {
# updateSelectInput(session, 'data.sel', selected = input$data.sel)
# })
# pnl1 <- reactive(
# switch(data1$data(),
# "Data 1" = "1",
# "Data 2" = "2")
# )
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}), data_selected = data1$data )
# Plot
# menu1
PlotServer("hist_norm1", data = reactive(d1$norm()) )
PlotServer("hist_pois1", data = reactive(d1$pois()) )
}
shinyApp(ui, server)

Answer 2

The problem arises because the data you pass to the PlotServer is not reactive. I've made the additional changes:
stored the data in the beginning in a list to avoid using get; it's easier and safer to directly work with a data object
removed the data_selected argument from the LoadDataServer as this information is determined by the input$data.sel variable, however this is only accessible from within the module and not the the main app server. For the initialisation, you need this information only in the UI part of the module (which you already have implemented). This allows me to remove observeEvent code in your main app server as this is handled by the module.
# Libraries
# pacman::p_load(shiny, shinydashboard,
# tidyverse, data.table, DT, stringr,
# ggplot2, plotly,
# survival, survminer, GGally, scales,
# shinycssloaders)
library(shiny)
library(shinydashboard)
library(ggplot2)
version <- 0.1
# GENERAL PARAMETERS
box.height <<- 700
select.box.height <<- 150
selectAB.box.height <<- 250
select.box.width <<- 12
# Data
data_object <- list(
men1_1 = list(
norm = as.numeric(rnorm(50)),
pois = as.numeric(rpois(50, lambda = 1))
),
men1_2 = list(
norm = as.numeric(rnorm(50, mean = 1)),
pois = as.numeric(rpois(50, lambda = 2))
)
)
# ui modules
LoadDataUI <- function(id,
label = "Select the data:",
sel = "Data 1",
choic = c('Data 1' = "1",'Data 2' = "2")){
ns <- NS(id)
selectInput(ns("data.sel"),
label = label,
choices = choic,
selected = sel)
}
PlotUI <- function(id){
ns <- NS(id)
plotOutput(ns("plot"))
}
# ui
ui <- dashboardPage(
dashboardHeader(title = paste('My Dashboard',version,sep='')),
dashboardSidebar(
sidebarMenu(
id = "sbMenu",
#Tabs for different data displays
menuItem("1st Menu", tabName = "men1", icon = icon('microscope'))
)
),
dashboardBody(
tabItems(
tabItem(tabName = 'men1',
h2(strong('tab 1')),
fluidRow(
### !!!! TO REMOVE ERROR MESSAGES !!!!
# tags$style(type="text/css",
# ".shiny-output-error { visibility: hidden; }",
# ".shiny-output-error:before { visibility: hidden; }"
#,
box(title='Select data to load:', height= select.box.height, width = select.box.width,
LoadDataUI("data1")
),
box(title='Normal', height=box.height,
PlotUI("hist_norm1")
),
box(title='Poisson', height=box.height,
PlotUI("hist_pois1")
)
)
)
)
)
)
# server modules
Panel <- function(id){
moduleServer(
id,
function(input, output, session) {
return(
list(
data = reactive({input$data.sel})
)
)
}
)
}
LoadDataServer <- function(id, menu
){
moduleServer(
id,
function(input, output, session){
data <- reactiveValues(norm = NULL,
pois = NULL)
observeEvent(input$data.sel, {
data$norm <- data_object[[paste0(menu(), "_", input$data.sel)]][["norm"]]
data$pois <- data_object[[paste0(menu(), "_", input$data.sel)]][["pois"]]
})
return(
data
)
}
)
}
PlotServer <- function(id,data = NULL){
moduleServer(
id,
function(input, output, session) {
output$plot <- renderPlot({
hist(data(), col = 'darkgray', border = 'white')
})
}
)
}
# server
server <- function(input, output, session){
d1 <- LoadDataServer("data1", menu = reactive({input$sbMenu}))
# Plot
# menu1
output$plot <- PlotServer("hist_norm1", data = reactive({d1$norm}))
output$plot <- PlotServer("hist_pois1", data = reactive({d1$pois}))
}
shinyApp(ui, server)
If you pass the complete d1 object to the PlotServer, you could remove the reactive({}) you currently need to pass the norm or pois data.
I recommend to read into how to pass data between modules and module capsulation, you can start with mastering shiny or my introduction to modules.