From c5e7ff77111b7655c60a7be2df4cb66e39546a96 Mon Sep 17 00:00:00 2001 From: Samuel Gratzl Date: Wed, 23 Jun 2021 20:23:46 +0200 Subject: [PATCH 01/13] feat: start with export scores --- dashboard/app.R | 107 ++++++++++++++++++++------------------ dashboard/export_scores.R | 32 ++++++++++++ 2 files changed, 89 insertions(+), 50 deletions(-) create mode 100644 dashboard/export_scores.R diff --git a/dashboard/app.R b/dashboard/app.R index 6f1bf49..ee719eb 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -32,9 +32,12 @@ if(length(cssFiles)!=1){ cssFile = cssFiles[1] cat(file=stderr(),"Loaded css file:",cssFile,"\n") +source('./export_scores.R') + ######## # Layout ######## + ui <- fluidPage(padding=0, tags$head( tags$link(rel = "stylesheet", type = "text/css", href = cssFile) @@ -48,7 +51,7 @@ ui <- fluidPage(padding=0, ) ), div(id="title", class="col-sm-6", - HTML("FORECAST EVALUATION DASHBOARD ", + HTML("FORECAST EVALUATION DASHBOARD ", includeHTML("arrow-left.svg"), " Back"), ), div(id="github-logo-container", class="col-sm-1", @@ -63,10 +66,10 @@ ui <- fluidPage(padding=0, sidebarPanel(id = "inputOptions", conditionalPanel(condition = "input.tabset == 'evaluations'", radioButtons("targetVariable", "Target Variable", - choices = list("Incident Deaths" = "Deaths", + choices = list("Incident Deaths" = "Deaths", "Incident Cases" = "Cases")), - - + + radioButtons("scoreType", "Scoring Metric", choices = list("Weighted Interval Score" = "wis", "Spread" = "sharpness", @@ -94,7 +97,7 @@ ui <- fluidPage(padding=0, ), tags$p(id="forecaster-disclaimer", "Some forecasters may not have data for the chosen location or scoring metric"), checkboxGroupInput( - "aheads", + "aheads", "Forecast Horizon (Weeks)", choices = c(1,2,3,4), selected = 1, @@ -119,11 +122,13 @@ ui <- fluidPage(padding=0, ) ), tags$hr(), + export_scores_ui, + tags$hr(), ), includeMarkdown("about-dashboard.md"), width=3, ), - + mainPanel( width=9, tabsetPanel(id = "tabset", @@ -151,7 +156,7 @@ ui <- fluidPage(padding=0, fluidRow(column(11, textOutput('renderWarningText'))), plotlyOutput(outputId = "summaryPlot", height="auto"), fluidRow( - column(11, offset=1, + column(11, offset=1, div(id="refresh-colors", actionButton(inputId="refreshColors", label= "Recolor")) )), tags$br(), @@ -174,7 +179,6 @@ ui <- fluidPage(padding=0, tags$br() ) ) - ) ), ), @@ -194,7 +198,7 @@ server <- function(input, output, session) { return(NULL) } ) - + # Get and prepare data getData <- function(filename){ if(!is.null(s3bucket)) { @@ -211,7 +215,7 @@ server <- function(input, output, session) { getFallbackData(filename) } } - + getFallbackData = function(filename) { path = ifelse( file.exists(filename), @@ -220,12 +224,12 @@ server <- function(input, output, session) { ) readRDS(path) } - + dfStateCases <- getData("score_cards_state_cases.rds") dfStateDeaths <- getData("score_cards_state_deaths.rds") dfNationCases = getData("score_cards_nation_cases.rds") dfNationDeaths = getData("score_cards_nation_deaths.rds") - + # Pick out expected columns only covCols = paste0("cov_", COVERAGE_INTERVALS) expectedCols = c("ahead", "geo_value", "forecaster", "forecast_date", @@ -237,18 +241,19 @@ server <- function(input, output, session) { dfStateDeaths = dfStateDeaths %>% select(all_of(expectedCols)) dfNationCases = dfNationCases %>% select(all_of(expectedCols)) dfNationDeaths = dfNationDeaths %>% select(all_of(expectedCols)) - + df <- rbind(dfStateCases, dfStateDeaths, dfNationCases, dfNationDeaths) df <- df %>% rename("10" = cov_10, "20" = cov_20, "30" = cov_30, "40" = cov_40, "50" = cov_50, "60" = cov_60, "70" = cov_70, "80" = cov_80, "90" = cov_90, "95" = cov_95, "98" = cov_98) - + + cat(file=stderr(), 'here') # Prepare color palette colorSeed = 100 - + # Prepare input choices forecasterChoices = sort(unique(df$forecaster)) updateForecasterChoices(session, df, forecasterChoices, 'wis') - - + + ################## # CREATE MAIN PLOT ################## @@ -262,13 +267,13 @@ server <- function(input, output, session) { if (targetVariable == "Deaths") { signalFilter = DEATH_FILTER } - scoreDf = scoreDf %>% + scoreDf = scoreDf %>% filter(signal == signalFilter) %>% filter(ahead %in% horizon) %>% filter(forecaster %in% forecasters) - + filteredScoreDf <- scoreDf %>% rename(Forecaster = forecaster, Week_End_Date = target_end_date) - + if (scoreType == "wis" || scoreType == "sharpness") { # Only show WIS or Sharpness for forecasts that have all intervals filteredScoreDf = filteredScoreDf %>% filter(!is.na(`50`)) %>% filter(!is.na(`80`)) %>% filter(!is.na(`95`)) @@ -299,7 +304,7 @@ server <- function(input, output, session) { if (allLocations || scoreType == "coverage") { filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score)) # Create df with col for all locations across each unique date, ahead and forecaster combo - locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>% + locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>% summarize(location_list = paste(sort(unique(geo_value)),collapse=",")) # Create a list containing each row's location list locationList = sapply(locationDf$location_list, function(x) strsplit(x, ",")) @@ -345,7 +350,7 @@ server <- function(input, output, session) { output$renderLocations <- renderText("") output$renderWarningText <- renderText("") } - + # Render truth plot with observed values showElement("truthPlot") showElement("refresh-colors") @@ -353,7 +358,7 @@ server <- function(input, output, session) { output$truthPlot <- renderPlotly({ truthPlot(truthDf, targetVariable, locationsIntersect, allLocations || scoreType == "coverage") }) - + # Format and transform data filteredScoreDf = filteredScoreDf[c("Forecaster", "Week_End_Date", "Score", "ahead")] filteredScoreDf = filteredScoreDf %>% mutate(across(where(is.numeric), ~ round(., 2))) @@ -382,15 +387,15 @@ server <- function(input, output, session) { as_tsibble(key = c(Forecaster, ahead), index = Week_End_Date) %>% group_by(Forecaster, ahead) %>% fill_gaps(.full = TRUE) - - filteredScoreDf$ahead = factor(filteredScoreDf$ahead, levels = c(1, 2, 3, 4), + + filteredScoreDf$ahead = factor(filteredScoreDf$ahead, levels = c(1, 2, 3, 4), labels = c("Horizon: 1 Week", "Horizon: 2 Weeks", "Horizon: 3 Weeks", "Horizon: 4 Weeks")) set.seed(colorSeed) forecasterRand <- sample(unique(df$forecaster)) colorPalette = setNames(object = viridis(length(unique(df$forecaster))), nm = forecasterRand) - + p = ggplot( - filteredScoreDf, + filteredScoreDf, aes(x = Week_End_Date, y = Score, color = Forecaster, shape = Forecaster) ) + geom_line() + @@ -399,7 +404,7 @@ server <- function(input, output, session) { scale_x_date(date_labels = "%b %Y") + facet_wrap(~ahead, ncol=1) + scale_color_manual(values = colorPalette) + - theme_bw() + + theme_bw() + theme(panel.spacing=unit(0.5, "lines")) + theme(legend.title = element_blank()) @@ -412,23 +417,23 @@ server <- function(input, output, session) { p = p + scale_y_continuous(limits = c(0,NA), labels = scales::comma) } plotHeight = 550 + (length(horizon)-1)*100 - finalPlot <- - ggplotly(p,tooltip = c("x", "y", "shape")) %>% + finalPlot <- + ggplotly(p,tooltip = c("x", "y", "shape")) %>% layout( - height = plotHeight, - legend = list(orientation = "h", y = -0.1), - margin = list(t=90), - height=500, - hovermode = 'x unified', + height = plotHeight, + legend = list(orientation = "h", y = -0.1), + margin = list(t=90), + height=500, + hovermode = 'x unified', xaxis = list( - title = list(text = "Target Date",standoff = 8L), + title = list(text = "Target Date",standoff = 8L), titlefont = list(size = 12)) ) %>% config(displayModeBar = F) - + return(finalPlot) } - + ################### # CREATE TRUTH PLOT ################### @@ -437,16 +442,16 @@ server <- function(input, output, session) { titleText = paste0('Observed Incident ', targetVariable, '') if (allLocations) { titleText = paste0('Observed Incident ', targetVariable, '', '
Totaled over all states and territories common to selected forecasters*') - } + } scoreDf <- scoreDf %>% group_by(Week_End_Date) %>% summarize(Reported_Incidence = actual) - + return (ggplotly(ggplot(scoreDf, aes(x = Week_End_Date, y = Reported_Incidence)) + geom_line() + geom_point() + labs(x = "", y = "", title = titleText) + scale_y_continuous(limits = c(0,NA), labels = scales::comma) + - scale_x_date(date_labels = "%b %Y") + theme_bw()) + scale_x_date(date_labels = "%b %Y") + theme_bw()) %>% layout(hovermode = 'x unified') %>% config(displayModeBar = F)) } @@ -455,22 +460,22 @@ server <- function(input, output, session) { # PLOT OUTPUT ############# output$summaryPlot <- renderPlotly({ - summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, + summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline) }) ################### # EVENT OBSERVATION ################### - + observeEvent(input$refreshColors, { colorSeed = floor(runif(1, 1, 1000)) output$summaryPlot <- renderPlotly({ - summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, + summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline) }) }) - + # When the target variable changes, update available forecasters, locations, and CIs to choose from observeEvent(input$targetVariable, { if (input$targetVariable == 'Deaths') { @@ -482,16 +487,16 @@ server <- function(input, output, session) { updateLocationChoices(session, df, input$targetVariable, input$forecasters, input$location) updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output) }) - + observeEvent(input$scoreType, { if (input$targetVariable == 'Deaths') { df = df %>% filter(signal == DEATH_FILTER) } else { df = df %>% filter(signal == CASE_FILTER) } - # Only show forecasters that have data for the score chosen + # Only show forecasters that have data for the score chosen updateForecasterChoices(session, df, input$forecasters, input$scoreType) - + if (input$scoreType == "wis") { show("wisExplanation") hide("sharpnessExplanation") @@ -540,7 +545,7 @@ server <- function(input, output, session) { updateLocationChoices(session, df, input$targetVariable, input$forecasters, input$location) updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output) }) - + # Ensure the minimum necessary input selections observe({ # Ensure there is always one ahead selected @@ -557,7 +562,9 @@ server <- function(input, output, session) { if(input$scaleByBaseline && !("COVIDhub-baseline" %in% input$forecasters)) { updateSelectInput(session, "forecasters", selected = c(input$forecasters, "COVIDhub-baseline")) } - }) + }) + + export_scores_server(output, input, df) } ################ diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R new file mode 100644 index 0000000..c74cead --- /dev/null +++ b/dashboard/export_scores.R @@ -0,0 +1,32 @@ + +create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) { + allLocations = FALSE + if (loc == TOTAL_LOCATIONS) { + allLocations = TRUE + } + signalFilter = CASE_FILTER + if (targetVariable == "Deaths") { + signalFilter = DEATH_FILTER + } + scoreDf = scoreDf %>% + filter(signal == signalFilter) %>% + filter(ahead %in% horizon) %>% + filter(forecaster %in% forecasters) + return(scoreDf) +} + +export_scores_ui = downloadButton(id="exportScores", "Download CSV") + +export_scores_server = function(output, input, df) { + output$exportScores <- downloadHandler( + filename = function() { + paste0("forecast-eval-scores-", Sys.Date(), ".csv") + }, + contentType = 'text/csv', + content = function(file) { + out_df = create_export_df(df, input$targetVariable, input$forecasters, + input$aheads, input$location) + write.csv(out_df, file) + } + ) +} From ba6172b42d343ecab6b4570ab7b637355a9d24d0 Mon Sep 17 00:00:00 2001 From: Samuel Gratzl Date: Wed, 23 Jun 2021 21:22:49 +0200 Subject: [PATCH 02/13] feat: simple export --- dashboard/app.R | 7 ++----- dashboard/common.R | 5 +++++ dashboard/export_scores.R | 25 ++++++++++++++++++++----- 3 files changed, 27 insertions(+), 10 deletions(-) create mode 100644 dashboard/common.R diff --git a/dashboard/app.R b/dashboard/app.R index ee719eb..c8d8622 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -9,10 +9,7 @@ library(shinyjs) library(tsibble) library(aws.s3) -COVERAGE_INTERVALS = c("10", "20", "30", "40", "50", "60", "70", "80", "90", "95", "98") -DEATH_FILTER = "deaths_incidence_num" -CASE_FILTER = "confirmed_incidence_num" -TOTAL_LOCATIONS = "Totaled Over States*" +source('./common.R') # Score explanations wisExplanation = includeMarkdown("wis.md") @@ -564,7 +561,7 @@ server <- function(input, output, session) { } }) - export_scores_server(output, input, df) + export_scores_server(input, output, df) } ################ diff --git a/dashboard/common.R b/dashboard/common.R new file mode 100644 index 0000000..c76dc97 --- /dev/null +++ b/dashboard/common.R @@ -0,0 +1,5 @@ + +COVERAGE_INTERVALS = c("10", "20", "30", "40", "50", "60", "70", "80", "90", "95", "98") +DEATH_FILTER = "deaths_incidence_num" +CASE_FILTER = "confirmed_incidence_num" +TOTAL_LOCATIONS = "Totaled Over States*" diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R index c74cead..8be7608 100644 --- a/dashboard/export_scores.R +++ b/dashboard/export_scores.R @@ -1,3 +1,4 @@ +source('./common.R') create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) { allLocations = FALSE @@ -15,18 +16,32 @@ create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) return(scoreDf) } -export_scores_ui = downloadButton(id="exportScores", "Download CSV") +export_scores_ui = div( + downloadButton("exportScores", "Download CSV"), + actionButton("exportR", "Show Download R Script") +) -export_scores_server = function(output, input, df) { +export_scores_server = function(input, output, df) { output$exportScores <- downloadHandler( filename = function() { paste0("forecast-eval-scores-", Sys.Date(), ".csv") }, contentType = 'text/csv', content = function(file) { - out_df = create_export_df(df, input$targetVariable, input$forecasters, - input$aheads, input$location) - write.csv(out_df, file) + withProgress(message = 'Preparing export', + detail = 'This may take a while...', value = 0, max = 2, { + out_df = create_export_df(df, input$targetVariable, input$forecasters, input$aheads, input$location) + incProgress(1) + write.csv(out_df, file, row.names=FALSE) + incProgress(2) + }) } ) + + observeEvent(input$exportR, { + showModal(modalDialog( + title='Export R', size='l', + "This is s test", + )) + }) } From 37367409c171e491bee6cb53812dc82542e0be8f Mon Sep 17 00:00:00 2001 From: Samuel Gratzl Date: Wed, 23 Jun 2021 21:45:24 +0200 Subject: [PATCH 03/13] fix: remove R script function for now --- dashboard/export_scores.R | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R index 8be7608..ee470e5 100644 --- a/dashboard/export_scores.R +++ b/dashboard/export_scores.R @@ -17,8 +17,7 @@ create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) } export_scores_ui = div( - downloadButton("exportScores", "Download CSV"), - actionButton("exportR", "Show Download R Script") + downloadButton("exportScores", "Download CSV") ) export_scores_server = function(input, output, df) { @@ -37,11 +36,4 @@ export_scores_server = function(input, output, df) { }) } ) - - observeEvent(input$exportR, { - showModal(modalDialog( - title='Export R', size='l', - "This is s test", - )) - }) } From d501289f99ab4918148829b9a879b8c6a0fde017 Mon Sep 17 00:00:00 2001 From: Samuel Gratzl Date: Wed, 23 Jun 2021 21:54:09 +0200 Subject: [PATCH 04/13] feat: better filename --- dashboard/export_scores.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R index ee470e5..f5284a0 100644 --- a/dashboard/export_scores.R +++ b/dashboard/export_scores.R @@ -1,10 +1,6 @@ source('./common.R') create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) { - allLocations = FALSE - if (loc == TOTAL_LOCATIONS) { - allLocations = TRUE - } signalFilter = CASE_FILTER if (targetVariable == "Deaths") { signalFilter = DEATH_FILTER @@ -13,6 +9,9 @@ create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) filter(signal == signalFilter) %>% filter(ahead %in% horizon) %>% filter(forecaster %in% forecasters) + if (loc != TOTAL_LOCATIONS) { + scoreDf = scoreDf %>% filter(geo_value == tolower(loc)) + } return(scoreDf) } @@ -23,7 +22,11 @@ export_scores_ui = div( export_scores_server = function(input, output, df) { output$exportScores <- downloadHandler( filename = function() { - paste0("forecast-eval-scores-", Sys.Date(), ".csv") + filename = paste0("forecast-eval-scores-", input$targetVariable) + if (input$location != TOTAL_LOCATIONS) { + filename = paste0(filename, '-', input$location) + } + paste0(filename,'-', Sys.Date(), ".csv") }, contentType = 'text/csv', content = function(file) { From 569034bc1de5a41c170dab7094eb1eb79cc912ff Mon Sep 17 00:00:00 2001 From: Samuel Gratzl Date: Thu, 24 Jun 2021 20:51:45 +0200 Subject: [PATCH 05/13] fix: remove debug output --- dashboard/app.R | 1 - 1 file changed, 1 deletion(-) diff --git a/dashboard/app.R b/dashboard/app.R index c8d8622..b84bd42 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -242,7 +242,6 @@ server <- function(input, output, session) { df <- rbind(dfStateCases, dfStateDeaths, dfNationCases, dfNationDeaths) df <- df %>% rename("10" = cov_10, "20" = cov_20, "30" = cov_30, "40" = cov_40, "50" = cov_50, "60" = cov_60, "70" = cov_70, "80" = cov_80, "90" = cov_90, "95" = cov_95, "98" = cov_98) - cat(file=stderr(), 'here') # Prepare color palette colorSeed = 100 From ce06f84e23e3086e891ebab03b9f02eb7457ece3 Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Mon, 19 Jul 2021 11:45:00 -0400 Subject: [PATCH 06/13] export scores --- dashboard/app.R | 109 +++++++++++++++----------------------- dashboard/common.R | 46 ++++++++++++++++ dashboard/export_scores.R | 27 +++++++--- 3 files changed, 111 insertions(+), 71 deletions(-) diff --git a/dashboard/app.R b/dashboard/app.R index 867bcbf..48e7272 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -256,34 +256,30 @@ server <- function(input, output, session) { ################## # CREATE MAIN PLOT ################## - summaryPlot = function(scoreDf, targetVariable, scoreType, forecasters, - horizon, loc, coverageInterval = NULL, colorSeed, logScale, scaleByBaseline) { + summaryPlot = function(scoreDf, colorSeed) { allLocations = FALSE - if (loc == TOTAL_LOCATIONS) { + if (input$location == TOTAL_LOCATIONS) { allLocations = TRUE } signalFilter = CASE_FILTER - if (targetVariable == "Deaths") { + if (input$targetVariable == "Deaths") { signalFilter = DEATH_FILTER } - if (targetVariable == "Hospitalizations") { + if (input$targetVariable == "Hospitalizations") { signalFilter = HOSPITALIZATIONS_FILTER } - scoreDf = scoreDf %>% + filteredScoreDf = scoreDf %>% filter(signal == signalFilter) %>% - filter(forecaster %in% forecasters) + filter(forecaster %in% input$forecasters) if (signalFilter == HOSPITALIZATIONS_FILTER) { - scoreDf = filterHospitalizationsAheads(scoreDf) + filteredScoreDf = filterHospitalizationsAheads(filteredScoreDf) } - scoreDf = scoreDf %>% filter(ahead %in% horizon) - filteredScoreDf <- scoreDf %>% rename(Forecaster = forecaster, Forecast_Date = forecast_date, - Week_End_Date = target_end_date) - - if (scoreType == "wis" || scoreType == "sharpness") { + filteredScoreDf = filteredScoreDf %>% filter(ahead %in% input$aheads) + if (input$scoreType == "wis" || input$scoreType == "sharpness") { # Only show WIS or Sharpness for forecasts that have all intervals filteredScoreDf = filteredScoreDf %>% filter(!is.na(`50`)) %>% filter(!is.na(`80`)) %>% filter(!is.na(`95`)) - if (targetVariable == "Deaths") { + if (input$targetVariable == "Deaths") { filteredScoreDf = filteredScoreDf %>% filter(!is.na(`10`)) %>% filter(!is.na(`20`)) %>% filter(!is.na(`30`)) %>% filter(!is.na(`40`)) %>% filter(!is.na(`60`)) %>% filter(!is.na(`70`)) %>% filter(!is.na(`90`)) %>% filter(!is.na(`98`)) } @@ -291,51 +287,33 @@ server <- function(input, output, session) { output$renderWarningText <- renderText("The selected forecasters do not have enough data to display the selected scoring metric.") return() } - if (scoreType == "wis") { - filteredScoreDf <- filteredScoreDf %>% rename(Score = wis) - title = "Weighted Interval Score" + if (input$scoreType == "wis") { + plotTitle = "Weighted Interval Score" } else { - filteredScoreDf <- filteredScoreDf %>% rename(Score = sharpness) - title = "Spread" + plotTitle = "Spread" } } - if (scoreType == "ae") { - filteredScoreDf <- filteredScoreDf %>% rename(Score = ae) - title = "Absolute Error" + if (input$scoreType == "ae") { + plotTitle = "Absolute Error" } - if (scoreType == "coverage") { - filteredScoreDf <- filteredScoreDf %>% rename(Score = !!coverageInterval) - title = "Coverage" + if (input$scoreType == "coverage") { + plotTitle = "Coverage" } + filteredScoreDf = renameScoreCol(filteredScoreDf, input$scoreType, input$coverageInterval) # Totaling over all locations - locationsIntersect = list() - if (allLocations || scoreType == "coverage") { - filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score)) - # Create df with col for all locations across each unique date, ahead and forecaster combo - locationDf = filteredScoreDf %>% group_by(Forecaster, Week_End_Date, ahead) %>% - summarize(location_list = paste(sort(unique(geo_value)),collapse=",")) - locationDf = locationDf %>% filter(location_list != c('us')) - # Create a list containing each row's location list - locationList = sapply(locationDf$location_list, function(x) strsplit(x, ",")) - locationList = lapply(locationList, function(x) x[x != 'us']) - # Get the intersection of all the locations in these lists - locationsIntersect = unique(Reduce(intersect, locationList)) - filteredScoreDf = filteredScoreDf %>% filter(geo_value %in% locationsIntersect) + if (allLocations || input$scoreType == "coverage") { + filteredScoreDfAndIntersections = filterOverAllLocations(filteredScoreDf, input$scoreType, input$coverageInterval) + filteredScoreDf = filteredScoreDfAndIntersections[[1]] + locationsIntersect = filteredScoreDfAndIntersections[[2]] aggregateText = "*For fair comparison, all displayed forecasters on all displayed dates are compared across a common set of states and territories." - if (scoreType == "coverage") { + if (input$scoreType == "coverage") { aggregate = "Averaged" - filteredScoreDf = filteredScoreDf %>% - group_by(Forecaster, Forecast_Date, Week_End_Date, ahead) %>% - summarize(Score = sum(Score)/length(locationsIntersect), actual = sum(actual)) output$renderAggregateText = renderText(paste(aggregateText," Some forecasters may not have any data for the coverage interval chosen. Locations inlcuded: ")) } else { aggregate = "Totaled" - filteredScoreDf = filteredScoreDf %>% - group_by(Forecaster, Forecast_Date, Week_End_Date, ahead) %>% - summarize(Score = sum(Score), actual = sum(actual)) output$renderAggregateText = renderText(paste(aggregateText, " Locations included: ")) } if (length(locationsIntersect) == 0) { @@ -353,8 +331,8 @@ server <- function(input, output, session) { } # Not totaling over all locations } else { - filteredScoreDf <- filteredScoreDf %>% filter(geo_value == tolower(loc)) %>% - group_by(Forecaster, Forecast_Date, Week_End_Date, ahead) %>% + filteredScoreDf <- filteredScoreDf %>% filter(geo_value == tolower(input$location)) %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% summarize(Score = Score, actual = actual) locationSubtitleText = paste0(', Location: ', input$location) output$renderAggregateText = renderText("") @@ -362,19 +340,22 @@ server <- function(input, output, session) { output$renderWarningText <- renderText("") } + # Rename columns that will be used as labels + filteredScoreDf = filteredScoreDf %>% rename(Forecaster = forecaster, Forecast_Date = forecast_date, + Week_End_Date = target_end_date) # Render truth plot with observed values showElement("truthPlot") showElement("refresh-colors") truthDf = filteredScoreDf output$truthPlot <- renderPlotly({ - truthPlot(truthDf, targetVariable, locationsIntersect, allLocations || scoreType == "coverage") + truthPlot(truthDf, locationsIntersect, allLocations || input$scoreType == "coverage") }) # Format and transform data filteredScoreDf = filteredScoreDf[c("Forecaster", "Forecast_Date", "Week_End_Date", "Score", "ahead")] filteredScoreDf = filteredScoreDf %>% mutate(across(where(is.numeric), ~ round(., 2))) - if (scoreType != 'coverage') { - if (scaleByBaseline) { + if (input$scoreType != 'coverage') { + if (input$scaleByBaseline) { baselineDf = filteredScoreDf %>% filter(Forecaster %in% 'COVIDhub-baseline') filteredScoreDfMerged = merge(filteredScoreDf, baselineDf, by=c("Week_End_Date","ahead")) # Scaling score by baseline forecaster @@ -383,13 +364,13 @@ server <- function(input, output, session) { rename(Forecaster = Forecaster.x, Score = Score.x, Forecast_Date = Forecast_Date.x) %>% select(Forecaster, Forecast_Date, Week_End_Date, ahead, Score) } - if (logScale) { + if (input$logScale) { filteredScoreDf$Score = log10(filteredScoreDf$Score) } } - titleText = paste0('',title,'','
', '', - 'Target Variable: ', targetVariable, + titleText = paste0('', plotTitle,'','
', '', + 'Target Variable: ', input$targetVariable, locationSubtitleText, '
', tags$span(id="drag-to-zoom", " Drag to zoom"), '') @@ -401,7 +382,7 @@ server <- function(input, output, session) { # Set labels for faceted horizon plots horizonOptions = AHEAD_OPTIONS horizonLabels = lapply(AHEAD_OPTIONS, function (x) paste0("Horizon: ", x, " Week(s)")) - if (targetVariable == 'Hospitalizations') { + if (input$targetVariable == 'Hospitalizations') { horizonOptions = HOSPITALIZATIONS_AHEAD_OPTIONS horizonLabels = lapply(HOSPITALIZATIONS_AHEAD_OPTIONS, function (x) paste0("Horizon: ", x, " Days")) } @@ -426,15 +407,15 @@ server <- function(input, output, session) { theme(panel.spacing=unit(0.5, "lines")) + theme(legend.title = element_blank()) - if (scoreType == "coverage") { - p = p + geom_hline(yintercept = .01 * as.integer(coverageInterval)) + if (input$scoreType == "coverage") { + p = p + geom_hline(yintercept = .01 * as.integer(input$coverageInterval)) } - if (logScale) { + if (input$logScale) { p = p + scale_y_continuous(label = function(x) paste0("10^", x)) } else { p = p + scale_y_continuous(limits = c(0,NA), labels = scales::comma) } - plotHeight = 550 + (length(horizon)-1)*100 + plotHeight = 550 + (length(input$aheads)-1)*100 finalPlot <- ggplotly(p, tooltip = c("x", "y", "shape", "label")) %>% layout( @@ -456,9 +437,9 @@ server <- function(input, output, session) { # CREATE TRUTH PLOT ################### # Create the plot for target variable ground truth - truthPlot = function(scoreDf = NULL, targetVariable = NULL, locationsIntersect = NULL, allLocations = FALSE) { - observation = paste0('Incident ', targetVariable) - if (targetVariable == "Hospitalizations") { + truthPlot = function(scoreDf = NULL, locationsIntersect = NULL, allLocations = FALSE) { + observation = paste0('Incident ', input$targetVariable) + if (input$targetVariable == "Hospitalizations") { observation = paste0('Hospital Admissions') } titleText = paste0('Observed ', observation, '') @@ -482,8 +463,7 @@ server <- function(input, output, session) { # PLOT OUTPUT ############# output$summaryPlot <- renderPlotly({ - summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, - input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline) + summaryPlot(df, colorSeed) }) ################### @@ -493,8 +473,7 @@ server <- function(input, output, session) { observeEvent(input$refreshColors, { colorSeed = floor(runif(1, 1, 1000)) output$summaryPlot <- renderPlotly({ - summaryPlot(df, input$targetVariable, input$scoreType, input$forecasters, - input$aheads, input$location, input$coverageInterval, colorSeed, input$logScale, input$scaleByBaseline) + summaryPlot(df, colorSeed) }) }) diff --git a/dashboard/common.R b/dashboard/common.R index c5b89db..1902e81 100644 --- a/dashboard/common.R +++ b/dashboard/common.R @@ -2,7 +2,10 @@ COVERAGE_INTERVALS = c("10", "20", "30", "40", "50", "60", "70", "80", "90", "95", "98") DEATH_FILTER = "deaths_incidence_num" CASE_FILTER = "confirmed_incidence_num" +HOSPITALIZATIONS_FILTER = "confirmed_admissions_covid_1d" +HOSPITALIZATIONS_TARGET_DAY = "Wednesday" TOTAL_LOCATIONS = "Totaled Over States*" +AHEAD_OPTIONS = c(1,2,3,4) # Num days to offset the forecast week by # Example: if HOSPITALIZATIONS_TARGET_DAY is Wednesday and HOSPITALIZATIONS_OFFSET is 2, @@ -11,3 +14,46 @@ TOTAL_LOCATIONS = "Totaled Over States*" HOSPITALIZATIONS_OFFSET = 2 HOSPITALIZATIONS_AHEAD_OPTIONS = c(HOSPITALIZATIONS_OFFSET, HOSPITALIZATIONS_OFFSET + 7, HOSPITALIZATIONS_OFFSET + 14, HOSPITALIZATIONS_OFFSET + 21) + +renameScoreCol = function(filteredScoreDf, scoreType, coverageInterval) { + if (scoreType == "wis") { + filteredScoreDf <- filteredScoreDf %>% rename(Score = wis) + } + else if (scoreType == "sharpness") { + filteredScoreDf <- filteredScoreDf %>% rename(Score = sharpness) + } + else if (scoreType == "ae") { + filteredScoreDf <- filteredScoreDf %>% rename(Score = ae) + } + else if (scoreType == "coverage") { + filteredScoreDf <- filteredScoreDf %>% rename(Score = !!coverageInterval) + } + return (filteredScoreDf) +} + + +filterOverAllLocations = function(filteredScoreDf, scoreType, coverageInterval) { + locationsIntersect = list() + filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score)) + # Create df with col for all locations across each unique date, ahead and forecaster combo + locationDf = filteredScoreDf %>% group_by(forecaster, target_end_date, ahead) %>% + summarize(location_list = paste(sort(unique(geo_value)),collapse=",")) + locationDf = locationDf %>% filter(location_list != c('us')) + # Create a list containing each row's location list + locationList = sapply(locationDf$location_list, function(x) strsplit(x, ",")) + locationList = lapply(locationList, function(x) x[x != 'us']) + # Get the intersection of all the locations in these lists + locationsIntersect = unique(Reduce(intersect, locationList)) + filteredScoreDf = filteredScoreDf %>% filter(geo_value %in% locationsIntersect) + if (scoreType == "coverage") { + filteredScoreDf = filteredScoreDf %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = sum(Score)/length(locationsIntersect), actual = sum(actual)) + } + else { + filteredScoreDf = filteredScoreDf %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = sum(Score), actual = sum(actual)) + } + return (list(filteredScoreDf, locationsIntersect)) +} \ No newline at end of file diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R index f5284a0..8a9366a 100644 --- a/dashboard/export_scores.R +++ b/dashboard/export_scores.R @@ -1,18 +1,24 @@ source('./common.R') -create_export_df = function(scoreDf, targetVariable, forecasters, horizon, loc) { +create_export_df = function(scoreDf, targetVariable, scoreType, forecasters, loc, coverageInterval) { signalFilter = CASE_FILTER if (targetVariable == "Deaths") { signalFilter = DEATH_FILTER + } else if (targetVariable == "Hospitalizations") { + signalFilter = HOSPITALIZATIONS_FILTER } + scoreDf = renameScoreCol(scoreDf, scoreType, coverageInterval) scoreDf = scoreDf %>% filter(signal == signalFilter) %>% - filter(ahead %in% horizon) %>% filter(forecaster %in% forecasters) - if (loc != TOTAL_LOCATIONS) { + if (loc == TOTAL_LOCATIONS || input$scoreType == "coverage") { + scoreDf = filterOverAllLocations(scoreDf, scoreType, coverageInterval) + return(scoreDf[[1]]) + } else { scoreDf = scoreDf %>% filter(geo_value == tolower(loc)) + scoreDf = scoreDf[c("ahead", "geo_value", "forecaster", "forecast_date", "data_source", "target_end_date", "Score", "actual")] + return(scoreDf) } - return(scoreDf) } export_scores_ui = div( @@ -22,9 +28,17 @@ export_scores_ui = div( export_scores_server = function(input, output, df) { output$exportScores <- downloadHandler( filename = function() { - filename = paste0("forecast-eval-scores-", input$targetVariable) + score = input$scoreType + if (input$scoreType == 'sharpness') { + score = 'spread' + } + filename = paste0("forecast-eval-", input$targetVariable, "-", score) if (input$location != TOTAL_LOCATIONS) { filename = paste0(filename, '-', input$location) + } else if (input$scoreType == 'coverage') { + filename = paste0(filename, '-', 'average-over-common-locations-coverage-interval-', input$coverageInterval) + } else { + filename = paste0(filename, '-total-over-common-locations-') } paste0(filename,'-', Sys.Date(), ".csv") }, @@ -32,7 +46,8 @@ export_scores_server = function(input, output, df) { content = function(file) { withProgress(message = 'Preparing export', detail = 'This may take a while...', value = 0, max = 2, { - out_df = create_export_df(df, input$targetVariable, input$forecasters, input$aheads, input$location) + out_df = create_export_df(df, input$targetVariable, input$scoreType, input$forecasters, + input$location, input$coverageInterval) incProgress(1) write.csv(out_df, file, row.names=FALSE) incProgress(2) From c7a8a61da5452c91e27e21aaf418616550c7176a Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Mon, 19 Jul 2021 12:58:48 -0400 Subject: [PATCH 07/13] update hosp filtering for exports --- dashboard/app.R | 24 +----------------------- dashboard/common.R | 24 +++++++++++++++++++++++- dashboard/export_scores.R | 11 +++++++---- 3 files changed, 31 insertions(+), 28 deletions(-) diff --git a/dashboard/app.R b/dashboard/app.R index 48e7272..74cbb8f 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -304,7 +304,7 @@ server <- function(input, output, session) { # Totaling over all locations if (allLocations || input$scoreType == "coverage") { - filteredScoreDfAndIntersections = filterOverAllLocations(filteredScoreDf, input$scoreType, input$coverageInterval) + filteredScoreDfAndIntersections = filterOverAllLocations(filteredScoreDf, input$scoreType) filteredScoreDf = filteredScoreDfAndIntersections[[1]] locationsIntersect = filteredScoreDfAndIntersections[[2]] aggregateText = "*For fair comparison, all displayed forecasters on all displayed dates are compared across a common set of states and territories." @@ -649,26 +649,4 @@ updateAheadChoices = function(session, df, targetVariable, forecasterChoices, ah inline = TRUE) } -# Only use weekly aheads for hospitalizations -# May change in the future -filterHospitalizationsAheads = function(scoreDf) { - scoreDf['weekday'] = weekdays(as.Date(scoreDf$target_end_date)) - scoreDf = scoreDf %>% filter(weekday == HOSPITALIZATIONS_TARGET_DAY) - - oneAheadDf = scoreDf %>% filter(ahead >= HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 7 + HOSPITALIZATIONS_OFFSET) %>% - group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% - mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[1]) - twoAheadDf = scoreDf %>% filter(ahead >= 7 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 14 + HOSPITALIZATIONS_OFFSET) %>% - group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% - mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[2]) - threeAheadDf = scoreDf %>% filter(ahead >= 14 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 21 + HOSPITALIZATIONS_OFFSET) %>% - group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% - mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[3]) - fourAheadDf = scoreDf %>% filter(ahead >= 21 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 28 + HOSPITALIZATIONS_OFFSET) %>% - group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% - mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[4]) - - return(rbind(oneAheadDf, twoAheadDf, threeAheadDf, fourAheadDf)) -} - shinyApp(ui = ui, server = server) diff --git a/dashboard/common.R b/dashboard/common.R index 1902e81..8d15859 100644 --- a/dashboard/common.R +++ b/dashboard/common.R @@ -32,7 +32,7 @@ renameScoreCol = function(filteredScoreDf, scoreType, coverageInterval) { } -filterOverAllLocations = function(filteredScoreDf, scoreType, coverageInterval) { +filterOverAllLocations = function(filteredScoreDf, scoreType) { locationsIntersect = list() filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score)) # Create df with col for all locations across each unique date, ahead and forecaster combo @@ -56,4 +56,26 @@ filterOverAllLocations = function(filteredScoreDf, scoreType, coverageInterval) summarize(Score = sum(Score), actual = sum(actual)) } return (list(filteredScoreDf, locationsIntersect)) +} + +# Only use weekly aheads for hospitalizations +# May change in the future +filterHospitalizationsAheads = function(scoreDf) { + scoreDf['weekday'] = weekdays(as.Date(scoreDf$target_end_date)) + scoreDf = scoreDf %>% filter(weekday == HOSPITALIZATIONS_TARGET_DAY) + + oneAheadDf = scoreDf %>% filter(ahead >= HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 7 + HOSPITALIZATIONS_OFFSET) %>% + group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% + mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[1]) + twoAheadDf = scoreDf %>% filter(ahead >= 7 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 14 + HOSPITALIZATIONS_OFFSET) %>% + group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% + mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[2]) + threeAheadDf = scoreDf %>% filter(ahead >= 14 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 21 + HOSPITALIZATIONS_OFFSET) %>% + group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% + mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[3]) + fourAheadDf = scoreDf %>% filter(ahead >= 21 + HOSPITALIZATIONS_OFFSET) %>% filter(ahead < 28 + HOSPITALIZATIONS_OFFSET) %>% + group_by(target_end_date, forecaster) %>% filter(ahead == min(ahead)) %>% + mutate(ahead = HOSPITALIZATIONS_AHEAD_OPTIONS[4]) + + return(rbind(oneAheadDf, twoAheadDf, threeAheadDf, fourAheadDf)) } \ No newline at end of file diff --git a/dashboard/export_scores.R b/dashboard/export_scores.R index 8a9366a..9eb1954 100644 --- a/dashboard/export_scores.R +++ b/dashboard/export_scores.R @@ -11,8 +11,11 @@ create_export_df = function(scoreDf, targetVariable, scoreType, forecasters, loc scoreDf = scoreDf %>% filter(signal == signalFilter) %>% filter(forecaster %in% forecasters) - if (loc == TOTAL_LOCATIONS || input$scoreType == "coverage") { - scoreDf = filterOverAllLocations(scoreDf, scoreType, coverageInterval) + if (loc == TOTAL_LOCATIONS || scoreType == "coverage") { + if (signalFilter == HOSPITALIZATIONS_FILTER) { + scoreDf = filterHospitalizationsAheads(scoreDf) + } + scoreDf = filterOverAllLocations(scoreDf, scoreType) return(scoreDf[[1]]) } else { scoreDf = scoreDf %>% filter(geo_value == tolower(loc)) @@ -36,9 +39,9 @@ export_scores_server = function(input, output, df) { if (input$location != TOTAL_LOCATIONS) { filename = paste0(filename, '-', input$location) } else if (input$scoreType == 'coverage') { - filename = paste0(filename, '-', 'average-over-common-locations-coverage-interval-', input$coverageInterval) + filename = paste0(filename, '-', 'averaged-over-common-locations-Coverage-interval-', input$coverageInterval) } else { - filename = paste0(filename, '-total-over-common-locations-') + filename = paste0(filename, '-totaled-over-common-locations') } paste0(filename,'-', Sys.Date(), ".csv") }, From 7280111ca7786d830858758cbc035f7ff077cda8 Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Fri, 23 Jul 2021 10:35:39 -0400 Subject: [PATCH 08/13] adding data loading message --- dashboard/app.R | 21 ++++++++++++++++----- dashboard/www/style.css | 6 +++++- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/dashboard/app.R b/dashboard/app.R index f94fa1a..93ce25a 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -24,6 +24,9 @@ AHEAD_OPTIONS = c(1,2,3,4) HOSPITALIZATIONS_OFFSET = 2 HOSPITALIZATIONS_AHEAD_OPTIONS = c(HOSPITALIZATIONS_OFFSET, HOSPITALIZATIONS_OFFSET + 7, HOSPITALIZATIONS_OFFSET + 14, HOSPITALIZATIONS_OFFSET + 21) +# All data is fully loaded from AWS +dataLoaded = FALSE + # Score explanations wisExplanation = includeMarkdown("wis.md") sharpnessExplanation = includeMarkdown("sharpness.md") @@ -161,18 +164,19 @@ ui <- fluidPage(padding=0, plotlyOutput(outputId = "summaryPlot", height="auto"), fluidRow( column(11, offset=1, - div(id="refresh-colors", actionButton(inputId="refreshColors", label= "Recolor")) + hidden(div(id="refresh-colors", actionButton(inputId="refreshColors", label= "Recolor"))) )), tags$br(), plotlyOutput(outputId = "truthPlot", height="auto"), fluidRow( column(11, offset=1, - div(id="notes", "About the Scores"), + div(id="loading-message", "DATA IS LOADING..."), + hidden(div(id="notes", "About the Scores")), hidden(div(id = "wisExplanation", wisExplanation)), hidden(div(id = "sharpnessExplanation", sharpnessExplanation)), hidden(div(id = "aeExplanation", aeExplanation)), hidden(div(id = "coverageExplanation", coverageExplanation)), - div(id = "scoringDisclaimer", scoringDisclaimer) + hidden(div(id = "scoringDisclaimer", scoringDisclaimer)) ) ), fluidRow( @@ -236,6 +240,7 @@ server <- function(input, output, session) { dfNationDeaths = getData("score_cards_nation_deaths.rds") dfStateHospitalizations = getData("score_cards_state_hospitalizations.rds") dfNationHospitalizations = getData("score_cards_nation_hospitalizations.rds") + dataLoaded = TRUE # Pick out expected columns only covCols = paste0("cov_", COVERAGE_INTERVALS) @@ -260,7 +265,6 @@ server <- function(input, output, session) { # Prepare input choices forecasterChoices = sort(unique(df$forecaster)) updateForecasterChoices(session, df, forecasterChoices, 'wis') - ################## # CREATE MAIN PLOT @@ -456,7 +460,7 @@ server <- function(input, output, session) { titlefont = list(size = 12)) ) %>% config(displayModeBar = F) - + return(finalPlot) } @@ -577,6 +581,13 @@ server <- function(input, output, session) { # Ensure the minimum necessary input selections observe({ + # Show data loading message and hide other messages until all data is loaded + if (dataLoaded) { + hide("loading-message") + show("refresh-colors") + show("notes") + show("scoringDisclaimer") + } # Ensure there is always one ahead selected if(length(input$aheads) < 1) { if (input$targetVariable == 'Hospitalizations') { diff --git a/dashboard/www/style.css b/dashboard/www/style.css index 8a3413a..e898dac 100644 --- a/dashboard/www/style.css +++ b/dashboard/www/style.css @@ -88,13 +88,17 @@ #drag-to-zoom { font-size:11px; } -#refreshColors { +#refresh-colors { height: 26px; font-size: 12px; } #scale-score { font-weight: bold; } +#loading-message { + font-style: italic; + font-size: 18px; +} @media (max-width: 1450px) { #github-logo-container { From 9d3c7127280ae70b2cd81ba6156d37f04446495b Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Fri, 23 Jul 2021 11:47:19 -0400 Subject: [PATCH 09/13] adding r chunk to about --- dashboard/about.md | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/dashboard/about.md b/dashboard/about.md index 636edf6..8762dea 100644 --- a/dashboard/about.md +++ b/dashboard/about.md @@ -87,7 +87,9 @@ Though hospitalizations are forecasted on a daily basis, in keeping with the cas The forecasts and scores are available as RDS files and are uploaded weekly to a publicly accessible AWS bucket. You can use the url https://forecast-eval.s3.us-east-2.amazonaws.com/ + filename to download -any of the files from the bucket. For instance: https://forecast-eval.s3.us-east-2.amazonaws.com/score_cards_nation_cases.rds to download scores for nation level case predictions. +any of the files from the bucket. + +For instance: https://forecast-eval.s3.us-east-2.amazonaws.com/score_cards_nation_cases.rds to download scores for nation level case predictions. The available files are: * predictions_cards.rds (forecasts) @@ -97,5 +99,29 @@ The available files are: * score_cards_state_deaths.rds * score_cards_state_hospitalizations.rds * score_cards_nation_hospitalizations.rds + +You can also connect to AWS and retrieve the data in R. Example of retrieving state cases file: + +``` +library(aws.s3) +Sys.setenv("AWS_DEFAULT_REGION" = "us-east-2") +s3bucket = tryCatch( + { + get_bucket(bucket = 'forecast-eval') + }, + error = function(e) { + e + } +) + +stateCases = tryCatch( + { + s3readRDS(object = "score_cards_state_cases.rds", bucket = s3bucket) + }, + error = function(e) { + e + } +) +``` From dd34a78622512218b94ea440b7c0b32f9757046e Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Fri, 23 Jul 2021 13:12:44 -0400 Subject: [PATCH 10/13] adding horizon disclaimer for hosp --- dashboard/app.R | 8 ++++++-- dashboard/www/style.css | 4 ++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/dashboard/app.R b/dashboard/app.R index f94fa1a..b320384 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -109,6 +109,7 @@ ui <- fluidPage(padding=0, selected = AHEAD_OPTIONS[1], inline = TRUE ), + hidden(tags$p(id="horizon-disclaimer", "Forecasters submitted earlier than Mondays may have longer actual prediction horizons")), conditionalPanel(condition = "input.scoreType == 'coverage'", selectInput( "coverageInterval", @@ -652,11 +653,14 @@ updateLocationChoices = function(session, df, targetVariable, forecasterChoices, updateAheadChoices = function(session, df, targetVariable, forecasterChoices, aheads, targetVariableChange) { df = df %>% filter(forecaster %in% forecasterChoices) - aheadOptions = AHEAD_OPTIONS - title = "Forecast Horizon (Weeks)" if (targetVariable == 'Hospitalizations') { aheadOptions = HOSPITALIZATIONS_AHEAD_OPTIONS title = "Forecast Horizon (Days)" + show("horizon-disclaimer") + } else { + aheadOptions = AHEAD_OPTIONS + title = "Forecast Horizon (Weeks)" + hide("horizon-disclaimer") } aheadChoices = Filter(function(x) any(unique(df$ahead) %in% x), aheadOptions) # Ensure previsouly selected options are still allowed diff --git a/dashboard/www/style.css b/dashboard/www/style.css index 8a3413a..060f339 100644 --- a/dashboard/www/style.css +++ b/dashboard/www/style.css @@ -85,6 +85,10 @@ margin-top:-20px; font-size:12px; } +#horizon-disclaimer { + margin-top:-10px; + font-size:12px; +} #drag-to-zoom { font-size:11px; } From 81213d2511cce23e18cd6a072f569dc986cf7604 Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Fri, 23 Jul 2021 13:30:56 -0400 Subject: [PATCH 11/13] disallow scaling by baseline with hosp --- dashboard/app.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dashboard/app.R b/dashboard/app.R index 7c7dd02..bb6101c 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -360,7 +360,7 @@ server <- function(input, output, session) { filteredScoreDf = filteredScoreDf[c("Forecaster", "Forecast_Date", "Week_End_Date", "Score", "ahead")] filteredScoreDf = filteredScoreDf %>% mutate(across(where(is.numeric), ~ round(., 2))) if (input$scoreType != 'coverage') { - if (input$scaleByBaseline) { + if (input$scaleByBaseline && input$targetVariable != "Hospitalizations") { baselineDf = filteredScoreDf %>% filter(Forecaster %in% 'COVIDhub-baseline') filteredScoreDfMerged = merge(filteredScoreDf, baselineDf, by=c("Week_End_Date","ahead")) # Scaling score by baseline forecaster From 90c7b5f090143e64c8d8e24bd0f6a6f0432d169a Mon Sep 17 00:00:00 2001 From: Kate Harwood Date: Wed, 28 Jul 2021 09:15:41 -0400 Subject: [PATCH 12/13] add on to loading message --- dashboard/app.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dashboard/app.R b/dashboard/app.R index 7c7dd02..e1e9d35 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -162,7 +162,7 @@ ui <- fluidPage(padding=0, plotlyOutput(outputId = "truthPlot", height="auto"), fluidRow( column(11, offset=1, - div(id="loading-message", "DATA IS LOADING..."), + div(id="loading-message", "DATA IS LOADING...(this may take a while)"), hidden(div(id="notes", "About the Scores")), hidden(div(id = "wisExplanation", wisExplanation)), hidden(div(id = "sharpnessExplanation", sharpnessExplanation)), From ed940472e1272145e03d82f90272f3b9783229ec Mon Sep 17 00:00:00 2001 From: Nat DeFries <42820733+nmdefries@users.noreply.github.com> Date: Thu, 29 Jul 2021 15:42:58 -0400 Subject: [PATCH 13/13] Version 3.1 updates --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index e5cc969..4bba28b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: forecast-eval Title: Forecast Evaluation Dashboard -Version: 3 +Version: 3.1 Authors@R: person("Kate", "Harwood", role = c("cre")), person("Chris", "Scott",