Limit scoring to last year (#3053)

.github/workflows/scoring.yml

@@ -25,7 +25,7 @@ jobs:
     - uses: r-lib/actions/setup-renv@v2
 
     - name: Create score csv
-      run: Rscript 'code/evaluation/score_models.r'
+      run: Rscript 'code/evaluation/score_models.r' -l 52
 
     - name: Create summary csv
       run: Rscript 'code/evaluation/aggregate_scores.r'

code/evaluation/aggregate_scores.r

@@ -13,7 +13,7 @@ Usage:
 
 Options:
     -h, --help                   Show this screen
-    -s --histories <histories>   Weeks of history to produce, separated by commas (default: 10,Inf)
+    -s --histories <histories>   Weeks of history to produce, separated by commas (default: 10,52)
     -w --restrict-weeks <weeks>  Number of recent weeks of submission to require (default: 4)
     -r --re-run                  If given, will re-run all dates instead of just the latest
 
@@ -29,7 +29,7 @@ if (interactive()) {
 }
 
 ## default options
-histories_str <- ifelse(is.null(opts$histories), "10,Inf", opts$histories)
+histories_str <- ifelse(is.null(opts$histories), "10,52", opts$histories)
 histories <- as.numeric(unlist(strsplit(histories_str, split = ",")))
 restrict_weeks <-
   ifelse(is.null(opts$restrict_weeks), 4L, as.integer(opts$restrict_weeks))

code/evaluation/load_and_score_models.r

@@ -6,15 +6,22 @@ suppressMessages(library(scoringutils))
 suppressMessages(library(covidHubUtils))
 suppressMessages(library(EuroForecastHub))
 
-load_and_score_models <- function(subdir = "") {
+load_and_score_models <- function(subdir = "", limit = NULL) {
 
   data_types <- get_hub_config("target_variables")
 
+  if (is.null(limit)) {
+    dates <- NULL
+  } else {
+    dates <- seq(today() - weeks(limit), today(), by = "day")
+  }
+
   ## load forecasts --------------------------------------------------------------
   forecasts <- load_forecasts(
     source = "local_hub_repo",
     hub_repo_path = here(subdir),
-    hub = "ECDC"
+    hub = "ECDC",
+    dates = dates
   ) %>%
     ## set forecast date to corresponding submission date
     mutate(forecast_date = ceiling_date(forecast_date, "week", week_start = 2) - 1) %>%
@@ -27,6 +34,11 @@ load_and_score_models <- function(subdir = "") {
     EuroForecastHub::add_status() %>%
     filter(status == "final")
 
+  if (!is.null(limit)) {
+    raw_truth <- raw_truth |>
+      filter(target_end_date > today() - weeks(limit))
+  }
+
   ## get anomalies
   anomalies <- read_csv(here("data-truth", "anomalies", "anomalies.csv"))
   truth <- anti_join(raw_truth, anomalies) %>%

code/evaluation/score_models.r

@@ -1,5 +1,6 @@
 #! /usr/bin/env RScript
 suppressMessages(library("here"))
+suppressMessages(library("lubridate"))
 suppressMessages(library("docopt"))
 
 source(here("code", "evaluation", "load_and_score_models.r"))
@@ -8,10 +9,11 @@ source(here("code", "evaluation", "load_and_score_models.r"))
 ## e.g. Rscript code/evaluation/score_models.r ensembles
 'Produce date-by-date and model-by-model scores
 Usage:
-    score_models.r [<subdir>]
+    score_models.r [<subdir>] [-l limit]
 
 Options:
     -h --help Show this screen
+    -l --limit Limit to the recent "limit" number of weeks
 
 Arguments:
     subdir Subdirectory in which to score models if not scoring
@@ -25,7 +27,8 @@ if (interactive()) {
 }
 
 subdir <- ifelse(is.null(opts$subdir), "", opts$subdir)
+limit <- opts$limit
 
 suppressWarnings(dir.create(here(subdir, "evaluation")))
-scores <- load_and_score_models(subdir)
+scores <- load_and_score_models(subdir, limit = limit)
 write_csv(scores, here(subdir, "evaluation", "scores.csv"))