Merge pull request #1379 from cmu-delphi/survey-prevent-6d-7dav

Suppress too-recent smoothed weighted indicators

Author: krivard

facebook/delphiFacebook/NAMESPACE

@@ -112,6 +112,7 @@ importFrom(stats,na.omit)
 importFrom(stats,setNames)
 importFrom(stats,weighted.mean)
 importFrom(stringi,stri_extract)
+importFrom(stringi,stri_extract_first)
 importFrom(stringi,stri_replace)
 importFrom(stringi,stri_replace_all)
 importFrom(stringi,stri_split)

facebook/delphiFacebook/R/aggregate.R

@@ -179,6 +179,15 @@ summarize_indicators_day <- function(day_df, indicators, target_day, geo_level,
       var_weight <- indicators$var_weight[row]
       compute_fn <- indicators$compute_fn[[row]]
 
+      # Prevent smoothed weighted signals from being reported for dates after
+      # the latest available weight data.
+      if (target_day > params$latest_weight_date &&
+          indicators$smooth_days[row] > 1 &&
+          indicators$var_weight[row] != "weight_unif") {
+        
+        next
+      }
+
       # Copy only columns we're using.
       select_cols <- c(metric, var_weight, "weight_in_location")
       # This filter uses `x[, cols, with=FALSE]` rather than the newer

facebook/delphiFacebook/R/contingency_run.R

@@ -144,7 +144,7 @@ run_contingency_tables_one_period <- function(params, aggregations)
       return()
     }
 
-    data_agg <- join_weights(data_agg, params, weights = "full")
+    data_agg <- join_weights(data_agg, params, weights = "full")$df
     msg_df("response data to aggregate", data_agg)
 
     produce_aggregates(data_agg, aggregations, cw_list, params)

facebook/delphiFacebook/R/run.R

@@ -27,13 +27,19 @@ run_facebook <- function(params)
   # create data that will be aggregated for covidcast
   data_agg <- create_data_for_aggregation(input_data)
   data_agg <- filter_data_for_aggregation(data_agg, params, lead_days = 12)
-  data_agg <- join_weights(data_agg, params, weights = "step1")
+  weight_result <- join_weights(data_agg, params, weights = "step1")
+  data_agg <- weight_result$df
+  latest_weight_date_step1 <- weight_result$weight_date
   msg_df("response data to aggregate", data_agg)
 
+  params$latest_weight_date <- ifelse(
+    is.na(latest_weight_date_step1), as.Date(params$end_date), latest_weight_date_step1
+  )
+
   # create "complete" data that will be shared with research partners
   data_full <- create_complete_responses(input_data, cw_list$county, params)
   data_full <- filter_complete_responses(data_full, params)
-  data_full <- join_weights(data_full, params, weights = "full")
+  data_full <- join_weights(data_full, params, weights = "full")$df
   msg_df("full data to share with research partners", data_full)
 
   ## Set default number of cores for mclapply to the total available number,

facebook/delphiFacebook/R/weights.R

@@ -47,6 +47,7 @@ write_cid <- function(data, type_name, params)
 #'
 #' @importFrom dplyr bind_rows left_join
 #' @importFrom data.table fread
+#' @importFrom stringi stri_extract_first
 #' 
 #' @export
 join_weights <- function(data, params, weights = c("step1", "full"))
@@ -61,6 +62,11 @@ join_weights <- function(data, params, weights = c("step1", "full"))
 
   weights_files <- dir(params$weights_in_dir, pattern = pattern, full.names = TRUE)
   weights_files <- sort(weights_files)
+
+  latest_weight <- tail(weights_files, n = 1)
+  latest_weight_date <- as.Date(
+    stri_extract_first(latest_weight, regex = "^[0-9]{4}-[0-9]{2}-[0-9]{2}")
+  )
 
   col_types <- c("character", "double")
   col_names <- c("cid", "weight")
@@ -74,5 +80,5 @@ join_weights <- function(data, params, weights = c("step1", "full"))
   agg_weights <- agg_weights[!duplicated(cid),]
   data <- left_join(data, agg_weights, by = c("token" = "cid"))
 
-  return(data)
+  return( list(df = data, weight_date = latest_weight_date) )
 }

facebook/delphiFacebook/integration-tests/testthat/test-contingency-run.R

@@ -163,7 +163,7 @@ rand_weights <- rand_weights / sum(rand_weights)
 
 mock_join_weights <- function(data, params, weights = c("step1", "full")) {
   data <- cbind(as.data.table(data), weight=rand_weights)
-  return(data)
+  return( list(df = data, weight_date = NA) )
 }
 
 mock_mix_weights <- function(weights, s_mix_coef, s_weight) {

facebook/delphiFacebook/integration-tests/testthat/test-integration.R

@@ -152,7 +152,7 @@ test_that("testing weighted community values files", {
   params <- relativize_params(read_params(test_path("params-test.json")))
 
   input_data <- load_responses_all(params)
-  input_data <- join_weights(input_data, params)
+  input_data <- join_weights(input_data, params)$df
 
   # there are 2 / 4 households in PA on 2020-05-11 for community
   these <- input_data[input_data$date == "2020-05-11" & input_data$zip5 == "15106",]
@@ -194,7 +194,7 @@ test_that("testing weighted smoothed community values files", {
   params <- relativize_params(read_params(test_path("params-test.json")))
 
   input_data <- load_responses_all(params)
-  input_data <- join_weights(input_data, params)
+  input_data <- join_weights(input_data, params)$df
 
   # there are 2 / 4 households in PA on 2020-05-11 for community
   these <- input_data[
@@ -328,7 +328,7 @@ test_that("testing weighted ili/cli values files", {
   params <- relativize_params(read_params(test_path("params-test.json")))
 
   input_data <- load_responses_all(params)
-  input_data <- join_weights(input_data, params)
+  input_data <- join_weights(input_data, params)$df
   data_agg <- create_data_for_aggregation(input_data)
 
   ## There are 4 households in PA on 2020-05-11, one with ILI.

facebook/delphiFacebook/man/code_vaccinated_breakdown.Rd

@@ -33,7 +33,7 @@ test_that("testing join_weights command", {
   fake_data <- tibble(
     token = c("DSFIJBjAexoQjDStr", "mGDsqbweUYzFnmZUH", "zocUNXYISDyYcVIQn")
   )
-  fake_data_w <- join_weights(fake_data, list(weights_in_dir = "weights_in"))
+  fake_data_w <- join_weights(fake_data, list(weights_in_dir = "weights_in"))$df
 
   expect_true(max(abs(expected_weights - fake_data_w$weight)) < 1e-7)