Sheldus vignette revision

.Rbuildignore

@@ -11,6 +11,7 @@
 ^pkgdown$
 ^\.github$
 ^temporary-scripts$
+^data$
 \.Rmd\.orig$
 ^vignettes/precompile\.R$
 ^reviews$

R/get_business_patterns.R

@@ -98,6 +98,13 @@ get_cbp_naics_metadata = function(year) {
 #' @param naics_codes A vector of NAICS codes to query. If NULL, the function will
 #'     query all available codes with the specified number of digits. If not NULL,
 #'     this argument overrides the `naics_code_digits` argument.
+#' @param cache_directory Optional path to a directory used as a read-through cache
+#'     for the raw (pre-cleaning) CBP pull. If supplied, a cache file is named from
+#'     every parameter that determines its content (`geo`, `year`, and whichever of
+#'     `naics_code_digits`/`naics_codes` was used to select codes), so a later call
+#'     for a different year or code selection always misses the cache and re-queries
+#'     the API, rather than silently returning stale data. If `NULL` (the default),
+#'     data are queried fresh and not written to disk.
 #'
 #' @details
 #' County Business Patterns (CBP) is an annual series that provides subnational
@@ -172,7 +179,9 @@ get_cbp_naics_metadata = function(year) {
 #'  naics_codes = c(221111, 221112))
 #' }
 
-get_business_patterns = function(year = 2023, geo = "county", naics_code_digits = 2, naics_codes = NULL) {
+get_business_patterns = function(
+    year = 2023, geo = "county", naics_code_digits = 2, naics_codes = NULL,
+    cache_directory = NULL) {
   if (year < 2008) { stop("Year must be 2008 or later. Earlier years use different data structures not currently supported.") }
   if (year > 2023) { stop("Most recent year for data is 2023.") }
   if (! geo %in% c("county", "zipcode")) { stop("`geo` must be one of 'county' or 'zipcode'.") }
@@ -269,7 +278,31 @@ get_business_patterns = function(year = 2023, geo = "county", naics_code_digits
                 error = function(e2) tibble::tibble()) })
         } else { tibble::tibble() } }) }
 
