diff --git a/DESCRIPTION b/DESCRIPTION index 8546da4..2af097d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,44 +1,43 @@ -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 Suggests: - testthat (>= 3.0.0), ggplot2, - ggthemes, - leaflet, knitr, - tidycensus, + leaflet, sp, + testthat (>= 3.0.0), 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.3 diff --git a/NAMESPACE b/NAMESPACE index 56ea5a9..32e9144 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -63,9 +63,8 @@ import(rappdirs) import(rlang) import(sf) import(utils) -import(uuid) 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 497feea..a2e8475 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_bullets()` 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 diff --git a/R/enumeration_units.R b/R/enumeration_units.R index a0ef8cb..d4ac359 100644 --- a/R/enumeration_units.R +++ b/R/enumeration_units.R @@ -54,28 +54,18 @@ counties <- function( state = NULL, cb = FALSE, - resolution = '500k', + 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) + check_cb(cb) + year <- set_tigris_year(year, min_year = 1990) - message(sprintf("Retrieving data for the year %s", year)) - } - - cyear <- as.character(year) + if (cb) { + resolution <- match_resolution(resolution) - 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,43 +81,42 @@ 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 ) } } 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, ] @@ -141,39 +130,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 +238,33 @@ tracts <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + 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)) ) { - 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) { + if (year > 2018 && cb) { state <- "us" - message("Retrieving Census tracts for the entire United States") + cli_bullets("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 (cb) { 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", @@ -298,42 +279,43 @@ 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", - 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 +324,8 @@ tracts <- function( trcts <- load_tiger(url, tigris_type = "tract", ...) if (!is.null(county)) { - county <- sapply(county, function(x) { - validate_county(state, x) - }) + # TODO: Add check that state is not "us" + county <- validate_county(state, county, multiple = TRUE) trcts <- trcts[trcts$COUNTYFP %in% county, ] } @@ -359,50 +340,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 +444,52 @@ school_districts <- function( year = NULL, ... ) { - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + 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" - message("Retrieving school districts for the entire United States") + cli_bullets( + "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) + state <- validate_state(state, require_state = TRUE) } - 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 (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 - ) - } - - 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 +544,27 @@ 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) + 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" - message( + cli_bullets( "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 (cb) { 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 +581,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 +621,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 +634,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 +734,45 @@ zctas <- function( state = NULL, ... ) { - if (is.null(year)) { - year = getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + check_cb(cb) + 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) { - stop( - 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 + cli_abort( + 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) { - stop("ZCTAs are only available by state for 2000 and 2010.") + cli_abort("ZCTAs are only available by state for 2000 and 2010, not {year}.") } - if (!is.null(state) && year == 2010 && cb == TRUE) { - stop( - "ZCTAs are only available by state for 2010 when cb = FALSE.", - call. = FALSE + if (!is.null(state) && year == 2010 && cb) { + 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 - ) - } - - if (!is.null(state)) state <- validate_state(state) + state <- validate_state(state) cache <- getOption("tigris_use_cache") if (is.null(cache)) { - message( - "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)`" + 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." + ) ) } - cyear <- as.character(year) - if (cb) { if (year == 2000) { if (is.null(state)) { @@ -846,45 +788,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 +834,8 @@ zctas <- function( } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER%s/ZCTA5/tl_%s_us_zcta510.zip", - cyear, - cyear + year, + year ) } } @@ -903,8 +845,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_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." + ) ) } @@ -969,68 +914,46 @@ 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)) - } - - if (length(county) > 1 && year < 2011) { - p <- lapply(county, function(x) { - blocks(state = state, county = x, year = year, ...) - }) %>% - rbind_tigris() - - return(p) - } - - if (year < 2000) { - fname <- as.character(match.call())[[1]] - - msg <- "Block data are not available for 1990." - - stop(msg, call. = FALSE) - } - - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) + year <- set_tigris_year( + year, + min_year = 2000, + not_year = c(2001:2009) + ) - 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, multiple = TRUE, allow_null = TRUE) + suf <- year_suffix(year) 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 @@ -1038,36 +961,36 @@ blocks <- function(state, county = NULL, year = NULL, ...) { } else { url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2010/TABBLOCK/%s/tl_2010_%s_tabblock%s.zip", - cyear, + year, state, suf ) } - } else { - stop() } - 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) { - 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,30 +1030,11 @@ county_subdivisions <- function( year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + check_cb(cb) + year <- set_tigris_year(year, min_year = 2010) + state <- validate_state(state, require_state = TRUE) - 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) - } - - state <- validate_state(state) - - if (is.null(state)) stop("Invalid state", call. = FALSE) - - cyear <- as.character(year) - - if (cb == TRUE) { + if (cb) { if (year == 2010) { url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ2010/gz_2010_%s_060_00_500k.zip", @@ -1139,8 +1043,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 +1059,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 +1069,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..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) - message(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,10 +173,9 @@ load_tiger <- function( i <- 1 while (i < 4) { - message(sprintf( - "Previous download failed. Re-download attempt %s of 3...", - as.character(i) - )) + cli_bullets( + "Previous download failed. Re-download attempt{i}s of 3..." + ) if (grepl("^ftp://", url)) { # Use download.file for FTP URLs with timeout @@ -220,8 +221,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_bullets( + "HTTP download failed, trying FTP as fallback..." + ) + ftp_url <- gsub( + "^https://www2", + "ftp://ftp2", + original_url + ) # Try FTP download options(timeout = timeout) @@ -237,9 +244,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 +258,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 +326,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_bullets("HTTP download failed, trying FTP as fallback...") ftp_url <- gsub("^https://www2", "ftp://ftp2", original_url) # Try FTP download @@ -345,24 +354,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 +391,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)) { @@ -405,12 +414,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 - ), - call. = FALSE + 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 { @@ -499,9 +505,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 +547,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 +590,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 +647,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 +661,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 +718,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 @@ -720,9 +726,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\'.", - call. = FALSE + cli_warn( + "Multiple school district tigris types. Coercing to {.str sdall}." ) elements <- lapply(seq_along(elements), function(x) { @@ -750,7 +755,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 +764,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 +804,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 +862,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 +887,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 +896,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_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), @@ -907,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) - message( + 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/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..cbe2a93 100644 --- a/R/legislative.R +++ b/R/legislative.R @@ -33,20 +33,16 @@ congressional_districts <- function( state = NULL, cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + check_cb(cb) + 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 +64,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) - if (cb) { + resolution <- match_resolution(resolution) + url <- sprintf( "https://www2.census.gov/geo/tiger/GENZ%s/shp/cb_%s_us_cd%s_%s.zip", - cyear, - cyear, + year, + year, congress, resolution ) @@ -105,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 )) @@ -116,8 +94,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 +103,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 ) } @@ -134,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, ] @@ -183,61 +161,33 @@ 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) - } + 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" - message( + cli_bullets( "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 (cb) { if (year == 2010) { if (type == "sldu") { url <- sprintf( @@ -254,8 +204,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 +216,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 @@ -335,27 +285,29 @@ voting_districts <- function( year = 2020, ... ) { - if (year != 2020 && cb == TRUE) { - stop( - "Cartographic boundary voting districts files are only available for 2020.", - call. = FALSE + 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" - message("Retrieving voting districts for the entire United States") + cli_bullets( + "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) + county <- validate_county(state, county, multiple = TRUE) } if (cb) { @@ -369,9 +321,7 @@ voting_districts <- function( if (is.null(county)) { return(vtds) } else { - county = validate_county(state, county) - vtds_sub <- vtds[vtds$COUNTYFP20 == county, ] - return(vtds_sub) + return(vtds[vtds$COUNTYFP20 %in% county, ]) } } else { if (year == 2012) { @@ -382,8 +332,6 @@ voting_districts <- function( ) } else { if (!is.null(county)) { - county <- validate_county(state, county) - url <- sprintf( "https://www2.census.gov/geo/tiger/TIGER2020PL/LAYER/VTD/2020/tl_2020_%s%s_vtd20.zip", state, @@ -397,6 +345,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..98bb7e4 100644 --- a/R/metro_areas.R +++ b/R/metro_areas.R @@ -20,44 +20,22 @@ #' @export core_based_statistical_areas <- function( cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) + check_cb(cb) + year <- set_tigris_year(year, min_year = 2010) - 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) + if (cb) { + 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 +43,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 +58,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 +83,20 @@ 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) + check_cb(cb) + 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 +105,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 @@ -198,46 +157,24 @@ urban_areas <- function(cb = FALSE, year = NULL, criteria = NULL, ...) { #' @export combined_statistical_areas <- function( cb = FALSE, - resolution = '500k', + resolution = "500k", year = NULL, ... ) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) - - message(sprintf("Retrieving data for the year %s", year)) - } + check_cb(cb) + 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) - } - - if (!(resolution %in% c('500k', '5m', '20m'))) { - stop( - "Invalid value for resolution. Valid values are '500k', '5m', and '20m'.", - call. = FALSE - ) + cli_abort("CBSAs were not defined for 2022; choose a different year.") } - cyear <- as.character(year) + 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", - cyear, - cyear, + year, + year, resolution ) @@ -245,12 +182,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 +201,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 @@ -324,67 +243,43 @@ metro_divisions <- function(year = NULL, ...) { #' plot(ne$geometry) #' #' } -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) - - if (type == 'necta') { - if (cb == TRUE) { +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) { 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 ) } 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", - cyear, - cyear + year, + year ) 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", - 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..b04557c 100644 --- a/R/national.R +++ b/R/national.R @@ -17,38 +17,14 @@ #' addPolygons() #' } #' @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) +regions <- function(resolution = "500k", year = NULL, ...) { + 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 ) @@ -76,44 +52,18 @@ regions <- function(resolution = '500k', year = NULL, ...) { #' addTiles() %>% #' 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) +divisions <- function(resolution = "500k", year = NULL, ...) { + 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..34fdfd7 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,45 +23,28 @@ #' 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, ...) { - if (is.null(year)) { - year <- getOption("tigris_year", 2024) + check_cb(cb) + year <- set_tigris_year(year) - 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) - - if (cb == TRUE) { + if (cb) { 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,8 @@ 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) - } + check_cb(cb) + year <- set_tigris_year(year) if (cb) { url <- sprintf( @@ -131,7 +98,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 +117,24 @@ 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 - ) + check_cb(cb) + year <- set_tigris_year(year) - stop(msg, call. = FALSE) - } - - cyear <- as.character(year) - - if (cb == TRUE) { + if (cb) { 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 +173,14 @@ 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) - } + check_cb(cb) + 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 +190,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 +224,8 @@ 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) - } + check_cb(cb) + year <- set_tigris_year(year) if (cb) { url <- sprintf( @@ -319,5 +241,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..58172b4 100644 --- a/R/places.R +++ b/R/places.R @@ -15,70 +15,49 @@ #' @seealso \url{https://www2.census.gov/geo/pdfs/reference/GARM/Ch9GARM.pdf} #' @export places <- function(state = NULL, cb = FALSE, year = NULL, ...) { - if (length(state) > 1) { - p <- lapply(state, function(x) { - places(state = x, cb = cb, year = year, ...) - }) %>% - rbind_tigris() - - 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) - } + check_cb(cb) + year <- set_tigris_year(year) + state <- validate_state(state, multiple = TRUE) if (is.null(state)) { - if (year > 2018 && cb == TRUE) { + if (year > 2018 && cb) { state <- "us" - message( + cli_bullets( "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) } - cyear <- as.character(year) - - if (cb == TRUE) { + if (cb) { 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", ...)) + 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", ...) } #' 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..74e9af7 100644 --- a/R/pumas.R +++ b/R/pumas.R @@ -39,42 +39,22 @@ #' 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) - } + check_cb(cb) + 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_bullets("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 +63,29 @@ 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( + 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." + ) ) } if (year == 2020) { - message( + cli_bullets( "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 +94,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..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,45 +55,40 @@ #' 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, - 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 +109,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 +192,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 +224,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 +255,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 +265,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 +322,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 +372,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 +396,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 +425,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 +432,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..319520e 100644 --- a/R/states.R +++ b/R/states.R @@ -28,25 +28,15 @@ #' weight = 0.5) %>% #' 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) +states <- function(cb = FALSE, resolution = "500k", year = NULL, ...) { + check_cb(cb) + year <- set_tigris_year(year, min_year = 1990) - message(sprintf("Retrieving data for the year %s", year)) - } + if (cb) { + resolution <- match_resolution(resolution) - cyear <- as.character(year) - - 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 +52,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 ) } } @@ -183,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/R/tigris-package.R b/R/tigris-package.R index 913db45..0b49254 100644 --- a/R/tigris-package.R +++ b/R/tigris-package.R @@ -35,10 +35,9 @@ #' @import utils #' @import rappdirs #' @import httr -#' @import uuid #' @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/R/transportation.R b/R/transportation.R index 264c6d0..35f6f23 100644 --- a/R/transportation.R +++ b/R/transportation.R @@ -30,59 +30,43 @@ #' @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, ...) { - 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 - ) + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + multiple = TRUE, + require_county = TRUE + ) - stop(msg, call. = FALSE) - } + url <- sprintf( + "https://www2.census.gov/geo/tiger/TIGER%s/ROADS/tl_%s_%s%s_roads.zip", + year, + year, + state, + county + ) if (length(county) > 1) { - r <- lapply(county, function(x) { - roads(state = state, county = x, year = year, ...) + r <- lapply(url, function(x) { + load_tiger(x, tigris_type = "road", ...) }) %>% rbind_tigris() 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), - 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 +92,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 +132,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)) - } + year <- set_tigris_year(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) - - 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 +165,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 +190,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 ec185bd..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. @@ -229,15 +229,15 @@ 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( + + cli_bullets(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 + ) ) } } @@ -419,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. @@ -499,21 +507,21 @@ 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( + + 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]}" )) } @@ -619,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}." @@ -633,3 +641,128 @@ prep_input_sfc <- function( # Make NAD83 for coordinate alignment sf::st_transform(input, crs = crs) } + + +#' Get suffix of a 4 character year +#' @noRd +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, + not_year = NULL, + quiet = FALSE, + message = NULL, + call = caller_env() +) { + if (is.null(year)) { + year <- getOption("tigris_year", default) + + if (!quiet) { + cli_bullets("Retrieving data for the year {year}") + } + } + + check_tigris_year( + year, + min_year = min_year, + max_year = max_year, + not_year = not_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, + 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.", + call = call + ) + } + + outside_range <- !dplyr::between(year, min_year, max_year) + # TODO: Validate not_year + not_allowed <- is.numeric(not_year) && (year %in% not_year) + + if (!outside_range && !not_allowed) { + return(invisible(NULL)) + } + + if (outside_range) { + message <- c( + message, + "i" = "{.arg year} must be between {min_year} and {max_year}." + ) + } + + if (not_allowed) { + year <- c( + message, + "i" = "{.arg year} can't be {.or {not_year}}." + ) + } + + cli_abort( + message, + 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) +} + +#' 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 + ) +} diff --git a/R/water.R b/R/water.R index f4211ca..7bb4c55 100644 --- a/R/water.R +++ b/R/water.R @@ -24,53 +24,33 @@ #' #' } 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 - ) + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + require_county = TRUE, + multiple = TRUE + ) - stop(msg, call. = FALSE) - } + url <- sprintf( + "https://www2.census.gov/geo/tiger/TIGER%s/AREAWATER/tl_%s_%s%s_areawater.zip", + year, + year, + state, + county + ) if (length(county) > 1) { - w <- lapply(county, function(x) { - area_water(state = state, county = x, year = year, ...) + w <- lapply(url, function(x) { + load_tiger(x, tigris_type = "area_water", ...) }) %>% rbind_tigris() 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, - 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,52 +81,33 @@ 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 - ) + year <- set_tigris_year(year) + state <- validate_state(state, require_state = TRUE) + county <- validate_county( + state, + county, + require_county = TRUE, + multiple = TRUE + ) - stop(msg, call. = FALSE) - } + url <- sprintf( + "https://www2.census.gov/geo/tiger/TIGER%s/LINEARWATER/tl_%s_%s%s_linearwater.zip", + year, + year, + state, + county + ) if (length(county) > 1) { - w <- lapply(county, function(x) { - linear_water(state = state, county = x, year = year, ...) + w <- lapply(url, function(x) { + load_tiger(x, tigris_type = "linear_water", ...) }) %>% rbind_tigris() 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, - 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", ...) } diff --git a/R/zzz.R b/R/zzz.R index 209b35b..bee3078 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -30,16 +30,40 @@ 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")) +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" +)) 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/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)) - } } 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] } } 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. diff --git a/tests/testthat/_snaps/enumeration_units.md b/tests/testthat/_snaps/enumeration_units.md index d69f446..c2df43b 100644 --- a/tests/testthat/_snaps/enumeration_units.md +++ b/tests/testthat/_snaps/enumeration_units.md @@ -1,9 +1,7 @@ -# enumeration unit functions work +# `counties()` works 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 @@ -81,12 +77,10 @@ 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) - Message - Retrieving data for the year 2024 Output Simple feature collection with 48 features and 15 fields Geometry type: MULTIPOLYGON @@ -128,12 +122,10 @@ 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) - Message - Retrieving data for the year 2024 Output Simple feature collection with 1 feature and 13 fields Geometry type: POLYGON @@ -147,12 +139,10 @@ INTPTLON geometry 155 -104.4683727 POLYGON ((-104.8999 43.4996... ---- +# `block_groups()` work 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 @@ -169,12 +159,10 @@ 134 POLYGON ((-104.4524 42.7674... 135 POLYGON ((-104.8999 43.4996... ---- +# `blocks()` work 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 @@ -227,7 +215,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,12 +249,10 @@ 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) - 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 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/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 91e1146..1bdd81d 100644 --- a/tests/testthat/test-enumeration_units.R +++ b/tests/testthat/test-enumeration_units.R @@ -1,7 +1,6 @@ -test_that("enumeration unit functions work", { +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)) @@ -10,37 +9,79 @@ 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() + 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() + 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() + state <- "WY" + county <- "Niobrara" + expect_snapshot(block_groups( state = state, county = county, @@ -54,36 +95,110 @@ 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() + 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() + state <- "WY" + county <- "Niobrara" + expect_snapshot(zctas(state = state, year = 2010, progress_bar = FALSE)) - expect_warning( + 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)) + + 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_s3_class(zctas(year = 2010, cb = TRUE), "sf") +}) + + +test_that("`county_subdivisions()` works", { + skip_on_cran() + skip_on_ci() + 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-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 c6cb5e1..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" @@ -128,25 +126,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 +147,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" - ) }) @@ -184,12 +181,15 @@ 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" 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-metro_areas.R b/tests/testthat/test-metro_areas.R index 61ac4fb..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") @@ -34,4 +33,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)) }) 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 b4d0d17..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") @@ -20,8 +19,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..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 @@ -21,5 +20,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" + ) }) 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..41c6d70 100644 --- a/tests/testthat/test-states.R +++ b/tests/testthat/test-states.R @@ -1,28 +1,29 @@ 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") 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")) }) 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"