Merge branch 'ndefries/training-date-from-model' into ndefries/bc-input-file-dates

Author: nmdefries

backfill_corrections/delphiBackfillCorrection/R/beta_prior_estimation.R

@@ -48,7 +48,8 @@ objective <- function(theta, x, prob, ...) {
 #' @param start the initialization of the the points in nlm
 #' @param base_pseudo_denom the pseudo counts added to denominator if little data for training
 #' @param base_pseudo_num the pseudo counts added to numerator if little data for training
-#' @param training_end_date the most recent training date
+#' @template training_end_date-template
+#' @template training_start_date-template
 #' @param model_save_dir directory containing trained models
 #' 
 #' @importFrom stats nlm predict
@@ -58,7 +59,8 @@ objective <- function(theta, x, prob, ...) {
 est_priors <- function(train_data, prior_test_data, geo, value_type, dw, taus, 
                        covariates, response, lp_solver, lambda, 
                        indicator, signal, geo_level, signal_suffix, 
-                       training_end_date, model_save_dir, start=c(0, log(10)),
+                       training_end_date, training_start_date,
+                       model_save_dir, start=c(0, log(10)),
                        base_pseudo_denom=1000, base_pseudo_num=10,
                        train_models = TRUE, make_predictions = TRUE) {
   sub_train_data <- train_data %>% filter(train_data[[dw]] == 1)
@@ -76,6 +78,7 @@ est_priors <- function(train_data, prior_test_data, geo, value_type, dw, taus,
                                            geo=geo, dw=dw, tau=tau,
                                            value_type=value_type,
                                            training_end_date=training_end_date,
+                                           training_start_date=training_start_date,
                                            beta_prior_mode=TRUE)
       model_path <- file.path(model_save_dir, model_file_name)
 
@@ -123,7 +126,8 @@ frac_adj_with_pseudo <- function(data, dw, pseudo_num, pseudo_denom, num_col, de
 #' @template train_data-template
 #' @param test_data testing data
 #' @param prior_test_data testing data for the lag -1 model
-#' @param training_end_date the most recent training date
+#' @template training_end_date-template
+#' @template training_start_date-template
 #' @param model_save_dir directory containing trained models
 #' @template indicator-template
 #' @template signal-template
@@ -141,7 +145,8 @@ frac_adj_with_pseudo <- function(data, dw, pseudo_num, pseudo_denom, num_col, de
 frac_adj <- function(train_data, test_data, prior_test_data, 
                      indicator, signal, geo_level, signal_suffix,
                      lambda, value_type, geo, 
-                     training_end_date, model_save_dir, 
+                     training_end_date, training_start_date,
+                     model_save_dir,
                      taus, lp_solver,
                      train_models = TRUE,
                      make_predictions = TRUE) {
@@ -177,7 +182,7 @@ frac_adj <- function(train_data, test_data, prior_test_data,
     pseudo_counts <- est_priors(train_data, prior_test_data, geo, value_type, cov, taus, 
                                 pre_covariates, "log_value_target", lp_solver, lambda, 
                                 indicator, signal, geo_level, signal_suffix, 
-                                training_end_date, model_save_dir,
+                                training_end_date, training_start_date, model_save_dir,
                                 train_models = train_models,
                                 make_predictions = make_predictions)
     pseudo_denum = pseudo_counts[1]

backfill_corrections/delphiBackfillCorrection/R/io.R

@@ -22,17 +22,19 @@ read_data <- function(input_dir) {
 #' @template lambda-template
 #' @template value_type-template
 #' @template export_dir-template
-#' @param training_end_date the most recent training date
+#' @template training_end_date-template
+#' @template training_start_date-template
 #'
 #' @importFrom readr write_csv
 #' @importFrom stringr str_interp str_split
 export_test_result <- function(test_data, coef_data, indicator, signal, 
                                geo_level, geo, signal_suffix, lambda,
-                               training_end_date,
+                               training_end_date, training_start_date,
                                value_type, export_dir) {
   base_name <- generate_filename(indicator=indicator, signal=signal,
                                  geo_level=geo_level, signal_suffix=signal_suffix,
                                  lambda=lambda, training_end_date=training_end_date,
+                                 training_start_date=training_start_date,
                                  geo=geo, value_type=value_type, model_mode=FALSE)
 
   signal_info <- str_interp("indicator ${indicator} signal ${signal} geo ${geo} value_type ${value_type}")
@@ -102,13 +104,13 @@ subset_valid_files <- function(files_list, file_type = c("daily", "rollup"), par
   switch(file_type,
          daily = {
            start_issue_dates <- as.Date(
-             sub("^.*/.*_as_of_([0-9]{8}).parquet$", "\\1", files_list),
+             sub("^.*/.*_as_of_([0-9]{8})[.]parquet$", "\\1", files_list),
              format = date_format
            )
            end_issue_dates <- start_issue_dates
          },
          rollup = {
-           rollup_pattern <- "^.*/.*_from_([0-9]{8})_to_([0-9]{8}).parquet$"
+           rollup_pattern <- "^.*/.*_from_([0-9]{8})_to_([0-9]{8})[.]parquet$"
            start_issue_dates <- as.Date(
              sub(rollup_pattern, "\\1", files_list),
              format = date_format
@@ -187,7 +189,7 @@ create_name_pattern <- function(indicator, signal,
                                 file_type = c("daily", "rollup")) {
   file_type <- match.arg(file_type)
   switch(file_type,
-         daily = str_interp("${indicator}_${signal}_as_of_[0-9]{8}.parquet$"),
-         rollup = str_interp("${indicator}_${signal}_from_[0-9]{8}_to_[0-9]{8}.parquet$")
+         daily = str_interp("${indicator}_${signal}_as_of_[0-9]{8}[.]parquet$"),
+         rollup = str_interp("${indicator}_${signal}_from_[0-9]{8}_to_[0-9]{8}[.]parquet$")
   )
 }

backfill_corrections/delphiBackfillCorrection/R/main.R

@@ -17,10 +17,6 @@
 run_backfill <- function(df, params,
                          refd_col = "time_value", lag_col = "lag", issued_col = "issue_date",
                          signal_suffixes = c(""), indicator = "", signal = "") {
-  result <- get_training_date_range(params)
-  training_start_date <- result$training_start_date
-  training_end_date <- result$training_end_date
-
   df <- filter(df, .data$lag < params$ref_lag + 30) # a rough filtration to save memory
 
   geo_levels <- params$geo_levels
@@ -118,9 +114,9 @@ run_backfill <- function(df, params,
           combined_df <- combined_df %>% filter(.data$lag < params$ref_lag)
 
           geo_train_data <- combined_df %>%
-            filter(.data$issue_date < training_end_date) %>%
-            filter(.data$target_date <= training_end_date) %>%
-            filter(.data$target_date > training_start_date) %>%
+            filter(.data$issue_date < params$training_end_date) %>%
+            filter(.data$target_date <= params$training_end_date) %>%
+            filter(.data$target_date > params$training_start_date) %>%
             drop_na()
           geo_test_data <- combined_df %>%
             filter(.data$issue_date %in% params$test_dates) %>%
@@ -138,7 +134,8 @@ run_backfill <- function(df, params,
                                      indicator = indicator, signal = signal,
                                      geo_level = geo_level, signal_suffix = signal_suffix,
                                      lambda = params$lambda, value_type = value_type, geo = geo,
-                                     training_end_date = training_end_date,
+                                     training_end_date = params$training_end_date,
+                                     training_start_date = params$training_start_date,
                                      model_save_dir = params$cache_dir,
                                      taus = params$taus,
                                      lp_solver = params$lp_solver,
@@ -181,7 +178,9 @@ run_backfill <- function(df, params,
               lambda = params$lambda, test_lag = test_lag, geo = geo,
               value_type = value_type, model_save_dir = params$cache_dir,
               indicator = indicator, signal = signal, geo_level = geo_level,
-              signal_suffix =signal_suffix, training_end_date = training_end_date,
+              signal_suffix =signal_suffix,
+              training_end_date = params$training_end_date,
+              training_start_date = params$training_start_date,
               train_models = params$train_models,
               make_predictions = params$make_predictions
             )
@@ -210,10 +209,12 @@ run_backfill <- function(df, params,
             test_combined <- bind_rows(test_data_list[[key]]) 
             coef_combined <- bind_rows(coef_list[[key]]) 
             export_test_result(test_combined, coef_combined, 
-                               indicator, signal, 
-                               geo_level, geo, signal_suffix, params$lambda,
-                               training_end_date,
-                               value_type, export_dir=params$export_dir)
+                               indicator=indicator, signal=signal,
+                               geo_level=geo_level, geo=geo,
+                               signal_suffix=signal_suffix, lambda=params$lambda,
+                               training_end_date=params$training_end_date,
+                               training_start_date=params$training_start_date,
+                               value_type=value_type, export_dir=params$export_dir)
           }
         }
       }
@@ -239,7 +240,7 @@ main <- function(params) {
 
   if (params$train_models) {
     msg_ts("Removing stored models")
-    files_list <- list.files(params$cache_dir, pattern="*.model", full.names = TRUE)
+    files_list <- list.files(params$cache_dir, pattern="[.]model$", full.names = TRUE)
     file.remove(files_list)
   }
 
@@ -254,7 +255,13 @@ main <- function(params) {
       options(mc.cores = min(params$parallel_max_cores, max(floor(cores / 2), 1L)))
     }
   }
-  
+
+  # Training start and end dates are the same for all indicators, so we can fetch
+  # at the beginning.
+  result <- get_training_date_range(params)
+  params$training_start_date <- result$training_start_date
+  params$training_end_date <- result$training_end_date
+
   # Loop over every indicator + signal combination.
   for (group_i in seq_len(nrow(INDICATORS_AND_SIGNALS))) {
     input_group <- INDICATORS_AND_SIGNALS[group_i,]

backfill_corrections/delphiBackfillCorrection/R/model.R

@@ -89,7 +89,8 @@ add_sqrtscale<- function(train_data, test_data, max_raw, value_col) {
 #' @template train_models-template
 #' @template make_predictions-template
 #' @param model_save_dir directory containing trained models
-#' @param training_end_date Most recent training date
+#' @template training_end_date-template
+#' @template training_start_date-template
 #'
 #' @importFrom stats predict coef
 #' @importFrom stringr str_interp
@@ -101,6 +102,7 @@ model_training_and_testing <- function(train_data, test_data, taus, covariates,
                                        indicator, signal, 
                                        geo_level, signal_suffix,
                                        training_end_date, 
+                                       training_start_date,
                                        train_models = TRUE,
                                        make_predictions = TRUE) {
   success = 0
@@ -112,6 +114,7 @@ model_training_and_testing <- function(train_data, test_data, taus, covariates,
         model_file_name <- generate_filename(indicator=indicator, signal=signal,
                                  geo_level=geo_level, signal_suffix=signal_suffix,
                                  lambda=lambda, training_end_date=training_end_date,
+                                 training_start_date=training_start_date,
                                  geo=geo, value_type=value_type,
                                  test_lag=test_lag, tau=tau)
         model_path <- file.path(model_save_dir, model_file_name)
@@ -220,15 +223,16 @@ get_model <- function(model_path, train_data, covariates, tau,
 #' @param tau decimal quantile to be predicted. Values must be between 0 and 1.
 #' @param beta_prior_mode bool, indicate whether it is for a beta prior model
 #' @param model_mode bool, indicate whether the file name is for a model
-#' @param training_end_date the most recent training date
+#' @template training_end_date-template
+#' @template training_start_date-template
 #'
 #' @return path to file containing model object
 #'
 #' @importFrom stringr str_interp
 #' 
 generate_filename <- function(indicator, signal, 
                               geo_level, signal_suffix, lambda,
-                              training_end_date="", geo="", 
+                              training_end_date, training_start_date, geo="",
                               value_type = "", test_lag="", tau="", dw="",
                               beta_prior_mode = FALSE, model_mode = TRUE) {
   if (lambda != "") {
@@ -250,7 +254,8 @@ generate_filename <- function(indicator, signal,
   } else {
     file_type <- ".csv.gz"
   }
-  components <- c(as.character(training_end_date), beta_prior,
+  components <- c(format(training_end_date, "%Y%m%d"),
+                  format(training_start_date, "%Y%m%d"), beta_prior,
                   indicator, signal, signal_suffix,
                   geo_level, lambda, value_type,
                   geo, test_lag, dw, tau)
@@ -265,8 +270,10 @@ generate_filename <- function(indicator, signal,
 
 #' Get date range of data to use for training models
 #'
-#' Calculate training end date, input data start date, and input
-#' data end date based on user settings.
+#' Calculate training start and end dates based on user settings.
+#' `training_start_date` is the minimum allowed target date when selecting
+#' training data to use. `training_end_date` is the maximum allowed target
+#' date and maximum allowed issue date.
 #'
 #' Cases:
 #'   1. We are training new models.
@@ -290,20 +297,26 @@ get_training_date_range <- function(params) {
       training_end_date <- default_end_date
     }
   } else {
-    # Get end date from cached model files.
-    # Assumes filename format like `2022-06-28_changehc_covid_state_lambda0.1_count_ca_lag5_tau0.9.model`
-    # where the leading date is the training end date for that model.
-    model_files <- list.files(params$cache_dir, "202[0-9]-[0-9]{2}-[0-9]{2}*.model")
+    # Get end date from cached model files. Assumes filename format like
+    # `20220628_20220529_changehc_covid_state_lambda0.1_count_ca_lag5_tau0.9.model`
+    # where the leading date is the training end date for that model, and the
+    # second date is the training start date.
+    model_files <- list.files(params$cache_dir, "^202[0-9]{5}_202[0-9]{5}.*[.]model$")
     if (length(model_files) == 0) {
       # We know we'll be retraining models today.
       training_end_date <- default_end_date
     } else {
       # If only some models are in the cache, they will be used and those
       # missing will be regenerated as-of the training end date.
-      training_end_date <- max(as.Date(substr(model_files, 1, 10)))
+      training_end_date <- max(as.Date(substr(model_files, 1, 8), "%Y%m%d"))
     }
   }
 
+  # Calculate start date instead of reading from cached files. This assumes
+  # that the user-provided `params$training_days` is more up-to-date. If
+  # `params$training_days` has changed such that for a given training end
+  # date, the calculated training start date differs from the start date
+  # referenced in cached file names, then those cached files will not be used.
   training_start_date <- training_end_date - params$training_days
 
   msg_ts(paste0(

backfill_corrections/delphiBackfillCorrection/man-roxygen/training_end_date-template.R

@@ -0,0 +1 @@
+#' @param training_end_date the latest target date and issue date included in training data

backfill_corrections/delphiBackfillCorrection/man-roxygen/training_start_date-template.R

@@ -0,0 +1 @@
+ #' @param training_start_date the earliest target date included in training data