-  cbp = purrr::map_dfr(naics_codes_to_query, fetch_cbp_data) %>%
+  ## caches the raw Census API pull -- before the renaming/mutating/recoding below --
+  ## so that if the cleaning logic changes later, previously-cached raw data can still
+  ## be reprocessed with the updated logic instead of needing to be re-queried
+  cbp_cache_path = if (is.null(cache_directory)) {
+    NULL
+  } else {
+    naics_key = if (!is.null(naics_codes)) {
+      stringr::str_c("codes-", stringr::str_c(sort(unique(as.character(naics_codes))), collapse = "-"))
+    } else {
+      stringr::str_c("digits-", naics_code_digits) }
+    file.path(cache_directory, stringr::str_c(
+      "business_patterns_raw_", geo, "_", year, "_", naics_key, ".parquet")) }
+
+  if (!is.null(cbp_cache_path) && file.exists(cbp_cache_path)) {
+    message("Reading cached raw CBP data: ", basename(cbp_cache_path))
+    cbp_raw = arrow::read_parquet(cbp_cache_path)
+  } else {
+    cbp_raw = purrr::map_dfr(naics_codes_to_query, fetch_cbp_data)
+    if (!is.null(cbp_cache_path)) {
+      if (!dir.exists(cache_directory)) { dir.create(cache_directory, recursive = TRUE) }
+      arrow::write_parquet(cbp_raw, cbp_cache_path)
+      message("Cached raw CBP data: ", basename(cbp_cache_path)) }
+  }
+
+  cbp = cbp_raw %>%
     # Rename the NAICS label column to a standard name
     dplyr::rename_with(~ "NAICS_LABEL", dplyr::matches("NAICS[0-9]+_(LABEL|TTL)")) %>%
     dplyr::mutate(

R/get_lodes.R

@@ -107,6 +107,14 @@ rename_lodes_variables = function(.df) {
 #' @param state_part One of c("main", "aux"). Default is "main", which includes
 #'     only workers who reside inside the state where they work. "aux" returns
 #'     only workers who work in the specified state but live outside of that state.
+#' @param cache_directory Optional path to a directory used as a read-through cache
+#'     for the raw (pre-cleaning) LODES pull. If supplied, a cache file is named from
+#'     every parameter that determines its content (`lodes_type`, `jobs_type`,
+#'     `geography`, `state_part`, `states`, and the exact years requested), so a later
+#'     call with different `states`/`years` -- e.g. once a new LODES vintage year
+#'     becomes available -- always misses the cache and re-downloads, rather than
+#'     silently returning stale data. If `NULL` (the default), data are downloaded
+#'     fresh and not written to disk.
 #'
 #' @details
 #' The Longitudinal Employer-Household Dynamics (LEHD) data at the U.S. Census Bureau
@@ -163,7 +171,8 @@ get_lodes = function(
     states,
     years,
     geography = "tract",
-    state_part = "main") {
+    state_part = "main",
+    cache_directory = NULL) {
 
   if (geography == "bg") { geography = "block group"}
 
@@ -278,21 +287,58 @@ Returning for only those states that are available for all specified years.\n")
     jobs_type_all = "JT01"
     jobs_type_federal = "JT05" }
 
-  ## supress messages/warnings else this is noisy
-  suppressWarnings({suppressMessages({
-    lodes_all_jobs = lehdr::grab_lodes(
+  ## builds a cache filename that fully encodes every parameter influencing the raw
+  ## pull's content (including the exact years requested for *this* segment, since
+  ## the federal-jobs pull below requests a different, narrower years vector than the
+  ## all-jobs pull) -- so a later request for different states/years (e.g. once a new
+  ## LODES vintage year becomes available) always misses the cache rather than
+  ## silently returning stale data
+  lodes_cache_path = function(years_requested, segment_label) {
+    if (is.null(cache_directory)) { return(NULL) }
+    geography_slug = stringr::str_replace_all(geography, " ", "-")
+    file.path(cache_directory, stringr::str_c(
+      stringr::str_c(
+        "lodes_raw", lodes_type, jobs_type, geography_slug, state_part, segment_label,
+        stringr::str_c("states-", stringr::str_c(sort(states), collapse = "-")),
+        stringr::str_c("years-", stringr::str_c(sort(years_requested), collapse = "-")),
+        sep = "_"),
+      ".parquet")) }
+
+  ## caches the raw lehdr::grab_lodes() pull -- before the GEOID renaming/column
+  ## dropping below, let alone the pivot/relabel steps further down -- so that if the
+  ## cleaning logic changes later, previously-cached raw data can still be reprocessed
+  ## with the updated logic instead of needing to be re-downloaded
+  fetch_lodes_raw = function(years_requested, job_type_code, segment_label) {
+    cache_path = lodes_cache_path(years_requested, segment_label)
+
+    if (!is.null(cache_path) && file.exists(cache_path)) {
+      message("Reading cached raw LODES data: ", basename(cache_path))
+      return(arrow::read_parquet(cache_path))
+    }
+
+    raw = suppressWarnings({suppressMessages({
+      lehdr::grab_lodes(
         state = states,
-        year = years,
-        job_type = jobs_type_all, ## all primary jobs, i.e., the highest-paying job per worker
+        year = years_requested,
+        job_type = job_type_code,
         agg_geo = geography,
         segment = "S000", ## total number of jobs for workers
         lodes_type = lodes_type,
         version = "LODES8",
-        state_part = state_part) %>% ## include out-of-state workers who work in the state of interest
-      dplyr::rename_with(
-        .cols = dplyr::everything(),
-        .fn = ~ stringr::str_replace_all(.x, geoid_rename)) %>%
-      dplyr::select(-dplyr::matches("create")) })})
+        state_part = state_part) })}) ## include out-of-state workers who work in the state of interest
+
+    if (!is.null(cache_path)) {
+      if (!dir.exists(cache_directory)) { dir.create(cache_directory, recursive = TRUE) }
+      arrow::write_parquet(raw, cache_path)
+      message("Cached raw LODES data: ", basename(cache_path)) }
+
+    raw }
+
+  lodes_all_jobs = fetch_lodes_raw(years, jobs_type_all, "alljobs") %>%
+    dplyr::rename_with(
+      .cols = dplyr::everything(),
+      .fn = ~ stringr::str_replace_all(.x, geoid_rename)) %>%
+    dplyr::select(-dplyr::matches("create"))
 
   if (years %>% min < 2010 & years %>% max > 2010) {
     warning(
@@ -320,20 +366,11 @@ as NA.\n") }
 
   } else {
 
-  suppressWarnings({suppressMessages({
-    lodes_federal_jobs = lehdr::grab_lodes(
-        state = states,
-        year = years[years > 2009],
-        job_type = jobs_type_federal, ## federal jobs
-        agg_geo = geography,
-        segment = "S000",
-        lodes_type = lodes_type,
-        version = "LODES8",
-      state_part = state_part) %>%
-      dplyr::rename_with(
-        .cols = dplyr::everything(),
-        .fn = ~ stringr::str_replace_all(.x, geoid_rename)) %>%
-      dplyr::select(-dplyr::matches("create")) })})
+  lodes_federal_jobs = fetch_lodes_raw(years[years > 2009], jobs_type_federal, "federaljobs") %>%
+    dplyr::rename_with(
+      .cols = dplyr::everything(),
+      .fn = ~ stringr::str_replace_all(.x, geoid_rename)) %>%
+    dplyr::select(-dplyr::matches("create"))
 
   if (lodes_type == "od")  { join_by = c("year", "w_GEOID", "h_GEOID") } 
   if (lodes_type == "rac") { join_by = c("year", "h_GEOID") } 

R/get_national_risk_index.R

@@ -200,7 +200,7 @@ get_national_risk_index = function(
       value_building = buildvalue,
       value_agriculture = agrivalue,
       area_sq_mi = area) |>
-    dplyr::select(-c(nri_id, stateabbrv, statefips, countytype, countyfips, stcofips, tract, tractfips)) |>
+    dplyr::select(-dplyr::any_of(c("nri_id", "stateabbrv", "statefips", "countytype", "countyfips", "stcofips", "tract", "tractfips"))) |>
     dplyr::rename_with(
       .cols = dplyr::everything(),
       .fn = ~ stringr::str_replace_all(.x, c(

renv.lock

@@ -5853,12 +5853,12 @@
       "Author": "Will Curran-Groome [aut, cre]",
       "Maintainer": "Will Curran-Groome <wcurrangroome@gmail.com>",
       "RemoteType": "github",
+      "Remotes": "UI-Research/crosswalk, UrbanInstitute/urbnthemes",
       "RemoteUsername": "UI-Research",
       "RemoteRepo": "urbnindicators",
       "RemoteRef": "main",
       "RemoteSha": "e47d4b2a749b504e27f80997526bdbe3e0c7aef9",
-      "RemoteHost": "api.github.com",
-      "Remotes": "UI-Research/crosswalk, UrbanInstitute/urbnthemes"
+      "RemoteHost": "api.github.com"
     },
     "urbnthemes": {
       "Package": "urbnthemes",

tests/testthat/helper-cache.R

@@ -0,0 +1,18 @@
+# Absolute path to a local raw-data cache used by get_lodes()/get_business_patterns()
+# tests, so re-running devtools::check() doesn't re-download the same data every time.
+#
+# Returns NULL (no caching -- tests hit the live API directly, same as before this
+# helper existed) unless CLIMATEAPI_TEST_CACHE_DIR is set to an absolute path (e.g. in
+# .Renviron). A relative path would not work here: devtools::check() builds and checks
+# the package from a temporary directory disconnected from this source tree, so tests
+# running under check() can't find a repo-relative "../../data" -- only an absolute
+# path set outside that sandbox (via an environment variable) survives the trip.
+get_test_cache_directory <- function() {
+  cache_directory <- Sys.getenv("CLIMATEAPI_TEST_CACHE_DIR", unset = NA)
+
+  if (is.na(cache_directory) || !nzchar(cache_directory)) {
+    return(NULL)
+  }
+
+  cache_directory
+}

tests/testthat/test-get_business_patterns.R

@@ -12,11 +12,13 @@ testthat::test_that("year errors clearly when year is outside accceptable range"
 
 testthat::test_that("geo errors clearly when geo is not 'county' or 'zipcode'; does not error when in 'county' or 'zipcode' ", {
   testthat::expect_error({get_business_patterns(geo = "tract", naics_code_digits = 3)})
-  testthat::expect_no_error({get_business_patterns(geo = "county", naics_code_digits = 2)})
+  testthat::expect_no_error({get_business_patterns(
+    geo = "county", naics_code_digits = 2, cache_directory = get_test_cache_directory())})
 })
 
 testthat::test_that("employees has no negative values", {
-  test <- get_business_patterns(geo = "zipcode", naics_code_digits = 2)
+  test <- get_business_patterns(
+    geo = "zipcode", naics_code_digits = 2, cache_directory = get_test_cache_directory())
 
   # Ensure the column exists
   testthat::expect_true(

tests/testthat/test-get_lodes.R

@@ -7,13 +7,13 @@ testthat::test_that("states clearly errors when invalid state abbreviation is su
 
 testthat::test_that("warning generated when missing state and year combination is supplied", {
   testthat::expect_warning(
-    {get_lodes(lodes_type = "od", years = 2022, states = c("AK", "MN"))},
+    {get_lodes(lodes_type = "od", years = 2022, states = c("AK", "MN"), cache_directory = get_test_cache_directory())},
     "state-year combinations")
   ## pre-2015 years also trigger the federal-jobs reporting warning; capture both
   ## so neither escapes the expectation
   testthat::expect_warning(
     testthat::expect_warning(
-      {get_lodes(lodes_type = "wac", years = 2009, states = c("DC", "MN"))},
+      {get_lodes(lodes_type = "wac", years = 2009, states = c("DC", "MN"), cache_directory = get_test_cache_directory())},
       "state-year combinations"),
     "federal jobs")
 })
@@ -26,7 +26,9 @@ testthat::test_that("error generated when invalid lodes_type is supplied", {
 testthat::test_that("variables have no negative values", {
   ## states = "all" includes state-years missing from LODES (e.g., AK/MI in 2022),
   ## which triggers an expected availability warning
-  test <- suppressWarnings(get_lodes(lodes_type = "wac", years = 2022, states = "all"))
+  test <- suppressWarnings(get_lodes(
+    lodes_type = "wac", years = 2022, states = "all",
+    cache_directory = get_test_cache_directory()))
 
   # Select numeric columns
   num_df <- dplyr::select(test, where(is.numeric))