diff --git a/dashboard/about.md b/dashboard/about.md index 8762dea..534223b 100644 --- a/dashboard/about.md +++ b/dashboard/about.md @@ -79,9 +79,11 @@ Though hospitalizations are forecasted on a daily basis, in keeping with the cas #### **Notes on the Data** * If a forecast does not include an explicit point estimate, the 0.5 quantile is taken as the point estimate for calculating absolute error. -* WIS is only shown for forecasts that have predictions for all quantiles (23 quantiles for deaths and hospitalizations and 7 for cases) +* The weighted interval score is only shown for forecasts that have predictions for all quantiles (23 quantiles for deaths and hospitalizations and 7 for cases) * Totaling over all states and territories does not include nationwide forecasts. To ensure that values are comparable, these totals also exclude any locations that are absent from any file that was submitted by one of the selected forecasters. -* We include revisions of observed values, which means that the scores for forecasts made in the past can change as our understanding of the ground truth changes. +* For scoring, we include revisions of observed values, which means that the scores for forecasts made in the past can change as our understanding of the ground truth changes. +* The observed data can also be viewed **'as of'** a certain date, which shows what observed data a forecaster had available +when a past forecast was made (but the forecasts are always scored on the latest revision of the observed data). #### **Accessing the Data** The forecasts and scores are available as RDS files and are uploaded weekly to a publicly accessible AWS bucket. diff --git a/dashboard/app.R b/dashboard/app.R index 224ffbc..7ce96c6 100644 --- a/dashboard/app.R +++ b/dashboard/app.R @@ -8,11 +8,17 @@ library(plotly) library(shinyjs) library(tsibble) library(aws.s3) +library(covidcast) source('./common.R') # All data is fully loaded from AWS -dataLoaded = FALSE +DATA_LOADED = FALSE + +# Earliest 'as of' date available from covidcast API +MIN_AVAIL_NATION_AS_OF_DATE = as.Date('2021-01-02') +MIN_AVAIL_HOSP_AS_OF_DATE = as.Date('2020-11-11') +MIN_AVAIL_TERRITORY_AS_OF_DATE = as.Date('2021-02-10') # Score explanations wisExplanation = includeMarkdown("wis.md") @@ -121,6 +127,13 @@ ui <- fluidPage(padding=0, selected = "US" ) ), + selectInput( + "asOf", + "As Of", + choices = '', + multiple = FALSE, + selected = '' + ), tags$hr(), export_scores_ui, tags$hr(), @@ -163,12 +176,15 @@ ui <- fluidPage(padding=0, plotlyOutput(outputId = "truthPlot", height="auto"), fluidRow( column(11, offset=1, - div(id="loading-message", "DATA IS LOADING...(this may take a while)"), + div(id="data-loading-message", "DATA IS LOADING...(this may take a while)"), + hidden(div(id="truth-plot-loading-message", "Fetching 'as of' data and loading observed values...")), 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)), + hidden(div(id="scoreExplanations", + hidden(div(id = "wisExplanation", wisExplanation)), + hidden(div(id = "sharpnessExplanation", sharpnessExplanation)), + hidden(div(id = "aeExplanation", aeExplanation)), + hidden(div(id = "coverageExplanation", coverageExplanation)) + )), hidden(div(id = "scoringDisclaimer", scoringDisclaimer)) ) ), @@ -232,7 +248,10 @@ 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 + DATA_LOADED = TRUE + TERRITORIES = c('AS', 'GU', 'MP', 'VI') + MAX_WEEK_END_DATE = reactiveVal(max(dfNationDeaths$target_end_date)) + PREV_AS_OF_DATA = reactiveVal(NULL) # Pick out expected columns only covCols = paste0("cov_", COVERAGE_INTERVALS) @@ -248,11 +267,8 @@ server <- function(input, output, session) { dfStateHospitalizations = dfStateHospitalizations %>% select(all_of(expectedCols)) dfNationHospitalizations = dfNationHospitalizations %>% select(all_of(expectedCols)) - df <- rbind(dfStateCases, dfStateDeaths, dfNationCases, dfNationDeaths, dfStateHospitalizations, dfNationHospitalizations) - 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) - - # Prepare color palette - colorSeed = 100 + df = rbind(dfStateCases, dfStateDeaths, dfNationCases, dfNationDeaths, dfStateHospitalizations, dfNationHospitalizations) + 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) # Prepare input choices forecasterChoices = sort(unique(df$forecaster)) @@ -262,55 +278,41 @@ server <- function(input, output, session) { ################## # CREATE MAIN PLOT ################## - summaryPlot = function(scoreDf, colorSeed) { - allLocations = FALSE - if (input$location == TOTAL_LOCATIONS) { - allLocations = TRUE - } - signalFilter = CASE_FILTER - if (input$targetVariable == "Deaths") { - signalFilter = DEATH_FILTER - } - if (input$targetVariable == "Hospitalizations") { - signalFilter = HOSPITALIZATIONS_FILTER - } - filteredScoreDf = scoreDf %>% - filter(signal == signalFilter) %>% - filter(forecaster %in% input$forecasters) - - if (signalFilter == HOSPITALIZATIONS_FILTER) { - filteredScoreDf = filterHospitalizationsAheads(filteredScoreDf) + summaryPlot = function(colorSeed = 100, reRenderTruth = FALSE, asOfData = NULL) { + filteredScoreDf = filterScoreDf() + if (dim(filteredScoreDf)[1] == 0) { + output$renderWarningText <- renderText("The selected forecasters do not have enough data to display the selected scoring metric.") + return() } - 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 (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`)) - } - if (dim(filteredScoreDf)[1] == 0) { - output$renderWarningText <- renderText("The selected forecasters do not have enough data to display the selected scoring metric.") - return() - } - if (input$scoreType == "wis") { - plotTitle = "Weighted Interval Score" - } - else { - plotTitle = "Spread" + if (is.null(asOfData)) { + if (!is.null(isolate(PREV_AS_OF_DATA())) && dim(isolate(PREV_AS_OF_DATA()))[1] != 0 && + isolate(input$asOf) != '' && isolate(input$asOf) != isolate(MAX_WEEK_END_DATE())) { + asOfData = isolate(PREV_AS_OF_DATA()) } } - if (input$scoreType == "ae") { - plotTitle = "Absolute Error" - } - if (input$scoreType == "coverage") { - plotTitle = "Coverage" + if (!is.null(asOfData) && dim(asOfData)[1] != 0) { + asOfData = asOfData %>% rename(target_end_date = time_value, as_of_actual = value) + asOfData = asOfData[c("target_end_date", "geo_value", "as_of_actual")] + + # Get the 'as of' dates that are the target_end_dates in the scoring df + dateGroupDf = asOfData %>% filter(asOfData$target_end_date %in% filteredScoreDf$target_end_date) + if (dim(dateGroupDf)[1] != 0) { + # Since cases and deaths are shown as weekly incidence, but the "as of" data from the covidcast API + # is daily, we need to sum over the days leading up to the target_end_date of each week to get the + # weekly incidence + asOfData = filterAsOfData(asOfData, dateGroupDf, filteredScoreDf) + filteredScoreDf = merge(filteredScoreDf, asOfData, by=c("target_end_date", "geo_value"), all = TRUE) + } else { + # Input 'as of' date chosen does not match the available target_end_dates that result from the rest of the selected inputs + # It is too far back or we are switching between hosp and cases/deaths which have different target date days + # As of input will be updated to the default (latest) and plot will re-render with the just the normal truth data, no 'as of' + asOfData = NULL + } } - filteredScoreDf = renameScoreCol(filteredScoreDf, input$scoreType, input$coverageInterval) # Totaling over all locations - if (allLocations || input$scoreType == "coverage") { - filteredScoreDfAndIntersections = filterOverAllLocations(filteredScoreDf, input$scoreType) + if (input$location == TOTAL_LOCATIONS || input$scoreType == "coverage") { + filteredScoreDfAndIntersections = filterOverAllLocations(filteredScoreDf, input$scoreType, !is.null(asOfData)) 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." @@ -334,30 +336,53 @@ server <- function(input, output, session) { locationSubtitleText = paste0(', Location: ', aggregate ,' over all states and territories common to these forecasters*') output$renderLocations <- renderText(toupper(locationsIntersect)) output$renderWarningText = renderText("") + showElement("truthPlot") } # Not totaling over all locations } else { - filteredScoreDf <- filteredScoreDf %>% filter(geo_value == tolower(input$location)) %>% - group_by(forecaster, forecast_date, target_end_date, ahead) %>% - summarize(Score = Score, actual = actual) + if (!is.null(asOfData)) { + filteredScoreDf <- filteredScoreDf %>% filter(geo_value == tolower(input$location)) %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = Score, actual = actual, as_of_actual = as_of_actual) + } else { + 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("") output$renderLocations <- renderText("") output$renderWarningText <- renderText("") } - # Rename columns that will be used as labels + showElement("refresh-colors") + if(dim(filteredScoreDf)[1] == 0) { + return() + } + + # Rename columns that will be used as labels and for clarity on CSV exports 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, locationsIntersect, allLocations || input$scoreType == "coverage") + truthPlot(truthDf, locationsIntersect, !is.null(asOfData)) }) + if (!is.null(truthDf) && length(truthDf$Week_End_Date) != 0) { + MAX_WEEK_END_DATE(max(truthDf$Week_End_Date, na.rm=TRUE)) + } + + # If we are just re-rendering the truth plot with as of data + # we don't need to re-render the score plot + if (reRenderTruth) { + return() + } + # If we are re-rendering scoring plot with new inputs that were just selected + # we need to make sure the as of input options are valid with those inputs + updateAsOfChoices(session, truthDf) - # Format and transform data + # Format and transform data for plot + filteredScoreDf = filteredScoreDf %>% filter(!is.na(Week_End_Date)) filteredScoreDf = filteredScoreDf[c("Forecaster", "Forecast_Date", "Week_End_Date", "Score", "ahead")] filteredScoreDf = filteredScoreDf %>% mutate(across(where(is.numeric), ~ round(., 2))) if (input$scoreType != 'coverage') { @@ -375,12 +400,28 @@ server <- function(input, output, session) { } } + # Title plot + if (input$scoreType == "wis") { + plotTitle = "Weighted Interval Score" + } + else if (input$scoreType == "sharpness") { + plotTitle = "Spread" + } + else if (input$scoreType == "ae") { + plotTitle = "Absolute Error" + } + else { + plotTitle = "Coverage" + } + titleText = paste0('', plotTitle,'','
', '', 'Target Variable: ', input$targetVariable, locationSubtitleText, '
', tags$span(id="drag-to-zoom", " Drag to zoom"), '') + # Fill gaps so there are line breaks on weeks without data + # This is failing for CU-select on US deaths (https://github.com/cmu-delphi/forecast-eval/issues/157) filteredScoreDf = filteredScoreDf %>% as_tsibble(key = c(Forecaster, ahead), index = Week_End_Date) %>% group_by(Forecaster, Forecast_Date, ahead) %>% @@ -443,24 +484,40 @@ server <- function(input, output, session) { # CREATE TRUTH PLOT ################### # Create the plot for target variable ground truth - truthPlot = function(scoreDf = NULL, locationsIntersect = NULL, allLocations = FALSE) { + truthPlot = function(filteredDf = NULL, locationsIntersect = NULL, hasAsOfData = FALSE) { observation = paste0('Incident ', input$targetVariable) if (input$targetVariable == "Hospitalizations") { observation = paste0('Hospital Admissions') } titleText = paste0('Observed ', observation, '') - if (allLocations) { + if (input$location == TOTAL_LOCATIONS || input$scoreType == "coverage") { titleText = paste0('Observed ', observation, '', '
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() + + if (hasAsOfData) { + filteredDf <- filteredDf %>% + group_by(Week_End_Date) %>% summarize(Reported_Incidence = actual, Reported_As_Of_Incidence = as_of_actual) + } else { + filteredDf <- filteredDf %>% + group_by(Week_End_Date) %>% summarize(Reported_Incidence = actual) + } + + finalPlot = ggplot(filteredDf, aes(Week_End_Date)) + 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() + + if (hasAsOfData) { + finalPlot = finalPlot + + geom_line(aes(y = Reported_Incidence), color="grey") + + geom_point(aes(y = Reported_Incidence), color="grey") + + geom_line(aes(y = Reported_As_Of_Incidence)) + + geom_point(aes(y = Reported_As_Of_Incidence)) + } else { + finalPlot = finalPlot + geom_line(aes(y = Reported_Incidence)) + + geom_point(aes(y = Reported_Incidence)) + } + return (ggplotly(finalPlot) %>% layout(hovermode = 'x unified') %>% config(displayModeBar = F)) } @@ -469,9 +526,79 @@ server <- function(input, output, session) { # PLOT OUTPUT ############# output$summaryPlot <- renderPlotly({ - summaryPlot(df, colorSeed) + summaryPlot() }) + # Filter scoring df by inputs chosen (targetVariable, forecasters, aheads) + filterScoreDf = function() { + signalFilter = CASE_FILTER + if (input$targetVariable == "Deaths") { + signalFilter = DEATH_FILTER + } + if (input$targetVariable == "Hospitalizations") { + signalFilter = HOSPITALIZATIONS_FILTER + } + filteredScoreDf = df %>% + filter(signal == signalFilter) %>% + filter(forecaster %in% input$forecasters) + + if (signalFilter == HOSPITALIZATIONS_FILTER) { + filteredScoreDf = filterHospitalizationsAheads(filteredScoreDf) + } + 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 (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`)) + } + } + filteredScoreDf = renameScoreCol(filteredScoreDf, input$scoreType, input$coverageInterval) + return(filteredScoreDf) + } + + # Filter as of data so that it matches weekly incidence for the target end dates in the score df + filterAsOfData = function(asOfData, dateGroupDf, filteredScoreDf) { + # Hospitalization scores are shown as daily incidence, not weekly incidence, no summing necessary + if (input$targetVariable != "Hospitalizations") { + # Create a df to fill in the corresponding target_end_date in a new date_group column for all intervening days + dateGroupDf[,"date_group"] <- NA + dateGroupDf$date_group = dateGroupDf$target_end_date + asOfData = merge(asOfData, dateGroupDf, by=c('target_end_date', 'geo_value', 'as_of_actual'), all = TRUE) + + # Cut off the extra days on beginning and end of series so that when we sum the values we are only + # summing over the weeks included in the score plot + asOfData = asOfData %>% filter(target_end_date >= min(filteredScoreDf$target_end_date) - 6) + asOfData = asOfData %>% filter(target_end_date <= isolate(input$asOf)) + + # Fill in the date_group column with the target week end days for all intervening days + asOfData = asOfData %>% arrange(geo_value) %>% fill(date_group, .direction = "up") + + # In the case where there are target week end days missing from the scoring or as of data + # we don't want to end up summing values over multiple weeks so we make sure each date_group only spans one week + asOfData = asOfData %>% filter(asOfData$date_group - asOfData$target_end_date < 7) + + asOfData = asOfData[c('geo_value', 'as_of_actual', 'date_group')] + # Sum over preceding week for all weekly target variables + asOfData = asOfData %>% group_by(geo_value, date_group) %>% summarize(as_of_actual = sum(as_of_actual)) + asOfData = asOfData %>% rename(target_end_date = date_group) + # If targetVariable is Hospitalizations + } else { + asOfData = dateGroupDf + # Need to make sure that we are only matching the target_end_dates shown in the scoring plot + # and not using fetched data for as of dates before those target_end_dates. + # This is taken care of above for cases and deaths. + minDate = min(filteredScoreDf$target_end_date) + if (input$scoreType != 'coverage' && input$location != TOTAL_LOCATIONS) { + chosenLocationDf = filteredScoreDf %>% filter(geo_value == tolower(input$location)) + minDate = min(chosenLocationDf$target_end_date) + } + asOfData = asOfData %>% filter(target_end_date >= minDate) + } + return(asOfData) + } + ################### # EVENT OBSERVATION ################### @@ -479,7 +606,7 @@ server <- function(input, output, session) { observeEvent(input$refreshColors, { colorSeed = floor(runif(1, 1, 1000)) output$summaryPlot <- renderPlotly({ - summaryPlot(df, colorSeed) + summaryPlot(colorSeed) }) }) @@ -497,7 +624,8 @@ server <- function(input, output, session) { updateForecasterChoices(session, df, input$forecasters, input$scoreType) updateLocationChoices(session, df, input$targetVariable, input$forecasters, input$location) updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output) - }) + updateAsOfData() + }) observeEvent(input$scoreType, { if (input$targetVariable == 'Deaths') { @@ -510,6 +638,12 @@ server <- function(input, output, session) { # Only show forecasters that have data for the score chosen updateForecasterChoices(session, df, input$forecasters, input$scoreType) + # If we are switching between coverage and other score types we need to + # update the as of data we have so it matches the correct locations shown + if (input$location == 'US') { + updateAsOfData() + } + if (input$scoreType == "wis") { show("wisExplanation") hide("sharpnessExplanation") @@ -552,13 +686,22 @@ server <- function(input, output, session) { updateCoverageChoices(session, df, input$targetVariable, input$forecasters, input$coverageInterval, output) }) - # Ensure the minimum necessary input selections + observeEvent(input$location, { + updateAsOfData() + }) + + observeEvent(input$asOf, { + updateAsOfData() + }) + + # The following checks 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") + if (DATA_LOADED) { + hide("data-loading-message") show("refresh-colors") show("notes") + show("scoreExplanations") show("scoringDisclaimer") } # Ensure there is always one ahead selected @@ -582,6 +725,82 @@ server <- function(input, output, session) { } }) + updateAsOfData = function() { + dataSource = "jhu-csse" + if(input$targetVariable == "Cases") { + targetSignal = "confirmed_incidence_num" + } else if (input$targetVariable == "Deaths") { + targetSignal = "deaths_incidence_num" + } else if (input$targetVariable == "Hospitalizations") { + targetSignal = "confirmed_admissions_covid_1d" + dataSource = "hhs" + } + + if (input$location == 'US' && input$scoreType != 'coverage') { + location = "nation" + } else { + location = "state" + } + if (input$asOf < MAX_WEEK_END_DATE() && input$asOf != '') { + hideElement("truthPlot") + hideElement("notes") + hideElement("scoringDisclaimer") + hideElement("scoreExplanations") + hideElement("renderAggregateText") + hideElement("renderLocations") + showElement("truth-plot-loading-message") + + # Since as_of matches to the issue date in covidcast (rather than the time_value) + # we need to add one extra day to get the as of we want. + fetchDate = as.Date(input$asOf) + 1 + + # Covidcast API call + asOfTruthData = covidcast_signal(data_source = dataSource, signal = targetSignal, + start_day = "2020-02-15", end_day = fetchDate, + as_of = fetchDate, + geo_type = location) + showElement("truthPlot") + showElement("notes") + showElement("scoringDisclaimer") + showElement("scoreExplanations") + showElement("renderAggregateText") + showElement("renderLocations") + hideElement("truth-plot-loading-message") + PREV_AS_OF_DATA(asOfTruthData) + + if(dim(asOfTruthData)[1] == 0) { + return() + } + summaryPlot(reRenderTruth = TRUE, asOfData = asOfTruthData) + } else if(input$asOf == MAX_WEEK_END_DATE() && input$asOf != '') { + summaryPlot(reRenderTruth = TRUE) + } + } + + updateAsOfChoices = function(session, truthDf) { + asOfChoices = truthDf$Week_End_Date + selectedAsOf = isolate(input$asOf) + if (selectedAsOf == '' && length(asOfChoices) != 0) { + selectedAsOf = max(asOfChoices, na.rm=TRUE) + } + if (input$targetVariable == "Hospitalizations") { + minChoice = MIN_AVAIL_HOSP_AS_OF_DATE + asOfChoices = asOfChoices[asOfChoices >= minChoice] + } else if(input$location == 'US' && input$scoreType != 'coverage') { + minChoice = MIN_AVAIL_NATION_AS_OF_DATE + asOfChoices = asOfChoices[asOfChoices >= minChoice] + } else if(input$location %in% TERRITORIES || input$location == TOTAL_LOCATIONS || input$scoreType == 'coverage') { + minChoice = MIN_AVAIL_TERRITORY_AS_OF_DATE + asOfChoices = asOfChoices[asOfChoices >= minChoice] + } + # Make sure we have a valid as of selection + if (length(asOfChoices) != 0 && !(as.Date(selectedAsOf) %in% asOfChoices)) { + selectedAsOf = max(asOfChoices, na.rm=TRUE) + } + updateSelectInput(session, "asOf", + choices = sort(asOfChoices), + selected = selectedAsOf) + } export_scores_server(input, output, df) } @@ -625,7 +844,7 @@ updateLocationChoices = function(session, df, targetVariable, forecasterChoices, locationChoices = unique(toupper(df$geo_value)) locationChoices = locationChoices[c(length(locationChoices), (1:length(locationChoices)-1))] # Move US to front of list locationChoices = c(TOTAL_LOCATIONS, locationChoices) - # Ensure previsouly selected options are still allowed + # Ensure previously selected options are still allowed if (locationInput %in% locationChoices) { selectedLocation = locationInput } else { diff --git a/dashboard/common.R b/dashboard/common.R index 8d15859..ba763a4 100644 --- a/dashboard/common.R +++ b/dashboard/common.R @@ -32,7 +32,7 @@ renameScoreCol = function(filteredScoreDf, scoreType, coverageInterval) { } -filterOverAllLocations = function(filteredScoreDf, scoreType) { +filterOverAllLocations = function(filteredScoreDf, scoreType, hasAsOfData = FALSE) { locationsIntersect = list() filteredScoreDf = filteredScoreDf %>% filter(!is.na(Score)) # Create df with col for all locations across each unique date, ahead and forecaster combo @@ -46,14 +46,26 @@ filterOverAllLocations = function(filteredScoreDf, scoreType) { 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)) + if (hasAsOfData) { + filteredScoreDf = filteredScoreDf %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = sum(Score)/length(locationsIntersect), actual = sum(actual), as_of_actual = sum(as_of_actual)) + } else { + filteredScoreDf = filteredScoreDf %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = sum(Score)/length(locationsIntersect), actual = sum(actual)) + } } else { + if (hasAsOfData) { + filteredScoreDf = filteredScoreDf %>% + group_by(forecaster, forecast_date, target_end_date, ahead) %>% + summarize(Score = sum(Score), actual = sum(actual), as_of_actual = sum(as_of_actual)) + } else { filteredScoreDf = filteredScoreDf %>% group_by(forecaster, forecast_date, target_end_date, ahead) %>% summarize(Score = sum(Score), actual = sum(actual)) + } } return (list(filteredScoreDf, locationsIntersect)) } diff --git a/dashboard/www/style.css b/dashboard/www/style.css index fa20980..e715fc3 100644 --- a/dashboard/www/style.css +++ b/dashboard/www/style.css @@ -99,10 +99,16 @@ #scale-score { font-weight: bold; } -#loading-message { +#data-loading-message { font-style: italic; font-size: 18px; } +#truth-plot-loading-message { + margin-top:50px; + font-size: 18px; + font-style:italic; + color: #949494; +} @media (max-width: 1450px) { #github-logo-container { diff --git a/docker_dashboard/Dockerfile b/docker_dashboard/Dockerfile index f70d71c..48ffbb6 100644 --- a/docker_dashboard/Dockerfile +++ b/docker_dashboard/Dockerfile @@ -3,7 +3,7 @@ LABEL org.opencontainers.image.source = "https://github.com/cmu-delphi/forecast- ADD docker_dashboard/shiny_server.conf /etc/shiny-server/shiny-server.conf -RUN install2.r plotly shinyjs tsibble viridis aws.s3 +RUN install2.r plotly shinyjs tsibble viridis aws.s3 covidcast COPY dist/*rds /srv/shiny-server/ COPY dashboard/* /srv/shiny-server/