Merge pull request #1712 from cmu-delphi/ndefries/bc-input-file-dates

Make input file filter rely on user inputs

Author: krivard

backfill_corrections/delphiBackfillCorrection/NAMESPACE

@@ -5,6 +5,7 @@ export(add_dayofweek)
 export(add_shift)
 export(add_sqrtscale)
 export(add_weekofmonth)
+export(assert)
 export(create_dir_not_exist)
 export(data_filteration)
 export(evaluate)

backfill_corrections/delphiBackfillCorrection/R/constants.R

@@ -3,7 +3,7 @@ TAUS <- c(0.01, 0.025, 0.1, 0.25, 0.5, 0.75, 0.9, 0.975, 0.99)
 REF_LAG <- 60
 TEST_LAGS <- c(1:14, 21, 35, 51)
 TRAINING_DAYS <- 270
-TESTING_WINDOW <- 14
+TESTING_WINDOW <- 1
 LAG_WINDOW <- 5
 LAMBDA <- 0.1
 LAG_PAD <- 2

backfill_corrections/delphiBackfillCorrection/R/io.R

@@ -108,42 +108,86 @@ get_files_list <- function(indicator, signal, params, sub_dir) {
 subset_valid_files <- function(files_list, file_type = c("daily", "rollup"), params) {
   file_type <- match.arg(file_type)
   date_format = "%Y%m%d"
+
+  # Put min and max issue date for each file into vectors the same length as
+  # `files_list`.
   switch(file_type,
          daily = {
-           start_dates <- as.Date(
+           start_issue_dates <- as.Date(
              sub("^.*/.*_as_of_([0-9]{8})[.]parquet$", "\\1", files_list),
              format = date_format
            )
-           end_dates <- start_dates
+           end_issue_dates <- start_issue_dates
          },
          rollup = {
            rollup_pattern <- "^.*/.*_from_([0-9]{8})_to_([0-9]{8})[.]parquet$"
-           start_dates <- as.Date(
+           start_issue_dates <- as.Date(
              sub(rollup_pattern, "\\1", files_list),
              format = date_format
            )
-           end_dates <- as.Date(
+           end_issue_dates <- as.Date(
              sub(rollup_pattern, "\\2", files_list),
              format = date_format
            )
          }
   )
 
-  ## TODO: right now, this gets both training and testing data regardless of
-  #  which mode is selected
-  n_addl_days <- params$ref_lag + params$training_days
-  start_date <- TODAY - n_addl_days
-  end_date <- TODAY - 1
-  
+  # Find the earliest and latest issue dates needed for either training or testing.
+  result <- get_issue_date_range(params)
+  start_issue <- result$start_issue
+  end_issue <- result$end_issue
+
   # Only keep files with data that falls at least somewhat between the desired
-  # start and end range dates.
+  # start and end issue dates.
   files_list <- files_list[
-    !(( start_dates < start_date & end_dates < start_date ) | 
-        ( start_dates > end_date & end_dates > end_date ))]
-  
+    !(( start_issue_dates < start_issue & end_issue_dates < start_issue ) |
+        ( start_issue_dates > end_issue & end_issue_dates > end_issue ))]
+
   return(files_list)
 }
 
+#' Find the earliest and latest issue dates needed for either training or testing.
+#'
+#' With current logic, we always need to include data for model training (in
+#' case cached models are not available for a "make_predictions"-only run and
+#' we need to train new models).
+#'
+#' We generate test and train data by applying the following filters:
+#'   - Test data is data where issue_date is in params$test_dates
+#'     (as a continuous filter, min(params$test_dates) <= issue_date <= max(params$test_dates) )
+#'   - Train data is data where issue_date < training_end_date; and
+#'     training_start_date < target_date <= training_end_date
+#'
+#' Train data doesn't have an explicit lower bound on issue_date, but we can
+#' derive one.
+#'
+#' Since target_date = reference_date + params$ref_lag and issue_date >=
+#' reference_date, the requirement that training_start_date < target_date
+#' also implies that issue date must be > training_start_date - params$ref_lag
+#'
+#' @template params-template
+get_issue_date_range <- function(params) {
+  result <- get_training_date_range(params)
+
+  # Check that all training data is earlier than the earliest test date.
+  #
+  # It's inappropriate to make predictions of historical data based on a model
+  # trained using future data. If we want to make predictions for an old test
+  # date t0 (t0 < TODAY), we will always need to train a new model based on
+  # data t < t0.
+  assert(
+    result$training_end_date <= min(params$test_dates),
+    "training end date must be earlier than the earliest test date to produce valid predictions"
+  )
+
+  ## TODO: right now, this gets both training and testing data regardless of
+  #  which mode is selected
+  start_issue <- result$training_start_date - params$ref_lag
+  end_issue <- max(params$test_dates)
+
+  return(list("start_issue" = start_issue, "end_issue" = end_issue))
+}
+
 #' Create pattern to match input files of a given type and signal
 #' 
 #' @template indicator-template

backfill_corrections/delphiBackfillCorrection/R/model.R

@@ -290,13 +290,15 @@ generate_filename <- function(indicator, signal,
 #'
 #' @template params-template
 get_training_date_range <- function(params) {
+  default_end_date <- TODAY - params$testing_window + 1
+
   if (params$train_models) {
     if (params_element_exists_and_valid(params, "training_end_date")) {
       # Use user-provided end date.
       training_end_date <- as.Date(params$training_end_date)
     } else {
       # Default end date is today.
-      training_end_date <- TODAY
+      training_end_date <- default_end_date
     }
   } else {
     # Get end date from cached model files. Assumes filename format like
@@ -306,7 +308,7 @@ get_training_date_range <- function(params) {
     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 <- 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.

backfill_corrections/delphiBackfillCorrection/R/utils.R

@@ -76,8 +76,8 @@ read_params <- function(path = "params.json", template_path = "params.json.templ
   if (!("ref_lag" %in% names(params))) {params$ref_lag <- REF_LAG}
   if (!("testing_window" %in% names(params))) {params$testing_window <- TESTING_WINDOW}
   if (!("test_dates" %in% names(params)) || length(params$test_dates) == 0) {
-    start_date <- TODAY - params$testing_window
-    end_date <- TODAY - 1
+    start_date <- TODAY - params$testing_window + 1
+    end_date <- TODAY
     params$test_dates <- seq(start_date, end_date, by="days")
   } else {
     if (length(params$test_dates) != 2) {
@@ -218,3 +218,19 @@ make_key <- function(value_type, signal_suffix) {
 params_element_exists_and_valid <- function(params, key) {
   return(key %in% names(params) && !is.null(params[[key]]) && !is.na(params[[key]]))
 }
+
+#' Assert a logical value
+#'
+#' Will issue a \code{stop} command if the given statement is false.
+#'
+#' @param statement a logical value
+#' @param msg a character string displayed as an additional message
+#'
+#' @export
+assert <- function(statement, msg="")
+{
+  if (!statement)
+  {
+    stop(msg, call.=(msg==""))
+  }
+}