From 216bf73b426c9704a2604be12ef29c8d8b9a02cc Mon Sep 17 00:00:00 2001 From: Julian A Wolfson Date: Tue, 25 Aug 2020 12:49:23 -0500 Subject: [PATCH] Add school district tab --- app.R | 337 ++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 270 insertions(+), 67 deletions(-) diff --git a/app.R b/app.R index f226832..ad85f45 100644 --- a/app.R +++ b/app.R @@ -16,6 +16,7 @@ library(formattable) library(bootstraplib) library(forcats) library(shinycssloaders) +library(shinyWidgets) bs_theme_new(version = "4+3", bootswatch = "sketchy") @@ -40,10 +41,14 @@ casedata <- read_csv("https://raw.githubusercontent.com/nytimes/covid-19-data/ma totalcases_last = cases - cases_lag) %>% ungroup() %>% mutate(rate_last = totalcases_last / pop * POP_DENOM, + rate_last_ci_upper = POP_DENOM / pop * (totalcases_last + 1.96*sqrt(totalcases_last)), + rate_last_ci_lower = pmax(0, POP_DENOM / pop * (totalcases_last - 1.96*sqrt(totalcases_last))), school_opening_status = cut(rate_last, c(-Inf, STATUS_CUTOFFS, Inf), labels = STATUS_LABELS)) +casedata_district <- read_csv("district_cases.csv") + opening_status <- data.frame(x = rep(c(ymd("2020-01-01"), ymd("2030-01-01")), each = length(STATUS_LABELS)), ymin = rep(c(0, STATUS_CUTOFFS), 2), ymax = rep(c(STATUS_CUTOFFS, Inf), 2), @@ -57,12 +62,15 @@ first.day <- latest.day - 90 last.accurate.day <- latest.day casedata <- casedata %>% mutate(unreliable_data = (date > last.accurate.day)) +casedata_district <- casedata_district %>% mutate(unreliable_data = FALSE) makeCountyPlot <- function(countydata) { countydata %>% - ggplot(aes(x = date, y = rate_last)) + - geom_line(show.legend = FALSE, aes(linetype = unreliable_data)) + - geom_point(show.legend = FALSE, aes(shape = unreliable_data), size = 2) + + ggplot(aes(x = date)) + + geom_line(show.legend = FALSE, aes(y = rate_last, linetype = unreliable_data)) + +# geom_point(aes(y = rate_last_ci_upper), shape = 18) + + geom_ribbon(aes(ymin = rate_last_ci_lower, ymax = rate_last_ci_upper), fill = "black", alpha = 0.1) + + geom_point(show.legend = FALSE, aes(y = rate_last, shape = unreliable_data), size = 2) + scale_color_brewer(palette = "RdYlGn", direction = -1, drop = FALSE ) + geom_ribbon(data = opening_status, aes(x = x, ymin = ymin, @@ -83,6 +91,44 @@ makeCountyPlot <- function(countydata) { theme(legend.position = "bottom") } +makeDistrictPlot <- function(districtdata) { + districtdata %>% + mutate( + school_opening_status = factor(school_opening_status, + levels = STATUS_LABELS) + ) %>% + ggplot(aes(x = date, + fill = school_opening_status)) + + # geom_bar(aes(y = rate_last), + # stat = "identity", + # alpha = 0.7) + + #geom_point(aes(y = (rate_last + rate_last_max)/2), size = 1) + + geom_errorbar(aes(ymin = rate_last, + ymax = rate_last_max), + width = 0, + size = 2) + + geom_errorbar(aes(ymin = rate_last_ci_lower, + ymax = rate_last_ci_upper), + width = 0.5) + + geom_ribbon(data = opening_status, aes(x = x, + ymin = ymin, + ymax = ymax, + fill = school_opening_status), + alpha = 0.3, + inherit.aes = FALSE) + + scale_fill_brewer(palette = "RdYlGn", + direction = -1, + drop = FALSE, + name = "") + + scale_x_date(breaks = districtdata$date, date_labels = "Week ending\n%b %d") + + coord_cartesian(xlim = c(min(districtdata$date) - 7, max(districtdata$date) + 7), + ylim = c(0, MAX_Y)) + + ylab(sprintf("Total cases in past %d days\nper %s population", LAG_DAYS, comma(POP_DENOM, digits = 0))) + + xlab(NULL) + + theme_minimal(base_size = 16) + + theme(legend.position = "bottom") +} + makeCountyComparisonPlot <- function(allcounties) { allcounties %>% filter(!is.na(rate_last)) %>% @@ -151,7 +197,8 @@ makeCountryPlot <- function(alldata, bypop) { } # Define UI for application that draws a histogram -ui <- fluidPage( +ui <- function(request) { + fluidPage( bootstrap(), tags$head( tags$style(HTML("hr {border-top: 1px solid #000000;} @@ -167,64 +214,74 @@ ui <- fluidPage( sidebarPanel( id = "sidebar", uiOutput("countyselect"), + #uiOutput("districtselect"), div( - checkboxInput(inputId = "multicounty", - label = "Select/combine multiple counties"), - style = "padding-left:20px; color: #3333AA" + uiOutput("multicheck"), + style = "color: #333399; font-size: 12pt" ), uiOutput("countyweights"), uiOutput("rescale_message"), + uiOutput("bookmark"), hr(), - h4("Background"), - p("On July 30, 2020, the State of Minnesota released its", - a(href = "https://education.mn.gov/mdeprod/idcplg?IdcService=GET_FILE&dDocName=MDE033418&RevisionSelectionMethod=latestReleased&Rendition=primary", - "Safe Learning Plan"), - "for the 2020-2021 school year. One of the key components of the plan was a set of guidelines for the mode in which schools should operate (in-person, hybrid, distance learning) based on the level of COVID-19 transmission in the local community. The key metric recommended for - quantifying community transmission for each county is the", - - tags$i("total number of cases over the past 14 days per 10,000 county residents"), - - ". The purpose of this app is to display this key metric for each county in Minnesota, including both its current value and what it has been - over the past three months."), + uiOutput("background"), uiOutput("fineprint"), ), # Show a plot of the generated distribution mainPanel( - - fluidRow( - column(6, - uiOutput("county_info_1")), - column(6, align = "right", - uiOutput("county_info_2")) - ), - fluidRow( - column(12, - withSpinner(plotOutput("opening"), type = 5, color = "#DAE6FF") - ) - ), - fluidRow( - column(12, - h3("County Comparison"), - h6("How Minnesota's counties compare"), - withSpinner(plotOutput("compare_counties"), type = 5, color = "#DAE6FF") - ) - ), - fluidRow( - column(12, - h2("U.S. Comparison"), - h5("How each state's counties stack up using Minnesota's school opening guidance"), - withSpinner(plotOutput("compare_us", height = "700px"), type = 5, color = "#DAE6FF") - ) - ), - fluidRow( - column(12, align = "center", - checkboxInput("bypop", span("View by population", style = "font-size:20px")) - ) + tabsetPanel(id = "tab", selected = "county", + + tabPanel(title = "By County", value = "county", + fluidRow( + column(6, + uiOutput("county_info_1")), + column(6, align = "right", + uiOutput("county_info_2")) + ), + fluidRow( + column(12, + withSpinner(plotOutput("opening"), type = 5, color = "#DAE6FF") + ) + ), + fluidRow( + column(12, + h3("County Comparison"), + h6("How Minnesota's counties compare"), + withSpinner(plotOutput("compare_counties"), type = 5, color = "#DAE6FF") + ) + ), + fluidRow( + column(12, + h2("U.S. Comparison"), + h5("How each state's counties stack up using Minnesota's school opening guidance"), + withSpinner(plotOutput("compare_us", height = "700px"), type = 5, color = "#DAE6FF") + ) + ), + fluidRow( + column(12, align = "center", + checkboxInput("bypop", span("View by population", style = "font-size:20px")) + ) + ) + ), + + tabPanel(title = "By School District", value = "district", + fluidRow( + column(6, + uiOutput("district_info_1")), + column(6, align = "right", + uiOutput("district_info_2")) + ), + fluidRow( + column(12, + withSpinner(plotOutput("opening_district"), type = 5, color = "#DAE6FF"), + p("Inner (thick) bar gives the range of 14-day per 10,000 case totals that are consistent with reported case data (MDH does not report exact case numbers in ZIP codes with <= 5 cases). Outer bars give 95% confidence intervals for this range. For larger school districts where no ZIP codes have <= 5 cases, only the outer bars are visible."), + ) + )) ) ) ) ) +} # Define server logic required to draw a histogram server <- function(input, output) { @@ -246,11 +303,16 @@ server <- function(input, output) { date >= first.day, date <= latest.day) %>% group_by(date) %>% - summarise(rate_last = - ifelse(length(rate_last)==1, + summarise( + rate_last = ifelse(length(rate_last)!= length(weights), NA, - weighted.mean(rate_last, w = weights))) %>% - mutate(school_opening_status = cut(rate_last, + weighted.mean(rate_last, w = weights)), + rate_last_SE = ifelse(length(totalcases_last) != length(weights), + NA, + POP_DENOM * sqrt(sum(totalcases_last*weights^2/pop^2)))) %>% + mutate(rate_last_ci_lower = rate_last - 1.96*rate_last_SE, + rate_last_ci_upper = rate_last + 1.96*rate_last_SE, + school_opening_status = cut(rate_last, c(-Inf, STATUS_CUTOFFS, Inf), labels = STATUS_LABELS), county = sprintf("Custom (%s)", paste(input$county, collapse = "/")), @@ -260,6 +322,12 @@ server <- function(input, output) { dat }) + district_data <- reactive({ + req(input$district) + casedata_district %>% filter(name == input$district, + !is.na(rate_last)) + }) + get_weights <- reactive({ req(input$weight_1) as.numeric(unlist(lapply(1:length(input$county), @@ -277,29 +345,61 @@ server <- function(input, output) { output$opening <- renderPlot({ + req(input$county) suppressWarnings(county_data() %>% makeCountyPlot()) }) + output$opening_district <- renderPlot({ + req(input$district) + suppressWarnings(district_data() %>% makeDistrictPlot()) + }) + output$compare_counties <- renderPlot({ + req(input$county) current_county_rates() %>% makeCountyComparisonPlot() }) output$compare_us <- renderPlot({ + req(input$county) casedata %>% makeCountryPlot(bypop = input$bypop) }) output$countyselect <- renderUI( { - - single <- is.null(input$multicounty) | !input$multicounty - multi <- !single + if(is.null(input$tab) | input$tab == "county") { + if(is.null(input$multicounty)) { + single <- TRUE + } else { + single <- !input$multicounty + } + + multi <- !single + selectInput("county", "Select a county", choices = pops %>% filter(state == STATE) %>% pull(county), selected = pops %>% filter(state == STATE) %>% arrange(desc(pop)) %>% slice(1:(1+multi)) %>% pull(county), multiple = multi) + + } else { + selectInput("district", + "Select a school district", + choices = casedata_district %>% pull(name) %>% unique(), + multiple = FALSE) + } + }) + + output$multicheck <- renderUI({ + if(is.null(input$tab) | input$tab == "county") { + prettySwitch(inputId = "multicounty", + label = "Select/combine multiple counties", + value = FALSE, + status = "primary", + fill = TRUE) + } }) + output$countyweights <- renderUI( { req(input$county) if(length(input$county) == 1) { @@ -317,10 +417,21 @@ server <- function(input, output) { }) output$rescale_message <- renderUI( { + req(input$county) + if(abs(sum(get_weights()) - 100) > 1 & length(input$county) > 1) { return(p("Sums of percentages not adding to 100% will be rescaled proportionally")) } }) + + output$bookmark <- renderUI( { + req(input$county) +# if(length(input$county) > 1) { + bookmarkButton(title = "Generate a custom URL to return to these inputs at a later time.", + style = "background-color: #333399; border-width: 0px") +# } + }) + output$county_info_1 <- renderUI({ req(input$county) @@ -347,6 +458,18 @@ server <- function(input, output) { } }) + output$district_info_1 <- renderUI({ + req(input$district) + + zips <- district_data() %>% pull(zips) %>% first() + + return(tagList( + h1(input$district), + h4(sprintf("ZIP codes: %s", zips)) + )) + + }) + output$county_info_2 <- renderUI({ caserate <- county_data() %>% filter(date == last.accurate.day) %>% pull(rate_last) @@ -363,24 +486,104 @@ server <- function(input, output) { ) }) - output$fineprint <- renderUI({ + output$district_info_2 <- renderUI({ + + dd <- district_data() + + caserate <- dd %>% filter(date == max(dd$date)) %>% pull(rate_last) + caserate_max <- dd %>% filter(date == max(dd$date)) %>% pull(rate_last_max) + status <- dd %>% filter(date == max(dd$date)) %>% pull(school_opening_status) + tagList( - hr(), - h6("Fine print"), - div(class = "fineprint", - p( - HTML("County populations are based on 2019 estimates from the US Census." )), - p( - HTML("Case numbers are obtained from the + h3(paste0("As of ", strftime(max(dd$date), "%B %d, %Y"), ":"), + style = "color:#999999"), + h4(sprintf("%d-day case rate per %s: %.1f-%.1f", + LAG_DAYS, + comma(POP_DENOM, digits = 0), + round(caserate,1), + round(caserate_max, 1)), + style = "color:#99CC99") + ) + }) + + output$background <- renderUI({ + + if(input$tab == "county") { + tagList( + h4("Background"), + p("On July 30, 2020, the State of Minnesota released its", + a(href = "https://education.mn.gov/mdeprod/idcplg?IdcService=GET_FILE&dDocName=MDE033418&RevisionSelectionMethod=latestReleased&Rendition=primary", + "Safe Learning Plan"), + "for the 2020-2021 school year. One of the key components of the plan was a set of guidelines for the mode in which schools should operate (in-person, hybrid, distance learning) based on the level of COVID-19 transmission in the local community. The key metric recommended for + quantifying community transmission for each county is the", + + tags$i("total number of cases over the past 14 days per 10,000 residents"), + + ". The purpose of this app is to display this key metric for each county and school district in Minnesota.") + ) + + } else { + tagList( + h4("Background"), + p("On July 30, 2020, the State of Minnesota released its", + a(href = "https://education.mn.gov/mdeprod/idcplg?IdcService=GET_FILE&dDocName=MDE033418&RevisionSelectionMethod=latestReleased&Rendition=primary", + "Safe Learning Plan"), + "for the 2020-2021 school year. One of the key components of the plan was a set of guidelines for the mode in which schools should operate (in-person, hybrid, distance learning) based on the level of COVID-19 transmission in the local community. The key metric recommended for + quantifying community transmission for each county is the", + + tags$i("total number of cases over the past 14 days per 10,000 residents"), + + ". The purpose of this app is to display this key metric for each county and school district in Minnesota."), + p(HTML("NOTE: The state has proposed using county-level metrics to make decisions on school status. + School district level estimates are less accurate, and are provided for information purposes only."), + style = "font-size: 16px; color: #000099") + + ) + + } + }) + + output$fineprint <- renderUI({ + if(input$tab == "county") { + tagList( + hr(), + h6("Fine print"), + div(class = "fineprint", + p( + HTML("County populations are based on 2019 estimates from the US Census." )), + p( + HTML("Case numbers are obtained from the New York Times Coronavirus GitHub data repository, and will update whenever that data source does (at least daily)." )), - p( - HTML("Source code for this app is available on my GitHub site.") + p("Shaded areas in the top plot give 95% confidence intervals for the 14-day case total per 10,000 people."), + p( + HTML("Source code for this app is available on my GitHub site.") + ) ) ) - ) + + } else { + tagList( + hr(), + h6("Fine print"), + div(class = "fineprint", + p( + HTML("ZIP-code specific case numbers are obtained on a weekly basis from the Minesota Department of Health's + COVID-19 Weekly Report") + ), + p( + HTML("ZIP code populations are obtained from UnitedStatesZipCodes.org") + ), + p("Mappings between ZIP codes and school districts are obtained from Minnesota Department of Education data."), + p( + HTML("Source code for this app is available on my GitHub site.") + ) + ) + ) + + } }) } # Run the application -shinyApp(ui = ui, server = server) +shinyApp(ui = ui, server = server, enableBookmarking = "url")