From a96c5c6cc14f05d5ae3093b17cb5a027a779cb4d Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Sat, 19 Jul 2025 01:36:44 -0400 Subject: [PATCH 01/23] Add `year_suf` helper function --- R/utils.R | 53 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 19 deletions(-) diff --git a/R/utils.R b/R/utils.R index ec185bd..50b7506 100644 --- a/R/utils.R +++ b/R/utils.R @@ -229,14 +229,14 @@ validate_state <- function( # Show informative messages about successful state matches valid_state_fips <- state_fips[state_is_fips] valid_state_names <- state[state_is_fips] - + message_parts <- paste0( valid_state_fips, " for ", valid_state_names, collapse = ", " ) - + cli_inform(c( "*" = "Using FIPS code{?s} {message_parts}" )) @@ -276,17 +276,20 @@ county_values <- function( # Remove .msg from ... to avoid conflicts dots <- list(...) dots[[".msg"]] <- NULL - - state <- do.call(validate_state, c( - list( - state = state, - require_state = require_state, - multiple = multiple, - .msg = FALSE, - error_call = error_call - ), - dots - )) + + state <- do.call( + validate_state, + c( + list( + state = state, + require_state = require_state, + multiple = multiple, + .msg = FALSE, + error_call = error_call + ), + dots + ) + ) if (!require_state && is.null(state)) { return(NULL) @@ -391,15 +394,20 @@ match_county_name <- function( # For ambiguous matches, use the first match and warn about alternatives for (i in which(uncertain_matches)) { matches <- county_matches[[i]] - county_matches[[i]] <- matches[1] # Use first match - + county_matches[[i]] <- matches[1] # Use first match + # Build warning message with all matches all_matches <- paste(names(matches), collapse = ", ") uncertain_county <- county[i] - + message <- c( message, - paste0("Using first match for '", uncertain_county, "'. Multiple matches found: ", all_matches) + paste0( + "Using first match for '", + uncertain_county, + "'. Multiple matches found: ", + all_matches + ) ) } } @@ -499,14 +507,14 @@ validate_county <- function( # Show informative messages about successful county matches valid_county_fips <- county_fips[!na_county_fips] valid_county_names <- county[!na_county_fips] - + message_parts <- paste0( valid_county_fips, " for ", valid_county_names, collapse = ", " ) - + cli_inform(c( "*" = "Using FIPS code{?s} {message_parts}" )) @@ -633,3 +641,10 @@ prep_input_sfc <- function( # Make NAD83 for coordinate alignment sf::st_transform(input, crs = crs) } + + +#' Get suffix of a 4 character year +#' @noRd +year_suf <- function(year) { + substr(year, 3, 4) +} From b12d8b7ea66c42978a3496975da73e4687e5b4ec Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Sun, 20 Jul 2025 18:07:46 -0400 Subject: [PATCH 02/23] Standardize input checks + minor clean-up - Revise state/county checks to use new `require_` and `multiple` parameters - Add `set_tigris_year` to reduce duplicate code + improve validation - Add `year_suffix()` helper function for readability - Add `match_resolution()` function - Replace calls to stop w/ cli_abort + message w/ cli_inform - Remove .data operator (deprecated in tidyselect 1.2.0) - Minor style clean-up --- R/enumeration_units.R | 524 +++++++++++++++++------------------------- R/helpers.R | 110 ++++----- R/landmarks.R | 73 ++---- R/legislative.R | 137 ++++------- R/metro_areas.R | 209 ++++------------- R/national.R | 104 ++------- R/native.R | 124 ++-------- R/places.R | 45 ++-- R/pumas.R | 50 ++-- R/shift_geometry.R | 204 +++++++++------- R/states.R | 43 ++-- R/transportation.R | 147 +++--------- R/utils.R | 108 ++++++++- R/water.R | 102 +++----- 14 files changed, 741 insertions(+), 1239 deletions(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index a0ef8cb..9081005 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -58,24 +58,13 @@ counties <- function( year = NULL, ... ) { - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + resolution <- match_resolution(resolution) - cyear <- as.character(year) + year <- set_tigris_year(year, min_year = 1990) if (cb == TRUE) { if (year %in% c(1990, 2000)) { - suf <- substr(as.character(year), 3, 4) + suf <- year_suffix(year) url <- sprintf( "https://www2.census.gov/geo/tiger/PREVGENZ/co/co%sshp/co99_d%s_shp.zip", @@ -91,36 +80,35 @@ counties <- function( if (year > 2013) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_county_%s.zip", - cyear, - cyear, + year, + year, resolution ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/cb_%s_us_county_%s.zip", - cyear, - cyear, + year, + year, resolution ) } } } else { - if (year == 1990) - stop("Please specify `cb = TRUE` to get 1990 data.", call. = FALSE) + if (year == 1990) { + cli_abort("Please specify `cb = TRUE` to get 1990 data.") + } if (year %in% c(2000, 2010)) { - suf <- substr(cyear, 3, 4) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/COUNTY/%s/tl_2010_us_county%s.zip", - cyear, - suf + year, + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/COUNTY/tl_%s_us_county.zip", - cyear, - cyear + year, + year ) } } @@ -141,39 +129,39 @@ counties <- function( } if (year == 1990) { ctys <- ctys %>% - mutate(id = paste0(.data$ST, .data$CO)) %>% - group_by(.data$id) %>% + mutate(id = paste0(ST, CO)) %>% + group_by(id) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - ST = first(.data$ST), - CO = first(.data$CO), - CO99_D90_ = first(.data$CO99_D90_), - CO99_D90_I = first(.data$CO99_D90_I), - NAME = first(.data$NAME), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + ST = first(ST), + CO = first(CO), + CO99_D90_ = first(CO99_D90_), + CO99_D90_I = first(CO99_D90_I), + NAME = first(NAME), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% - select(-.data$id) %>% + select(-id) %>% st_cast("MULTIPOLYGON") } else if (year == 2000) { ctys <- ctys %>% - mutate(id = paste0(.data$STATE, .data$COUNTY)) %>% - group_by(.data$id) %>% + mutate(id = paste0(STATE, COUNTY)) %>% + group_by(id) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - STATE = first(.data$STATE), - COUNTY = first(.data$COUNTY), - CO99_D00_ = first(.data$CO99_D00_), - CO99_D00_I = first(.data$CO99_D00_I), - NAME = first(.data$NAME), - LSAD = first(.data$LSAD), - LSAD_TRANS = first(.data$LSAD_TRANS), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + STATE = first(STATE), + COUNTY = first(COUNTY), + CO99_D00_ = first(CO99_D00_), + CO99_D00_I = first(CO99_D00_I), + NAME = first(NAME), + LSAD = first(LSAD), + LSAD_TRANS = first(LSAD_TRANS), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% - select(-.data$id) %>% + select(-id) %>% st_cast("MULTIPOLYGON") } if (any(sclass == "SpatialPolygonsDataFrame")) { @@ -249,41 +237,33 @@ tracts <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year, min_year = 1990) if ( (resolution == "5m" && year < 2022) | (resolution == "5m" && !is.null(state)) ) { - stop( - "`resolution = '5m'` for Census tracts is only available for the national Census tract CB file in years 2022 and later.", - call. = FALSE + cli_abort( + "`resolution = '5m'` for Census tracts is only available for the national Census tract CB file in years 2022 and later." ) } if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message("Retrieving Census tracts for the entire United States") + cli_inform("Retrieving Census tracts for the entire United States") } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } if (cb == TRUE) { if (year %in% c(1990, 2000)) { - suf <- substr(as.character(year), 3, 4) + suf <- year_suffix(year) url <- sprintf( "https://www2.census.gov/geo/tiger/PREVGENZ/tr/tr%sshp/tr%s_d%s_shp.zip", @@ -300,40 +280,39 @@ tracts <- function( if (year > 2013) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_tract_%s.zip", - as.character(year), - as.character(year), + year, + year, state, resolution ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/cb_%s_%s_tract_500k.zip", - as.character(year), - as.character(year), + year, + year, state ) } } } else { - if (year == 1990) - stop("Please specify `cb = TRUE` to get 1990 data.", call. = FALSE) + if (year == 1990) { + cli_abort( + "Please specify `cb = TRUE` to get 1990 data." + ) + } if (year %in% c(2000, 2010)) { - cyear <- as.character(year) - - suf <- substr(cyear, 3, 4) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/TRACT/%s/tl_2010_%s_tract%s.zip", - cyear, + year, state, - suf + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/TRACT/tl_%s_%s_tract.zip", - as.character(year), - as.character(year), + year, + year, state ) } @@ -342,9 +321,7 @@ tracts <- function( trcts <- load_tiger(url, tigris_type = "tract", ...) if (!is.null(county)) { - county <- sapply(county, function(x) { - validate_county(state, x) - }) + county <- validate_county(state, county, multiple = TRUE) trcts <- trcts[trcts$COUNTYFP %in% county, ] } @@ -359,50 +336,50 @@ tracts <- function( trcts <- trcts %>% mutate( TRACTSUF = ifelse( - is.na(.data$TRACTSUF), + is.na(TRACTSUF), "00", - .data$TRACTSUF + TRACTSUF ) ) %>% mutate( id = paste0( - .data$ST, - .data$CO, - .data$TRACTBASE, - .data$TRACTSUF + ST, + CO, + TRACTBASE, + TRACTSUF ) ) %>% - group_by(.data$id) %>% + group_by(id) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - ST = first(.data$ST), - CO = first(.data$CO), - TRACTBASE = first(.data$TRACTBASE), - TRACTSUF = first(.data$TRACTSUF), - TRACT_NAME = first(.data$TRACT_NAME), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + ST = first(ST), + CO = first(CO), + TRACTBASE = first(TRACTBASE), + TRACTSUF = first(TRACTSUF), + TRACT_NAME = first(TRACT_NAME), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% - select(-.data$id) %>% + select(-id) %>% st_cast("MULTIPOLYGON") } else if (year == 2000) { trcts <- trcts %>% - mutate(TRACT = str_pad(.data$TRACT, 6, "right", "0")) %>% - mutate(id = paste0(.data$STATE, .data$COUNTY, .data$TRACT)) %>% - group_by(.data$id) %>% + mutate(TRACT = str_pad(TRACT, 6, "right", "0")) %>% + mutate(id = paste0(STATE, COUNTY, TRACT)) %>% + group_by(id) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - STATE = first(.data$STATE), - COUNTY = first(.data$COUNTY), - TRACT = first(.data$TRACT), - NAME = first(.data$NAME), - LSAD = first(.data$LSAD), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + STATE = first(STATE), + COUNTY = first(COUNTY), + TRACT = first(TRACT), + NAME = first(NAME), + LSAD = first(LSAD), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% - select(-.data$id) %>% + select(-id) %>% st_cast("MULTIPOLYGON") } if (any(sclass == "SpatialPolygonsDataFrame")) { @@ -463,75 +440,52 @@ school_districts <- function( year = NULL, ... ) { - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year) if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message("Retrieving school districts for the entire United States") + cli_inform( + "Retrieving school districts for the entire United States" + ) } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) + state <- validate_state(state, require_state = TRUE) } - if (type == 'unified') { - type <- 'unsd' - } else if (type == 'elementary') { - type <- 'elsd' - } else if (type == 'secondary') { - type <- 'scsd' - } else { - stop( - "Invalid school district type. Valid types are 'unified', 'elementary', and 'secondary'.", - call. = FALSE - ) - } + type <- arg_match(type, c("unified", "elementary", "secondary")) - cyear <- as.character(year) + type <- switch( + type, + unified = "unsd", + elementary = "elsd", + secondary = "scsd" + ) if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_%s_500k.zip", - cyear, - cyear, + year, + year, state, type ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/%s/tl_%s_%s_%s.zip", - cyear, + year, toupper(type), - cyear, + year, state, type ) } - return(load_tiger(url, tigris_type = type, ...)) + load_tiger(url, tigris_type = type, ...) } #' Download a Census block groups shapefile into R, and optionally subset by county @@ -586,35 +540,26 @@ block_groups <- function( year = NULL, ... ) { - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - cyear <- as.character(year) + year <- set_tigris_year(year, min_year = 1990) if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message( + cli_inform( "Retrieving Census block groups for the entire United States" ) } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } if (cb == TRUE) { if (year %in% c(1990, 2000)) { - suf <- substr(as.character(year), 3, 4) + suf <- year_suffix(year) url <- sprintf( "https://www2.census.gov/geo/tiger/PREVGENZ/bg/bg%sshp/bg%s_d%s_shp.zip", @@ -631,37 +576,38 @@ block_groups <- function( if (year > 2013) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_bg_500k.zip", - cyear, - cyear, + year, + year, state ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/cb_%s_%s_bg_500k.zip", - cyear, - cyear, + year, + year, state ) } } } else { - if (year == 1990) - stop("Please specify `cb = TRUE` to get 1990 data.", call. = FALSE) + if (year == 1990) { + cli_abort( + "Please specify `cb = TRUE` to get 1990 data." + ) + } if (year %in% c(2000, 2010)) { - suf <- substr(cyear, 3, 4) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/BG/%s/tl_2010_%s_bg%s.zip", - cyear, + year, state, - suf + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/BG/tl_%s_%s_bg.zip", - cyear, - cyear, + year, + year, state ) } @@ -670,9 +616,7 @@ block_groups <- function( bgs <- load_tiger(url, tigris_type = "block_group", ...) if (!is.null(county)) { - county <- sapply(county, function(x) { - validate_county(state, x) - }) + county <- validate_county(state, county, multiple = TRUE) bgs <- bgs[bgs$COUNTYFP %in% county, ] } @@ -685,48 +629,48 @@ block_groups <- function( } if (year == 1990) { bgs <- bgs %>% - group_by(.data$GEOID) %>% + group_by(GEOID) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - ST = first(.data$ST), - CO = first(.data$CO), - TRACT = first(.data$TRACT), - BG = first(.data$BG), - AREALAND = first(.data$AREALAND), - AREAWAT = first(.data$AREAWAT), - AREATOT = first(.data$AREATOT), - NAME = first(.data$NAME), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + ST = first(ST), + CO = first(CO), + TRACT = first(TRACT), + BG = first(BG), + AREALAND = first(AREALAND), + AREAWAT = first(AREAWAT), + AREATOT = first(AREATOT), + NAME = first(NAME), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% st_cast("MULTIPOLYGON") } else if (year == 2000) { bgs <- bgs %>% - mutate(TRACT = str_pad(.data$TRACT, 6, "right", "0")) %>% + mutate(TRACT = str_pad(TRACT, 6, "right", "0")) %>% mutate( id = paste0( - .data$STATE, - .data$COUNTY, - .data$TRACT, - .data$BLKGROUP + STATE, + COUNTY, + TRACT, + BLKGROUP ) ) %>% - group_by(.data$id) %>% + group_by(id) %>% summarize( - AREA = sum(.data$AREA), - PERIMETER = sum(.data$PERIMETER), - STATE = first(.data$STATE), - COUNTY = first(.data$COUNTY), - TRACT = first(.data$TRACT), - BLKGROUP = first(.data$BLKGROUP), - NAME = first(.data$NAME), - LSAD = first(.data$LSAD), - LSAD_TRANS = first(.data$LSAD_TRANS), - COUNTYFP = first(.data$COUNTYFP), - STATEFP = first(.data$STATEFP) + AREA = sum(AREA), + PERIMETER = sum(PERIMETER), + STATE = first(STATE), + COUNTY = first(COUNTY), + TRACT = first(TRACT), + BLKGROUP = first(BLKGROUP), + NAME = first(NAME), + LSAD = first(LSAD), + LSAD_TRANS = first(LSAD_TRANS), + COUNTYFP = first(COUNTYFP), + STATEFP = first(STATEFP) ) %>% - select(-.data$id) %>% + select(-id) %>% st_cast("MULTIPOLYGON") } if (any(sclass == "SpatialPolygonsDataFrame")) { @@ -785,52 +729,43 @@ zctas <- function( state = NULL, ... ) { - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year, min_year = 1990) if (year > 2020 && cb) { - stop( + cli_abort( sprintf( "The Census Bureau has not yet released the CB ZCTA file for %s. Please use the argument `year = 2020` or `cb = FALSE` instead.", year - ), - call. = FALSE + ) ) } if (!is.null(state) && year > 2010) { - stop("ZCTAs are only available by state for 2000 and 2010.") + cli_abort("ZCTAs are only available by state for 2000 and 2010.") } if (!is.null(state) && year == 2010 && cb == TRUE) { - stop( - "ZCTAs are only available by state for 2010 when cb = FALSE.", - call. = FALSE + cli_abort( + "ZCTAs are only available by state for 2010 when cb = FALSE." ) } if (year == 1990) { - stop( - "Zip Code Tabulation Areas are only available beginning with the 2000 Census.", - call. = FALSE + cli_abort( + "Zip Code Tabulation Areas are only available beginning with the 2000 Census." ) } - if (!is.null(state)) state <- validate_state(state) + state <- validate_state(state) cache <- getOption("tigris_use_cache") if (is.null(cache)) { - message( + cli_inform( "ZCTAs can take several minutes to download. To cache the data and avoid re-downloading in future R sessions, set `options(tigris_use_cache = TRUE)`" ) } - cyear <- as.character(year) - if (cb) { if (year == 2000) { if (is.null(state)) { @@ -846,45 +781,45 @@ zctas <- function( } else if (year >= 2020) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_zcta520_500k.zip", - cyear, - cyear + year, + year ) } else if (year < 2020) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_zcta510_500k.zip", - cyear, - cyear + year, + year ) if (year == 2013) url <- gsub("shp/", "", url) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_zcta520_500k.zip", - cyear, - cyear + year, + year ) } } else { if (year >= 2020) { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ZCTA520/tl_%s_us_zcta520.zip", - cyear, - cyear + year, + year ) } else { if (year %in% c(2000, 2010)) { - suf <- substr(cyear, 3, 4) + suf <- year_suffix(year) if (is.null(state)) { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/ZCTA5/%s/tl_2010_us_zcta5%s.zip", - cyear, + year, suf ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/ZCTA5/%s/tl_2010_%s_zcta5%s.zip", - cyear, + year, state, suf ) @@ -892,8 +827,8 @@ zctas <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ZCTA5/tl_%s_us_zcta510.zip", - cyear, - cyear + year, + year ) } } @@ -969,11 +904,7 @@ zctas <- function( #' #' } blocks <- function(state, county = NULL, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year, min_year = 2000) if (length(county) > 1 && year < 2011) { p <- lapply(county, function(x) { @@ -989,85 +920,73 @@ blocks <- function(state, county = NULL, year = NULL, ...) { msg <- "Block data are not available for 1990." - stop(msg, call. = FALSE) + cli_abort(msg) } - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - cyear <- as.character(year) + state <- validate_state(state, require_state = TRUE) if (year >= 2014) { if (year >= 2020) { # New block logic for 2020 url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/TABBLOCK20/tl_%s_%s_tabblock20.zip", - cyear, - cyear, + year, + year, state ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/TABBLOCK/tl_%s_%s_tabblock10.zip", - cyear, - cyear, + year, + year, state ) } } else if (year %in% 2011:2013) { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/TABBLOCK/tl_%s_%s_tabblock.zip", - cyear, - cyear, + year, + year, state ) } else if (year %in% c(2000, 2010)) { - suf <- substr(cyear, 3, 4) + county <- validate_county(state, county, allow_null = TRUE) if (!is.null(county)) { - county <- validate_county(state, county) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/TABBLOCK/%s/tl_2010_%s%s_tabblock%s.zip", - cyear, + year, state, county, - suf + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/TABBLOCK/%s/tl_2010_%s_tabblock%s.zip", - cyear, + year, state, suf ) } } else { - stop() + cli_abort() } blks <- load_tiger(url, tigris_type = "block", ...) if (!is.null(county) && year > 2010) { - if (year >= 2020) { - county <- sapply(county, function(x) { - validate_county(state, x) - }) + county <- validate_county(state, county, multiple = TRUE) + if (year >= 2020) { blks <- blks[blks$COUNTYFP20 %in% county, ] } else { - county <- sapply(county, function(x) { - validate_county(state, x) - }) - blks <- blks[blks$COUNTYFP10 %in% county, ] } } attr(blks, "tigris") <- "block" - return(blks) + blks } #' Download a county subdivision shapefile into R @@ -1107,28 +1026,9 @@ county_subdivisions <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2010) { - fname <- as.character(match.call())[[1]] + year <- set_tigris_year(year, min_year = 2010) - msg <- sprintf( - "%s is not currently available for years prior to 2010.", - fname - ) - - stop(msg, call. = FALSE) - } - - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - cyear <- as.character(year) + state <- validate_state(state, require_state = TRUE) if (cb == TRUE) { if (year == 2010) { @@ -1139,8 +1039,8 @@ county_subdivisions <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_cousub_500k.zip", - cyear, - cyear, + year, + year, state ) @@ -1155,8 +1055,8 @@ county_subdivisions <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/COUSUB/tl_%s_%s_cousub.zip", - cyear, - cyear, + year, + year, state ) } @@ -1165,14 +1065,10 @@ county_subdivisions <- function( cs <- load_tiger(url, tigris_type = "county_subdivision", ...) if (!is.null(county)) { - county <- sapply(county, function(x) { - validate_county(state, x) - }) - + county <- validate_county(state, county, multiple = TRUE) cs <- cs[cs$COUNTYFP %in% county, ] } attr(cs, "tigris") <- "county_subdivision" - - return(cs) + cs } diff --git a/R/helpers.R b/R/helpers.R index 191d53c..2aeb18c 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -42,7 +42,7 @@ tigris_cache_dir <- function(path) { var <- paste0("TIGRIS_CACHE_DIR=", "'", path, "'") write(var, renv, sep = "\n", append = TRUE) - message(sprintf( + cli_inform(sprintf( "Your new tigris cache directory is %s. \nTo use now, restart R or run `readRenviron('~/.Renviron')`", path )) @@ -171,7 +171,7 @@ load_tiger <- function( i <- 1 while (i < 4) { - message(sprintf( + cli_inform(sprintf( "Previous download failed. Re-download attempt %s of 3...", as.character(i) )) @@ -220,8 +220,14 @@ load_tiger <- function( # If using HTTP protocol and about to make final retry, try FTP as fallback if (i == 3 && protocol == "http") { - message("HTTP download failed, trying FTP as fallback...") - ftp_url <- gsub("^https://www2", "ftp://ftp2", original_url) + cli_inform( + "HTTP download failed, trying FTP as fallback..." + ) + ftp_url <- gsub( + "^https://www2", + "ftp://ftp2", + original_url + ) # Try FTP download options(timeout = timeout) @@ -237,9 +243,12 @@ load_tiger <- function( options(timeout = 60) # Reset to R default # Check if FTP download succeeded - t <- tryCatch(unzip_tiger(), warning = function(w) w) + t <- tryCatch( + unzip_tiger(), + warning = function(w) w + ) if (!("warning" %in% class(t))) { - break # FTP worked, exit the retry loop + break # FTP worked, exit the retry loop } } } else { @@ -248,10 +257,9 @@ load_tiger <- function( } if (i == 4) { - stop( + cli_abort( "Download failed with both HTTP and FTP; check your internet connection or the status of the Census Bureau website - at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/.", - call. = FALSE + at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/." ) } } else { @@ -317,15 +325,15 @@ load_tiger <- function( unzip_result <- tryCatch( { unzip(file_loc, exdir = tmp) - TRUE # Success + TRUE # Success }, - warning = function(w) FALSE, # Failed - error = function(e) FALSE # Failed + warning = function(w) FALSE, # Failed + error = function(e) FALSE # Failed ) # If HTTP download failed, try FTP as fallback if (!unzip_result && protocol == "http") { - message("HTTP download failed, trying FTP as fallback...") + cli_inform("HTTP download failed, trying FTP as fallback...") ftp_url <- gsub("^https://www2", "ftp://ftp2", original_url) # Try FTP download @@ -345,24 +353,22 @@ load_tiger <- function( unzip_result <- tryCatch( { unzip(file_loc, exdir = tmp) - TRUE # Success + TRUE # Success }, - warning = function(w) FALSE, # Failed - error = function(e) FALSE # Failed + warning = function(w) FALSE, # Failed + error = function(e) FALSE # Failed ) if (!unzip_result) { - stop( + cli_abort( "Download failed with both HTTP and FTP; check your internet connection or the status of the Census Bureau website - at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/.", - call. = FALSE + at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/." ) } } else if (!unzip_result) { - stop( + cli_abort( "Download failed; check your internet connection or the status of the Census Bureau website - at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/.", - call. = FALSE + at https://www2.census.gov/geo/tiger/ or ftp://ftp2.census.gov/geo/tiger/." ) } shape <- gsub(".zip", "", tiger_file) @@ -384,7 +390,9 @@ load_tiger <- function( attr(obj, "tigris") <- "tigris" # this will help identify the object "sub type" - if (!is.null(tigris_type)) attr(obj, "tigris") <- tigris_type + if (!is.null(tigris_type)) { + attr(obj, "tigris") <- tigris_type + } # Take care of COUNTYFP, STATEFP issues for historic data if ("COUNTYFP00" %in% names(obj)) { @@ -409,8 +417,7 @@ load_tiger <- function( stringr::str_wrap( "Spatial* (sp) classes are no longer formally supported in tigris as of version 2.0. We strongly recommend updating your workflow to use sf objects (the default in tigris) instead.", 50 - ), - call. = FALSE + ) ) return(sf::as_Spatial(obj)) } else { @@ -499,9 +506,8 @@ geo_join <- function( } else if (how == 'left') { return(spatial_data) } else { - stop( - "The available options for `how` are 'left' and 'inner'.", - call. = FALSE + cli_abort( + "The available options for `how` are 'left' and 'inner'." ) } @@ -542,9 +548,8 @@ geo_join <- function( return(joined) } else { - stop( - "The available options for `how` are 'left' and 'inner'.", - call. = FALSE + cli_abort( + "The available options for `how` are 'left' and 'inner'." ) } } @@ -586,9 +591,9 @@ geo_join <- function( #' ## [1] "The code for Maine is '23' and the code for York County is '031'." #' } lookup_code <- function(state, county = NULL) { - state <- validate_state(state, .msg = FALSE) + state <- validate_state(state, .msg = FALSE, require_state = TRUE) - if (is.null(state)) stop("Invalid state", call. = FALSE) + fips_codes <- tigris::fips_codes if (!is.null(county)) { vals <- fips_codes[ @@ -643,7 +648,9 @@ is_tigris <- function(obj) { #' or \code{NA} if \code{obj} is not a code \code{tigris} object #' @export tigris_type <- function(obj) { - if (is_tigris(obj)) return(attr(obj, "tigris")) + if (is_tigris(obj)) { + return(attr(obj, "tigris")) + } return(NA) } @@ -655,9 +662,9 @@ tigris_type <- function(obj) { #' @return data frame of county name and FIPS code or NULL if invalid state #' @export list_counties <- function(state) { - state <- validate_state(state, .msg = FALSE) + state <- validate_state(state, .msg = FALSE, require_state = TRUE) - if (is.null(state)) stop("Invalid state", call. = FALSE) + fips_codes <- tigris::fips_codes vals <- fips_codes[ fips_codes$state_code == state, @@ -712,7 +719,7 @@ rbind_tigris <- function(...) { ) & "sf" %in% obj_classes ) { - stop("Cannot combine sp and sf objects", call. = FALSE) + cli_abort("Cannot combine sp and sf objects") } #handling for attempts to rbind disparate school districts @@ -721,8 +728,7 @@ rbind_tigris <- function(...) { # 3 school district types warning( - "Multiple school district tigris types. Coercing to \'sdall\'.", - call. = FALSE + "Multiple school district tigris types. Coercing to \'sdall\'." ) elements <- lapply(seq_along(elements), function(x) { @@ -750,7 +756,7 @@ rbind_tigris <- function(...) { "SpatialPolygonsDataFrame" ) ) { - stop( + cli_abort( "Spatial* classes are no longer supported in tigris as of version 2.0. You will need to install an earlier version of tigris with `remotes::install_version()`." ) } else if ("sf" %in% obj_classes) { @@ -759,7 +765,9 @@ rbind_tigris <- function(...) { })) if (length(crs) > 1) { - stop("All objects must share a single coordinate reference system.") + cli_abort( + "All objects must share a single coordinate reference system." + ) } if ( @@ -797,9 +805,8 @@ rbind_tigris <- function(...) { attr(tmp, "tigris") <- obj_attrs_u return(tmp) } else { - stop( - "Objects must all be the same type of tigris object.", - call. = FALSE + cli_abort( + "Objects must all be the same type of tigris object." ) } } @@ -856,12 +863,10 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { # } if (!"sf" %in% class(input_sf)) { - stop("The input dataset is not an sf object.", call. = FALSE) + cli_abort("The input dataset is not an sf object.") } - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - } + year <- set_tigris_year(year, min_year = 2010) # Define st_erase function internally st_erase <- function(x, y) { @@ -883,9 +888,8 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { # If nothing returned, exit if (nrow(county_overlay) == 0) { - stop( - "Your dataset does not appear to be in the United States; this function is not appropriate for your data.", - call. = FALSE + cli_abort( + "Your dataset does not appear to be in the United States; this function is not appropriate for your data." ) } @@ -893,7 +897,7 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { county_GEOIDs <- county_overlay$GEOID # Fetch water for those GEOIDs - message("Fetching area water data for your dataset's location...") + cli_inform("Fetching area water data for your dataset's location...") my_water <- lapply(county_GEOIDs, function(cty) { suppressMessages(tigris::area_water( state = stringr::str_sub(cty, 1, 2), @@ -907,7 +911,7 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { sf::st_filter(input_sf) %>% # New step to only erase intersecting water areas dplyr::filter(dplyr::percent_rank(AWATER) >= area_threshold) - message( + cli_inform( "Erasing water area...\nIf this is slow, try a larger area threshold value." ) erased_sf <- suppressMessages(st_erase(input_sf, my_water)) diff --git a/R/landmarks.R b/R/landmarks.R index 4749b4b..7a81145 100644 --- a/R/landmarks.R +++ b/R/landmarks.R @@ -18,31 +18,15 @@ #' @export military <- function(year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/MIL/tl_%s_us_mil.zip", - as.character(year), - as.character(year) + year, + year ) - return(load_tiger(url, tigris_type = "military", ...)) + load_tiger(url, tigris_type = "military", ...) } @@ -76,48 +60,17 @@ military <- function(year = NULL, ...) { #' @inheritSection load_tiger_doc_template Additional Arguments #' @export landmarks <- function(state, type = "point", year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - state <- validate_state(state) - - cyear <- as.character(year) + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + type <- arg_match(type, c("area", "point")) if (type == "area") { - url <- sprintf( - "https://www2.census.gov/geo/tiger/TIGER%s/AREALM/tl_%s_%s_arealm.zip", - cyear, - cyear, - state - ) - return(load_tiger(url, tigris_type = "area_landmark", ...)) + url <- "https://www2.census.gov/geo/tiger/TIGER%s/AREALM/tl_%s_%s_arealm.zip" } else if (type == "point") { - url <- sprintf( - "https://www2.census.gov/geo/tiger/TIGER%s/POINTLM/tl_%s_%s_pointlm.zip", - cyear, - cyear, - state - ) - return(load_tiger(url, tigris_type = "point_landmark", ...)) - } else { - stop( - 'The argument supplied to type must be either "point" or "area"', - call. = FALSE - ) + url <- "https://www2.census.gov/geo/tiger/TIGER%s/POINTLM/tl_%s_%s_pointlm.zip" } + + url <- sprintf(url, year, year, state) + + load_tiger(url, tigris_type = paste0(type, "_landmark"), ...) } diff --git a/R/legislative.R b/R/legislative.R index 4c57623..fb00472 100644 --- a/R/legislative.R +++ b/R/legislative.R @@ -37,16 +37,11 @@ congressional_districts <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year, min_year = 2010) if (year < 2013 && cb) { - stop( - "`cb = TRUE` for congressional districts is unavailable prior to 2013. Regular TIGER/Line files are available for 2010 through 2010 with `cb = FALSE`", - call. = FALSE + cli_abort( + "`cb = TRUE` for congressional districts is unavailable prior to 2013. Regular TIGER/Line files are available for 2010 through 2010 with `cb = FALSE`" ) } @@ -68,31 +63,13 @@ congressional_districts <- function( congress <- "119" } - if (year < 2010) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2010.", - fname - ) - - stop(msg, call. = FALSE) - } - - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + resolution <- match_resolution(resolution) if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_cd%s_%s.zip", - cyear, - cyear, + year, + year, congress, resolution ) @@ -116,8 +93,8 @@ congressional_districts <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CD/tl_%s_%s_cd%s.zip", - cyear, - cyear, + year, + year, validate_state(state), congress ) @@ -125,8 +102,8 @@ congressional_districts <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CD/tl_%s_us_cd%s.zip", - cyear, - cyear, + year, + year, congress ) } @@ -183,60 +160,31 @@ state_legislative_districts <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year, min_year = 2000) if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message( + cli_inform( "Retrieving state legislative districts for the entire United States" ) } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } - if (!house %in% c("upper", "lower")) - stop( - "Must specify 'upper' or 'lower' for 'house' parameter", - call. = FALSE - ) - - if (house == "lower" & state == "31") { - # Nebraska + house <- arg_match(house, values = c("upper", "lower")) + type <- "sldu" - type <- "sldu" - } else if (house == "lower") { + # Avoid lower house type for Nebraska + if (house == "lower" && state != "31") { type <- "sldl" - } else { - type <- "sldu" } - cyear <- as.character(year) - if (cb == TRUE) { if (year == 2010) { if (type == "sldu") { @@ -254,8 +202,8 @@ state_legislative_districts <- function( url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_%s_500k.zip", - cyear, - cyear, + year, + year, state, type ) @@ -266,24 +214,24 @@ state_legislative_districts <- function( url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/%s/%s/tl_2010_%s_%s%s.zip", toupper(type), - cyear, + year, state, type, - substr(cyear, 3, 4) + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/%s/tl_%s_%s_%s.zip", - cyear, + year, toupper(type), - cyear, + year, state, type ) } } - return(load_tiger(url, tigris_type = "state_legislative_districts", ...)) + load_tiger(url, tigris_type = "state_legislative_districts", ...) } #' Download a voting districts shapefile into R @@ -336,26 +284,24 @@ voting_districts <- function( ... ) { if (year != 2020 && cb == TRUE) { - stop( - "Cartographic boundary voting districts files are only available for 2020.", - call. = FALSE + cli_abort( + "Cartographic boundary voting districts files are only available for 2020." ) } if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message("Retrieving voting districts for the entire United States") + cli_inform( + "Retrieving voting districts for the entire United States" + ) } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } if (cb) { @@ -369,9 +315,14 @@ voting_districts <- function( if (is.null(county)) { return(vtds) } else { - county = validate_county(state, county) - vtds_sub <- vtds[vtds$COUNTYFP20 == county, ] - return(vtds_sub) + county <- validate_county( + state, + county, + multiple = TRUE, + require_county = TRUE + ) + + return(vtds[vtds$COUNTYFP20 %in% county, ]) } } else { if (year == 2012) { @@ -382,7 +333,7 @@ voting_districts <- function( ) } else { if (!is.null(county)) { - county <- validate_county(state, county) + county <- validate_county(state, county, require_county = TRUE) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2020PL/LAYER/VTD/2020/tl_2020_%s%s_vtd20.zip", @@ -397,6 +348,6 @@ voting_districts <- function( } } - return(load_tiger(url, tigris_type = 'voting_districts', ...)) + load_tiger(url, tigris_type = 'voting_districts', ...) } } diff --git a/R/metro_areas.R b/R/metro_areas.R index 1bc3b1d..0915137 100644 --- a/R/metro_areas.R +++ b/R/metro_areas.R @@ -24,40 +24,16 @@ core_based_statistical_areas <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2010) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2010. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + year <- set_tigris_year(year, min_year = 2010) + resolution <- match_resolution(resolution) if (cb == TRUE) { if (year == 2010) { - if (resolution == "5m") - stop( - "Available resolutions are '500k' and '20m'", - call. = FALSE + if (resolution == "5m") { + cli_abort( + "Available resolutions are '500k' and '20m'" ) + } url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ2010/gz_2010_us_310_m1_%s.zip", resolution @@ -65,8 +41,8 @@ core_based_statistical_areas <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_cbsa_%s.zip", - cyear, - cyear, + year, + year, resolution ) @@ -80,13 +56,13 @@ core_based_statistical_areas <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CBSA/tl_%s_us_cbsa.zip", - cyear, - cyear + year, + year ) } } - return(load_tiger(url, tigris_type = "cbsa", ...)) + load_tiger(url, tigris_type = "cbsa", ...) } #' Download an urban areas shapefile into R @@ -105,38 +81,19 @@ core_based_statistical_areas <- function( #' @seealso \url{https://www.census.gov/programs-surveys/geography/guidance/geo-areas/urban-rural.html} #' @export urban_areas <- function(cb = FALSE, year = NULL, criteria = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) if (cb) { if (!is.null(criteria)) { - stop( - "The `criteria` argument is not supported for cartographic boundary files", - call. = FALSE + cli_abort( + "The `criteria` argument is not supported for cartographic boundary files" ) } url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_ua10_500k.zip", - cyear, - cyear + year, + year ) if (year == 2013) url <- gsub("shp/", "", url) @@ -145,39 +102,38 @@ urban_areas <- function(cb = FALSE, year = NULL, criteria = NULL, ...) { if (year == 2023) { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/UAC/tl_%s_us_uac20.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/UAC20/tl_%s_us_uac20.zip", - cyear, - cyear + year, + year ) } } else if (!is.null(criteria) && criteria == "2020") { if (year != 2020) { - stop( - "2020 criteria is only supported when `year` is set to 2020 at the moment.", - call. = FALSE + cli_abort( + "2020 criteria is only supported when `year` is set to 2020 at the moment." ) } url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/UAC/tl_%s_us_uac20.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/UAC/tl_%s_us_uac10.zip", - cyear, - cyear + year, + year ) } } - return(load_tiger(url, tigris_type = "urban", ...)) + load_tiger(url, tigris_type = "urban", ...) } #' Download a combined statistical areas shapefile into R @@ -202,42 +158,19 @@ combined_statistical_areas <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + year <- set_tigris_year(year) if (year == 2022) { - stop("CBSAs were not defined for 2022; choose a different year.") - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) + cli_abort("CBSAs were not defined for 2022; choose a different year.") } - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + resolution <- match_resolution(resolution) if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_csa_%s.zip", - cyear, - cyear, + year, + year, resolution ) @@ -245,12 +178,12 @@ combined_statistical_areas <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CSA/tl_%s_us_csa.zip", - cyear, - cyear + year, + year ) } - return(load_tiger(url, tigris_type = "csa", ...)) + load_tiger(url, tigris_type = "csa", ...) } #' Download a metropolitan divisions shapefile into R. @@ -264,33 +197,15 @@ combined_statistical_areas <- function( #' @seealso \url{https://www2.census.gov/geo/pdfs/maps-data/data/tiger/tgrshp2020/TGRSHP2020_TechDoc.pdf} #' @export metro_divisions <- function(year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/METDIV/tl_%s_us_metdiv.zip", - cyear, - cyear + year, + year ) - return(load_tiger(url, tigris_type = "metro", ...)) + load_tiger(url, tigris_type = "metro", ...) } #' Download a New England City and Town Area shapefile into R @@ -325,42 +240,21 @@ metro_divisions <- function(year = NULL, ...) { #' #' } new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year > 2021) { - stop("New England areas are no longer defined for years after 2021.") - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) + type <- arg_match(type, values = c("necta", "combined", "divisions")) if (type == 'necta') { if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_necta_500k.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/NECTA/tl_%s_us_necta.zip", - cyear, - cyear + year, + year ) } @@ -368,23 +262,18 @@ new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { } else if (type == 'combined') { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CNECTA/tl_%s_us_cnecta.zip", - cyear, - cyear + year, + year ) return(load_tiger(url, tigris_type = "cnecta", ...)) } else if (type == 'divisions') { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/NECTADIV/tl_%s_us_nectadiv.zip", - cyear, - cyear + year, + year ) return(load_tiger(url, tigris_type = "nectadiv", ...)) - } else { - stop( - "Invalid NECTA type; valid values include 'necta' (the default), 'combined', and 'divisions'.", - call. = FALSE - ) } } diff --git a/R/national.R b/R/national.R index 095e8d1..ac02ef5 100644 --- a/R/national.R +++ b/R/national.R @@ -18,37 +18,13 @@ #' } #' @export regions <- function(resolution = '500k', year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) + resolution <- match_resolution(resolution) url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_region_%s.zip", - cyear, - cyear, + year, + year, resolution ) @@ -77,43 +53,17 @@ regions <- function(resolution = '500k', year = NULL, ...) { #' addPolygons() #' } divisions <- function(resolution = '500k', year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) + resolution <- match_resolution(resolution) url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_division_%s.zip", - cyear, - cyear, + year, + year, resolution ) - div <- load_tiger(url, tigris_type = "division", ...) - - return(div) + load_tiger(url, tigris_type = "division", ...) } #' Download a US national boundary shapefile into R @@ -135,41 +85,15 @@ divisions <- function(resolution = '500k', year = NULL, ...) { #' addPolygons() #' } nation <- function(resolution = '5m', year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - if (!(resolution %in% c('5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '5m', and '20m'.", - call. = FALSE - ) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) + resolution <- match_resolution(resolution, values = c("5m", "20m")) url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_nation_%s.zip", - cyear, - cyear, + year, + year, resolution ) - nat <- load_tiger(url, tigris_type = "nation", ...) - - return(nat) + load_tiger(url, tigris_type = "nation", ...) } diff --git a/R/native.R b/R/native.R index 6ad7445..54f57ce 100644 --- a/R/native.R +++ b/R/native.R @@ -28,41 +28,23 @@ #' gg #' } native_areas <- function(cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_aiannh_500k.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/AIANNH/tl_%s_us_aiannh.zip", - cyear, - cyear + year, + year ) } - return(load_tiger(url, tigris_type = "native areas", ...)) + load_tiger(url, tigris_type = "native areas", ...) } #' Download an American Indian Tribal Subdivision National shapefile into R. @@ -91,23 +73,7 @@ native_areas <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_subdivisions_national <- function(cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) if (cb) { url <- sprintf( @@ -131,7 +97,7 @@ tribal_subdivisions_national <- function(cb = FALSE, year = NULL, ...) { } } - return(load_tiger(url, tigris_type = "tribal subdivisions", ...)) + load_tiger(url, tigris_type = "tribal subdivisions", ...) } #' Download an Alaska Native Regional Corporation shapefile into R. @@ -150,41 +116,23 @@ tribal_subdivisions_national <- function(cb = FALSE, year = NULL, ...) { #' @seealso \url{https://www2.census.gov/geo/pdfs/reference/GARM/Ch5GARM.pdf} #' @export alaska_native_regional_corporations <- function(cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) + year <- set_tigris_year(year) if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_02_anrc_500k.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ANRC/tl_%s_02_anrc.zip", - cyear, - cyear + year, + year ) } - return(load_tiger(url, tigris_type = "ANRCs", ...)) + load_tiger(url, tigris_type = "ANRCs", ...) } #' Download a Tribal block groups shapefile into R. @@ -223,27 +171,13 @@ alaska_native_regional_corporations <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_block_groups <- function(cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) if (cb) { url <- sprintf( - "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_tbg_500k.zip" + "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_tbg_500k.zip", + year, + year ) } else { url <- sprintf( @@ -253,7 +187,7 @@ tribal_block_groups <- function(cb = FALSE, year = NULL, ...) { ) } - return(load_tiger(url, tigris_type = "tribal block groups", ...)) + load_tiger(url, tigris_type = "tribal block groups", ...) } #' Download a Tribal Census tract shapefile into R. @@ -287,23 +221,7 @@ tribal_block_groups <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_census_tracts <- function(cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) if (cb) { url <- sprintf( @@ -319,5 +237,5 @@ tribal_census_tracts <- function(cb = FALSE, year = NULL, ...) { ) } - return(load_tiger(url, tigris_type = "tribal tracts", ...)) + load_tiger(url, tigris_type = "tribal tracts", ...) } diff --git a/R/places.R b/R/places.R index e1312b3..54177ef 100644 --- a/R/places.R +++ b/R/places.R @@ -24,61 +24,40 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { return(p) } - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) if (is.null(state)) { if (year > 2018 && cb == TRUE) { state <- "us" - message( + cli_inform( "Retrieving Census-designated places for the entire United States" ) } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } - cyear <- as.character(year) - if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_place_500k.zip", - cyear, - cyear, + year, + year, state ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/PLACE/tl_%s_%s_place.zip", - cyear, - cyear, + year, + year, state ) } - return(load_tiger(url, tigris_type = "place", ...)) + load_tiger(url, tigris_type = "place", ...) } #' Filter a \code{places} Spatial object for only those places matching the @@ -126,7 +105,9 @@ grep_place <- function(places, term) { #' } list_places <- function(places, sorted = TRUE) { if (is_tigris(places) & tigris_type(places) == "place") { - if (sorted) return(sort(places$NAME)) + if (sorted) { + return(sort(places$NAME)) + } return(places$NAME) } } diff --git a/R/pumas.R b/R/pumas.R index c617bfb..50ff59f 100644 --- a/R/pumas.R +++ b/R/pumas.R @@ -39,42 +39,21 @@ #' plot(us_pumas$geometry) #' } pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) if (is.null(state)) { if (year %in% 2019:2020 && cb) { state <- "us" - message("Retrieving PUMAs for the entire United States") + cli_inform("Retrieving PUMAs for the entire United States") } else { - stop( - "A state must be specified for this year/dataset combination.", - call. = FALSE + cli_abort( + "A state must be specified for this year/dataset combination." ) } } else { - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) } - cyear <- as.character(year) - if (year > 2021) { suf <- "20" } else { @@ -83,27 +62,26 @@ pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { if (cb) { if (year > 2020) { - stop( - "Cartographic boundary PUMAs are not yet available for years after 2020. Use the argument `year = 2019` for 2010 PUMA boundaries or `year = 2020` for 2020 PUMA boundaries instead to request your data.", - call. = FALSE + cli_abort( + "Cartographic boundary PUMAs are not yet available for years after 2020. Use the argument `year = 2019` for 2010 PUMA boundaries or `year = 2020` for 2020 PUMA boundaries instead to request your data." ) } if (year == 2020) { - message( + cli_inform( "The 2020 CB PUMAs use the new 2020 PUMA boundary definitions." ) url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_puma20_500k.zip", - cyear, - cyear, + year, + year, state ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_puma10_500k.zip", - cyear, - cyear, + year, + year, state ) @@ -112,8 +90,8 @@ pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/PUMA/tl_%s_%s_puma%s.zip", - cyear, - cyear, + year, + year, state, suf ) diff --git a/R/shift_geometry.R b/R/shift_geometry.R index 8d5a400..922b72c 100644 --- a/R/shift_geometry.R +++ b/R/shift_geometry.R @@ -77,24 +77,29 @@ #' #' #' } -shift_geometry <- function(input_sf, - geoid_column = NULL, - preserve_area = FALSE, - position = c("below", "outside")) { - +shift_geometry <- function( + input_sf, + geoid_column = NULL, + preserve_area = FALSE, + position = c("below", "outside") +) { # sf::sf_use_s2(FALSE) # Check to see if the input is an sf object, otherwise exit if (!any(grepl("sf", class(input_sf)))) { - stop("The input dataset must be an sf object.", call = FALSE) + cli_abort("The input dataset must be an sf object.") } position <- match.arg(position) # Get a set of minimal states which we'll need to use throughout the function # Do the CRS transformation here to avoid S2 issues with sf 1.0 - minimal_states <- tigris::states(cb = TRUE, resolution = "20m", progress_bar = FALSE, - year = 2020) %>% + minimal_states <- tigris::states( + cb = TRUE, + resolution = "20m", + progress_bar = FALSE, + year = 2020 + ) %>% sf::st_transform('ESRI:102003') # Make some bboxes to check to see if shifting geometry even makes sense @@ -115,37 +120,65 @@ shift_geometry <- function(input_sf, input_sf <- sf::st_transform(input_sf, sf::st_crs(minimal_states)) - ak_check <- suppressMessages(sf::st_intersects(input_sf, ak_bbox, sparse = FALSE)[,1]) - hi_check <- suppressMessages(sf::st_intersects(input_sf, hi_bbox, sparse = FALSE)[,1]) - pr_check <- suppressMessages(sf::st_intersects(input_sf, pr_bbox, sparse = FALSE)[,1]) + ak_check <- suppressMessages(sf::st_intersects( + input_sf, + ak_bbox, + sparse = FALSE + )[, 1]) + hi_check <- suppressMessages(sf::st_intersects( + input_sf, + hi_bbox, + sparse = FALSE + )[, 1]) + pr_check <- suppressMessages(sf::st_intersects( + input_sf, + pr_bbox, + sparse = FALSE + )[, 1]) if (!any(ak_check) && !any(hi_check) && !any(pr_check)) { - warning("None of your features are in Alaska, Hawaii, or Puerto Rico, so no geometries will be shifted.\nTransforming your object's CRS to 'ESRI:102003'", - call. = FALSE) + cli_warn( + "None of your features are in Alaska, Hawaii, or Puerto Rico, so no geometries will be shifted.\nTransforming your object's CRS to 'ESRI:102003'" + ) transformed_output <- sf::st_transform(input_sf, 'ESRI:102003') return(transformed_output) - } # Check to see if there is a GEOID column to identify state information # If it is a GEOID that works (e.g. counties, tracts), then use it and avoid spatial inferences if (!is.null(geoid_column)) { input_sf$state_fips <- stringr::str_sub(input_sf[[geoid_column]], 1, 2) } else { - # This is where we need to infer the location of the features - # We can do this by checking to see where the input features intersect - # the AK/HI/PR bounding boxes - input_sf <- input_sf %>% - sf::st_transform(sf::st_crs(minimal_states)) %>% - dplyr::mutate(state_fips = dplyr::case_when( - suppressMessages(sf::st_intersects(input_sf, ak_bbox, sparse = FALSE)[,1]) ~ "02", - suppressMessages(sf::st_intersects(input_sf, hi_bbox, sparse = FALSE)[,1]) ~ "15", - suppressMessages(sf::st_intersects(input_sf, pr_bbox, sparse = FALSE)[,1]) ~ "72", + # This is where we need to infer the location of the features + # We can do this by checking to see where the input features intersect + # the AK/HI/PR bounding boxes + input_sf <- input_sf %>% + sf::st_transform(sf::st_crs(minimal_states)) %>% + dplyr::mutate( + state_fips = dplyr::case_when( + suppressMessages(sf::st_intersects( + input_sf, + ak_bbox, + sparse = FALSE + )[, 1]) ~ + "02", + suppressMessages(sf::st_intersects( + input_sf, + hi_bbox, + sparse = FALSE + )[, 1]) ~ + "15", + suppressMessages(sf::st_intersects( + input_sf, + pr_bbox, + sparse = FALSE + )[, 1]) ~ + "72", TRUE ~ "00" - )) - } - + ) + ) + } # Alaska/Hawaii/PR centroids are necessary to put any dataset in the correct location ak_crs <- 3338 @@ -170,18 +203,23 @@ shift_geometry <- function(input_sf, sf::st_geometry() %>% sf::st_centroid() - # Parse the geometries (thanks to Claus Wilke for code samples & inspiration) - place_geometry_wilke <- function(geometry, position, - scale = 1, centroid = sf::st_centroid(geometry)) { - (geometry - centroid) * scale + - sf::st_sfc(st_point(position)) + place_geometry_wilke <- function( + geometry, + position, + scale = 1, + centroid = sf::st_centroid(geometry) + ) { + (geometry - centroid) * scale + sf::st_sfc(st_point(position)) } cont_us <- dplyr::filter(minimal_states, !GEOID %in% c("02", "15", "72")) %>% sf::st_transform('ESRI:102003') - us_lower48 <- dplyr::filter(input_sf, !state_fips %in% c("02", "15", "72")) %>% + us_lower48 <- dplyr::filter( + input_sf, + !state_fips %in% c("02", "15", "72") + ) %>% sf::st_transform('ESRI:102003') bb <- sf::st_bbox(cont_us) @@ -197,24 +235,27 @@ shift_geometry <- function(input_sf, # Area not preserved (Alaska smaller, Hawaii bigger) if (!preserve_area) { - - if(any(ak_check)) { + if (any(ak_check)) { # Rescale and shift Alaska ak_rescaled <- sf::st_transform(us_alaska, ak_crs) if (position == "below") { st_geometry(ak_rescaled) <- place_geometry_wilke( sf::st_geometry(ak_rescaled), - c(bb$xmin + 0.08*(bb$xmax - bb$xmin), - bb$ymin + 0.07*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.08 * (bb$xmax - bb$xmin), + bb$ymin + 0.07 * (bb$ymax - bb$ymin) + ), scale = 0.5, centroid = ak_centroid ) } else if (position == "outside") { st_geometry(ak_rescaled) <- place_geometry_wilke( sf::st_geometry(ak_rescaled), - c(bb$xmin - 0.08*(bb$xmax - bb$xmin), - bb$ymin + 1.2*(bb$ymax - bb$ymin)), + c( + bb$xmin - 0.08 * (bb$xmax - bb$xmin), + bb$ymin + 1.2 * (bb$ymax - bb$ymin) + ), scale = 0.5, centroid = ak_centroid ) @@ -225,8 +266,7 @@ shift_geometry <- function(input_sf, shapes_list <- c(shapes_list, list(ak_rescaled)) } - if(any(hi_check)) { - + if (any(hi_check)) { # Clip to the Hawaii bbox to take care of the long archipelago # then rescale and shift Hawaii hi_rescaled <- suppressWarnings( @@ -236,51 +276,53 @@ shift_geometry <- function(input_sf, ) if (position == "below") { - sf::st_geometry(hi_rescaled) <- place_geometry_wilke( sf::st_geometry(hi_rescaled), - c(bb$xmin + 0.35*(bb$xmax - bb$xmin), - bb$ymin + 0.*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.35 * (bb$xmax - bb$xmin), + bb$ymin + 0. * (bb$ymax - bb$ymin) + ), scale = 1.5, centroid = hi_centroid ) - } else if (position == "outside") { - sf::st_geometry(hi_rescaled) <- place_geometry_wilke( sf::st_geometry(hi_rescaled), - c(bb$xmin - 0.*(bb$xmax - bb$xmin), - bb$ymin + 0.2*(bb$ymax - bb$ymin)), + c( + bb$xmin - 0. * (bb$xmax - bb$xmin), + bb$ymin + 0.2 * (bb$ymax - bb$ymin) + ), scale = 1.5, centroid = hi_centroid ) - } st_crs(hi_rescaled) <- 'ESRI:102003' shapes_list <- c(shapes_list, list(hi_rescaled)) - } - - if(any(pr_check)) { + if (any(pr_check)) { # Rescale and shift Puerto Rico pr_rescaled <- sf::st_transform(us_puerto_rico, pr_crs) if (position == "below") { sf::st_geometry(pr_rescaled) <- place_geometry_wilke( sf::st_geometry(pr_rescaled), - c(bb$xmin + 0.65*(bb$xmax - bb$xmin), - bb$ymin + 0.*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.65 * (bb$xmax - bb$xmin), + bb$ymin + 0. * (bb$ymax - bb$ymin) + ), scale = 2.5, centroid = pr_centroid ) } else if (position == "outside") { sf::st_geometry(pr_rescaled) <- place_geometry_wilke( sf::st_geometry(pr_rescaled), - c(bb$xmin + 0.95*(bb$xmax - bb$xmin), - bb$ymin - 0.05*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.95 * (bb$xmax - bb$xmin), + bb$ymin - 0.05 * (bb$ymax - bb$ymin) + ), scale = 2.5, centroid = pr_centroid ) @@ -291,49 +333,47 @@ shift_geometry <- function(input_sf, shapes_list <- c(shapes_list, list(pr_rescaled)) } - output_data <- shapes_list %>% dplyr::bind_rows() %>% dplyr::select(-state_fips) return(output_data) - } else { - # Area preserved (Alaska and Hawaii are true to size) - if(any(ak_check)) { + if (any(ak_check)) { # Shift Alaska but do not rescale ak_shifted <- sf::st_transform(us_alaska, ak_crs) if (position == "below") { st_geometry(ak_shifted) <- place_geometry_wilke( sf::st_geometry(ak_shifted), - c(bb$xmin + 0.2*(bb$xmax - bb$xmin), - bb$ymin - 0.13*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.2 * (bb$xmax - bb$xmin), + bb$ymin - 0.13 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = ak_centroid ) } else if (position == "outside") { st_geometry(ak_shifted) <- place_geometry_wilke( sf::st_geometry(ak_shifted), - c(bb$xmin - 0.25*(bb$xmax - bb$xmin), - bb$ymin + 1.35*(bb$ymax - bb$ymin)), + c( + bb$xmin - 0.25 * (bb$xmax - bb$xmin), + bb$ymin + 1.35 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = ak_centroid ) } - - sf::st_crs(ak_shifted) <- 'ESRI:102003' shapes_list <- c(shapes_list, list(ak_shifted)) } - # Shift Hawaii but do not rescale - if(any(hi_check)) { + if (any(hi_check)) { hi_shifted <- suppressWarnings( us_hawaii %>% sf::st_intersection(hi_bbox) %>% @@ -343,16 +383,20 @@ shift_geometry <- function(input_sf, if (position == "below") { sf::st_geometry(hi_shifted) <- place_geometry_wilke( sf::st_geometry(hi_shifted), - c(bb$xmin + 0.6*(bb$xmax - bb$xmin), - bb$ymin - 0.1*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.6 * (bb$xmax - bb$xmin), + bb$ymin - 0.1 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = hi_centroid ) } else if (position == "outside") { sf::st_geometry(hi_shifted) <- place_geometry_wilke( sf::st_geometry(hi_shifted), - c(bb$xmin - 0.*(bb$xmax - bb$xmin), - bb$ymin + 0.2*(bb$ymax - bb$ymin)), + c( + bb$xmin - 0. * (bb$xmax - bb$xmin), + bb$ymin + 0.2 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = hi_centroid ) @@ -363,24 +407,27 @@ shift_geometry <- function(input_sf, shapes_list <- c(shapes_list, list(hi_shifted)) } - if(any(pr_check)) { - + if (any(pr_check)) { # Shift Puerto Rico but do not rescale pr_shifted <- sf::st_transform(us_puerto_rico, pr_crs) if (position == "below") { sf::st_geometry(pr_shifted) <- place_geometry_wilke( sf::st_geometry(pr_shifted), - c(bb$xmin + 0.75*(bb$xmax - bb$xmin), - bb$ymin - 0.1*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.75 * (bb$xmax - bb$xmin), + bb$ymin - 0.1 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = pr_centroid ) } else if (position == "outside") { sf::st_geometry(pr_shifted) <- place_geometry_wilke( sf::st_geometry(pr_shifted), - c(bb$xmin + 0.95*(bb$xmax - bb$xmin), - bb$ymin - 0.05*(bb$ymax - bb$ymin)), + c( + bb$xmin + 0.95 * (bb$xmax - bb$xmin), + bb$ymin - 0.05 * (bb$ymax - bb$ymin) + ), scale = 1, centroid = pr_centroid ) @@ -389,7 +436,6 @@ shift_geometry <- function(input_sf, st_crs(pr_shifted) <- 'ESRI:102003' shapes_list <- c(shapes_list, list(pr_shifted)) - } output_data <- shapes_list %>% @@ -397,7 +443,5 @@ shift_geometry <- function(input_sf, dplyr::select(-state_fips) return(output_data) - } - } diff --git a/R/states.R b/R/states.R index a978061..71fb1c6 100644 --- a/R/states.R +++ b/R/states.R @@ -29,24 +29,12 @@ #' setView(-98.5795, 39.8282, zoom=3) #' } states <- function(cb = FALSE, resolution = '500k', year = NULL, ...) { - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) - } - - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - cyear <- as.character(year) + resolution <- match_resolution(resolution) + year <- set_tigris_year(year, min_year = 1990) if (cb == TRUE) { if (year %in% c(1990, 2000)) { - suf <- substr(as.character(year), 3, 4) + suf <- year_suffix(year) url <- sprintf( "https://www2.census.gov/geo/tiger/PREVGENZ/st/st%sshp/st99_d%s_shp.zip", @@ -62,36 +50,37 @@ states <- function(cb = FALSE, resolution = '500k', year = NULL, ...) { if (year > 2013) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_state_%s.zip", - cyear, - cyear, + year, + year, resolution ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_state_%s.zip", - cyear, - cyear, + year, + year, resolution ) } } } else { - if (year == 1990) - stop("Please specify `cb = TRUE` to get 1990 data.", call. = FALSE) + if (year == 1990) { + cli_abort( + "Please specify `cb = TRUE` to get 1990 data." + ) + } if (year %in% c(2000, 2010)) { - suf <- substr(cyear, 3, 4) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/STATE/%s/tl_2010_us_state%s.zip", - cyear, - suf + year, + year_suffix(year) ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/STATE/tl_%s_us_state.zip", - cyear, - cyear + year, + year ) } } diff --git a/R/transportation.R b/R/transportation.R index 264c6d0..004b032 100644 --- a/R/transportation.R +++ b/R/transportation.R @@ -41,21 +41,14 @@ #' gg #' } roads <- function(state, county, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + multiple = TRUE, + require_county = TRUE + ) if (length(county) > 1) { r <- lapply(county, function(x) { @@ -66,23 +59,15 @@ roads <- function(state, county, year = NULL, ...) { return(r) } - state <- validate_state(state) - - county <- validate_county(state, county) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - if (is.null(county)) stop("Invalid county", call. = FALSE) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ROADS/tl_%s_%s%s_roads.zip", - as.character(year), - as.character(year), + year, + year, state, county ) - return(load_tiger(url, tigris_type = "road", ...)) + load_tiger(url, tigris_type = "road", ...) } #' Download a national primary roads shapefile into R @@ -108,31 +93,15 @@ roads <- function(state, county, year = NULL, ...) { #' #' } primary_roads <- function(year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/PRIMARYROADS/tl_%s_us_primaryroads.zip", - as.character(year), - as.character(year) + year, + year ) - return(load_tiger(url, tigris_type = "primary_roads", ...)) + load_tiger(url, tigris_type = "primary_roads", ...) } #' Download a primary & secondary roads shapefile into R @@ -164,36 +133,18 @@ primary_roads <- function(year = NULL, ...) { #' #' } primary_secondary_roads <- function(state, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] + year <- set_tigris_year(year) - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + state <- validate_state(state, require_state = TRUE) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/PRISECROADS/tl_%s_%s_prisecroads.zip", - as.character(year), - as.character(year), + year, + year, state ) - return(load_tiger(url, tigris_type = "prim_sec_roads", ...)) + load_tiger(url, tigris_type = "prim_sec_roads", ...) } #' Download a national rails shapefile into R @@ -215,31 +166,15 @@ primary_secondary_roads <- function(state, year = NULL, ...) { #' #' } rails <- function(year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/RAILS/tl_%s_us_rails.zip", - as.character(year), - as.character(year) + year, + year ) - return(load_tiger(url, tigris_type = "rails", ...)) + load_tiger(url, tigris_type = "rails", ...) } @@ -256,39 +191,17 @@ rails <- function(year = NULL, ...) { #' @seealso \url{https://www2.census.gov/geo/pdfs/maps-data/data/tiger/tgrshp2020/TGRSHP2020_TechDoc.pdf} #' @export address_ranges <- function(state, county, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } - - state <- validate_state(state) - - county <- validate_county(state, county) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - if (is.null(county)) stop("Invalid county", call. = FALSE) + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county(state, county, require_county = TRUE) url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ADDRFEAT/tl_%s_%s%s_addrfeat.zip", - as.character(year), - as.character(year), + year, + year, state, county ) - return(load_tiger(url, tigris_type = "address_range", ...)) + load_tiger(url, tigris_type = "address_range", ...) } diff --git a/R/utils.R b/R/utils.R index 50b7506..120b0a4 100644 --- a/R/utils.R +++ b/R/utils.R @@ -645,6 +645,112 @@ prep_input_sfc <- function( #' Get suffix of a 4 character year #' @noRd -year_suf <- function(year) { +year_suffix <- function(year) { substr(year, 3, 4) } + +#' Set default year and validate year for tigris function +#' +#' [set_tigris_year()] returns year as a character string. +#' +#' @param year Year to use for download. +#' @param default Default year to use if "tigris_year" option is not set. +#' @param min_year Minimum year. Varies by geography and data source. +#' @param quiet If `TRUE`, do not display message about the year when +#' downloading data. +#' @inheritParams source +#' @noRd +set_tigris_year <- function( + year = NULL, + default = 2024, + min_year = 2011, + max_year = 2024, + quiet = FALSE, + message = NULL, + call = caller_env() +) { + if (is.null(year)) { + year <- getOption("tigris_year", default) + + if (!quiet) { + cli_inform(sprintf("Retrieving data for the year %s", year)) + } + } + + check_tigris_year( + year, + min_year = min_year, + max_year = max_year, + message = message, + call = call + ) + + as.integer(year) +} + + +#' Check if year is valid within range and does not match error year +#' @noRd +check_tigris_year <- function( + year, + min_year = 2011, + max_year = 2024, + message = NULL, + call = caller_env() +) { + year <- as.integer(year) + + if (length(year) != 1 || nchar(year) != 4) { + cli_abort( + "{.arg year} must be an integer or string with a single year.", + call = call + ) + } + + if ((year >= min_year) && year <= max_year) { + return(invisible(NULL)) + } + + if (!is.null(message)) { + cli_abort(message, call = call) + } + + msg <- "%s is not currently available for any year before %s." + limit_year <- min_year + + if (year > max_year) { + msg <- "%s is not currently available for any year after %s." + limit_year <- max_year + } + + # TODO: Figure out a more elegant way to handle this need + trace <- trace_back() + fname <- call_name(quote(trace[["call"]][[1]])) + fname <- paste0("`", fname, "`") + + if (fname == "`[[`") { + fname <- "Requested data" + } + + msg <- sprintf(msg, fname, limit_year) + + cli_abort( + c( + msg, + "*" = "To request this feature, file an issue at {.url https://github.com/walkerke/tigris/issues}" + ), + call = call + ) +} + + +#' Check if resolution is valid +#' @noRd +match_resolution <- function( + resolution, + values = c("500k", "5m", "20m"), + error_call = caller_env() +) { + resolution <- tolower(resolution) + arg_match(resolution, values = values, error_call = error_call) +} diff --git a/R/water.R b/R/water.R index f4211ca..831cfec 100644 --- a/R/water.R +++ b/R/water.R @@ -24,23 +24,14 @@ #' #' } area_water <- function(state, county, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + require_county = TRUE, + multiple = TRUE + ) if (length(county) > 1) { w <- lapply(county, function(x) { @@ -51,26 +42,15 @@ area_water <- function(state, county, year = NULL, ...) { return(w) } - state <- validate_state(state) - - county <- validate_county(state, county) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - if (is.null(county) | length(county) > 1) - stop("Invalid county", call. = FALSE) - - cyear <- as.character(year) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/AREAWATER/tl_%s_%s%s_areawater.zip", - cyear, - cyear, + year, + year, state, county ) - return(load_tiger(url, tigris_type = "area_water", ...)) + load_tiger(url, tigris_type = "area_water", ...) } #' Download an linear water shapefile into R @@ -101,23 +81,14 @@ area_water <- function(state, county, year = NULL, ...) { #' #' } linear_water <- function(state, county, year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } - - if (year < 2011) { - fname <- as.character(match.call())[[1]] - - msg <- sprintf( - "%s is not currently available for years prior to 2011. To request this feature, - file an issue at https://github.com/walkerke/tigris.", - fname - ) - - stop(msg, call. = FALSE) - } + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + require_county = TRUE, + multiple = TRUE + ) if (length(county) > 1) { w <- lapply(county, function(x) { @@ -128,25 +99,15 @@ linear_water <- function(state, county, year = NULL, ...) { return(w) } - state <- validate_state(state) - - county <- validate_county(state, county) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - if (is.null(county)) stop("Invalid county", call. = FALSE) - - cyear <- as.character(year) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/LINEARWATER/tl_%s_%s%s_linearwater.zip", - cyear, - cyear, + year, + year, state, county ) - return(load_tiger(url, tigris_type = "linear_water", ...)) + load_tiger(url, tigris_type = "linear_water", ...) } #' Download a shapefile of the US coastline into R @@ -156,27 +117,22 @@ linear_water <- function(state, county, year = NULL, ...) { #' @export #' @family water functions coastline <- function(year = NULL, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2020) - - message(sprintf("Retrieving data for the year %s", year)) - } - - cyear <- as.character(year) + # FIXME: 2024 data is available - why use 2020 as default? + year <- set_tigris_year(year, default = 2020) if (year > 2016) { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/COASTLINE/tl_%s_us_coastline.zip", - cyear, - cyear + year, + year ) } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/COAST/tl_%s_us_coastline.zip", - cyear, - cyear + year, + year ) } - return(load_tiger(url, tigris_type = "coastline", ...)) + load_tiger(url, tigris_type = "coastline", ...) } From ebe8ecf91d27569a5b9a517920c18d5d4031c999 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Sun, 20 Jul 2025 18:10:57 -0400 Subject: [PATCH 03/23] Remove .onLoad call Unnecessary after prefixing fips_code --- R/zzz.R | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/R/zzz.R b/R/zzz.R index 209b35b..c592c8c 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -30,16 +30,10 @@ fips_state_table <- structure(list(abb = c("ak", "al", "ar", "as", "az", "ca", " ), class = "data.frame") -.onLoad <- function(libname, pkgname) { - # options(tigris_refresh=FALSE) - # options(tigris_use_cache=FALSE) - # options(tigris_year = 2015) - # options(tigris_class = "sp") - data("fips_codes", package=pkgname, envir=parent.env(environment())) -} - .onAttach <- function(libname, pkgname) { - packageStartupMessage("To enable caching of data, set `options(tigris_use_cache = TRUE)`\nin your R script or .Rprofile.") + packageStartupMessage( + "To enable caching of data, set `options(tigris_use_cache = TRUE)`\nin your R script or .Rprofile." + ) } utils::globalVariables(c(".data", "geoid", "GEOID", "state_fips", "AWATER")) From 7e637f81528bb7091a8355a9d256b346d8bd7d9c Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Mon, 21 Jul 2025 23:59:06 -0400 Subject: [PATCH 04/23] Correct typo in `blocks()` --- R/enumeration_units.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index 9081005..8ff4bc0 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -951,6 +951,7 @@ blocks <- function(state, county = NULL, year = NULL, ...) { ) } else if (year %in% c(2000, 2010)) { county <- validate_county(state, county, allow_null = TRUE) + suf <- year_suffix(year) if (!is.null(county)) { url <- sprintf( @@ -958,7 +959,7 @@ blocks <- function(state, county = NULL, year = NULL, ...) { year, state, county, - year_suffix(year) + suf ) } else { url <- sprintf( From 24e1f3b0e276d49ec8228ab3ab3a736b00d0566b Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 22 Jul 2025 00:10:22 -0400 Subject: [PATCH 05/23] Expand tests Reorganize test for enumeration units by function --- tests/testthat/_snaps/enumeration_units.md | 14 +- tests/testthat/test-enumeration_units.R | 169 ++++++++++++++++++--- tests/testthat/test-legislative.R | 53 ++++--- tests/testthat/test-native.R | 3 +- tests/testthat/test-places.R | 15 +- 5 files changed, 195 insertions(+), 59 deletions(-) diff --git a/tests/testthat/_snaps/enumeration_units.md b/tests/testthat/_snaps/enumeration_units.md index d69f446..d753d0b 100644 --- a/tests/testthat/_snaps/enumeration_units.md +++ b/tests/testthat/_snaps/enumeration_units.md @@ -1,4 +1,4 @@ -# enumeration unit functions work +# `counties()` works Code counties(cb = TRUE, progress_bar = FALSE) @@ -81,7 +81,7 @@ 9 2468694578 23299110 +39.5769252 -120.5219926 MULTIPOLYGON (((-120.5559 3... 10 510391739 21636754 +36.7272577 -085.1360977 MULTIPOLYGON (((-85.00988 3... ---- +# `school_districts()` works Code school_districts(state = state, progress_bar = FALSE) @@ -128,7 +128,7 @@ 9 -104.9361616 MULTIPOLYGON (((-105.2807 4... 10 -109.4725605 MULTIPOLYGON (((-110.1726 4... ---- +# `tracts()` works Code tracts(state = state, county = county, progress_bar = FALSE) @@ -147,7 +147,7 @@ INTPTLON geometry 155 -104.4683727 POLYGON ((-104.8999 43.4996... ---- +# `block_groups()` work Code block_groups(state = state, county = county, progress_bar = FALSE) @@ -169,7 +169,7 @@ 134 POLYGON ((-104.4524 42.7674... 135 POLYGON ((-104.8999 43.4996... ---- +# `blocks()` work Code blocks(state = state, county = county, progress_bar = FALSE) @@ -227,7 +227,7 @@ 64 POLYGON ((-104.8983 43.2649... 65 POLYGON ((-104.2031 43.2401... ---- +# `zctas()` works Code zctas(state = state, year = 2010, progress_bar = FALSE) @@ -261,7 +261,7 @@ 9 +44.5051794 -109.4355582 N MULTIPOLYGON (((-109.5092 4... 10 +44.5730104 -106.9325212 N MULTIPOLYGON (((-106.9343 4... ---- +# `county_subdivisions()` works Code county_subdivisions(state = state, county = county, progress_bar = FALSE) diff --git a/tests/testthat/test-enumeration_units.R b/tests/testthat/test-enumeration_units.R index 91e1146..8287750 100644 --- a/tests/testthat/test-enumeration_units.R +++ b/tests/testthat/test-enumeration_units.R @@ -1,4 +1,4 @@ -test_that("enumeration unit functions work", { +test_that("`counties()` works", { skip_on_cran() skip_on_ci() withr::local_options(list(tigris_use_cache = TRUE)) @@ -10,37 +10,82 @@ test_that("enumeration unit functions work", { counties <- counties(state = state) expect_s3_class(counties, "sf") + expect_s3_class(counties(state = state, year = 2010), "sf") + expect_s3_class(counties(state = state, year = 2013), "sf") expect_s3_class(counties(state = state, cb = TRUE), "sf") - # TODO: Restore tests after fixing tidyselect deprecation warning - # expect_s3_class(counties(state = state, year = 1990, cb = TRUE), "sf") - # expect_s3_class(counties(state = state, year = 2000, cb = TRUE), "sf") + expect_s3_class(counties(state = state, year = 1990, cb = TRUE), "sf") expect_s3_class(counties(state = state, year = 2010, cb = TRUE), "sf") + expect_s3_class(counties(state = state, year = 2013, cb = TRUE), "sf") expect_s3_class(counties(state = state, year = 2014, cb = TRUE), "sf") - expect_s3_class(counties(state = state, year = 2010), "sf") - expect_s3_class(counties(state = state, year = 2013), "sf") + expect_error( + counties(state = state, year = 1990) + ) +}) + +test_that("`school_districts()` works", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" - # expect_s3_class(school_districts(year = 2019), "sf") expect_snapshot(school_districts(state = state, progress_bar = FALSE)) expect_s3_class(school_districts(state = state, cb = TRUE), "sf") + expect_s3_class(school_districts(year = 2019, cb = TRUE), "sf") + expect_error(school_districts(year = 2018)) +}) - expect_s3_class(tracts(year = 2019, cb = TRUE), "sf") - +test_that("`tracts()` works", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" county <- "Niobrara" expect_snapshot(tracts(state = state, county = county, progress_bar = FALSE)) expect_s3_class(tracts(state = state, county = county, cb = TRUE), "sf") - # TODO: Restore test after fixing tidyselect deprecation warning - # expect_s3_class( - # tracts(state = state, county = county, year = 1990, cb = TRUE), - # "sf" - # ) + expect_s3_class( + tracts(state = state, county = county, year = 1990, cb = TRUE), + "sf" + ) expect_s3_class( tracts(state = state, county = county, year = 2013, cb = TRUE), "sf" ) expect_s3_class(tracts(state = state, county = county, year = 2010), "sf") + expect_s3_class( + tracts(state = state, year = 1990, cb = TRUE), + "sf" + ) + + expect_s3_class( + tracts(state = state, year = 2010, cb = TRUE), + "sf" + ) + + expect_s3_class(tracts(year = 2019, cb = TRUE), "sf") + + expect_s3_class(tracts(state = state, year = 2019, cb = TRUE), "sf") + + expect_s3_class(tracts(state = state, year = 2013, cb = TRUE), "sf") + + expect_error( + tracts(state = state, resolution = "5m") + ) + + expect_error( + tracts(state = state, year = 1990) + ) +}) + +test_that("`block_groups()` work", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" + county <- "Niobrara" + expect_snapshot(block_groups( state = state, county = county, @@ -54,10 +99,64 @@ test_that("enumeration unit functions work", { expect_s3_class(block_groups(state = state, year = 2014, cb = TRUE), "sf") expect_s3_class(block_groups(state = state, year = 2010), "sf") + expect_error(block_groups(year = 2018)) +}) + +test_that("`blocks()` work", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" + county <- "Niobrara" + expect_snapshot(blocks(state = state, county = county, progress_bar = FALSE)) + expect_s3_class( + blocks(state = state, county = county, year = 2020), + "sf" + ) + + expect_s3_class( + blocks(state = state, county = county, year = 2014), + "sf" + ) + + expect_s3_class( + blocks(state = state, county = county, year = 2013), + "sf" + ) + expect_s3_class( + blocks(state = state, county = c(county, "Lincoln"), year = 2010), + "sf" + ) + expect_s3_class( + blocks(state = state, county = c(county, "Lincoln"), year = 2011), + "sf" + ) + expect_s3_class( + blocks(state = state, county = c(county, "Lincoln"), year = 2020), + "sf" + ) + expect_s3_class( + blocks(state = state, year = 2000), + "sf" + ) + + expect_error(blocks(state = state, year = 1990)) +}) + + +test_that("`zctas()` works", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" + county <- "Niobrara" + expect_snapshot(zctas(state = state, year = 2010, progress_bar = FALSE)) + expect_s3_class(zctas(year = 2010, cb = TRUE), "sf") + expect_warning( zctas(year = 2000, cb = TRUE), "CB ZCTAs for 2000 include separate polygons for discontiguous parts." @@ -66,24 +165,46 @@ test_that("enumeration unit functions work", { zctas(state = state, year = 2000, cb = TRUE), "CB ZCTAs for 2000 include separate polygons for discontiguous parts." ) - expect_s3_class(zctas(year = 2010, cb = TRUE), "sf") + + expect_error(zctas(state = state, year = 2021, cb = TRUE)) + expect_error(zctas(state = state, year = 2010, cb = TRUE)) +}) + + +test_that("`county_subdivisions()` works", { + skip_on_cran() + skip_on_ci() + withr::local_options(list(tigris_use_cache = TRUE)) + state <- "WY" + county <- "Niobrara" expect_snapshot(county_subdivisions( state = state, county = county, progress_bar = FALSE )) -}) -test_that("enumeration unit functions error", { - skip_on_cran() - skip_on_ci() - state <- "WY" + expect_s3_class( + county_subdivisions(state = state, year = 2010, cb = TRUE), + "sf" + ) - expect_error(school_districts(year = 2018)) + expect_s3_class( + county_subdivisions(state = state, year = 2013, cb = TRUE), + "sf" + ) - expect_error(block_groups(year = 2018)) + expect_s3_class( + county_subdivisions(state = state, year = 2020, cb = TRUE), + "sf" + ) - expect_error(zctas(state = state, year = 2021, cb = TRUE)) - expect_error(zctas(state = state, year = 2010, cb = TRUE)) + expect_s3_class(county_subdivisions(state = state, year = 2010), "sf") + + expect_s3_class(county_subdivisions(state = state, year = 2020), "sf") + + expect_s3_class( + county_subdivisions(state = state, county = county, year = 2020), + "sf" + ) }) diff --git a/tests/testthat/test-legislative.R b/tests/testthat/test-legislative.R index c6cb5e1..f6db380 100644 --- a/tests/testthat/test-legislative.R +++ b/tests/testthat/test-legislative.R @@ -128,25 +128,18 @@ test_that("state_legislative_districts works", { state_legislative_districts(state = 31, house = "lower"), "sf" ) - # TODO: Add support if support for year < 2011 is added - # expect_s3_class( - # state_legislative_districts( - # state = state, - # house = "lower", - # cb = TRUE, - # year = 2010 - # ), - # "sf" - # ) - # expect_s3_class( - # state_legislative_districts( - # state = state, - # house = "upper", - # cb = TRUE, - # year = 2010 - # ), - # "sf" - # ) + expect_s3_class( + state_legislative_districts(state = state, house = "upper"), + "sf" + ) + expect_s3_class( + state_legislative_districts( + state = state, + house = "upper", + year = 2010 + ), + "sf" + ) expect_s3_class( state_legislative_districts( state = state, @@ -156,19 +149,25 @@ test_that("state_legislative_districts works", { ), "sf" ) - # TODO: Enable after adding support for year < 2011 + # TODO: Check if this test is supposed to work or not # expect_s3_class( # state_legislative_districts( # state = state, # house = "upper", - # year = 2010 + # year = 2010, + # cb = TRUE + # ), + # "sf" + # ) + # expect_s3_class( + # state_legislative_districts( + # state = state, + # house = "lower", + # year = 2010, + # cb = TRUE # ), # "sf" # ) - expect_s3_class( - state_legislative_districts(state = state, house = "upper"), - "sf" - ) }) @@ -191,5 +190,9 @@ test_that("voting_districts works", { expect_s3_class(voting_districts(state = state, cb = TRUE), "sf") expect_s3_class(voting_districts(state = state, county = "Albany"), "sf") + expect_s3_class( + voting_districts(state = state, county = "Albany", cb = TRUE), + "sf" + ) expect_s3_class(voting_districts(state = state, year = 2012), "sf") }) diff --git a/tests/testthat/test-native.R b/tests/testthat/test-native.R index b4d0d17..a0f4563 100644 --- a/tests/testthat/test-native.R +++ b/tests/testthat/test-native.R @@ -20,8 +20,7 @@ test_that("native functions work", { # expect_s3_class(alaska_native_regional_corporations(year = 2000), "sf") expect_s3_class(tribal_block_groups(), "sf") - # TODO: Enable test after fixing issue w/ tribal_block_groups - # expect_s3_class(tribal_block_groups(cb = TRUE), "sf") + expect_s3_class(tribal_block_groups(cb = TRUE), "sf") # TODO: Enable test after adding year < 2011 support # expect_s3_class(tribal_block_groups(year = 2010), "sf") diff --git a/tests/testthat/test-places.R b/tests/testthat/test-places.R index 49734a3..11aed86 100644 --- a/tests/testthat/test-places.R +++ b/tests/testthat/test-places.R @@ -21,5 +21,18 @@ test_that("places works", { expect_s3_class(state_places, "sf") expect_type(list_places(state_places), "character") - expect_type(list_places(state_places, sorted = TRUE), "character") + expect_type(list_places(state_places, sorted = FALSE), "character") + + expect_type( + grep_place(state_places, "Laramie"), + "character" + ) + + expect_s3_class( + filter_place( + state_places, + "Laramie" + ), + "sf" + ) }) From 962d4939fca6b26d4f88b73bf8940180f519add6 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 22 Jul 2025 00:11:21 -0400 Subject: [PATCH 06/23] Tidy DESCRIPTION Also swap email for Eli Pousson --- DESCRIPTION | 54 +++++++++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 26 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8546da4..da64acf 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,44 +1,46 @@ -Package: tigris Type: Package +Package: tigris Title: Load Census TIGER/Line Shapefiles Version: 2.2.1.9000 Date: 2025-07-18 Authors@R: c( - person(given="Kyle", family="Walker", email="kyle@walker-data.com", role=c("aut", "cre")), - person(given="Bob", family="Rudis", email="bob@rudis.net", role="ctb"), - person(given="Eli", family="Pousson", email="Eli.Pousson@baltimorecity.gov", role="ctb") - ) -URL: https://github.com/walkerke/tigris -BugReports: https://github.com/walkerke/tigris/issues -Description: Download TIGER/Line shapefiles from the United States Census Bureau + person("Kyle", "Walker", , "kyle@walker-data.com", role = c("aut", "cre")), + person("Bob", "Rudis", , "bob@rudis.net", role = "ctb"), + person("Eli", "Pousson", , "eli.pousson@gmail.com", role = "ctb", + comment = c(ORCID = "0000-0001-8280-1706")) + ) +Description: Download TIGER/Line shapefiles from the United States Census + Bureau () and load into R as 'sf' objects. License: MIT + file LICENSE -LazyData: TRUE -Encoding: UTF-8 +URL: https://github.com/walkerke/tigris +BugReports: https://github.com/walkerke/tigris/issues Depends: R (>= 3.3.0) +Imports: + cli, + dplyr, + httr, + magrittr, + methods, + rappdirs, + rlang, + sf, + stringr, + utils, + uuid Suggests: - testthat (>= 3.0.0), ggplot2, ggthemes, - leaflet, knitr, - tidycensus, + leaflet, sp, + testthat (>= 3.0.0), + tidycensus, withr -Imports: - stringr, - magrittr, - utils, - rappdirs, - httr, - uuid, - sf, - dplyr, - methods, - cli, - rlang Config/testthat/edition: 3 -RoxygenNote: 7.3.2 +Encoding: UTF-8 +LazyData: TRUE Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 From 877e1cf9d02917a2a24be028d71370bc106ed51f Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 22 Jul 2025 00:16:37 -0400 Subject: [PATCH 07/23] Drop uuid from Imports + ggthemes from Suggests `theme_void()` is equivalent to `ggthemes::theme_map()` so dropped ggthemes from examples --- DESCRIPTION | 4 +--- NAMESPACE | 1 - R/native.R | 3 +-- R/tigris-package.R | 1 - R/transportation.R | 3 +-- man/native_areas.Rd | 3 +-- man/roads.Rd | 3 +-- man/tigris-package.Rd | 2 +- 8 files changed, 6 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index da64acf..c145cb9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,11 +28,9 @@ Imports: rlang, sf, stringr, - utils, - uuid + utils Suggests: ggplot2, - ggthemes, knitr, leaflet, sp, diff --git a/NAMESPACE b/NAMESPACE index 56ea5a9..0aa5a46 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -63,7 +63,6 @@ import(rappdirs) import(rlang) import(sf) import(utils) -import(uuid) importFrom(cli,cli_abort) importFrom(cli,cli_inform) importFrom(cli,cli_warn) diff --git a/R/native.R b/R/native.R index 54f57ce..eba709f 100644 --- a/R/native.R +++ b/R/native.R @@ -16,7 +16,6 @@ #' @examples \dontrun{ #' library(tigris) #' library(ggplot2) -#' library(ggthemes) #' #' nat <- native_areas(cb = TRUE) #' @@ -24,7 +23,7 @@ #' gg <- gg + geom_sf(data = nat, color="black", fill="white", size=0.25) #' gg <- gg + coord_sf(xlim=c(-179.1506, -129.9795), # alaska #' ylim=c(51.2097, 71.4410)) -#' gg <- gg + theme_map() +#' gg <- gg + theme_void() #' gg #' } native_areas <- function(cb = FALSE, year = NULL, ...) { diff --git a/R/tigris-package.R b/R/tigris-package.R index 913db45..cb79075 100644 --- a/R/tigris-package.R +++ b/R/tigris-package.R @@ -35,7 +35,6 @@ #' @import utils #' @import rappdirs #' @import httr -#' @import uuid #' @import sf #' @import dplyr #' @importFrom cli cli_abort cli_warn cli_inform diff --git a/R/transportation.R b/R/transportation.R index 004b032..ab4e9bb 100644 --- a/R/transportation.R +++ b/R/transportation.R @@ -30,14 +30,13 @@ #' @examples \dontrun{ #' library(tigris) #' library(ggplot2) -#' library(ggthemes) #' #' roads <- roads("Maine", "031") #' #' gg <- ggplot() #' gg <- gg + geom_sf(data = roads, #' color="black", fill="white", size=0.25) -#' gg <- gg + theme_map() +#' gg <- gg + theme_void() #' gg #' } roads <- function(state, county, year = NULL, ...) { diff --git a/man/native_areas.Rd b/man/native_areas.Rd index 5cdd617..c0ae8c6 100644 --- a/man/native_areas.Rd +++ b/man/native_areas.Rd @@ -41,7 +41,6 @@ option \code{"tigris_refresh"} if it is set. Specifying this argument will overr \dontrun{ library(tigris) library(ggplot2) -library(ggthemes) nat <- native_areas(cb = TRUE) @@ -49,7 +48,7 @@ gg <- ggplot() gg <- gg + geom_sf(data = nat, color="black", fill="white", size=0.25) gg <- gg + coord_sf(xlim=c(-179.1506, -129.9795), # alaska ylim=c(51.2097, 71.4410)) -gg <- gg + theme_map() +gg <- gg + theme_void() gg } } diff --git a/man/roads.Rd b/man/roads.Rd index 80ec46b..dd267d6 100644 --- a/man/roads.Rd +++ b/man/roads.Rd @@ -61,14 +61,13 @@ option \code{"tigris_refresh"} if it is set. Specifying this argument will overr \dontrun{ library(tigris) library(ggplot2) -library(ggthemes) roads <- roads("Maine", "031") gg <- ggplot() gg <- gg + geom_sf(data = roads, color="black", fill="white", size=0.25) -gg <- gg + theme_map() +gg <- gg + theme_void() gg } } diff --git a/man/tigris-package.Rd b/man/tigris-package.Rd index 459e6e6..fb112f8 100644 --- a/man/tigris-package.Rd +++ b/man/tigris-package.Rd @@ -55,7 +55,7 @@ Kyle Walker (@kyle_e_walker) Other contributors: \itemize{ \item Bob Rudis \email{bob@rudis.net} [contributor] - \item Eli Pousson \email{Eli.Pousson@baltimorecity.gov} [contributor] + \item Eli Pousson \email{eli.pousson@gmail.com} (\href{https://orcid.org/0000-0001-8280-1706}{ORCID}) [contributor] } } From ef393ea8b9b7d95b948f3f99642e8adc079186c0 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 22 Jul 2025 00:26:54 -0400 Subject: [PATCH 08/23] Fix check issue w/ `globalVariables` Issue due to removal of .data --- R/zzz.R | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/R/zzz.R b/R/zzz.R index c592c8c..bee3078 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -36,4 +36,34 @@ fips_state_table <- structure(list(abb = c("ak", "al", "ar", "as", "az", "ca", " ) } -utils::globalVariables(c(".data", "geoid", "GEOID", "state_fips", "AWATER")) +utils::globalVariables(c( + ".data", + "geoid", + "GEOID", + "state_fips", + "AWATER", + "AREA", + "AREALAND", + "AREATOT", + "AREAWAT", + "BG", + "BLKGROUP", + "CO", + "CO99_D00_", + "CO99_D00_I", + "CO99_D90_", + "CO99_D90_I", + "COUNTY", + "COUNTYFP", + "LSAD", + "LSAD_TRANS", + "NAME", + "PERIMETER", + "ST", + "STATE", + "STATEFP", + "TRACT", + "TRACTBASE", + "TRACTSUF", + "TRACT_NAME" +)) From 6158376af085ec65af84e215041acbd45605cc94 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 22 Jul 2025 14:54:20 -0400 Subject: [PATCH 09/23] Add missing max_year for `new_england()` Add test for new_england error --- R/metro_areas.R | 3 ++- tests/testthat/test-metro_areas.R | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/R/metro_areas.R b/R/metro_areas.R index 0915137..55f458c 100644 --- a/R/metro_areas.R +++ b/R/metro_areas.R @@ -240,7 +240,8 @@ metro_divisions <- function(year = NULL, ...) { #' #' } new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { - year <- set_tigris_year(year) + # TODO: Consider setting default year to 2021 for new_england + year <- set_tigris_year(year, max_year = 2021) type <- arg_match(type, values = c("necta", "combined", "divisions")) if (type == 'necta') { diff --git a/tests/testthat/test-metro_areas.R b/tests/testthat/test-metro_areas.R index 61ac4fb..105206e 100644 --- a/tests/testthat/test-metro_areas.R +++ b/tests/testthat/test-metro_areas.R @@ -34,4 +34,6 @@ test_that("metro areas functions error", { expect_error(urban_areas(year = 2021, criteria = 2020)) expect_error(combined_statistical_areas(year = 2022)) + + expect_error(new_england(year = 2024)) }) From 902bdb42deb7add15632179cd299c45ec3e8d491 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 29 Jul 2025 23:07:17 -0400 Subject: [PATCH 10/23] Add `not_year` arg to `check_tigris_year()` Simplify `check_tigris_year()` by removing function name from message and dropping "To request this feature, file an issue" suggestion Add `not_year` argument to exclude years between min/max values --- R/utils.R | 41 +++++++++++++++++------------------------ 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/R/utils.R b/R/utils.R index 120b0a4..a58e311 100644 --- a/R/utils.R +++ b/R/utils.R @@ -665,6 +665,7 @@ set_tigris_year <- function( default = 2024, min_year = 2011, max_year = 2024, + not_year = NULL, quiet = FALSE, message = NULL, call = caller_env() @@ -681,6 +682,7 @@ set_tigris_year <- function( year, min_year = min_year, max_year = max_year, + not_year = not_year, message = message, call = call ) @@ -695,11 +697,13 @@ check_tigris_year <- function( year, min_year = 2011, max_year = 2024, + not_year = NULL, message = NULL, call = caller_env() ) { year <- as.integer(year) + # Check that eyar is valid integer or integer-like string if (length(year) != 1 || nchar(year) != 4) { cli_abort( "{.arg year} must be an integer or string with a single year.", @@ -707,38 +711,27 @@ check_tigris_year <- function( ) } - if ((year >= min_year) && year <= max_year) { - return(invisible(NULL)) - } + outside_range <- !dplyr::between(year, min_year, max_year) + # TODO: Validate not_year + not_allowed <- is.numeric(not_year) && (year %in% not_year) - if (!is.null(message)) { - cli_abort(message, call = call) + if (!outside_range && !not_allowed) { + return(invisible(NULL)) } - msg <- "%s is not currently available for any year before %s." - limit_year <- min_year - - if (year > max_year) { - msg <- "%s is not currently available for any year after %s." - limit_year <- max_year + if (not_allowed) { + message <- c( + message, + "{.arg year} must be between {min_year} and {max_year}." + ) } - # TODO: Figure out a more elegant way to handle this need - trace <- trace_back() - fname <- call_name(quote(trace[["call"]][[1]])) - fname <- paste0("`", fname, "`") - - if (fname == "`[[`") { - fname <- "Requested data" + if (not_allowed) { + year <- c(message, "{.arg year} can't be {.or {not_year}}.") } - msg <- sprintf(msg, fname, limit_year) - cli_abort( - c( - msg, - "*" = "To request this feature, file an issue at {.url https://github.com/walkerke/tigris/issues}" - ), + message, call = call ) } From 23f60558b1f453ef1f67b614cfcf294fc876abd8 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 29 Jul 2025 23:09:12 -0400 Subject: [PATCH 11/23] Fix `blocks()` error message Remove duplicative check for year < 1990 (couldn't be triggered) Remove call to cli_abort w/ no message (for years 2001-2009 --- R/enumeration_units.R | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index 8ff4bc0..dbe8382 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -904,7 +904,13 @@ zctas <- function( #' #' } blocks <- function(state, county = NULL, year = NULL, ...) { - year <- set_tigris_year(year, min_year = 2000) + year <- set_tigris_year( + year, + min_year = 2000, + not_year = c(2001:2009) + ) + + state <- validate_state(state, require_state = TRUE) if (length(county) > 1 && year < 2011) { p <- lapply(county, function(x) { @@ -915,16 +921,6 @@ blocks <- function(state, county = NULL, year = NULL, ...) { return(p) } - if (year < 2000) { - fname <- as.character(match.call())[[1]] - - msg <- "Block data are not available for 1990." - - cli_abort(msg) - } - - state <- validate_state(state, require_state = TRUE) - if (year >= 2014) { if (year >= 2020) { # New block logic for 2020 @@ -969,8 +965,6 @@ blocks <- function(state, county = NULL, year = NULL, ...) { suf ) } - } else { - cli_abort() } blks <- load_tiger(url, tigris_type = "block", ...) From 94d28bc3767dac0b76c959e0fc1a6554894636d8 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 29 Jul 2025 23:21:18 -0400 Subject: [PATCH 12/23] Fix typo in check_tigris_year --- R/utils.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/R/utils.R b/R/utils.R index a58e311..3a2a7d7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -674,7 +674,7 @@ set_tigris_year <- function( year <- getOption("tigris_year", default) if (!quiet) { - cli_inform(sprintf("Retrieving data for the year %s", year)) + cli_inform("Retrieving data for {year}") } } @@ -719,15 +719,18 @@ check_tigris_year <- function( return(invisible(NULL)) } - if (not_allowed) { + if (outside_range) { message <- c( message, - "{.arg year} must be between {min_year} and {max_year}." + "i" = "{.arg year} must be between {min_year} and {max_year}." ) } if (not_allowed) { - year <- c(message, "{.arg year} can't be {.or {not_year}}.") + year <- c( + message, + "i" = "{.arg year} can't be {.or {not_year}}." + ) } cli_abort( From 7c77bc619af768989d632de30522447c5a6a5e28 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 29 Jul 2025 23:21:45 -0400 Subject: [PATCH 13/23] Reformat messages for `zctas()` --- R/enumeration_units.R | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index dbe8382..591ab9f 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -729,30 +729,28 @@ zctas <- function( state = NULL, ... ) { - year <- set_tigris_year(year, min_year = 1990) + year <- set_tigris_year( + year, + message = "Zip Code Tabulation Areas (ZCTAs) are only available beginning with the 2000 Census.", + min_year = 2000 + ) if (year > 2020 && cb) { cli_abort( - sprintf( - "The Census Bureau has not yet released the CB ZCTA file for %s. Please use the argument `year = 2020` or `cb = FALSE` instead.", - year + c( + "The Census Bureau has not yet released the CB ZCTA file for {year}.", + "*" = "Please set `year = 2020` or `cb = FALSE` instead." ) ) } if (!is.null(state) && year > 2010) { - cli_abort("ZCTAs are only available by state for 2000 and 2010.") - } - - if (!is.null(state) && year == 2010 && cb == TRUE) { - cli_abort( - "ZCTAs are only available by state for 2010 when cb = FALSE." - ) + cli_abort("ZCTAs are only available by state for 2000 and 2010, not {year}.") } - if (year == 1990) { + if (!is.null(state) && year == 2010 && cb) { cli_abort( - "Zip Code Tabulation Areas are only available beginning with the 2000 Census." + "ZCTAs are only available by state for 2010 when `cb = FALSE`." ) } @@ -762,7 +760,10 @@ zctas <- function( if (is.null(cache)) { cli_inform( - "ZCTAs can take several minutes to download. To cache the data and avoid re-downloading in future R sessions, set `options(tigris_use_cache = TRUE)`" + c( + "!" = "ZCTAs can take several minutes to download.", + "*" = "Set `options(tigris_use_cache = TRUE)` to cache the data and avoid re-downloading in future R sessions." + ) ) } @@ -838,8 +839,11 @@ zctas <- function( # Handle split ZCTAs in 2000 CB file if (year == 2000 && cb) { - warning( - "CB ZCTAs for 2000 include separate polygons for discontiguous parts.\nCombine by summarizing over the ZCTA column; this can be a time-consuming operation." + cli_inform( + c( + "!" = "CB ZCTAs for 2000 include separate polygons for discontiguous parts.", + "*" = "Combine by summarizing over the ZCTA column but note that this can be a time-consuming operation." + ) ) } From 88b9dc165414f4d85f24523c5c68e0ffaaf2007e Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 00:31:26 -0400 Subject: [PATCH 14/23] Add `check_cb()` helper Revert change to set_tigris_year message --- R/utils.R | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 3a2a7d7..ecd5d2f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -674,7 +674,7 @@ set_tigris_year <- function( year <- getOption("tigris_year", default) if (!quiet) { - cli_inform("Retrieving data for {year}") + cli_inform("Retrieving data for the year {year}") } } @@ -750,3 +750,19 @@ match_resolution <- function( resolution <- tolower(resolution) arg_match(resolution, values = values, error_call = error_call) } + +#' Check if cb argument is valid +#' @noRd +check_cb <- function( + cb, + call = caller_env() +) { + if (is.logical(cb) && has_length(cb, 1)) { + return(invisible(NULL)) + } + + cli_abort( + "{.arg cb} must be TRUE or FALSE, not {.obj_type_friendly {cb}}.", + call = call + ) +} From 7fd1ad1b29a2ca414da126f37eb8abe3c3656bd9 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 00:33:52 -0400 Subject: [PATCH 15/23] Incorporate `check_cb()` helper Relocate match_resolution function to calls w/ cb = TRUE --- R/enumeration_units.R | 38 ++++++++++++++++++++++---------------- R/helpers.R | 7 +++---- R/legislative.R | 31 ++++++++++++++----------------- R/metro_areas.R | 27 ++++++++++++++++----------- R/national.R | 4 ++-- R/native.R | 9 +++++++-- R/places.R | 12 ++++++------ R/pumas.R | 6 +++++- R/states.R | 8 +++++--- 9 files changed, 80 insertions(+), 62 deletions(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index 591ab9f..518ac23 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -54,15 +54,16 @@ counties <- function( state = NULL, cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { - resolution <- match_resolution(resolution) - + check_cb(cb) year <- set_tigris_year(year, min_year = 1990) - if (cb == TRUE) { + if (cb) { + resolution <- match_resolution(resolution) + if (year %in% c(1990, 2000)) { suf <- year_suffix(year) @@ -115,7 +116,7 @@ counties <- function( ctys <- load_tiger(url, tigris_type = "county", ...) - state <- unlist(sapply(state, validate_state, USE.NAMES = FALSE)) + state <- validate_state(state, multiple = TRUE) if (!is.null(state)) { ctys <- ctys[ctys$STATEFP %in% state, ] @@ -237,11 +238,11 @@ tracts <- function( year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 1990) if ( - (resolution == "5m" && year < 2022) | - (resolution == "5m" && !is.null(state)) + resolution == "5m" && (year < 2022 || !is.null(state)) ) { cli_abort( "`resolution = '5m'` for Census tracts is only available for the national Census tract CB file in years 2022 and later." @@ -249,7 +250,7 @@ tracts <- function( } if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform("Retrieving Census tracts for the entire United States") } else { @@ -261,7 +262,7 @@ tracts <- function( state <- validate_state(state, require_state = TRUE) } - if (cb == TRUE) { + if (cb) { if (year %in% c(1990, 2000)) { suf <- year_suffix(year) @@ -278,6 +279,8 @@ tracts <- function( ) } else { if (year > 2013) { + resolution <- match_resolution(resolution) + url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_tract_%s.zip", year, @@ -321,6 +324,7 @@ tracts <- function( trcts <- load_tiger(url, tigris_type = "tract", ...) if (!is.null(county)) { + # TODO: Add check that state is not "us" county <- validate_county(state, county, multiple = TRUE) trcts <- trcts[trcts$COUNTYFP %in% county, ] @@ -440,10 +444,12 @@ school_districts <- function( year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year) + type <- arg_match(type, c("unified", "elementary", "secondary")) if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform( "Retrieving school districts for the entire United States" @@ -457,8 +463,6 @@ school_districts <- function( state <- validate_state(state, require_state = TRUE) } - type <- arg_match(type, c("unified", "elementary", "secondary")) - type <- switch( type, unified = "unsd", @@ -540,10 +544,11 @@ block_groups <- function( year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 1990) if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform( "Retrieving Census block groups for the entire United States" @@ -557,7 +562,7 @@ block_groups <- function( state <- validate_state(state, require_state = TRUE) } - if (cb == TRUE) { + if (cb) { if (year %in% c(1990, 2000)) { suf <- year_suffix(year) @@ -729,6 +734,7 @@ zctas <- function( state = NULL, ... ) { + check_cb(cb) year <- set_tigris_year( year, message = "Zip Code Tabulation Areas (ZCTAs) are only available beginning with the 2000 Census.", @@ -1025,11 +1031,11 @@ county_subdivisions <- function( year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 2010) - state <- validate_state(state, require_state = TRUE) - if (cb == TRUE) { + if (cb) { if (year == 2010) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ2010/gz_2010_%s_060_00_500k.zip", diff --git a/R/helpers.R b/R/helpers.R index 2aeb18c..4561499 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -171,10 +171,9 @@ load_tiger <- function( i <- 1 while (i < 4) { - cli_inform(sprintf( - "Previous download failed. Re-download attempt %s of 3...", - as.character(i) - )) + cli_inform( + "Previous download failed. Re-download attempt{i}s of 3..." + ) if (grepl("^ftp://", url)) { # Use download.file for FTP URLs with timeout diff --git a/R/legislative.R b/R/legislative.R index fb00472..2b56f14 100644 --- a/R/legislative.R +++ b/R/legislative.R @@ -33,10 +33,11 @@ congressional_districts <- function( state = NULL, cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 2010) if (year < 2013 && cb) { @@ -63,9 +64,9 @@ congressional_districts <- function( congress <- "119" } - resolution <- match_resolution(resolution) - if (cb) { + resolution <- match_resolution(resolution) + url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_cd%s_%s.zip", year, @@ -111,7 +112,7 @@ congressional_districts <- function( cds <- load_tiger(url, tigris_type = "congressional_districts", ...) - state <- unlist(sapply(state, validate_state, USE.NAMES = FALSE)) + state <- validate_state(state, multiple = TRUE) if (!is.null(state)) { cds <- cds[cds$STATEFP %in% state, ] @@ -160,10 +161,11 @@ state_legislative_districts <- function( year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 2000) if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform( "Retrieving state legislative districts for the entire United States" @@ -185,7 +187,7 @@ state_legislative_districts <- function( type <- "sldl" } - if (cb == TRUE) { + if (cb) { if (year == 2010) { if (type == "sldu") { url <- sprintf( @@ -283,14 +285,17 @@ voting_districts <- function( year = 2020, ... ) { - if (year != 2020 && cb == TRUE) { + check_cb(cb) + year <- set_tigris_year(year = year) + + if (year != 2020 && cb) { cli_abort( "Cartographic boundary voting districts files are only available for 2020." ) } if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform( "Retrieving voting districts for the entire United States" @@ -302,6 +307,7 @@ voting_districts <- function( } } else { state <- validate_state(state, require_state = TRUE) + county <- validate_county(state, county, multiple = TRUE) } if (cb) { @@ -315,13 +321,6 @@ voting_districts <- function( if (is.null(county)) { return(vtds) } else { - county <- validate_county( - state, - county, - multiple = TRUE, - require_county = TRUE - ) - return(vtds[vtds$COUNTYFP20 %in% county, ]) } } else { @@ -333,8 +332,6 @@ voting_districts <- function( ) } else { if (!is.null(county)) { - county <- validate_county(state, county, require_county = TRUE) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2020PL/LAYER/VTD/2020/tl_2020_%s%s_vtd20.zip", state, diff --git a/R/metro_areas.R b/R/metro_areas.R index 55f458c..98bb7e4 100644 --- a/R/metro_areas.R +++ b/R/metro_areas.R @@ -20,14 +20,16 @@ #' @export core_based_statistical_areas <- function( cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year, min_year = 2010) - resolution <- match_resolution(resolution) - if (cb == TRUE) { + if (cb) { + resolution <- match_resolution(resolution) + if (year == 2010) { if (resolution == "5m") { cli_abort( @@ -81,6 +83,7 @@ core_based_statistical_areas <- function( #' @seealso \url{https://www.census.gov/programs-surveys/geography/guidance/geo-areas/urban-rural.html} #' @export urban_areas <- function(cb = FALSE, year = NULL, criteria = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) if (cb) { @@ -154,19 +157,20 @@ urban_areas <- function(cb = FALSE, year = NULL, criteria = NULL, ...) { #' @export combined_statistical_areas <- function( cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { + check_cb(cb) year <- set_tigris_year(year) if (year == 2022) { cli_abort("CBSAs were not defined for 2022; choose a different year.") } - resolution <- match_resolution(resolution) + if (cb) { + resolution <- match_resolution(resolution) - if (cb == TRUE) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_csa_%s.zip", year, @@ -239,13 +243,14 @@ metro_divisions <- function(year = NULL, ...) { #' plot(ne$geometry) #' #' } -new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { +new_england <- function(type = "necta", cb = FALSE, year = NULL, ...) { + check_cb(cb) # TODO: Consider setting default year to 2021 for new_england year <- set_tigris_year(year, max_year = 2021) type <- arg_match(type, values = c("necta", "combined", "divisions")) - if (type == 'necta') { - if (cb == TRUE) { + if (type == "necta") { + if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_necta_500k.zip", year, @@ -260,7 +265,7 @@ new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { } return(load_tiger(url, tigris_type = "necta", ...)) - } else if (type == 'combined') { + } else if (type == "combined") { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/CNECTA/tl_%s_us_cnecta.zip", year, @@ -268,7 +273,7 @@ new_england <- function(type = 'necta', cb = FALSE, year = NULL, ...) { ) return(load_tiger(url, tigris_type = "cnecta", ...)) - } else if (type == 'divisions') { + } else if (type == "divisions") { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/NECTADIV/tl_%s_us_nectadiv.zip", year, diff --git a/R/national.R b/R/national.R index ac02ef5..b04557c 100644 --- a/R/national.R +++ b/R/national.R @@ -17,7 +17,7 @@ #' addPolygons() #' } #' @export -regions <- function(resolution = '500k', year = NULL, ...) { +regions <- function(resolution = "500k", year = NULL, ...) { year <- set_tigris_year(year) resolution <- match_resolution(resolution) @@ -52,7 +52,7 @@ regions <- function(resolution = '500k', year = NULL, ...) { #' addTiles() %>% #' addPolygons() #' } -divisions <- function(resolution = '500k', year = NULL, ...) { +divisions <- function(resolution = "500k", year = NULL, ...) { year <- set_tigris_year(year) resolution <- match_resolution(resolution) diff --git a/R/native.R b/R/native.R index eba709f..34fdfd7 100644 --- a/R/native.R +++ b/R/native.R @@ -27,9 +27,10 @@ #' gg #' } native_areas <- function(cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) - if (cb == TRUE) { + if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_aiannh_500k.zip", year, @@ -72,6 +73,7 @@ native_areas <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_subdivisions_national <- function(cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) if (cb) { @@ -115,9 +117,10 @@ tribal_subdivisions_national <- function(cb = FALSE, year = NULL, ...) { #' @seealso \url{https://www2.census.gov/geo/pdfs/reference/GARM/Ch5GARM.pdf} #' @export alaska_native_regional_corporations <- function(cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) - if (cb == TRUE) { + if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_02_anrc_500k.zip", year, @@ -170,6 +173,7 @@ alaska_native_regional_corporations <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_block_groups <- function(cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) if (cb) { @@ -220,6 +224,7 @@ tribal_block_groups <- function(cb = FALSE, year = NULL, ...) { #' weight = 0.5) #' } tribal_census_tracts <- function(cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) if (cb) { diff --git a/R/places.R b/R/places.R index 54177ef..cd46b6a 100644 --- a/R/places.R +++ b/R/places.R @@ -15,6 +15,10 @@ #' @seealso \url{https://www2.census.gov/geo/pdfs/reference/GARM/Ch9GARM.pdf} #' @export places <- function(state = NULL, cb = FALSE, year = NULL, ...) { + check_cb(cb) + year <- set_tigris_year(year) + state <- validate_state(state, multiple = TRUE) + if (length(state) > 1) { p <- lapply(state, function(x) { places(state = x, cb = cb, year = year, ...) @@ -24,10 +28,8 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { return(p) } - year <- set_tigris_year(year) - if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" cli_inform( "Retrieving Census-designated places for the entire United States" @@ -37,11 +39,9 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { "A state must be specified for this year/dataset combination." ) } - } else { - state <- validate_state(state, require_state = TRUE) } - if (cb == TRUE) { + if (cb) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_%s_place_500k.zip", year, diff --git a/R/pumas.R b/R/pumas.R index 50ff59f..871820b 100644 --- a/R/pumas.R +++ b/R/pumas.R @@ -39,6 +39,7 @@ #' plot(us_pumas$geometry) #' } pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year) if (is.null(state)) { @@ -63,7 +64,10 @@ pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { if (cb) { if (year > 2020) { cli_abort( - "Cartographic boundary PUMAs are not yet available for years after 2020. Use the argument `year = 2019` for 2010 PUMA boundaries or `year = 2020` for 2020 PUMA boundaries instead to request your data." + c( + "Cartographic boundary PUMAs are not yet available for years after 2020.", + "i" = "Use the argument `year = 2019` for 2010 PUMA boundaries or `year = 2020` for 2020 PUMA boundaries instead to request your data." + ) ) } diff --git a/R/states.R b/R/states.R index 71fb1c6..6811d74 100644 --- a/R/states.R +++ b/R/states.R @@ -28,11 +28,13 @@ #' weight = 0.5) %>% #' setView(-98.5795, 39.8282, zoom=3) #' } -states <- function(cb = FALSE, resolution = '500k', year = NULL, ...) { - resolution <- match_resolution(resolution) +states <- function(cb = FALSE, resolution = "500k", year = NULL, ...) { + check_cb(cb) year <- set_tigris_year(year, min_year = 1990) - if (cb == TRUE) { + if (cb) { + resolution <- match_resolution(resolution) + if (year %in% c(1990, 2000)) { suf <- year_suffix(year) From 0739ae311064ae0c480eb375e728329dc4307b8b Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 00:41:13 -0400 Subject: [PATCH 16/23] Avoid recursion w/ vectorized parameters --- R/enumeration_units.R | 21 ++++++++++----------- R/places.R | 18 +++++++++--------- R/transportation.R | 18 +++++++++--------- R/water.R | 36 ++++++++++++++++++------------------ 4 files changed, 46 insertions(+), 47 deletions(-) diff --git a/R/enumeration_units.R b/R/enumeration_units.R index 518ac23..308abbe 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -922,15 +922,6 @@ blocks <- function(state, county = NULL, year = NULL, ...) { state <- validate_state(state, require_state = TRUE) - if (length(county) > 1 && year < 2011) { - p <- lapply(county, function(x) { - blocks(state = state, county = x, year = year, ...) - }) %>% - rbind_tigris() - - return(p) - } - if (year >= 2014) { if (year >= 2020) { # New block logic for 2020 @@ -956,7 +947,7 @@ blocks <- function(state, county = NULL, year = NULL, ...) { state ) } else if (year %in% c(2000, 2010)) { - county <- validate_county(state, county, allow_null = TRUE) + county <- validate_county(state, county, multiple = TRUE, allow_null = TRUE) suf <- year_suffix(year) if (!is.null(county)) { @@ -977,7 +968,15 @@ blocks <- function(state, county = NULL, year = NULL, ...) { } } - blks <- load_tiger(url, tigris_type = "block", ...) + + if (length(county) > 1 && year < 2011) { + blks <- lapply(url, function(x) { + load_tiger(x, tigris_type = "block", ...) + }) %>% + rbind_tigris() + } else { + blks <- load_tiger(url, tigris_type = "block", ...) + } if (!is.null(county) && year > 2010) { county <- validate_county(state, county, multiple = TRUE) diff --git a/R/places.R b/R/places.R index cd46b6a..fb2375c 100644 --- a/R/places.R +++ b/R/places.R @@ -19,15 +19,6 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { year <- set_tigris_year(year) state <- validate_state(state, multiple = TRUE) - if (length(state) > 1) { - p <- lapply(state, function(x) { - places(state = x, cb = cb, year = year, ...) - }) %>% - rbind_tigris() - - return(p) - } - if (is.null(state)) { if (year > 2018 && cb) { state <- "us" @@ -57,6 +48,15 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { ) } + if (length(state) > 1) { + p <- lapply(url, function(x) { + load_tiger(x, tigris_type = "place", ...) + }) %>% + rbind_tigris() + + return(p) + } + load_tiger(url, tigris_type = "place", ...) } diff --git a/R/transportation.R b/R/transportation.R index ab4e9bb..35f6f23 100644 --- a/R/transportation.R +++ b/R/transportation.R @@ -49,15 +49,6 @@ roads <- function(state, county, year = NULL, ...) { require_county = TRUE ) - if (length(county) > 1) { - r <- lapply(county, function(x) { - roads(state = state, county = x, year = year, ...) - }) %>% - rbind_tigris() - - return(r) - } - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ROADS/tl_%s_%s%s_roads.zip", year, @@ -66,6 +57,15 @@ roads <- function(state, county, year = NULL, ...) { county ) + if (length(county) > 1) { + r <- lapply(url, function(x) { + load_tiger(x, tigris_type = "road", ...) + }) %>% + rbind_tigris() + + return(r) + } + load_tiger(url, tigris_type = "road", ...) } diff --git a/R/water.R b/R/water.R index 831cfec..7bb4c55 100644 --- a/R/water.R +++ b/R/water.R @@ -33,15 +33,6 @@ area_water <- function(state, county, year = NULL, ...) { multiple = TRUE ) - if (length(county) > 1) { - w <- lapply(county, function(x) { - area_water(state = state, county = x, year = year, ...) - }) %>% - rbind_tigris() - - return(w) - } - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/AREAWATER/tl_%s_%s%s_areawater.zip", year, @@ -50,6 +41,15 @@ area_water <- function(state, county, year = NULL, ...) { county ) + if (length(county) > 1) { + w <- lapply(url, function(x) { + load_tiger(x, tigris_type = "area_water", ...) + }) %>% + rbind_tigris() + + return(w) + } + load_tiger(url, tigris_type = "area_water", ...) } @@ -90,15 +90,6 @@ linear_water <- function(state, county, year = NULL, ...) { multiple = TRUE ) - if (length(county) > 1) { - w <- lapply(county, function(x) { - linear_water(state = state, county = x, year = year, ...) - }) %>% - rbind_tigris() - - return(w) - } - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/LINEARWATER/tl_%s_%s%s_linearwater.zip", year, @@ -107,6 +98,15 @@ linear_water <- function(state, county, year = NULL, ...) { county ) + if (length(county) > 1) { + w <- lapply(url, function(x) { + load_tiger(x, tigris_type = "linear_water", ...) + }) %>% + rbind_tigris() + + return(w) + } + load_tiger(url, tigris_type = "linear_water", ...) } From 5fb42d3bbcd90d932ad4c958016ba205bd113316 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 00:42:50 -0400 Subject: [PATCH 17/23] Use test setup file to set options Remove repetitive calls to local_options --- tests/testthat/setup.R | 4 ++++ tests/testthat/test-enumeration_units.R | 18 ++++++------------ tests/testthat/test-landmarks.R | 2 -- tests/testthat/test-legislative.R | 3 --- tests/testthat/test-metro_areas.R | 1 - tests/testthat/test-national.R | 1 - tests/testthat/test-native.R | 1 - tests/testthat/test-places.R | 1 - tests/testthat/test-pumas.R | 2 -- tests/testthat/test-states.R | 1 - tests/testthat/test-transportation.R | 1 - tests/testthat/test-water.R | 1 - 12 files changed, 10 insertions(+), 26 deletions(-) create mode 100644 tests/testthat/setup.R diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..099e821 --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,4 @@ +withr::local_options( + list(tigris_use_cache = TRUE, cli.default_handler = suppressMessages), + .local_envir = teardown_env() +) diff --git a/tests/testthat/test-enumeration_units.R b/tests/testthat/test-enumeration_units.R index 8287750..1bdd81d 100644 --- a/tests/testthat/test-enumeration_units.R +++ b/tests/testthat/test-enumeration_units.R @@ -1,7 +1,6 @@ test_that("`counties()` works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_snapshot(counties(cb = TRUE, progress_bar = FALSE)) expect_snapshot(counties(progress_bar = FALSE)) @@ -26,7 +25,6 @@ test_that("`counties()` works", { test_that("`school_districts()` works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" expect_snapshot(school_districts(state = state, progress_bar = FALSE)) @@ -38,7 +36,6 @@ test_that("`school_districts()` works", { test_that("`tracts()` works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" county <- "Niobrara" expect_snapshot(tracts(state = state, county = county, progress_bar = FALSE)) @@ -82,7 +79,6 @@ test_that("`tracts()` works", { test_that("`block_groups()` work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" county <- "Niobrara" @@ -105,7 +101,6 @@ test_that("`block_groups()` work", { test_that("`blocks()` work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" county <- "Niobrara" @@ -149,7 +144,6 @@ test_that("`blocks()` work", { test_that("`zctas()` works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" county <- "Niobrara" @@ -157,24 +151,24 @@ test_that("`zctas()` works", { expect_s3_class(zctas(year = 2010, cb = TRUE), "sf") - expect_warning( + expect_error(zctas(state = state, year = 2021, cb = TRUE)) + expect_error(zctas(state = state, year = 2010, cb = TRUE)) + + withr::local_options(list(cli.default_handler = NULL)) + expect_message( zctas(year = 2000, cb = TRUE), "CB ZCTAs for 2000 include separate polygons for discontiguous parts." ) - expect_warning( + expect_message( zctas(state = state, year = 2000, cb = TRUE), "CB ZCTAs for 2000 include separate polygons for discontiguous parts." ) - - expect_error(zctas(state = state, year = 2021, cb = TRUE)) - expect_error(zctas(state = state, year = 2010, cb = TRUE)) }) test_that("`county_subdivisions()` works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" county <- "Niobrara" diff --git a/tests/testthat/test-landmarks.R b/tests/testthat/test-landmarks.R index 7fc943b..f7df245 100644 --- a/tests/testthat/test-landmarks.R +++ b/tests/testthat/test-landmarks.R @@ -7,7 +7,6 @@ test_that("landmarks errors", { test_that("landmarks works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" area_landmarks <- landmarks( @@ -28,6 +27,5 @@ test_that("landmarks works", { test_that("military works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_snapshot(military(progress_bar = FALSE)) }) diff --git a/tests/testthat/test-legislative.R b/tests/testthat/test-legislative.R index f6db380..3a69096 100644 --- a/tests/testthat/test-legislative.R +++ b/tests/testthat/test-legislative.R @@ -20,7 +20,6 @@ test_that("congressional_districts warns and errors", { test_that("congressional_districts works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(congressional_districts(), "sf") # TODO: Check why test failed on CI @@ -111,7 +110,6 @@ test_that("state_legislative_districts errors", { test_that("state_legislative_districts works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" @@ -183,7 +181,6 @@ test_that("voting_districts errors", { test_that("voting_districts works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(voting_districts(cb = TRUE), "sf") state <- "WY" diff --git a/tests/testthat/test-metro_areas.R b/tests/testthat/test-metro_areas.R index 105206e..a15d3e4 100644 --- a/tests/testthat/test-metro_areas.R +++ b/tests/testthat/test-metro_areas.R @@ -1,7 +1,6 @@ test_that("metro areas functions work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(core_based_statistical_areas(), "sf") expect_s3_class(core_based_statistical_areas(year = 2010), "sf") diff --git a/tests/testthat/test-national.R b/tests/testthat/test-national.R index db4d1c3..9f02357 100644 --- a/tests/testthat/test-national.R +++ b/tests/testthat/test-national.R @@ -7,7 +7,6 @@ test_that("nation errors", { test_that("national functions work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) res <- "20m" expect_s3_class(regions(resolution = res), "sf") diff --git a/tests/testthat/test-native.R b/tests/testthat/test-native.R index a0f4563..fa6542c 100644 --- a/tests/testthat/test-native.R +++ b/tests/testthat/test-native.R @@ -1,7 +1,6 @@ test_that("native functions work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(native_areas(), "sf") expect_s3_class(native_areas(cb = TRUE), "sf") diff --git a/tests/testthat/test-places.R b/tests/testthat/test-places.R index 11aed86..3950ab9 100644 --- a/tests/testthat/test-places.R +++ b/tests/testthat/test-places.R @@ -9,7 +9,6 @@ test_that("places errors", { test_that("places works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" expect_s3_class(places(year = 2019, cb = TRUE), "sf") # TODO: Enable tests if support is added for year < 2011 diff --git a/tests/testthat/test-pumas.R b/tests/testthat/test-pumas.R index f64e264..5d632f9 100644 --- a/tests/testthat/test-pumas.R +++ b/tests/testthat/test-pumas.R @@ -1,7 +1,6 @@ test_that("pumas works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(pumas(year = 2020, cb = TRUE), "sf") state <- "WY" @@ -15,7 +14,6 @@ test_that("pumas works", { test_that("pumas errors", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_error(pumas(year = 2018)) expect_error(pumas(year = 2021, cb = TRUE)) diff --git a/tests/testthat/test-states.R b/tests/testthat/test-states.R index 40bb72c..cf49439 100644 --- a/tests/testthat/test-states.R +++ b/tests/testthat/test-states.R @@ -1,7 +1,6 @@ test_that("states works", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) expect_s3_class(states(year = 1990, cb = TRUE), "sf") expect_s3_class(states(year = 2000, cb = TRUE), "sf") diff --git a/tests/testthat/test-transportation.R b/tests/testthat/test-transportation.R index 132199d..113ee15 100644 --- a/tests/testthat/test-transportation.R +++ b/tests/testthat/test-transportation.R @@ -1,7 +1,6 @@ test_that("transportation functions work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "WY" diff --git a/tests/testthat/test-water.R b/tests/testthat/test-water.R index 824ba67..944e72f 100644 --- a/tests/testthat/test-water.R +++ b/tests/testthat/test-water.R @@ -17,7 +17,6 @@ test_that("water functions error", { test_that("water functions work", { skip_on_cran() skip_on_ci() - withr::local_options(list(tigris_use_cache = TRUE)) state <- "NH" From da691389625d2e85bf22efd6cc982c95e3901699 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 00:56:04 -0400 Subject: [PATCH 18/23] Replace `warning` w/ `cli_warn` --- R/helpers.R | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index 4561499..513b9c3 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -412,11 +412,9 @@ load_tiger <- function( } if (class == "sp") { - warning( - stringr::str_wrap( - "Spatial* (sp) classes are no longer formally supported in tigris as of version 2.0. We strongly recommend updating your workflow to use sf objects (the default in tigris) instead.", - 50 - ) + cli_warn( + c("Spatial* (sp) classes are no longer formally supported in tigris as of version 2.0.", + "We strongly recommend updating your workflow to use sf objects (the default in tigris) instead.") ) return(sf::as_Spatial(obj)) } else { @@ -726,8 +724,8 @@ rbind_tigris <- function(...) { if (all(obj_attrs %in% c("unsd", "elsd", "scsd"))) { # 3 school district types - warning( - "Multiple school district tigris types. Coercing to \'sdall\'." + cli_warn( + "Multiple school district tigris types. Coercing to {.str sdall}." ) elements <- lapply(seq_along(elements), function(x) { From 550c07b53f2a1d052052d777556563cc79056492 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 01:05:42 -0400 Subject: [PATCH 19/23] Remove tidycensus from example Drop tidycensus from Suggests --- DESCRIPTION | 1 - R/shift_geometry.R | 25 +++++++------------------ man/shift_geometry.Rd | 24 +++++++----------------- 3 files changed, 14 insertions(+), 36 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c145cb9..dd0cd21 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,6 @@ Suggests: leaflet, sp, testthat (>= 3.0.0), - tidycensus, withr Config/testthat/edition: 3 Encoding: UTF-8 diff --git a/R/shift_geometry.R b/R/shift_geometry.R index 922b72c..45b9494 100644 --- a/R/shift_geometry.R +++ b/R/shift_geometry.R @@ -40,10 +40,9 @@ #' #' @examples \dontrun{ #' -#' # Shift and rescale AK/HI/PR for thematic mapping +#' # Shift and rescale AK/HI/PR #' library(tigris) -#' library(tidycensus) -#' library(tidyverse) +#' library(ggplot2) #' #' us_states <- states(cb = TRUE, resolution = "20m") %>% #' shift_geometry() @@ -56,26 +55,16 @@ #' us_states_outside <- states(cb = TRUE, resolution = "20m") %>% #' shift_geometry(position = "outside") #' -#' # Shift a dataset obtained outside tigris and make a map -#' income_by_metro <- get_acs( -#' geography = "cbsa", -#' variables = "B01002_001", -#' geometry = TRUE -#' ) %>% -#' shift_geometry() -#' -# #' ggplot() + -#' geom_sf(data = income_by_metro, aes(fill = estimate), color = NA) + +#' geom_sf(data = us_states_outside, color = "blue") + +#' geom_sf(data = us_states_eqarea, color = "red") + #' geom_sf(data = us_states, fill = NA, color = "black", size = 0.1) + -#' scale_fill_viridis_c() + #' theme_void(base_size = 16) + -#' labs(title = "Median age by CBSA, 2015-2019 ACS", -#' fill = "ACS estimate ", -#' caption = "Note: Alaska, Hawaii, and Puerto Rico are shifted and not to scale.") + +#' labs( +#' title = "Alaska, Hawaii, and Puerto Rico are shifted and not to scale." +#' ) + #' theme(plot.title = element_text(hjust = 0.5)) #' -#' #' } shift_geometry <- function( input_sf, diff --git a/man/shift_geometry.Rd b/man/shift_geometry.Rd index fb4bc5f..208207f 100644 --- a/man/shift_geometry.Rd +++ b/man/shift_geometry.Rd @@ -58,10 +58,9 @@ albersusa R package (\url{https://github.com/hrbrmstr/albersusa}); and the ggcar \examples{ \dontrun{ -# Shift and rescale AK/HI/PR for thematic mapping +# Shift and rescale AK/HI/PR library(tigris) -library(tidycensus) -library(tidyverse) +library(ggplot2) us_states <- states(cb = TRUE, resolution = "20m") \%>\% shift_geometry() @@ -74,24 +73,15 @@ us_states_eqarea <- states(cb = TRUE, resolution = "20m") \%>\% us_states_outside <- states(cb = TRUE, resolution = "20m") \%>\% shift_geometry(position = "outside") -# Shift a dataset obtained outside tigris and make a map -income_by_metro <- get_acs( - geography = "cbsa", - variables = "B01002_001", - geometry = TRUE -) \%>\% - shift_geometry() - ggplot() + - geom_sf(data = income_by_metro, aes(fill = estimate), color = NA) + + geom_sf(data = us_states_outside, color = "blue") + + geom_sf(data = us_states_eqarea, color = "red") + geom_sf(data = us_states, fill = NA, color = "black", size = 0.1) + - scale_fill_viridis_c() + theme_void(base_size = 16) + - labs(title = "Median age by CBSA, 2015-2019 ACS", - fill = "ACS estimate ", - caption = "Note: Alaska, Hawaii, and Puerto Rico are shifted and not to scale.") + + labs( + title = "Alaska, Hawaii, and Puerto Rico are shifted and not to scale." + ) + theme(plot.title = element_text(hjust = 0.5)) - } } From 453455fcbb0df5637a7831dd3d40a9c0386af588 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Wed, 30 Jul 2025 01:08:14 -0400 Subject: [PATCH 20/23] Update NEWS --- NEWS | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 497feea..133b85e 100644 --- a/NEWS +++ b/NEWS @@ -1,11 +1,15 @@ tigris development ------------------------------------------------------- -* Add `{rlang}` and `{cli}` packages to Imports. Add `{withr}` to Suggests. +* Add `{rlang}` and `{cli}` packages to Imports. Add `{withr}` to Suggests. Remove `{uuid}` and `{tidycensus}` from Suggests. + +* Switch to use `cli::cli_abort()`, `cli::cli_warn()` and `cli::cli_inform()` for all errors, warnings, and messages. * Warn users when `filter_by` contains multiple geometries and only part of the filter can be used. * Export `validate_state()` and `validate_county()` functions with added `multiple` argument to allow validation of multiple states or counties in a single call. +* Improve consistency of validation for input `year`, `cb`, and `resolution` arguments. + * Expand test coverage. tigris 2.2.1 From d9034474d4dca0c3b6667b046605d0ea5ed40f16 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Thu, 28 May 2026 09:07:50 -0400 Subject: [PATCH 21/23] Update validate_county + _state docs to pass checks --- DESCRIPTION | 2 +- R/utils.R | 18 +++++++++--------- man/validate_county.Rd | 2 +- man/validate_state.Rd | 2 +- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index dd0cd21..2af097d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,4 @@ Config/testthat/edition: 3 Encoding: UTF-8 LazyData: TRUE Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 diff --git a/R/utils.R b/R/utils.R index ecd5d2f..5b0829e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -123,7 +123,7 @@ match_state_fips <- function( } if (any(long_state)) { - cli_inform( + cli_bullets( "Subsetting first two digits from supplied {.arg {error_arg}} to make valid FIPS codes: {state[long_state]}" ) @@ -154,7 +154,7 @@ match_state_fips <- function( #' Check if state is a FIPS code, full name or abbreviation #' -#' [validate_state()] checks if an input state values is a FIPS code, full name +#' `validate_state()` checks if an input state values is a FIPS code, full name #' or abbreviation. If some or all input values are invalid, error if #' `require_state = TRUE`, return `NULL` if all inputs are invalid, or warn and #' return valid input values. @@ -237,7 +237,7 @@ validate_state <- function( collapse = ", " ) - cli_inform(c( + cli_bullets(c( "*" = "Using FIPS code{?s} {message_parts}" )) } @@ -427,7 +427,7 @@ match_county_name <- function( #' Check if county is a FIPS code, full name or abbreviation. #' -#' [validate_county()] checks if an input `county` is a FIPS code, name or +#' `validate_county()` checks if an input `county` is a FIPS code, name or #' abbreviation. If some or all input values are invalid, error if #' `require_county = TRUE`, return `NULL` if all inputs are invalid, or warn and #' return valid input values. @@ -515,13 +515,13 @@ validate_county <- function( collapse = ", " ) - cli_inform(c( + cli_bullets(c( "*" = "Using FIPS code{?s} {message_parts}" )) } if (.msg && any(na_county_fips)) { - cli_inform(c( + cli_bullets(c( "!" = "Dropping invalid {.arg county} value{?s}: {county[na_county_fips]}" )) } @@ -627,7 +627,7 @@ prep_input_sfc <- function( } if (length(input) > 1) { - cli_inform( + cli_bullets( c( "!" = "{.arg {arg}} contains multiple geometries and may not work as expected.", "i" = "Unioning .arg {arg}} geometries with {.fn sf::st_union}." @@ -651,7 +651,7 @@ year_suffix <- function(year) { #' Set default year and validate year for tigris function #' -#' [set_tigris_year()] returns year as a character string. +#' `set_tigris_year()` returns year as a character string. #' #' @param year Year to use for download. #' @param default Default year to use if "tigris_year" option is not set. @@ -674,7 +674,7 @@ set_tigris_year <- function( year <- getOption("tigris_year", default) if (!quiet) { - cli_inform("Retrieving data for the year {year}") + cli_bullets("Retrieving data for the year {year}") } } diff --git a/man/validate_county.Rd b/man/validate_county.Rd index 5bf9c40..80a19ea 100644 --- a/man/validate_county.Rd +++ b/man/validate_county.Rd @@ -44,7 +44,7 @@ usage. Uses \code{is_interactive()} by default.} } } \description{ -\code{\link[=validate_county]{validate_county()}} checks if an input \code{county} is a FIPS code, name or +\code{validate_county()} checks if an input \code{county} is a FIPS code, name or abbreviation. If some or all input values are invalid, error if \code{require_county = TRUE}, return \code{NULL} if all inputs are invalid, or warn and return valid input values. diff --git a/man/validate_state.Rd b/man/validate_state.Rd index a7f1b02..15c3bbc 100644 --- a/man/validate_state.Rd +++ b/man/validate_state.Rd @@ -41,7 +41,7 @@ usage. Uses \code{is_interactive()} by default.} } } \description{ -\code{\link[=validate_state]{validate_state()}} checks if an input state values is a FIPS code, full name +\code{validate_state()} checks if an input state values is a FIPS code, full name or abbreviation. If some or all input values are invalid, error if \code{require_state = TRUE}, return \code{NULL} if all inputs are invalid, or warn and return valid input values. From 09d7bbfda3ec4cbcfb33e54b426b14d2f5bd0e2e Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Thu, 28 May 2026 09:10:24 -0400 Subject: [PATCH 22/23] Swap cli_inform for cli_bullets --- NAMESPACE | 2 +- NEWS | 2 +- R/enumeration_units.R | 10 +++++----- R/helpers.R | 20 +++++++++++--------- R/legislative.R | 6 +++--- R/places.R | 2 +- R/pumas.R | 4 ++-- R/tigris-package.R | 2 +- tests/testthat/_snaps/enumeration_units.md | 14 -------------- tests/testthat/_snaps/landmarks.md | 2 -- 10 files changed, 25 insertions(+), 39 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0aa5a46..32e9144 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -64,7 +64,7 @@ import(rlang) import(sf) import(utils) importFrom(cli,cli_abort) -importFrom(cli,cli_inform) +importFrom(cli,cli_bullets) importFrom(cli,cli_warn) importFrom(dplyr,mutate) importFrom(httr,GET) diff --git a/NEWS b/NEWS index 133b85e..a2e8475 100644 --- a/NEWS +++ b/NEWS @@ -2,7 +2,7 @@ tigris development ------------------------------------------------------- * Add `{rlang}` and `{cli}` packages to Imports. Add `{withr}` to Suggests. Remove `{uuid}` and `{tidycensus}` from Suggests. -* Switch to use `cli::cli_abort()`, `cli::cli_warn()` and `cli::cli_inform()` for all errors, warnings, and messages. +* Switch to use `cli::cli_abort()`, `cli::cli_warn()` and `cli::cli_bullets()` for all errors, warnings, and messages. * Warn users when `filter_by` contains multiple geometries and only part of the filter can be used. diff --git a/R/enumeration_units.R b/R/enumeration_units.R index 308abbe..d4ac359 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -252,7 +252,7 @@ tracts <- function( if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform("Retrieving Census tracts for the entire United States") + cli_bullets("Retrieving Census tracts for the entire United States") } else { cli_abort( "A state must be specified for this year/dataset combination." @@ -451,7 +451,7 @@ school_districts <- function( if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform( + cli_bullets( "Retrieving school districts for the entire United States" ) } else { @@ -550,7 +550,7 @@ block_groups <- function( if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform( + cli_bullets( "Retrieving Census block groups for the entire United States" ) } else { @@ -765,7 +765,7 @@ zctas <- function( cache <- getOption("tigris_use_cache") if (is.null(cache)) { - cli_inform( + cli_bullets( c( "!" = "ZCTAs can take several minutes to download.", "*" = "Set `options(tigris_use_cache = TRUE)` to cache the data and avoid re-downloading in future R sessions." @@ -845,7 +845,7 @@ zctas <- function( # Handle split ZCTAs in 2000 CB file if (year == 2000 && cb) { - cli_inform( + cli_bullets( c( "!" = "CB ZCTAs for 2000 include separate polygons for discontiguous parts.", "*" = "Combine by summarizing over the ZCTA column but note that this can be a time-consuming operation." diff --git a/R/helpers.R b/R/helpers.R index 513b9c3..eb75da1 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -42,10 +42,12 @@ tigris_cache_dir <- function(path) { var <- paste0("TIGRIS_CACHE_DIR=", "'", path, "'") write(var, renv, sep = "\n", append = TRUE) - cli_inform(sprintf( - "Your new tigris cache directory is %s. \nTo use now, restart R or run `readRenviron('~/.Renviron')`", - path - )) + cli_bullets( + c( + "i" = "Your new tigris cache directory is {.path path}.", + "*" = "To use now, restart R or run `readRenviron('~/.Renviron')`" + ) + ) } @@ -171,7 +173,7 @@ load_tiger <- function( i <- 1 while (i < 4) { - cli_inform( + cli_bullets( "Previous download failed. Re-download attempt{i}s of 3..." ) @@ -219,7 +221,7 @@ load_tiger <- function( # If using HTTP protocol and about to make final retry, try FTP as fallback if (i == 3 && protocol == "http") { - cli_inform( + cli_bullets( "HTTP download failed, trying FTP as fallback..." ) ftp_url <- gsub( @@ -332,7 +334,7 @@ load_tiger <- function( # If HTTP download failed, try FTP as fallback if (!unzip_result && protocol == "http") { - cli_inform("HTTP download failed, trying FTP as fallback...") + cli_bullets("HTTP download failed, trying FTP as fallback...") ftp_url <- gsub("^https://www2", "ftp://ftp2", original_url) # Try FTP download @@ -894,7 +896,7 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { county_GEOIDs <- county_overlay$GEOID # Fetch water for those GEOIDs - cli_inform("Fetching area water data for your dataset's location...") + cli_bullets("Fetching area water data for your dataset's location...") my_water <- lapply(county_GEOIDs, function(cty) { suppressMessages(tigris::area_water( state = stringr::str_sub(cty, 1, 2), @@ -908,7 +910,7 @@ erase_water <- function(input_sf, area_threshold = 0.75, year = NULL) { sf::st_filter(input_sf) %>% # New step to only erase intersecting water areas dplyr::filter(dplyr::percent_rank(AWATER) >= area_threshold) - cli_inform( + cli_bullets( "Erasing water area...\nIf this is slow, try a larger area threshold value." ) erased_sf <- suppressMessages(st_erase(input_sf, my_water)) diff --git a/R/legislative.R b/R/legislative.R index 2b56f14..cbe2a93 100644 --- a/R/legislative.R +++ b/R/legislative.R @@ -83,7 +83,7 @@ congressional_districts <- function( state_codes <- unique(tigris::fips_codes$state_code) state_codes <- state_codes[state_codes != "74"] cds <- lapply(state_codes, function(x) { - suppressMessages(tigris::congressional_districts( + suppressMessages(congressional_districts( state = x, year = year )) @@ -167,7 +167,7 @@ state_legislative_districts <- function( if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform( + cli_bullets( "Retrieving state legislative districts for the entire United States" ) } else { @@ -297,7 +297,7 @@ voting_districts <- function( if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform( + cli_bullets( "Retrieving voting districts for the entire United States" ) } else { diff --git a/R/places.R b/R/places.R index fb2375c..58172b4 100644 --- a/R/places.R +++ b/R/places.R @@ -22,7 +22,7 @@ places <- function(state = NULL, cb = FALSE, year = NULL, ...) { if (is.null(state)) { if (year > 2018 && cb) { state <- "us" - cli_inform( + cli_bullets( "Retrieving Census-designated places for the entire United States" ) } else { diff --git a/R/pumas.R b/R/pumas.R index 871820b..74e9af7 100644 --- a/R/pumas.R +++ b/R/pumas.R @@ -45,7 +45,7 @@ pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { if (is.null(state)) { if (year %in% 2019:2020 && cb) { state <- "us" - cli_inform("Retrieving PUMAs for the entire United States") + cli_bullets("Retrieving PUMAs for the entire United States") } else { cli_abort( "A state must be specified for this year/dataset combination." @@ -72,7 +72,7 @@ pumas <- function(state = NULL, cb = FALSE, year = NULL, ...) { } if (year == 2020) { - cli_inform( + cli_bullets( "The 2020 CB PUMAs use the new 2020 PUMA boundary definitions." ) url <- sprintf( diff --git a/R/tigris-package.R b/R/tigris-package.R index cb79075..0b49254 100644 --- a/R/tigris-package.R +++ b/R/tigris-package.R @@ -37,7 +37,7 @@ #' @import httr #' @import sf #' @import dplyr -#' @importFrom cli cli_abort cli_warn cli_inform +#' @importFrom cli cli_abort cli_warn cli_bullets #' @import rlang #' @importFrom methods as NULL diff --git a/tests/testthat/_snaps/enumeration_units.md b/tests/testthat/_snaps/enumeration_units.md index d753d0b..c2df43b 100644 --- a/tests/testthat/_snaps/enumeration_units.md +++ b/tests/testthat/_snaps/enumeration_units.md @@ -2,8 +2,6 @@ Code counties(cb = TRUE, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 3235 features and 12 fields Geometry type: MULTIPOLYGON @@ -38,8 +36,6 @@ Code counties(progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 3235 features and 18 fields Geometry type: MULTIPOLYGON @@ -85,8 +81,6 @@ Code school_districts(state = state, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 48 features and 15 fields Geometry type: MULTIPOLYGON @@ -132,8 +126,6 @@ Code tracts(state = state, county = county, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 1 feature and 13 fields Geometry type: POLYGON @@ -151,8 +143,6 @@ Code block_groups(state = state, county = county, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 2 features and 13 fields Geometry type: POLYGON @@ -173,8 +163,6 @@ Code blocks(state = state, county = county, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 1276 features and 17 fields Geometry type: POLYGON @@ -265,8 +253,6 @@ Code county_subdivisions(state = state, county = county, progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 2 features and 16 fields Geometry type: POLYGON diff --git a/tests/testthat/_snaps/landmarks.md b/tests/testthat/_snaps/landmarks.md index b81967c..7f54060 100644 --- a/tests/testthat/_snaps/landmarks.md +++ b/tests/testthat/_snaps/landmarks.md @@ -59,8 +59,6 @@ Code military(progress_bar = FALSE) - Message - Retrieving data for the year 2024 Output Simple feature collection with 858 features and 7 fields Geometry type: MULTIPOLYGON From d79478dfe413160ec2d4a51d4d3ff642777bb628 Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Thu, 28 May 2026 09:11:21 -0400 Subject: [PATCH 23/23] Fix list_states function Also add tests for list_states, filter_state, and grep_state --- R/states.R | 6 +- tests/testthat/_snaps/states.md | 150 ++++++++++++++++++++++++++++++++ tests/testthat/test-states.R | 12 +-- 3 files changed, 161 insertions(+), 7 deletions(-) create mode 100644 tests/testthat/_snaps/states.md diff --git a/R/states.R b/R/states.R index 6811d74..319520e 100644 --- a/R/states.R +++ b/R/states.R @@ -174,7 +174,9 @@ grep_state <- function(states, term) { #' } list_states <- function(states, sorted = TRUE) { if (is_tigris(states) & tigris_type(states) == "state") { - if (sorted) return(sort(states@data$NAME)) - return(states@data$NAME) + if (sorted) { + return(sort(states$NAME)) + } + return(states$NAME) } } diff --git a/tests/testthat/_snaps/states.md b/tests/testthat/_snaps/states.md new file mode 100644 index 0000000..e217434 --- /dev/null +++ b/tests/testthat/_snaps/states.md @@ -0,0 +1,150 @@ +# states works + + Code + list_states(tigris_states) + Output + [1] "Alabama" + [2] "Alaska" + [3] "American Samoa" + [4] "Arizona" + [5] "Arkansas" + [6] "California" + [7] "Colorado" + [8] "Commonwealth of the Northern Mariana Islands" + [9] "Connecticut" + [10] "Delaware" + [11] "District of Columbia" + [12] "Florida" + [13] "Georgia" + [14] "Guam" + [15] "Hawaii" + [16] "Idaho" + [17] "Illinois" + [18] "Indiana" + [19] "Iowa" + [20] "Kansas" + [21] "Kentucky" + [22] "Louisiana" + [23] "Maine" + [24] "Maryland" + [25] "Massachusetts" + [26] "Michigan" + [27] "Minnesota" + [28] "Mississippi" + [29] "Missouri" + [30] "Montana" + [31] "Nebraska" + [32] "Nevada" + [33] "New Hampshire" + [34] "New Jersey" + [35] "New Mexico" + [36] "New York" + [37] "North Carolina" + [38] "North Dakota" + [39] "Ohio" + [40] "Oklahoma" + [41] "Oregon" + [42] "Pennsylvania" + [43] "Puerto Rico" + [44] "Rhode Island" + [45] "South Carolina" + [46] "South Dakota" + [47] "Tennessee" + [48] "Texas" + [49] "United States Virgin Islands" + [50] "Utah" + [51] "Vermont" + [52] "Virginia" + [53] "Washington" + [54] "West Virginia" + [55] "Wisconsin" + [56] "Wyoming" + +--- + + Code + list_states(tigris_states, sorted = FALSE) + Output + [1] "West Virginia" + [2] "Florida" + [3] "Illinois" + [4] "Minnesota" + [5] "Maryland" + [6] "Rhode Island" + [7] "Idaho" + [8] "New Hampshire" + [9] "North Carolina" + [10] "Vermont" + [11] "Connecticut" + [12] "Delaware" + [13] "New Mexico" + [14] "California" + [15] "New Jersey" + [16] "Wisconsin" + [17] "Oregon" + [18] "Nebraska" + [19] "Pennsylvania" + [20] "Washington" + [21] "Louisiana" + [22] "Georgia" + [23] "Alabama" + [24] "Utah" + [25] "Ohio" + [26] "Texas" + [27] "Colorado" + [28] "South Carolina" + [29] "Oklahoma" + [30] "Tennessee" + [31] "Wyoming" + [32] "Hawaii" + [33] "North Dakota" + [34] "Kentucky" + [35] "United States Virgin Islands" + [36] "Commonwealth of the Northern Mariana Islands" + [37] "Guam" + [38] "Maine" + [39] "New York" + [40] "Nevada" + [41] "Alaska" + [42] "American Samoa" + [43] "Michigan" + [44] "Arkansas" + [45] "Mississippi" + [46] "Missouri" + [47] "Montana" + [48] "Kansas" + [49] "Indiana" + [50] "Puerto Rico" + [51] "South Dakota" + [52] "Massachusetts" + [53] "Virginia" + [54] "District of Columbia" + [55] "Iowa" + [56] "Arizona" + +--- + + Code + filter_state(tigris_states, "Wyoming") + Output + Simple feature collection with 1 feature and 15 fields + Geometry type: MULTIPOLYGON + Dimension: XY + Bounding box: xmin: -111.0546 ymin: 40.99477 xmax: -104.0522 ymax: 45.00582 + Geodetic CRS: NAD83 + REGION DIVISION STATEFP STATENS GEOID GEOIDFQ STUSPS NAME LSAD MTFCC + 31 4 8 56 01779807 56 0400000US56 WY Wyoming 00 G4000 + FUNCSTAT ALAND AWATER INTPTLAT INTPTLON + 31 A 251458190512 1868025485 +42.9896591 -107.5443922 + geometry + 31 MULTIPOLYGON (((-106.3212 4... + +--- + + Code + grep_state(tigris_states, "north") + Output + [1] "Commonwealth of the Northern Mariana Islands" + [2] "North Carolina" + [3] "North Dakota" + diff --git a/tests/testthat/test-states.R b/tests/testthat/test-states.R index cf49439..41c6d70 100644 --- a/tests/testthat/test-states.R +++ b/tests/testthat/test-states.R @@ -7,21 +7,23 @@ test_that("states works", { expect_s3_class(states(year = 2010, cb = TRUE), "sf") expect_s3_class(states(year = 2014, cb = TRUE), "sf") # TODO: Check why test failed on CI - # expect_s3_class(states(year = 2013, cb = TRUE), "sf") + expect_s3_class(states(year = 2013, cb = TRUE), "sf") expect_s3_class(states(year = 2010), "sf") expect_s3_class(states(year = 2012), "sf") + expect_error(states(year = 1990)) + tigris_states <- states() expect_s3_class(tigris_states, "sf") # TODO: Enable tests after adding support for sf objects - # expect_snapshot(list_states(tigris_states)) + expect_snapshot(list_states(tigris_states)) - # expect_snapshot(list_states(tigris_states, sorted = FALSE)) + expect_snapshot(list_states(tigris_states, sorted = FALSE)) - # expect_snapshot(filter_state(tigris_states, "Wyoming")) + expect_snapshot(filter_state(tigris_states, "Wyoming")) - # expect_snapshot(grep_state(tigris_states, "north")) + expect_snapshot(grep_state(tigris_states, "north")) })