I have the shiny app below which works with the following logic:
1.When the app is first loaded, the widgets should have no selections, and the action buttons should be disabled.
2.When a district is selected, update the school choices.
3.Enable the "Preview" action button when at least one school is selected.
4.Enable the "Download" action button only after "Preview" is clicked.
5.If all selections are cleared, both action buttons should be disabled again.
These all work but the table should be subsetted only after the user will click the Preview button.
You will see that each time I select or deselect on choice from schools the table seems to be affected but is should stay stable.
Then if I click Preview it is actually subsetted.
Also when I deselect all school values or district values the table is empty while it should wait for Preview to be clicked first.
If I then add a choice to schools the table is displayed but not subseted until I click Preview.
library(renv)
library(dplyr)
library(shiny)
library(shinyWidgets)
library(DT)
library(tidyr)
early<-structure(list(temp_record_id = c("3_8", "3_14", "3_20", "3_35",
"3_45", "3_49", "3_59", "3_67", "3_72", "3_79"), district_number = c("0001",
"0001", "0001", "0014", "0038", "0110", "0113", "0196", "0200",
"0273"), district_type = c("33", "33", "33", "31", "31", "31",
"31", "31", "31", "31"), school_number = c("012", "015", "036",
"006", "001", "001", "100", "007", "002", "007"), grade = c("03",
"03", "03", "03", "03", "03", "03", "03", "03", "03"), subject = c("Reading",
"Reading", "Reading", "Reading", "Reading", "Reading", "Reading",
"Reading", "Reading", "Reading"), group_category = c("All Categories",
"All Categories", "All Categories", "All Categories", "All Categories",
"All Categories", "All Categories", "All Categories", "All Categories",
"All Categories"), student_group = c("All Students", "All Students",
"All Students", "All Students", "All Students", "All Students",
"All Students", "All Students", "All Students", "All Students"
), school_year = c(2015, 2015, 2015, 2015, 2015, 2015, 2015,
2015, 2015, 2015), denominator = c(40, 31, 21, 21, 12, 18, NA,
22, 14, 80), numerator = c(17, 12, 9, 10, 4, 13, NA, 19, 11,
68), school_name = c("Ascension Catholic School", "Risen Christ",
"St. Helena Catholic School", "Al-Amal School", "St. Mary's Mission",
"St. Joseph", "Immanuel Lutheran School", "St. Joseph's Catholic",
"St. John The Baptist", "Our Lady Of Grace"), district_name = c("Nonpublic School",
"Nonpublic School", "Nonpublic School", "Nonpublic School", "Nonpublic School",
"Nonpublic School", "Nonpublic School", "Nonpublic School", "Nonpublic School",
"Nonpublic School"), county_name = c("Hennepin", "Hennepin",
"Hennepin", "Anoka", "Beltrami", "Carver", "Cass", "Dakota",
"Dakota", "Hennepin"), school_classification = c("00", "00",
"00", "40", "00", "00", "00", "00", "00", "00"), school_name_unique = c("Ascension Catholic School 0001-33-012",
"Risen Christ 0001-33-015", "St. Helena Catholic School 0001-33-036",
"Al-Amal School 0014-31-006", "St. Mary's Mission 0038-31-001",
"St. Joseph 0110-31-001", "Immanuel Lutheran School 0113-31-100",
"St. Joseph's Catholic 0196-31-007", "St. John The Baptist 0200-31-002",
"Our Lady Of Grace 0273-31-007"), id = c("0001-33-012", "0001-33-015",
"0001-33-036", "0014-31-006", "0038-31-001", "0110-31-001", "0113-31-100",
"0196-31-007", "0200-31-002", "0273-31-007")), row.names = c(NA,
-10L), class = c("tbl_df", "tbl", "data.frame"))
all_districts <- unique(sort(early$district_name))
all_schools <- unique(sort(early$school_name_unique))
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("CIA Data Prep"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
h2("Select Schools to Include"),
shinyWidgets::pickerInput(inputId = "districts",
label = "Districts:",
choices = all_districts,
options = list(`actions-box` = TRUE),
multiple = TRUE),
shinyWidgets::pickerInput(inputId = "schools",
label = "Schools:",
choices = "",
options = list(`actions-box` = TRUE),
selected = "",
multiple = TRUE),
shiny::actionButton(inputId = "runButton", label = "Preview", disabled = TRUE),
shiny::actionButton(inputId = "downButton", label = "Download", disabled = TRUE)),
# Show a plot of the generated distribution
mainPanel(
fluidRow(
column(6,uiOutput("ear"))
),
fluidRow(
column(12,dataTableOutput("early_reading")#,
)
)
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observeEvent(input$districts, {
if (!is.null(input$districts) && length(input$districts) > 0) {
shinyWidgets::updatePickerInput(
session = session,
inputId = "schools",
choices = early %>% dplyr::arrange(district_name, school_name_unique) %>% dplyr::filter(district_name %in% input$districts) %>% dplyr::select(school_name_unique) %>% unique() %>% pull()
)
} else {
shinyWidgets::updatePickerInput(
session = session,
inputId = "schools",
choices = "",
options = list(`actions-box` = TRUE),
selected = ""
)
updateActionButton(session, "runButton", disabled = TRUE)
updateActionButton(session, "downButton", disabled = TRUE)
}
}, ignoreNULL = FALSE)
observeEvent(input$schools, {
if (!is.null(input$schools) &&
length(input$schools) > 0 && any(input$schools != "")) {
updateActionButton(inputId = "runButton",
disabled = FALSE)
} else {
updateActionButton(inputId = "runButton",
disabled = TRUE)
updateActionButton(inputId = "downButton",
disabled = TRUE)
}
}, ignoreNULL = FALSE)
observeEvent(input$runButton, {
if (input$runButton > 0) {
updateActionButton(inputId = "downButton",
disabled = FALSE)
}
})
# Store filtered data in a reactiveVal
filtered_data <- reactiveVal(early)
observeEvent(input$runButton, {
filtered_data(
early %>%
dplyr::filter(district_name %in% input$districts,
school_name_unique %in% input$schools)
)
})
early_reading<-reactive({
req(input$runButton)
# Create Population and Gender combinations
all_groups <-filtered_data() %>%
select(student_group) %>%
distinct() %>%
mutate(Gender = "All") %>%
bind_rows(
filtered_data() %>% select(student_group) %>% distinct() %>% mutate(Gender = "Female"),
filtered_data() %>% select(student_group) %>% distinct() %>% mutate(Gender = "Male")
) %>%
rename(Population = student_group)
# Summarize numerator and denominator by id, Population and Gender
summary_data <- filtered_data() %>%
mutate(Gender = case_when(
student_group == "Male Students" ~ "Male",
student_group == "Female Students" ~ "Female",
TRUE ~ "All"
)) %>%
rename(Population = student_group) %>%
group_by(id, Population, Gender, school_year) %>%
summarise(numerator = sum(numerator, na.rm = TRUE),
denominator = sum(denominator, na.rm = TRUE)) %>%
ungroup()
# Merge all_groups with summary_data
combined_data <- all_groups %>%
left_join(summary_data, by = c("Population", "Gender")) %>%
pivot_longer(cols = c(numerator, denominator), names_to = "measure_type", values_to = "value") %>%
unite("year_measure", c("measure_type", "school_year"), sep = "_") %>%
pivot_wider(names_from = year_measure, values_from = value, values_fill = list(value = 0))
# Sum the values based on Gender and Population
summarized_data <- combined_data %>%
group_by(Gender, Population) %>%
summarise(across(starts_with("numerator_"), sum, na.rm = TRUE),
across(starts_with("denominator_"), sum, na.rm = TRUE)) %>%
ungroup()
# Remove columns with _NA suffix
summarized_data <- summarized_data %>%
select(-ends_with("_NA"))
# Reorder columns to have numerator and denominator sequentially
year_columns <- summarized_data %>%
select(starts_with("numerator_"), starts_with("denominator_")) %>%
names() %>%
sort()
# Split the columns into numerator and denominator columns
numerator_columns <- grep("^numerator_", year_columns, value = TRUE)
denominator_columns <- grep("^denominator_", year_columns, value = TRUE)
# Interleave numerator and denominator columns
interleaved_columns <- c(rbind(numerator_columns, denominator_columns))
# Add Outcome column and rearrange
final_data <- summarized_data %>%
mutate(Outcome = "Early Grade Reading") %>%
select(Outcome, Gender, Population, all_of(interleaved_columns))
})
output$early_reading <- renderDataTable({
if (is.null(input$schools) ||
any(input$schools == "") || input$runButton == 0) {
return()
}
else{
datatable(early_reading(),
options = list(
pageLength = 5,
scrollX = TRUE
))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is a solution where the table data is an eventReactive depending on input$runButton. Using this the table is only updated if the button is clicked, not if you toggle between choices.
library(renv)
library(dplyr)
library(shiny)
library(shinyWidgets)
library(DT)
library(tidyr)
early <-
structure(
list(
temp_record_id = c(
"3_8",
"3_14",
"3_20",
"3_35",
"3_45",
"3_49",
"3_59",
"3_67",
"3_72",
"3_79"
),
district_number = c(
"0001",
"0001",
"0001",
"0014",
"0038",
"0110",
"0113",
"0196",
"0200",
"0273"
),
district_type = c("33", "33", "33", "31", "31", "31",
"31", "31", "31", "31"),
school_number = c(
"012",
"015",
"036",
"006",
"001",
"001",
"100",
"007",
"002",
"007"
),
grade = c("03",
"03", "03", "03", "03", "03", "03", "03", "03", "03"),
subject = c(
"Reading",
"Reading",
"Reading",
"Reading",
"Reading",
"Reading",
"Reading",
"Reading",
"Reading",
"Reading"
),
group_category = c(
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories",
"All Categories"
),
student_group = c(
"All Students",
"All Students",
"All Students",
"All Students",
"All Students",
"All Students",
"All Students",
"All Students",
"All Students",
"All Students"
),
school_year = c(2015, 2015, 2015, 2015, 2015, 2015, 2015,
2015, 2015, 2015),
denominator = c(40, 31, 21, 21, 12, 18, NA,
22, 14, 80),
numerator = c(17, 12, 9, 10, 4, 13, NA, 19, 11,
68),
school_name = c(
"Ascension Catholic School",
"Risen Christ",
"St. Helena Catholic School",
"Al-Amal School",
"St. Mary's Mission",
"St. Joseph",
"Immanuel Lutheran School",
"St. Joseph's Catholic",
"St. John The Baptist",
"Our Lady Of Grace"
),
district_name = c(
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School",
"Nonpublic School"
),
county_name = c(
"Hennepin",
"Hennepin",
"Hennepin",
"Anoka",
"Beltrami",
"Carver",
"Cass",
"Dakota",
"Dakota",
"Hennepin"
),
school_classification = c("00", "00",
"00", "40", "00", "00", "00", "00", "00", "00"),
school_name_unique = c(
"Ascension Catholic School 0001-33-012",
"Risen Christ 0001-33-015",
"St. Helena Catholic School 0001-33-036",
"Al-Amal School 0014-31-006",
"St. Mary's Mission 0038-31-001",
"St. Joseph 0110-31-001",
"Immanuel Lutheran School 0113-31-100",
"St. Joseph's Catholic 0196-31-007",
"St. John The Baptist 0200-31-002",
"Our Lady Of Grace 0273-31-007"
),
id = c(
"0001-33-012",
"0001-33-015",
"0001-33-036",
"0014-31-006",
"0038-31-001",
"0110-31-001",
"0113-31-100",
"0196-31-007",
"0200-31-002",
"0273-31-007"
)
),
row.names = c(NA,
-10L),
class = c("tbl_df", "tbl", "data.frame")
)
all_districts <- unique(sort(early$district_name))
all_schools <- unique(sort(early$school_name_unique))
# Define UI for application that draws a histogram
ui <- fluidPage(# Application title
titlePanel("CIA Data Prep"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
h2("Select Schools to Include"),
shinyWidgets::pickerInput(
inputId = "districts",
label = "Districts:",
choices = all_districts,
options = list(`actions-box` = TRUE),
multiple = TRUE
),
shinyWidgets::pickerInput(
inputId = "schools",
label = "Schools:",
choices = "",
options = list(`actions-box` = TRUE),
selected = "",
multiple = TRUE
),
shiny::actionButton(
inputId = "runButton",
label = "Preview",
disabled = TRUE
),
shiny::actionButton(
inputId = "downButton",
label = "Download",
disabled = TRUE
)
),
# Show a plot of the generated distribution
mainPanel(fluidRow(column(6, uiOutput(
"ear"
))),
fluidRow(column(
12, dataTableOutput("early_reading")#,
)))
))
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observeEvent(input$districts, {
if (!is.null(input$districts) && length(input$districts) > 0) {
shinyWidgets::updatePickerInput(
session = session,
inputId = "schools",
choices = early %>% dplyr::arrange(district_name, school_name_unique) %>% dplyr::filter(district_name %in% input$districts) %>% dplyr::select(school_name_unique) %>% unique() %>% pull()
)
} else {
shinyWidgets::updatePickerInput(
session = session,
inputId = "schools",
choices = "",
options = list(`actions-box` = TRUE),
selected = ""
)
}
}, ignoreNULL = FALSE)
observeEvent(input$schools, {
if ((is.null(input$schools) && !is.null(early_reading())) ||
(length(input$schools) > 0 && any(input$schools != ""))) {
updateActionButton(inputId = "runButton",
disabled = FALSE)
}
}, ignoreNULL = FALSE)
observeEvent(input$runButton, {
if (input$runButton > 0) {
updateActionButton(inputId = "downButton",
disabled = FALSE)
}
})
# Store filtered data in a reactiveVal
filtered_data <- reactiveVal(early)
observeEvent(input$runButton, {
filtered_data(
early %>%
dplyr::filter(
district_name %in% input$districts,
school_name_unique %in% input$schools
)
)
})
early_reading <- eventReactive(input$runButton, {
if (is.null(input$schools) || any(input$schools == "")) {
updateActionButton(inputId = "runButton",
disabled = TRUE)
updateActionButton(inputId = "downButton",
disabled = TRUE)
return()
}
# Create Population and Gender combinations
all_groups <- filtered_data() %>%
select(student_group) %>%
distinct() %>%
mutate(Gender = "All") %>%
bind_rows(
filtered_data() %>% select(student_group) %>% distinct() %>% mutate(Gender = "Female"),
filtered_data() %>% select(student_group) %>% distinct() %>% mutate(Gender = "Male")
) %>%
rename(Population = student_group)
# Summarize numerator and denominator by id, Population and Gender
summary_data <- filtered_data() %>%
mutate(
Gender = case_when(
student_group == "Male Students" ~ "Male",
student_group == "Female Students" ~ "Female",
TRUE ~ "All"
)
) %>%
rename(Population = student_group) %>%
group_by(id, Population, Gender, school_year) %>%
summarise(
numerator = sum(numerator, na.rm = TRUE),
denominator = sum(denominator, na.rm = TRUE)
) %>%
ungroup()
# Merge all_groups with summary_data
combined_data <- all_groups %>%
left_join(summary_data, by = c("Population", "Gender")) %>%
pivot_longer(
cols = c(numerator, denominator),
names_to = "measure_type",
values_to = "value"
) %>%
unite("year_measure", c("measure_type", "school_year"), sep = "_") %>%
pivot_wider(
names_from = year_measure,
values_from = value,
values_fill = list(value = 0)
)
# Sum the values based on Gender and Population
summarized_data <- combined_data %>%
group_by(Gender, Population) %>%
summarise(across(starts_with("numerator_"), \(x) sum(x, na.rm = TRUE)),
across(starts_with("denominator_"), \(x) sum(x, na.rm = TRUE))) %>%
ungroup()
# Remove columns with _NA suffix
summarized_data <- summarized_data %>%
select(-ends_with("_NA"))
# Reorder columns to have numerator and denominator sequentially
year_columns <- summarized_data %>%
select(starts_with("numerator_"), starts_with("denominator_")) %>%
names() %>%
sort()
# Split the columns into numerator and denominator columns
numerator_columns <-
grep("^numerator_", year_columns, value = TRUE)
denominator_columns <-
grep("^denominator_", year_columns, value = TRUE)
# Interleave numerator and denominator columns
interleaved_columns <-
c(rbind(numerator_columns, denominator_columns))
# Add Outcome column and rearrange
final_data <- summarized_data %>%
mutate(Outcome = "Early Grade Reading") %>%
select(Outcome, Gender, Population, all_of(interleaved_columns))
}, ignoreNULL = FALSE)
output$early_reading <- renderDataTable({
datatable(early_reading(),
options = list(pageLength = 5,
scrollX = TRUE))
})
}
# Run the application
shinyApp(ui = ui, server = server)