这是一个解决方案,其中表数据是
eventReactive
取决于
input$runButton
。使用此选项时,仅当单击按钮时才会更新表格,而当您在选项之间切换时则不会。
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) && !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)
