We're currently implementing Shiny Modules to manage multiple filters within our Shiny App. Users can select a specific campus, specialty, or department and subsequent filters should adjust accordingly. However, we're encountering an issue where the observer in the specialty server doesn't update when the user selects another campus. I've included sample data and our code for reference. I would greatly appreciate any insights into where we might have made an error.
library(tidyverse)
library(shiny)
library(shinyWidgets)
library(shinydashboard)
data <- data.frame(
CAMPUS = c("Campus A", "Campus A", "Campus B", "Campus B", "Campus C"),
SPECIALTY = c("Cardiology", "Neurology", "Cardiology", "Orthopedics", "Oncology"),
DEPARTMENT = c("Cardiology Department", "Neurology Department", "Cardiology Department", "Orthopedics Department", "Oncology Department")
)
# Define UI for Campus
CampusInput <- function(id, data) {
campus_choices <- data %>%
select(CAMPUS) %>% distinct() %>% pull()
box(
title = "Select Campus:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id, "selectedCampus"),
label=NULL,
choices= campus_choices,
multiple=TRUE,
selected = campus_choices[1]))
}
# Define Server for Campus
CampusServer <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$selectedCampus
})
})
}
# Define UI for Specialty
SpecialtyInput <- function(id) {
box(
title = "Select Specialty:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id,"selectedSpecialty"),
label=NULL,
choices= NULL,
multiple=TRUE,
selected = NULL))
}
# Define Server for Specialty
SpecialtyServer <- function(id, data, campus) {
moduleServer(id, function(input, output, session) {
observeEvent(campus, {
if(!is.null(campus)) {
print(campus)
specailty_choices <- data %>% filter(CAMPUS %in% campus) %>%
select(SPECIALTY) %>% distinct() %>% pull()
updatePickerInput(session,
inputId = id,
choices = specailty_choices,
selected = specailty_choices)
}
})
})
}
# Define UI for Department
DepartmentInput <- function(id) {
box(
title = "Select Department:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id,"selectedDepartment"),
label=NULL,
choices= NULL,
multiple=TRUE,
selected = NULL))
}
# Define Server for Department
DepartmentServer <- function(id, data, campus, specialty) {
moduleServer(id, function(input, output, session) {
observeEvent(specialty, {
if(!is.null(specialty)) {
department_choices <- data %>% filter(CAMPUS %in% campus, CAMPUS_SPECIALTY %in% specialty ) %>%
select(DEPARTMENT) %>% distinct() %>% pull()
updatePickerInput(session,
inputId = id,
choices = department_choices,
selected = department_choices)
}
})
})
}
#Define UI for the app
ui <- fluidPage(
CampusInput("selectedCampus", data = data),
SpecialtyInput("selectedSpecialty"),
DepartmentInput("selectedDepartment"),
textOutput("result")
)
#Define Server for the app
server <- function(input, output, session) {
selected_campus <- CampusServer("selectedCampus")
selected_specialty <- SpecialtyServer("selectedSpecialty", data = data, campus = selected_campus())
selected_department <- DepartmentServer("selectedDepartment", data = data,
campus = selected_campus(), specialty = selected_specialty())
output$result <- renderText(selected_department())
}
shinyApp(ui, server)
We read Chapter 19 Shiny modules and stackoverflow and stackoverflow1. Despite our efforts, we haven't found an example that addresses our specific case.
When you pass the reactive functions to a module, send the function as selected_campus without () at the end. Then use campus() within the module. Here is the working code.
library(tidyverse)
library(shiny)
library(shinyWidgets)
library(shinydashboard)
data <- data.frame(
CAMPUS = c("Campus A", "Campus A", "Campus B", "Campus B", "Campus C"),
SPECIALTY = c("Cardiology", "Neurology", "Cardiology", "Orthopedics", "Oncology"),
DEPARTMENT = c("Cardiology Department", "Neurology Department", "Cardiology Department", "Orthopedics Department", "Oncology Department")
)
campus_choices <- data %>%
select(CAMPUS) %>% distinct() %>% pull()
# Define UI for Campus
CampusInput <- function(id, data) {
box(
title = "Select Campus:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id, "selectedCampus"),
label=NULL,
choices= campus_choices,
multiple=TRUE,
selected = campus_choices[1]))
}
# Define Server for Campus
CampusServer <- function(id) {
moduleServer(id, function(input, output, session) {
reactive({
input$selectedCampus
})
})
}
# Define UI for Specialty
SpecialtyInput <- function(id) {
box(
title = "Select Specialty:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id,"selectedSpecialty"),
label=NULL,
choices= NULL,
multiple=TRUE,
selected = NULL))
}
# Define Server for Specialty
SpecialtyServer <- function(id, data, campus) {
moduleServer(id, function(input, output, session) {
observeEvent(campus(), {
if(!is.null(campus())) {
print(campus())
specailty_choices <- data %>% dplyr::filter(CAMPUS %in% campus()) %>%
select(SPECIALTY) %>% distinct() %>% pull()
updatePickerInput(session,
inputId = id,
choices = specailty_choices,
selected = specailty_choices)
}
}, ignoreNULL = FALSE)
return(reactive(input[[paste0("selectedSpecialty")]]))
})
}
# Define UI for Department
DepartmentInput <- function(id) {
box(
title = "Select Department:",
width = 12,
height = "100px",
solidHeader = FALSE,
pickerInput(NS(id,"selectedDepartment"),
label=NULL,
choices= NULL,
multiple=TRUE,
selected = NULL))
}
# Define Server for Department
DepartmentServer <- function(id, data, campus, specialty) {
moduleServer(id, function(input, output, session) {
observeEvent(specialty(), {
# print(specialty())
if(!is.null(specialty())) {
department_choices <- data %>% dplyr::filter(CAMPUS %in% campus(), SPECIALTY %in% specialty() ) %>%
select(DEPARTMENT) %>% distinct() %>% pull()
# print(department_choices)
updatePickerInput(session,
inputId = id,
choices = department_choices,
selected = department_choices)
}
}, ignoreNULL = FALSE)
# observe({print(input$selectedDepartment )})
return(reactive(input[["selectedDepartment"]]))
})
}
#Define UI for the app
ui <- fluidPage(
CampusInput("selectedCampus", data = data),
SpecialtyInput("selectedSpecialty"),
DepartmentInput("selectedDepartment"),
textOutput("result")
)
#Define Server for the app
server <- function(input, output, session) {
selected_campus <- CampusServer("selectedCampus")
selected_specialty <- SpecialtyServer("selectedSpecialty", data = data, campus = selected_campus )
selected_department <- DepartmentServer("selectedDepartment", data = data,
campus = selected_campus, specialty = selected_specialty )
output$result <- renderText(selected_department())
}
shinyApp(ui, server)