Release covidcast-indicators 0.3.19

.bumpversion.cfg

@@ -1,5 +1,5 @@
 [bumpversion]
-current_version = 0.3.18
+current_version = 0.3.19
 commit = True
 message = chore: bump covidcast-indicators to {new_version}
 tag = False

ansible/templates/sir_complainsalot-params-prod.json.j2

@@ -38,11 +38,6 @@
       "maintainers": ["U01AP8GSWG3","U01069KCRS7"],
       "retired-signals": ["confirmed_7dav_cumulative_num", "confirmed_7dav_cumulative_prop", "deaths_7dav_cumulative_num", "deaths_7dav_cumulative_prop"]
     },
-    "safegraph": {
-      "max_age": 11,
-      "maintainers": ["U01AP8GSWG3","U01069KCRS7"],
-      "retired-signals": ["completely_home_prop", "full_time_work_prop", "part_time_work_prop", "median_home_dwell_time", "completely_home_prop_7dav", "full_time_work_prop_7dav", "part_time_work_prop_7dav", "median_home_dwell_time_7dav"]
-    },
     "quidel": {
       "max_age":6,
       "maintainers": ["U01AP8GSWG3","U01069KCRS7"],

facebook/Dockerfile

@@ -11,6 +11,8 @@ RUN install2.r --error \
     roxygen2 \
     Rcpp \
     BH \
+    plyr \
+    survey \
     readr
 
 RUN apt-get update && apt-get install -qq -y \

facebook/amend_monthly_microdata.R

@@ -0,0 +1,128 @@
+#!/usr/bin/env Rscript
+
+## Modify monthly microdata. Add state column. Rename `wave` field to `version`.
+##
+## Usage:
+##
+## Rscript microdata_add_state_col__rename_wave.R path/to/individual/files/ path/to/output/dir/ [/path/to/static/dir/]
+##
+## Writes the processed files to the specified directory under the original file name.
+
+suppressPackageStartupMessages({
+  library(dplyr)
+  library(readr)
+  library(rlang)
+  library(stringi)
+  library(covidcast)
+  library(delphiFacebook)
+})
+
+amend_microdata <- function(input_dir, output_dir, static_dir, pattern = ".*[.]csv[.]gz$") {
+  # Create mapping of county FIPS codes to state postal codes.
+  zips <- read_csv(
+    file.path(static_dir, "02_20_uszips.csv"),
+    col_types = cols(.default = "c", population = "i")
+  ) %>%
+    mutate(
+      fips = stri_pad(.data$fips, 5, pad="0"),
+      zip = stri_pad(.data$zip, 5, pad="0")
+    )
+  invalid_zips <- zips %>%
+    filter(population <= 100) %>%
+    pull(zip)
+  territory_zips <- zips %>%
+    filter(state_id %in% c("AS", "GU", "PR", "VI", "MP")) %>%
+    pull(zip)
+
+  # Read in each monthly file from the microdata directory.
+  for (fname in list.files(input_dir, pattern = pattern)) {
+    # Read in file.
+    # stop readr from thinking commas = thousand separators,
+    # and from inferring column types incorrectly
+    message("reading data in")
+    data <- read_csv(file.path(input_dir, fname), locale = locale(grouping_mark = ""),
+             col_types = cols(
+               .default = col_character())) %>%
+      # Rename `wave` field.
+      rename(version = .data$wave) %>%
+      create_zip5()
+
+    # Add state column based on county FIPS code.
+    data <- mutate(data, state = state_fips_to_name(substr(fips, 1, 2)) %>% name_to_abbr())
+
+    assert(
+      all(is.na(data$fips) == is.na(data$state)),
+      "fips and state fields are not missing in the same places"
+    )
+
+    # Drop any territories.
+    data <- filter(data,
+      !(.data$state %in% c("AS", "GU", "PR", "VI", "MP")),
+      # If fips not available and state didn't get filled in.
+      !(.data$zip5 %in% territory_zips)
+    )
+
+    # what zip5 values have a large enough population (>100) to include in micro
+    # output. Those with too small of a population are blanked to NA
+    data <- blank_zips(data, invalid_zips, fname)
+
+    # Save file under original name but in output directory.
+    message("writing data for ", fname)
+    write_csv(data, file.path(output_dir, fname))
+  }
+}
+
+create_zip5 <- function(data) {
+  data$zip5 <- data$A3
+
+  # clean the ZIP data
+  data$zip5 <- stri_replace_all(data$zip5, "", regex = " *")
+  data$zip5 <- stri_replace(data$zip5, "", regex ="-.*")
+
+  # some people enter 9-digit ZIPs, which could make them easily identifiable in
+  # the individual output files. rather than truncating to 5 digits -- which may
+  # turn nonsense entered by some respondents into a valid ZIP5 -- we simply
+  # replace these ZIPs with NA.
+  data$zip5 <- ifelse(nchar(data$zip5) > 5, NA_character_,
+                            data$zip5)
+
+  return(data)
+}
+
+blank_zips <- function(data, invalid_zips, fname) {
+  change_zip <- (data$zip5 %in% invalid_zips)
+  # Population-based blanking of zip codes was implemented in late May 2020. For
+  # later files, we shouldn't be blanking any new obs.
+  if (sum(change_zip) > 0) {
+    warning("trying to remove obs with invalid zip via population")
+    print(fname)
+    print(head(data[change_zip,] %>% select(zip5, fips, state)))
+  }
+  data$A3[change_zip] <- NA
+
+  data <- select(data, -zip5)
+
+  return(data)
+}
+
+args <- commandArgs(TRUE)
+
+if (!(length(args) %in% c(2, 3))) {
+  stop("Usage: Rscript microdata_add_state_col__rename_wave.R path/to/individual/files/ path/to/output/dir/ [/path/to/static/dir/]")
+}
+
+input_dir <- args[1]
+output_dir <- args[2]
+
+if (length(args) == 3) {
+  static_dir <- args[3]
+} else {
+  static_dir <- "static"
+}
+
+# Specifies monthly microdata rollup naming scheme like "YYYY-MM.csv.gz" and the
+# race-ethnicity version "YYYY-MM-race-ethnicity.csv.gz"
+pattern <- "^202[0-9]-[0-9]{2}(-race-ethnicity)?[.]csv[.]gz$"
+
+amend_microdata(input_dir, output_dir, static_dir, pattern = pattern)
+

facebook/delphiFacebook/DESCRIPTION

@@ -15,18 +15,21 @@ Imports:
     rlang,
     readr,
     dplyr,
+    plyr,
+    tidyr,
     stringi,
     jsonlite,
     lubridate,
     data.table,
     tibble,
     purrr,
-    Rcpp
+    Rcpp,
+    survey
 Suggests:
     knitr (>= 1.15),
     rmarkdown (>= 1.4),
     testthat (>= 1.0.1),
     covr (>= 2.2.2)
 LinkingTo: Rcpp
-RoxygenNote: 7.1.1
+RoxygenNote: 7.2.0
 Encoding: UTF-8

facebook/delphiFacebook/NAMESPACE

@@ -69,6 +69,7 @@ importFrom(dplyr,bind_rows)
 importFrom(dplyr,case_when)
 importFrom(dplyr,coalesce)
 importFrom(dplyr,desc)
+importFrom(dplyr,distinct)
 importFrom(dplyr,everything)
 importFrom(dplyr,filter)
 importFrom(dplyr,full_join)
@@ -98,6 +99,7 @@ importFrom(lubridate,ymd)
 importFrom(lubridate,ymd_hms)
 importFrom(parallel,detectCores)
 importFrom(parallel,mclapply)
+importFrom(plyr,round_any)
 importFrom(purrr,reduce)
 importFrom(readr,col_character)
 importFrom(readr,col_integer)
@@ -115,13 +117,19 @@ importFrom(stats,setNames)
 importFrom(stats,weighted.mean)
 importFrom(stringi,stri_extract)
 importFrom(stringi,stri_extract_first)
+importFrom(stringi,stri_pad)
 importFrom(stringi,stri_replace)
 importFrom(stringi,stri_replace_all)
 importFrom(stringi,stri_split)
 importFrom(stringi,stri_sub)
 importFrom(stringi,stri_trans_tolower)
 importFrom(stringi,stri_trim)
+importFrom(survey,oldsvyquantile)
+importFrom(survey,svydesign)
+importFrom(survey,svymean)
+importFrom(survey,svyvar)
 importFrom(tibble,add_column)
 importFrom(tibble,tribble)
+importFrom(tidyr,drop_na)
 importFrom(utils,tail)
 useDynLib(delphiFacebook, .registration = TRUE)

facebook/delphiFacebook/R/aggregate.R

@@ -203,10 +203,9 @@ summarize_indicators_day <- function(day_df, indicators, target_day, geo_level,
 
         sample_size <- sum(ind_df$weight_in_location)
 
-        ## TODO: See issue #764
         new_row <- compute_fn(
           response = ind_df[[metric]],
-          weight = if (indicators$skip_mixing[row]) { mixing$normalized_preweights } else { mixing$weights },
+          weight = mixing$weights,
           sample_size = sample_size)
 
         dfs_out[[indicator]][["val"]][ii] <- new_row$val
@@ -217,15 +216,13 @@ summarize_indicators_day <- function(day_df, indicators, target_day, geo_level,
     }
   }
 
-  # Convert list of lists to list of tibbles.
-  for (indicator in indicators$name) {
-   dfs_out[[indicator]] <- bind_rows(dfs_out[[indicator]])
-  }
-
   for (row in seq_len(nrow(indicators))) {
     indicator <- indicators$name[row]
     post_fn <- indicators$post_fn[[row]]
 
+    # Convert list of lists to list of tibbles.
+    dfs_out[[indicator]] <- bind_rows(dfs_out[[indicator]])
+
     dfs_out[[indicator]] <- dfs_out[[indicator]][
       rowSums(is.na(dfs_out[[indicator]][, c("val", "sample_size", "geo_id", "day")])) == 0,
     ]

facebook/delphiFacebook/R/binary.R

@@ -59,8 +59,8 @@ get_binary_indicators <- function() {
 
     # work outside home
     # pre-wave 4
-    "wip_smoothed_work_outside_home_5d", "weight_unif", "c_work_outside_5d", 6, compute_binary_response, jeffreys_binary,
-    "wip_smoothed_wwork_outside_home_5d", "weight", "c_work_outside_5d", 6, compute_binary_response, jeffreys_binary,
+    "smoothed_work_outside_home_5d", "weight_unif", "c_work_outside_5d", 6, compute_binary_response, jeffreys_binary,
+    "smoothed_wwork_outside_home_5d", "weight", "c_work_outside_5d", 6, compute_binary_response, jeffreys_binary,
     # wave 4+, pre-wave 10
     "smoothed_work_outside_home_1d", "weight_unif", "a_work_outside_home_1d", 6, compute_binary_response, jeffreys_binary,
     "smoothed_wwork_outside_home_1d", "weight", "a_work_outside_home_1d", 6, compute_binary_response, jeffreys_binary,
@@ -420,9 +420,6 @@ get_binary_indicators <- function() {
     "smoothed_wwant_info_none", "weight", "i_want_info_none", 6, compute_binary_response, jeffreys_binary
   )
 
-
-  ind$skip_mixing <- TRUE
-
   return(ind)
 }
 
@@ -449,10 +446,12 @@ compute_binary_response <- function(response, weight, sample_size)
   response_prop <- weighted.mean(response, weight)
 
   val <- 100 * response_prop
+
+  effective_sample_size <- length(weight) * mean(weight)^2 / mean(weight^2)
 
   return(list(val = val,
               se = NA_real_,
-              effective_sample_size = sample_size)) # TODO effective sample size
+              effective_sample_size = effective_sample_size))
 }
 
 #' Apply a Jeffreys correction to estimates and their standard errors.
@@ -477,8 +476,8 @@ jeffreys_multinomial_factory <- function(k) {
   # Returns: Updated data frame.
   jeffreys_multinomial <- function(df) {
     return(mutate(df,
-                  val = jeffreys_percentage(.data$val, .data$sample_size, k),
-                  se = binary_se(.data$val, .data$sample_size)))
+                  val = jeffreys_percentage(.data$val, .data$effective_sample_size, k),
+                  se = binary_se(.data$val, .data$effective_sample_size)))
   }
 
   return(jeffreys_multinomial)
@@ -506,6 +505,6 @@ jeffreys_percentage <- function(percentage, sample_size, k) {
 #' @return Vector of standard errors; NA when a sample size is 0.
 binary_se <- function(val, sample_size) {
   return(ifelse(sample_size > 0,
-                sqrt( (val * (100 - val) / sample_size) ),
+                sqrt( val * (100 - val) / (sample_size + 1) ),
                 NA))
 }