Merge pull request #144 from cmu-delphi/release_v3.0

Release v3.0

Author: kateharwood

.github/workflows/s3_upload.yml

@@ -1,6 +1,6 @@
 Package: forecast-eval
 Title: Forecast Evaluation Dashboard
-Version: 2.1
+Version: 3
 Authors@R: person("Kate", "Harwood",
                   role = c("cre")), 
 	   person("Chris", "Scott",

DESCRIPTION

@@ -5,7 +5,7 @@ S3_BUCKET=s3://forecast-eval
 build: build_dashboard
 
 r_build:
-	docker build -t forecast-eval-build docker_build
+	docker build --no-cache --pull -t forecast-eval-build docker_build
 
 predictions_cards.rds score_cards_state_deaths.rds score_cards_state_cases.rds score_cards_nation_cases.rds score_cards_nation_deaths.rds: dist
 	test -f dist/$@ || curl -o dist/$@ $(S3_URL)/$@ 
@@ -32,18 +32,18 @@ deploy: score_forecast
 
 # Starts a docker image with a full preconfigured R environment
 start_dev: r_build
-	docker run -ti --rm \
+	docker run --pull=always -ti --rm \
 		-v ${PWD}/Report:/var/forecast-eval \
 		-v ${PWD}/dashboard:/var/forecast-eval-dashboard \
 		-v ${PWD}/dist:/var/dist \
 		-w /var/forecast-eval \
 		ghcr.io/cmu-delphi/forecast-eval:latest bash
 
 build_dashboard_dev: pull_data
-	docker build -t ghcr.io/cmu-delphi/forecast-eval:latest -f docker_dashboard/Dockerfile .
+	docker build --no-cache --pull -t ghcr.io/cmu-delphi/forecast-eval:latest -f docker_dashboard/Dockerfile .
 
 build_dashboard: pull_data
-	docker build --no-cache=true -t ghcr.io/cmu-delphi/forecast-eval:$(imageTag) -f docker_dashboard/Dockerfile .
+	docker build --no-cache=true --pull -t ghcr.io/cmu-delphi/forecast-eval:$(imageTag) -f docker_dashboard/Dockerfile .
 
 deploy_dashboard: build_dashboard
 	docker push ghcr.io/cmu-delphi/forecast-eval:$(imageTag)

Makefile

@@ -49,6 +49,8 @@ git tag -a v1.0 -m "Version 1.0"
 git push origin release_v1.0
 git push origin v1.0
 ```
+Create a PR into `main`.  
+After code is merged to `main`, perform cleanup by merging `main` into `dev` so that `dev` stays up to date.
 
 ## Note on Scoring Script
 

README.md

@@ -23,29 +23,45 @@ prediction_cards_filepath = case_when(
     TRUE~prediction_cards_filename
 )
 
-forecasters = c(get_covidhub_forecaster_names(designations = "primary"),
-                "COVIDhub-baseline")
+forecasters = unique(c(get_covidhub_forecaster_names(designations = c("primary", "secondary")),
+                "COVIDhub-baseline", "COVIDhub-trained_ensemble"))
 locations = covidHubUtils::hub_locations
 
 # also includes "us", which is national level data
 state_geos = locations %>%
                 filter(nchar(.data$geo_value) == 2) %>%
                 pull(.data$geo_value)
 signals = c("confirmed_incidence_num",
-            "deaths_incidence_num")
+            "deaths_incidence_num",
+            "confirmed_admissions_covid_1d")
 
 predictions_cards = get_covidhub_predictions(forecasters,
                                              signal = signals,
+                                             ahead = 1:28,
                                              geo_values = state_geos,
                                              verbose = TRUE,
-                                             use_disk = TRUE)
+                                             use_disk = TRUE) %>% 
+    filter(!(incidence_period == "epiweek" & ahead > 4))
+
+predictions_cards = predictions_cards %>%
+    filter(!is.na(target_end_date)) %>%
+    filter(target_end_date < today())
+
+# For hospitalizations, drop all US territories except Puerto Rico and the
+# Virgin Islands; HHS does not report data for any territories except PR and VI.
+territories <- c("as", "gu", "mp", "fm", "mh", "pw", "um")
 predictions_cards = predictions_cards %>%
-    filter(!is.na(predictions_cards$target_end_date))
-predictions_cards = predictions_cards %>% filter(target_end_date < today())
+    filter(!(geo_value %in% territories & data_source == "hhs"))
 
-# Only accept forecasts made Monday or earlier
+# For epiweek predictions, only accept forecasts made Monday or earlier.
+# target_end_date is the date of the last day (Saturday) in the epiweek
+# For daily predictions, accept any forecast where the target_end_date is later
+# than the forecast_date.
 predictions_cards = predictions_cards %>%
-    filter(target_end_date - (forecast_date + 7 * ahead) >= -2)
+    filter(
+        (incidence_period == "epiweek" & target_end_date - (forecast_date + 7 * ahead) >= -2) |
+            (incidence_period == "day" & target_end_date > forecast_date)
+    )
 
 # And only a forecaster's last forecast if multiple were made
 predictions_cards = predictions_cards %>%
@@ -56,7 +72,7 @@ class(predictions_cards) = c("predictions_cards", class(predictions_cards))
 
 print("Saving predictions...")
 saveRDS(predictions_cards,
-        file = "predictions_cards.rds",
+        file = prediction_cards_filepath,
         compress = "xz")
 print("Predictions saved")
 
@@ -76,7 +92,10 @@ err_measures = c(wis = weighted_interval_score,
                  underprediction = underprediction,
                  sharpness = sharpness,
                  ae = absolute_error,
-                 coverage_functions)
+                 coverage_functions,
+                 value_20 = get_quantile_prediction_factory(0.2),
+                 value_50 = get_quantile_prediction_factory(0.5),
+                 value_80 = get_quantile_prediction_factory(0.8))
 
 nation_predictions = predictions_cards %>% filter(geo_value == "us")
 state_predictions = predictions_cards %>% filter(geo_value != "us")
@@ -91,22 +110,54 @@ state_scores = evaluate_covid_predictions(state_predictions,
                                           geo_type = "state")
 
 source("score.R")
-print("Saving state confirmed incidence...")
-save_score_cards(state_scores, "state", signal_name = "confirmed_incidence_num",
-                 output_dir = opt$dir)
-print("Saving state deaths incidence...")
-save_score_cards(state_scores, "state", signal_name = "deaths_incidence_num",
-                 output_dir = opt$dir)
+if ( "confirmed_incidence_num" %in% unique(state_scores$signal)) {
+    print("Saving state confirmed incidence...")
+    save_score_cards(state_scores, "state", signal_name = "confirmed_incidence_num",
+                     output_dir = opt$dir)
+} else {
+    warning("State confirmed incidence should generally be available. Please 
+            verify that you expect not to have any cases incidence forecasts")
+}
+if ( "deaths_incidence_num" %in% unique(state_scores$signal)) {
+    print("Saving state deaths incidence...")
+    save_score_cards(state_scores, "state", signal_name = "deaths_incidence_num",
+                     output_dir = opt$dir)
+} else {
+    warning("State deaths incidence should generally be available. Please 
+            verify that you expect not to have any deaths incidence forecasts")
+}
+if ( "confirmed_admissions_covid_1d" %in% unique(state_scores$signal)) {
+    print("Saving state hospitalizations...")
+    save_score_cards(state_scores, "state", signal_name = "confirmed_admissions_covid_1d",
+                     output_dir = opt$dir)
+}
+
 
 print("Evaluating national forecasts")
 # COVIDcast does not return national level data, using CovidHubUtils instead
+
 nation_scores = evaluate_chu(nation_predictions, signals, err_measures)
 
-print("Saving nation confirmed incidence...")
-save_score_cards(nation_scores, "nation",
-                 signal_name = "confirmed_incidence_num", output_dir = opt$dir)
-print("Saving nation deaths incidence...")
-save_score_cards(nation_scores, "nation", signal_name = "deaths_incidence_num",
-                 output_dir = opt$dir)
+if ( "confirmed_incidence_num" %in% unique(state_scores$signal)) {
+    print("Saving nation confirmed incidence...")
+    save_score_cards(nation_scores, "nation",
+                     signal_name = "confirmed_incidence_num", output_dir = opt$dir)
+} else {
+    warning("Nation confirmed incidence should generally be available. Please 
+            verify that you expect not to have any cases incidence forecasts")
+}
+if ( "deaths_incidence_num" %in% unique(state_scores$signal)) {
+    print("Saving nation deaths incidence...")
+    save_score_cards(nation_scores, "nation", signal_name = "deaths_incidence_num",
+                     output_dir = opt$dir)
+} else {
+    warning("Nation deaths incidence should generally be available. Please 
+            verify that you expect not to have any deaths incidence forecasts")
+}
+if ( "confirmed_admissions_covid_1d" %in% unique(state_scores$signal)) {
+    print("Saving nation hospitalizations...")
+    save_score_cards(nation_scores, "nation", signal_name = "confirmed_admissions_covid_1d",
+                     output_dir = opt$dir)
+}
 
 print("Done")

Report/create_reports.R

@@ -72,6 +72,23 @@ find_quantile_match <- function(quantiles, val_to_match, tol=1e-8){
   return(abs(quantiles - val_to_match) < tol  & !is.na(quantiles))
 }
 
+get_quantile_prediction_factory <- function(val_to_match, tol=1e-8) {
+  get_quantile_prediction <- function(quantile, value, actual_value) {
+    if (all(is.na(quantile))) return(NA)
+
+    value <- value[!is.na(quantile)]
+    quantile <- quantile[!is.na(quantile)]
+    
+    val <- value[find_quantile_match(quantile, val_to_match, tol)]
+    
+    if (length(val) != 1L) return(NA)
+    
+    return(val)
+  }
+  
+  return(get_quantile_prediction)
+}
+
 score_func_param_checker <- function(quantiles, values, actual_value, id = ""){
   id_str = paste0(id, ": ")
   if (length(actual_value) > 1) {

Report/error_measures.R

@@ -3,7 +3,8 @@ library("assertthat")
 
 save_score_cards = function(score_card, geo_type = c("state", "nation"),
                               signal_name = c("confirmed_incidence_num",
-                                              "deaths_incidence_num"),
+                                              "deaths_incidence_num",
+                                              "confirmed_admissions_covid_1d"),
                               output_dir = ".") {
   signal_name = match.arg(signal_name)
   geo_type = match.arg(geo_type)
@@ -13,11 +14,11 @@ save_score_cards = function(score_card, geo_type = c("state", "nation"),
   assert_that(signal_name %in% signals,
                 msg = "signal is not in score_card")
   score_card = score_card %>% filter(signal == signal_name)
-  if (signal_name == "confirmed_incidence_num") {
-    sig_suffix = "cases"
-  } else {
-    sig_suffix = "deaths"
-  }
+  
+  type_map <- list("confirmed_incidence_num" = "cases",
+                     "deaths_incidence_num" = "deaths",
+                     "confirmed_admissions_covid_1d" = "hospitalizations")
+  sig_suffix <- type_map[[signal_name]]
   output_file_name = file.path(output_dir,
                                paste0("score_cards_", geo_type, "_",
                                       sig_suffix, ".rds"))
@@ -37,20 +38,25 @@ save_score_cards = function(score_card, geo_type = c("state", "nation"),
 
 evaluate_chu = function(predictions, signals, err_measures) {
   allowed_signals = c("confirmed_incidence_num",
-                      "deaths_incidence_num")
+                      "deaths_incidence_num",
+                      "confirmed_admissions_covid_1d")
   assert_that(all(signals %in% allowed_signals),
               msg = paste("Signal not allowed:",
                           setdiff(signals, allowed_signals)))
+  
+  target_map <- list("confirmed_incidence_num" = "inc case",
+                     "deaths_incidence_num" = "inc death",
+                     "confirmed_admissions_covid_1d" = "inc hosp")
+  source_map <- list("confirmed_incidence_num" = "JHU",
+                     "deaths_incidence_num" = "JHU",
+                     "confirmed_admissions_covid_1d" = "HealthData")
   scores = c()
   for (signal_name in signals) {
     preds_signal = predictions %>%
       filter(signal == signal_name)
-    if (signal_name == "confirmed_incidence_num") {
-      jhu_signal = "inc case"
-    } else {
-      jhu_signal = "inc death"
-    }
-    chu_truth = covidHubUtils::load_truth("JHU", jhu_signal)
+    signal <- target_map[[signal_name]]
+    source <- source_map[[signal_name]]
+    chu_truth = covidHubUtils::load_truth(source, signal)
     chu_truth = chu_truth %>%
       rename(actual = value) %>%
       select(-c(model,