|
3 | 3 | #' CSV name includes date specifying start of time period aggregated, geo level, |
4 | 4 | #' and grouping variables. |
5 | 5 | #' |
6 | | -#' @param data a data frame to save; must contain the columns "geo_id", "val", |
7 | | -#' "se", "sample_size", and grouping variables. The first four are saved in the |
8 | | -#' output; day is used for spliting the data into files. |
9 | | -#' @param params a named list, containing the value "export_dir" indicating the |
10 | | -#' directory where the csv should be saved |
11 | | -#' @param geo_level name of the geographic level; used for naming the output file |
| 6 | +#' @param data a data frame to save; must contain the columns in |
| 7 | +#' `groupby_vars`. |
| 8 | +#' @param params a named list, containing the values: |
| 9 | +#' "export_dir" - directory where the csv should be saved |
| 10 | +#' "static_dir" - directory where the state lookup file is |
| 11 | +#' "aggregate_range" - "month", "week", etc. |
| 12 | +#' "start_date" - start date of the aggregate range |
| 13 | +#' "end_date" - end date of the aggregate range |
| 14 | +#' @param geo_type name of the geographic level; used for naming the output file |
12 | 15 | #' @param groupby_vars character vector of column names used for grouping to |
13 | 16 | #' calculate aggregations; used for naming the output file |
14 | 17 | #' |
|
17 | 20 | #' @importFrom stringi stri_trim |
18 | 21 | #' |
19 | 22 | #' @export |
20 | | -write_contingency_tables <- function(data, params, geo_level, groupby_vars) |
| 23 | +write_contingency_tables <- function(data, params, geo_type, groupby_vars) |
21 | 24 | { |
22 | 25 | if (!is.null(data) && nrow(data) != 0) { |
23 | | - data <- arrange(data, across(all_of(groupby_vars))) |
| 26 | + |
| 27 | + # Reorder the group-by columns and sort the dataset by them. |
| 28 | + groupby_vars <- c("geo_id", sort(setdiff(groupby_vars, "geo_id"))) |
| 29 | + data <- data %>% |
| 30 | + select(all_of(groupby_vars), everything()) %>% |
| 31 | + arrange(across(all_of(groupby_vars))) |
24 | 32 |
|
25 | 33 | # Format reported columns. |
26 | | - data <- mutate_at(data, vars(-c(groupby_vars)), |
27 | | - function(x) { |
28 | | - stri_trim( |
29 | | - formatC(as.numeric(x), digits=7, format="f", drop0trailing=TRUE) |
30 | | - ) |
31 | | - }) |
32 | | - |
33 | | - # Reduce verbosity of grouping vars for output purposes |
34 | | - groupby_vars <- gsub("_", "", sub( |
35 | | - ".+?_", "", groupby_vars[groupby_vars != "geo_id"])) |
36 | | - filename <- sprintf("%s_%s.csv", format(params$start_date, "%Y%m%d"), |
37 | | - paste(c(geo_level, groupby_vars), collapse="_")) |
38 | | - file_out <- file.path(params$export_dir, filename) |
39 | | - |
| 34 | + format_number <- function(x) { |
| 35 | + stri_trim(formatC(as.numeric(x), digits=7, format="f", drop0trailing=TRUE)) |
| 36 | + } |
| 37 | + data <- mutate_at(data, vars(-groupby_vars), format_number) |
| 38 | + |
| 39 | + # Add standard geographic and metadata variables to the data. |
| 40 | + data <- add_geo_vars(data, params, geo_type) |
| 41 | + data <- add_metadata_vars(data, params, geo_type, groupby_vars) |
| 42 | + |
40 | 43 | create_dir_not_exist(params$export_dir) |
41 | | - |
42 | | - msg_df(sprintf("saving contingency table data to %-35s", filename), data) |
43 | | - write_csv(data, file_out) |
| 44 | + |
| 45 | + file_name <- get_file_name(params, geo_type, groupby_vars) |
| 46 | + msg_df(sprintf("saving contingency table data to %-35s", file_name), data) |
| 47 | + write_csv(data, file.path(params$export_dir, file_name)) |
44 | 48 |
|
45 | 49 | } else { |
46 | 50 | msg_plain(sprintf( |
47 | 51 | "no aggregations produced for grouping variables %s (%s); CSV will not be saved", |
48 | | - paste(groupby_vars, collapse=", "), geo_level |
| 52 | + paste(groupby_vars, collapse=", "), geo_type |
49 | 53 | )) |
50 | 54 | } |
51 | 55 | } |
| 56 | + |
| 57 | +#' Add geographic variables to a dataset, e.g. state and state FIPS codes. |
| 58 | +#' |
| 59 | +#' @param data A data frame, containing the variables in groupby_vars. |
| 60 | +#' @param params A parameters object with the `static_dir` resources folder. |
| 61 | +#' @param geo_type "nation", "state". |
| 62 | +#' |
| 63 | +#' @importFrom dplyr bind_cols left_join select |
| 64 | +#' @importFrom readr read_csv cols |
| 65 | +#' @noRd |
| 66 | +add_geo_vars <- function(data, params, geo_type) { |
| 67 | + |
| 68 | + start <- data.frame( |
| 69 | + country = "United States", |
| 70 | + ISO_3 = "USA", |
| 71 | + GID_0 = "USA" |
| 72 | + ) |
| 73 | + |
| 74 | + if (geo_type == "nation") { |
| 75 | + |
| 76 | + rest <- data.frame( |
| 77 | + region = "overall", |
| 78 | + GID_1 = NA_character_, |
| 79 | + state = "overall", |
| 80 | + state_fips = NA_character_, |
| 81 | + county = "overall", |
| 82 | + county_fips = NA_character_ |
| 83 | + ) |
| 84 | + |
| 85 | + } else if (geo_type == "state") { |
| 86 | + |
| 87 | + states <- read_csv( |
| 88 | + file.path(params$static_dir, "state_list.csv"), |
| 89 | + col_types = cols(.default = "c") |
| 90 | + ) |
| 91 | + |
| 92 | + rest <- data.frame( |
| 93 | + region = toupper(data$geo_id), |
| 94 | + state = toupper(data$geo_id), |
| 95 | + county = "overall", |
| 96 | + county_fips = NA_character_ |
| 97 | + ) |
| 98 | + |
| 99 | + rest$state <- toupper(rest$state) |
| 100 | + states$state <- toupper(states$state) |
| 101 | + |
| 102 | + rest <- left_join(rest, states, by = "state") %>% |
| 103 | + select(region, GID_1, state, state_fips, county, county_fips) |
| 104 | + } |
| 105 | + |
| 106 | + geo_vars <- bind_cols(start, rest) |
| 107 | + |
| 108 | + # Insert the geographic variables in place of the "geo_id" variable. |
| 109 | + index <- which(names(data) == "geo_id") |
| 110 | + before <- if (index > 1) data[1:(index-1)] else NULL |
| 111 | + after <- data[(index+1):ncol(data)] |
| 112 | + result <- bind_cols(before, geo_vars, after) |
| 113 | + |
| 114 | + return(result) |
| 115 | +} |
| 116 | + |
| 117 | +#' Add metadata variables to a dataset, e.g. start and end dates. |
| 118 | +#' |
| 119 | +#' @param data A data frame, containing the variables in `groupby_vars.` |
| 120 | +#' @param params A parameters object containing start & end date, period, etc. |
| 121 | +#' @param geo_type "nation", "state", "county". |
| 122 | +#' @param groupby_vars A list of variables `data` is aggregated by. |
| 123 | +#' |
| 124 | +#' @importFrom dplyr bind_cols |
| 125 | +#' @noRd |
| 126 | +add_metadata_vars <- function(data, params, geo_type, groupby_vars) { |
| 127 | + |
| 128 | + aggregation_type <- setdiff(groupby_vars, "geo_id") |
| 129 | + if (length(aggregation_type) == 0) aggregation_type <- "overall" |
| 130 | + |
| 131 | + # Add metadata about this period and level of aggregation. |
| 132 | + metadata <- data.frame( |
| 133 | + survey_geo = "us", |
| 134 | + period_start = format(params$start_date, "%Y%m%d"), |
| 135 | + period_end = format(params$end_date, "%Y%m%d"), |
| 136 | + period_val = get_period_val(params$aggregate_range, params$start_date), |
| 137 | + period_type = get_period_type(params$aggregate_range), |
| 138 | + geo_type = paste(geo_type, collapse = "_"), |
| 139 | + aggregation_type = paste(aggregation_type, collapse = "_") |
| 140 | + ) |
| 141 | + data <- bind_cols(metadata, data) |
| 142 | + data$issue_date <- format(Sys.Date(), "%Y%m%d") |
| 143 | + |
| 144 | + return(data) |
| 145 | +} |
| 146 | + |
| 147 | +#' Get the file name for the given parameters, geography, and set of group-by variables. |
| 148 | +#' @noRd |
| 149 | +get_file_name <- function(params, geo_type, groupby_vars) { |
| 150 | + |
| 151 | + aggregation_type <- setdiff(groupby_vars, "geo_id") |
| 152 | + if (length(aggregation_type) == 0) aggregation_type <- "overall" |
| 153 | + |
| 154 | + file_name <- paste( |
| 155 | + format(params$start_date, "%Y%m%d"), |
| 156 | + format(params$end_date, "%Y%m%d"), |
| 157 | + get_period_type(params$aggregate_range), |
| 158 | + geo_type, |
| 159 | + paste(aggregation_type, collapse = "_"), |
| 160 | + sep = "_" |
| 161 | + ) |
| 162 | + file_name <- paste0(file_name, ".csv") |
| 163 | + return(file_name) |
| 164 | +} |
| 165 | + |
| 166 | +#' Get the period type for the given range, i.e. "weekly" or "monthly". |
| 167 | +#' @noRd |
| 168 | +get_period_type <- function(range) { |
| 169 | + switch( |
| 170 | + range, |
| 171 | + "month" = "monthly", |
| 172 | + "week" = "weekly", |
| 173 | + "" |
| 174 | + ) |
| 175 | +} |
| 176 | + |
| 177 | +#' Get the period value (e.g. epiweek number) for the range and start date. |
| 178 | +#' @importFrom lubridate epiweek |
| 179 | +#' @noRd |
| 180 | +get_period_val <- function(range, period_start) { |
| 181 | + switch( |
| 182 | + range, |
| 183 | + "week" = epiweek(period_start), |
| 184 | + "month" = as.integer(format(period_start, "%m")), |
| 185 | + NA_integer_ |
| 186 | + ) |
| 187 | +} |
0 commit comments