From 3489d8f43204e325e4d75f16ef4cfc43caba4a0e Mon Sep 17 00:00:00 2001 From: Ian D Buller Date: Thu, 29 Aug 2024 18:44:08 -0400 Subject: [PATCH] =?UTF-8?q?=F0=9F=94=80=20Merge=20`branch:dev=5Fduncan=5Fc?= =?UTF-8?q?uzzort`=20into=20`branch:main`=20(#24)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * :sparkles: Initial commit for branch "dev_duncan_cuzzort" (ndi v0.1.6.9007) * Added `geo_large = 'place'` for census-designated places as the larger geographical unit in `atkinson()`, `bell()`, `bemanian_beyer()`, `duncan()`, `hoover()`, `james_taeuber()`, `lieberson()`, `sudano()`, `theil()`, and `white()`, `white_blau()` functions. * Specifying census block groups in `geo` or `geo_small` arguments is now `'block group'` or `'cbg'` to match internal `get_acs()` function from the [tidycensus](https://CRAN.R-project.org/package=tidycensus) package * Added census block group computation for `anthopolos()` by specifying `geo == 'cbg'` or `geo == 'block group'` * :hammer: Added `duncan_cuzzort()` function * Added `duncan_cuzzort()` function to compute the aspatial racial or ethnic Absolute Centralization (*ACE*) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281) * Added census block group computation for `anthopolos()` by specifying `geo == 'cbg'` or `geo == 'block group'` * Fixed bug in `atkinson()` function to properly compute the income Atkinson Index * Updated and reordered the contents of 'ndi-package.R' * Consolidated DESCRIPTION * Reordered the README examples alphabetically * :bricks: Split up vignette into three separate vignettes * Split up vignette into three separate vignettes: 'ndi1', 'ndi2', and 'ndi3' for the *NDI*, racial or ethnic residential segregation, and additional socioeconomic disparity indices, respectively --- DESCRIPTION | 44 +- NAMESPACE | 6 + NEWS.md | 29 +- R/anthopolos.R | 352 +-- R/atkinson.R | 648 +++-- R/bell.R | 686 ++--- R/bemanian_beyer.R | 660 +++-- R/bravo.R | 505 ++-- R/duncan.R | 682 ++--- R/duncan_cuzzort.R | 415 +++ R/gini.R | 334 ++- R/globals.R | 11 +- R/hoover.R | 86 +- R/james_taeuber.R | 231 +- R/lieberson.R | 98 +- R/messer.R | 2 +- R/ndi-package.R | 56 +- R/powell_wiley.R | 716 ++--- R/sudano.R | 58 +- R/theil.R | 98 +- R/utils.R | 37 +- R/white.R | 98 +- R/white_blau.R | 112 +- README.md | 845 +++--- cran-comments.md | 27 +- inst/CITATION | 42 +- man/anthopolos.Rd | 13 +- man/atkinson.Rd | 18 +- man/bell.Rd | 6 +- man/bemanian_beyer.Rd | 14 +- man/bravo.Rd | 11 +- man/duncan.Rd | 6 +- man/duncan_cuzzort.Rd | 101 + man/figures/ace.png | Bin 0 -> 286207 bytes man/figures/lexis.png | Bin 319253 -> 318798 bytes man/gini.Rd | 6 +- man/hoover.Rd | 8 +- man/james_taeuber.Rd | 8 +- man/lieberson.Rd | 6 +- man/ndi-package.Rd | 50 +- man/sudano.Rd | 6 +- man/theil.Rd | 6 +- man/white.Rd | 6 +- man/white_blau.Rd | 9 +- tests/testthat/test-atkinson.R | 2 +- tests/testthat/test-duncan_cuzzort.R | 87 + vignettes/ndi1.Rmd | 534 ++++ vignettes/ndi1.html | 1201 ++++++++ vignettes/ndi1.html.asis | 3 + vignettes/ndi2.Rmd | 859 ++++++ vignettes/ndi2.html | 1500 ++++++++++ vignettes/ndi2.html.asis | 3 + vignettes/ndi3.Rmd | 338 +++ vignettes/ndi3.html | 846 ++++++ vignettes/ndi3.html.asis | 3 + vignettes/vignette.Rmd | 1821 ------------ vignettes/vignette.html | 3987 -------------------------- vignettes/vignette.html.asis | 3 - 58 files changed, 9455 insertions(+), 8884 deletions(-) create mode 100644 R/duncan_cuzzort.R create mode 100644 man/duncan_cuzzort.Rd create mode 100644 man/figures/ace.png create mode 100644 tests/testthat/test-duncan_cuzzort.R create mode 100644 vignettes/ndi1.Rmd create mode 100644 vignettes/ndi1.html create mode 100644 vignettes/ndi1.html.asis create mode 100644 vignettes/ndi2.Rmd create mode 100644 vignettes/ndi2.html create mode 100644 vignettes/ndi2.html.asis create mode 100644 vignettes/ndi3.Rmd create mode 100644 vignettes/ndi3.html create mode 100644 vignettes/ndi3.html.asis delete mode 100644 vignettes/vignette.Rmd delete mode 100644 vignettes/vignette.html delete mode 100644 vignettes/vignette.html.asis diff --git a/DESCRIPTION b/DESCRIPTION index d96b7de..a39a46f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: ndi Title: Neighborhood Deprivation Indices -Version: 0.1.6.9006 -Date: 2024-08-24 +Version: 0.1.6.9007 +Date: 2024-08-29 Authors@R: c(person(given = "Ian D.", family = "Buller", @@ -11,10 +11,10 @@ Authors@R: person(given = "NCI", role = c("cph", "fnd"))) Maintainer: Ian D. Buller -Description: Computes various metrics of socio-economic deprivation and disparity in - the United States. Some metrics are considered "spatial" because they +Description: Computes various indices of socioeconomic deprivation and disparity in + the United States. Some indices are considered "spatial" because they consider the values of neighboring (i.e., adjacent) census geographies in - their computation, while other metrics are "aspatial" because they only + their computation, while other indices are "aspatial" because they only consider the value within each census geography. Two types of aspatial neighborhood deprivation indices (NDI) are available: including: (1) based on Messer et al. (2006) @@ -24,36 +24,10 @@ Description: Computes various metrics of socio-economic deprivation and disparit . Both are a decomposition of multiple demographic characteristics from the U.S. Census Bureau American Community Survey 5-year estimates (ACS-5; 2006-2010 onward). Using data from the ACS-5 - (2005-2009 onward), the package can also (1) compute the spatial Racial Isolation - Index (RI) based on Anthopolos et al. (2011) , - (2) compute the spatial Educational Isolation Index (EI) based on Bravo et al. - (2021) , (3) compute the aspatial Index of - Concentration at the Extremes (ICE) based on Feldman et al. (2015) - and Krieger et al. (2016) - , (4) compute the aspatial racial or ethnic - Dissimilarity Index (D) based on Duncan & Duncan (1955) , (5) - compute the aspatial income or racial or ethnic Atkinson Index (A) based on Atkinson - (1970) , (6) aspatial racial or ethnic Interaction - Index (xPy*) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell - (1954) , (7) aspatial racial or ethnic Correlation Ratio (V) - based on Bell (1954) and White (1986) , - (8) aspatial racial or ethnic Location Quotient (LQ) based on Merton (1939) - and Sudano et al. (2013) - , (9) aspatial racial or ethnic Local - Exposure and Isolation (LEx/Is) metric based on Bemanian & Beyer (2017) - , (10) aspatial racial or ethnic Delta (DEL) - based on Hoover (1941) and Duncan et al. (1961; - LC:60007089), (11) an index of spatial proximity (SP) based on White (1986) - and Blau (1977; ISBN-13:978-0-029-03660-0), (12) the - aspatial racial or ethnic Isolation Index (xPx*) based on Lieberson (1981; - ISBN-13:978-1-032-53884-6) and Bell (1954) , (13) the - aspatial racial or ethnic Gini Index (G) based Gini (1921) , - (14) the aspatial racial or ethnic Dissimilarity Index (D) based on James & - Taeuber (1985) , and (15) the aspatial racial or ethnic - Entropy (H) based on Theil (1972; ISBN-13:978-0-444-10378-9) and Theil & Finizza - (1971) . Also using data from the ACS-5 (2005-2009 - onward), the package can retrieve the aspatial income Gini Index (G) based on - Gini (1921) . + (2005-2009 onward), the package can also compute indices of racial or ethnic + residential segregation, including but limited to those discussed in Massey + & Denton (1988) , and additional indices of + socioeconomic disparity. License: Apache License (>= 2.0) Encoding: UTF-8 LazyData: true diff --git a/NAMESPACE b/NAMESPACE index 96424ae..d6360c7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ export(bell) export(bemanian_beyer) export(bravo) export(duncan) +export(duncan_cuzzort) export(gini) export(hoover) export(james_taeuber) @@ -28,6 +29,7 @@ importFrom(sf,st_distance) importFrom(sf,st_drop_geometry) importFrom(sf,st_geometry) importFrom(sf,st_intersects) +importFrom(sf,st_transform) importFrom(sf,st_within) importFrom(stats,complete.cases) importFrom(stats,cor) @@ -45,7 +47,11 @@ importFrom(tidyr,pivot_longer) importFrom(tidyr,separate) importFrom(tigris,combined_statistical_areas) importFrom(tigris,core_based_statistical_areas) +importFrom(tigris,counties) importFrom(tigris,metro_divisions) +importFrom(tigris,places) +importFrom(tigris,states) +importFrom(tigris,tracts) importFrom(units,drop_units) importFrom(units,set_units) importFrom(utils,stack) diff --git a/NEWS.md b/NEWS.md index 9e148af..554c128 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,31 +1,40 @@ # ndi (development version) -## ndi v0.1.6.9006 +## ndi v0.1.6.9007 ### New Features -* Added `hoover()` function to compute the aspatial racial or ethnic Delta (*DEL*) based on [Hoover (1941)](https://doi.org/10.1017/S0022050700052980) and Duncan et al. (1961; LC:60007089) -* Added `white_blau()` function to compute an index of spatial proximity (*SP*) based on [White (1986)](https://doi.org/10.2307/3644339) and Blau (1977; ISBN-13:978-0-029-03660-0) -* Added `lieberson()` function to compute the aspatial racial or ethnic Isolation Index (_xPx\*_) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and and [Bell (1954)](https://doi.org/10.2307/2574118) +* Added `duncan_cuzzort()` function to compute the aspatial racial or ethnic Absolute Centralization (*ACE*) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281) +* Added `hoover()` function to compute the aspatial racial or ethnic Delta (*DEL*) based on [Hoover (1941)](https://doi.org/10.1017/S0022050700052980) and Duncan, Cuzzort, & Duncan (1961; LC:60007089) * Added `james_taeuber()` function to compute the aspatial racial or ethnic Dissimilarity Index (*D*) based on [James & Taeuber (1985)](https://doi.org/10.2307/270845) +* Added `lieberson()` function to compute the aspatial racial or ethnic Isolation Index (_xPx\*_) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and and [Bell (1954)](https://doi.org/10.2307/2574118) * Added `theil()` function the aspatial racial or ethnic Entropy (*H*) based on Theil (1972; ISBN:978-0-444-10378-9) and [Theil & Finizza (1971)](https://doi.org/110.1080/0022250X.1971.9989795) -* Added `geo_large = 'cbsa'` for Core Based Statistical Areas, `geo_large = 'csa'` for Combined Statistical Areas, and `geo_large = 'metro'` for Metropolitan Divisions as the larger geographical unit in `atkinson()`, `bell()`, `bemanian_beyer()`, `duncan()`, `hoover()`, `lieberson()`, `sudano()`, and `white()`, `white_blau()` functions. +* Added `white_blau()` function to compute an index of spatial proximity (*SP*) based on [White (1986)](https://doi.org/10.2307/3644339) and Blau (1977; ISBN-13:978-0-029-03660-0) * Thank you for the feature suggestions, [Symielle Gaston](https://orcid.org/0000-0001-9495-1592) +* Added `geo_large = 'place'` for census-designated places, `geo_large = 'cbsa'` for core-based statistical areas, `geo_large = 'csa'` for combined statistical areas, and `geo_large = 'metro'` for metropolitan divisions as the larger geographical unit in `atkinson()`, `bell()`, `bemanian_beyer()`, `duncan()`, `duncan_cuzzort()`, `hoover()`, `james_taeuber()`, `lieberson()`, `sudano()`, `theil()`, and `white()`, `white_blau()` functions. +* Added census block group computation for `anthopolos()` by specifying `geo == 'cbg'` or `geo == 'block group'` * Added `holder` argument to `atkinson()` function to toggle the computation with or without the Hölder mean. The function can now compute *A* without the Hölder mean. The default is `holder = FALSE`. +* Added `crs` argument to `anthopolos()`, `bravo()`, and `white_blau()` functions to provide spatial projection of the distance-based metrics * The `gini()` function now computes the aspatial racial or ethnic Gini Index (*G*) based on [Gini (1921)](https://doi.org/10.2307/2223319) as the main outcome. Arguments `geo_large`, `geo_small`, `subgroup`, and `omit_NAs` were added and argument `geo` was deprecated. The `gini()` function still retrieves the original output of the aspatial income Gini Index (*G*) at each smaller geography and is moved from the `g` output to `g_data` output. +* Specifying census block groups in `geo` or `geo_small` arguments is now `'block group'` or `'cbg'` to match internal `get_acs()` function from the [tidycensus](https://CRAN.R-project.org/package=tidycensus) package ### Updates -* `bell()` function computes the Interaction Index (Bell) not the Isolation Index as previously documented. Updated documentation throughout +* `bell()` function computes the Interaction Index (Bell) not the Isolation Index as previously documented. Updated documentation throughout. * Fixed bug in `bell()`, `bemanian_beyer()`, `duncan()`, `sudano()`, and `white()` functions when a smaller geography contains n=0 total population, will assign a value of zero (0) in the internal calculation instead of NA +* Fixed bug in `atkinson()` function to properly compute the income Atkinson Index * Renamed *AI* as *A*, *DI* as *D*, *Gini* as *G*, and *II* as _xPy\*_ to align with the definitions from [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281). The output for `atkinson()` now produces `a` instead of `ai`. The output for `duncan()` now produces `d` instead of `ai`. The output for `gini()` now produces `g` instead of `gini`. The output for `bell()` now produces `xPy_star` instead of `II`. The internal functions `ai_fun()`, `di_fun()` and `ii_fun()` were renamed `a_fun()`, `ddd_fun()` and `xpy_star_fun()`, respectively. * `tigris` and `units` are now Imports -* 'package.R' deprecated. Replaced with 'ndi-package.R' +* Reformatted functions for consistent internal structure +* 'package.R' deprecated. Replaced with 'ndi-package.R' and reordered the contents +* Consolidated DESCRIPTION * Re-formatted code and documentation throughout for consistent readability * Renamed 'race/ethnicity' or 'racial/ethnic' to 'race or ethnicity' or 'racial or ethnic' throughout documentation to use more modern, inclusive, and appropriate language * Updated documentation about value range of *V* (White) from `{0 to 1}` to `{-Inf to Inf}` -* Added examples for `gini()`, `james_taeuber()`, `lieberson()`, `hoover()`, `theil()`, and `white_blau()` functions in vignette and README +* Split up vignette into three separate vignettes: 'ndi1', 'ndi2', and 'ndi3' for the *NDI*, racial or ethnic residential segregation, and additional socioeconomic disparity indices, respectively +* Added examples for `atkinson()`, `duncan_cuzzort()`, `gini()`, `hoover()`, `james_taeuber()`, `lieberson()`, `theil()`, and `white_blau()` functions in vignettes and README * Added example for `holder` argument in `atkinson()` function in README -* Reformatted functions for consistent internal structure -* Updated examples in vignette to showcase a larger variety of U.S. states +* Reordered the README examples alphabetically +* Reordered the vignette examples to group the racial or ethnic residential segregation indices +* Updated examples in vignettes to showcase a larger variety of U.S. states * Updated examples in functions to better describe the metrics * Updated documentation formatting of metric names in all functions diff --git a/R/anthopolos.R b/R/anthopolos.R index 6ddbc91..4d08523 100644 --- a/R/anthopolos.R +++ b/R/anthopolos.R @@ -2,9 +2,10 @@ #' #' Compute the spatial Racial Isolation Index (Anthopolos) of selected subgroup(s). #' -#' @param geo Character string specifying the geography of the data either census tracts \code{geo = 'tract'} (the default) or counties \code{geo = 'county'}. +#' @param geo Character string specifying the geography of the data either counties \code{geo = 'county'}, census tracts \code{geo = 'tract'} (the default), or census block groups \code{geo = 'cbg'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. +#' @param crs Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}. #' @param quiet Logical. If TRUE, will display messages about potential missing census information. The default is FALSE. #' @param ... Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics #' @@ -47,7 +48,7 @@ #' #' @import dplyr #' @importFrom Matrix sparseMatrix -#' @importFrom sf st_drop_geometry st_geometry st_intersects +#' @importFrom sf st_drop_geometry st_geometry st_intersects st_transform #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate @@ -73,178 +74,195 @@ anthopolos <- function(geo = 'tract', year = 2020, subgroup, + crs = 'ESRI:102008', quiet = FALSE, ...) { - # Check arguments - match.arg(geo, choices = c('county', 'tract')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + # Check arguments + match.arg(geo, choices = c('county', 'tract', 'cbg', 'block group')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - - # Select census variables - vars <- c( - TotalPop = 'B03002_001', - NHoL = 'B03002_002', - NHoLW = 'B03002_003', - NHoLB = 'B03002_004', - NHoLAIAN = 'B03002_005', - NHoLA = 'B03002_006', - NHoLNHOPI = 'B03002_007', - NHoLSOR = 'B03002_008', - NHoLTOMR = 'B03002_009', - NHoLTRiSOR = 'B03002_010', - NHoLTReSOR = 'B03002_011', - HoL = 'B03002_012', - HoLW = 'B03002_013', - HoLB = 'B03002_014', - HoLAIAN = 'B03002_015', - HoLA = 'B03002_016', - HoLNHOPI = 'B03002_017', - HoLSOR = 'B03002_018', - HoLTOMR = 'B03002_019', - HoLTRiSOR = 'B03002_020', - HoLTReSOR = 'B03002_021' + ) + + # Select census variables + vars <- c( + TotalPop = 'B03002_001', + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021' + ) + + selected_vars <- vars[c('TotalPop', subgroup)] + out_names <- names(selected_vars) # save for output + prefix <- 'subgroup' + suffix <- seq(1:length(subgroup)) + names(selected_vars) <- c('TotalPop', paste0(prefix, suffix)) + in_names <- paste0(names(selected_vars), 'E') + + # Acquire RI variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + ... ) - - selected_vars <- vars[c('TotalPop', subgroup)] - out_names <- names(selected_vars) # save for output - prefix <- 'subgroup' - suffix <- seq(1:length(subgroup)) - names(selected_vars) <- c('TotalPop', paste0(prefix, suffix)) - in_names <- paste0(names(selected_vars), 'E') - - # Acquire RI variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - ... - ) - )) - - if (geo == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } else { - out_dat <- out_dat %>% - tidyr::separate(NAME, into = c('county', 'state'), sep = ',') - } - + )) + + # Format output + if (geo == 'county') { out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(sf::st_drop_geometry(out_dat[, in_names[-1]]))) - - # Compute RI - ## From Anthopolos et al. (2011) https://doi.org/10.1016/j.sste.2011.06.002 - ## RI_{im} = (Sigma_{j∈∂_{i}} w_{ij} * T_{jm}) / (Sigma_{j∈∂_{i}} w_{ij} * T_{j}) - ## Where: - ## ∂_{i} denotes the set of index units i and its neighbors - ## Given M mutually exclusive racial or ethnic subgroups, m indexes the subgroups of M - ## T_{i} denotes the total population in region i (TotalPop) - ## T_{im} denotes the population of the selected subgroup(s) (subgroup1, ...) - ## w_{ij} denotes a nXn first-order adjacency matrix, where n is the number of census geometries in the study area - ### and the entries of w_{ij} are set to 1 if a boundary is shared by region i and region j and zero otherwise - ### Entries of the main diagonal (since i∈∂_{i}, w_{ij} = w_{ii} when j = i) of w_{ij} are set to 1.5 - ### such that the weight of the index unit, i, is larger than the weights assigned to adjacent tracts - - ## Geospatial adjacency matrix (w_ij) - tmp <- out_dat %>% - sf::st_geometry() %>% - sf::st_intersects(sparse = TRUE) - names(tmp) <- as.character(seq_len(nrow(out_dat))) - tmp_L <- length(tmp) - tmp_counts <- unlist(Map(length, tmp)) - tmp_i <- rep(1:tmp_L, tmp_counts) - tmp_j <- unlist(tmp) - w_ij <- Matrix::sparseMatrix( - i = tmp_i, - j = tmp_j, - x = 1, - dims = c(tmp_L, tmp_L) - ) - diag(w_ij) <- 1.5 - - ## Compute + tidyr::separate(NAME, into = c('county', 'state'), sep = ',') + } + if (geo == 'tract') { out_dat <- out_dat %>% - sf::st_drop_geometry() # drop geometries (can join back later) - out_tmp <- list() - for (i in 1:dim(w_ij)[1]) { - out_tmp[[i]] <- sum(as.matrix(w_ij[i,]) * out_dat[, 'subgroup']) / - sum(as.matrix(w_ij[i,]) * out_dat[, 'TotalPopE']) - } - out_dat$RI <- unlist(out_tmp) - - # Warning for missingness of census characteristics - missingYN <- out_dat[, in_names] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo == 'cbg' | geo == 'block group') { + out_dat <- out_dat %>% + tidyr::separate(NAME, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), cbg = gsub('[^0-9\\.]', '', cbg) ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo == 'tract') { - out <- out_dat %>% - dplyr::select(c('GEOID', 'state', 'county', 'tract', 'RI', dplyr::all_of(in_names))) - names(out) <- c('GEOID', 'state', 'county', 'tract', 'RI', out_names) - } else { - out <- out_dat %>% - dplyr::select(c('GEOID', 'state', 'county', 'RI', dplyr::all_of(in_names))) - names(out) <- c('GEOID', 'state', 'county', 'RI', out_names) + } + + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(sf::st_drop_geometry(out_dat[, in_names[-1]]))) + + # Compute RI + ## From Anthopolos et al. (2011) https://doi.org/10.1016/j.sste.2011.06.002 + ## RI_{im} = (Sigma_{j∈∂_{i}} w_{ij} * T_{jm}) / (Sigma_{j∈∂_{i}} w_{ij} * T_{j}) + ## Where: + ## ∂_{i} denotes the set of index units i and its neighbors + ## Given M mutually exclusive racial or ethnic subgroups, m indexes the subgroups of M + ## T_{i} denotes the total population in region i (TotalPop) + ## T_{im} denotes the population of the selected subgroup(s) (subgroup1, ...) + ## w_{ij} denotes a nXn first-order adjacency matrix, where n is the number of census geometries in the study area + ### and the entries of w_{ij} are set to 1 if a boundary is shared by region i and region j and zero otherwise + ### Entries of the main diagonal (since i∈∂_{i}, w_{ij} = w_{ii} when j = i) of w_{ij} are set to 1.5 + ### such that the weight of the index unit, i, is larger than the weights assigned to adjacent tracts + + ## Geospatial adjacency matrix (w_ij) + tmp <- out_dat %>% + sf::st_transform(crs = crs) %>% + sf::st_geometry() %>% + sf::st_intersects(sparse = TRUE) + names(tmp) <- as.character(seq_len(nrow(out_dat))) + tmp_L <- length(tmp) + tmp_counts <- unlist(Map(length, tmp)) + tmp_i <- rep(1:tmp_L, tmp_counts) + tmp_j <- unlist(tmp) + w_ij <- Matrix::sparseMatrix( + i = tmp_i, + j = tmp_j, + x = 1, + dims = c(tmp_L, tmp_L) + ) + diag(w_ij) <- 1.5 + + ## Compute + out_dat <- out_dat %>% + sf::st_drop_geometry() # drop geometries (can join back later) + out_tmp <- list() + for (i in 1:dim(w_ij)[1]) { + out_tmp[[i]] <- sum(as.matrix(w_ij[i,]) * out_dat[, 'subgroup']) / + sum(as.matrix(w_ij[i,]) * out_dat[, 'TotalPopE']) + } + out_dat$RI <- unlist(out_tmp) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, in_names] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - - out <- out %>% - dplyr::mutate( - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(ri = out, missing = missingYN) - - return(out) } + + # Format output + if (geo == 'county') { + out <- out_dat %>% + dplyr::select(c(GEOID, state, county, RI, dplyr::all_of(in_names))) + names(out) <- c('GEOID', 'state', 'county', 'RI', out_names) + } + if (geo == 'tract') { + out <- out_dat %>% + dplyr::select(c(GEOID, state, county, tract, RI, dplyr::all_of(in_names))) + names(out) <- c('GEOID', 'state', 'county', 'tract', 'RI', out_names) + } + if (geo == 'cbg' | geo == 'block group') { + out <- out_dat %>% + dplyr::select(c(GEOID, state, county, tract, cbg, RI, dplyr::all_of(in_names))) + names(out) <- c('GEOID', 'state', 'county', 'tract', 'cbg', 'RI', out_names) + } + + out <- out %>% + dplyr::mutate( + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(ri = out, missing = missingYN) + + return(out) +} diff --git a/R/atkinson.R b/R/atkinson.R index e0aaa6c..abe8ccc 100644 --- a/R/atkinson.R +++ b/R/atkinson.R @@ -3,7 +3,7 @@ #' Compute the aspatial Atkinson Index of income or selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the income or racial or ethnic subgroup(s) as the comparison population. See Details for available choices. #' @param epsilon Numerical. Shape parameter that denotes the aversion to inequality. Value must be between 0 and 1.0 (the default is 0.5). @@ -14,7 +14,7 @@ #' #' @details This function will compute the aspatial Atkinson Index (\emph{A}) of income or selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}. This function provides the computation of \emph{A} for median household income and any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. When \code{subgroup = 'MedHHInc'}, the metric will be computed for median household income ('B19013_001'). The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. When \code{subgroup = 'MedHHInc'}, the metric will be computed for median household income ('B19013_001') using the Hölder mean. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -44,7 +44,7 @@ #' #' The \code{epsilon} argument that determines how to weight the increments to inequality contributed by different proportions of the Lorenz curve. A user must explicitly decide how heavily to weight smaller geographical units at different points on the Lorenz curve (i.e., whether the index should take greater account of differences among units of over- or under-representation). The \code{epsilon} argument must have values between 0 and 1.0. For \code{0 <= epsilon < 0.5} or less 'inequality-averse,' smaller geographical units with a subgroup proportion smaller than the subgroup proportion of the larger geographical unit contribute more to inequality ('over-representation'). For \code{0.5 < epsilon <= 1.0} or more 'inequality-averse,' smaller geographical units with a subgroup proportion larger than the subgroup proportion of the larger geographical unit contribute more to inequality ('under-representation'). If \code{epsilon = 0.5} (the default), units of over- and under-representation contribute equally to the index. See Section 2.3 of Saint-Jacques et al. (2020) \doi{10.48550/arXiv.2002.05819} for one method to select \code{epsilon}. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{A} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{A} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{A} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{A} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{A} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{A} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -60,7 +60,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -78,7 +78,17 @@ #' state = 'GA', #' year = 2020, #' subgroup = c('NHoLB', 'HoLB') -#' ) +#' ) +#' +#' # Atkinson Index of median household income +#' ## of census tracts within counties within Georgia, U.S.A., counties (2020) +#' atkinson( +#' geo_large = 'county', +#' geo_small = 'tract', +#' state = 'GA', +#' year = 2020, +#' subgroup = 'MedHHInc' +#' ) #' #' } #' @@ -92,316 +102,334 @@ atkinson <- function(geo_large = 'county', quiet = FALSE, ...) { - # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR', - 'MedHHInc' - ) + # Check arguments + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR', + 'MedHHInc' ) - stopifnot(is.numeric(epsilon), epsilon >= 0 , epsilon <= 1) # values between 0 and 1 - - # Select census variables - vars <- c( - TotalPop = 'B03002_001', - NHoL = 'B03002_002', - NHoLW = 'B03002_003', - NHoLB = 'B03002_004', - NHoLAIAN = 'B03002_005', - NHoLA = 'B03002_006', - NHoLNHOPI = 'B03002_007', - NHoLSOR = 'B03002_008', - NHoLTOMR = 'B03002_009', - NHoLTRiSOR = 'B03002_010', - NHoLTReSOR = 'B03002_011', - HoL = 'B03002_012', - HoLW = 'B03002_013', - HoLB = 'B03002_014', - HoLAIAN = 'B03002_015', - HoLA = 'B03002_016', - HoLNHOPI = 'B03002_017', - HoLSOR = 'B03002_018', - HoLTOMR = 'B03002_019', - HoLTRiSOR = 'B03002_020', - HoLTReSOR = 'B03002_021' + ) + stopifnot(is.numeric(epsilon), epsilon >= 0 , epsilon <= 1) # values between 0 and 1 + if ('MedHHInc' %in% subgroup) { holder <- TRUE } + + # Select census variables + vars <- c( + TotalPop = 'B03002_001', + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021', + MedHHInc = 'B19013_001' + ) + + selected_vars <- vars[c('TotalPop', subgroup)] + out_names <- names(selected_vars) # save for output + in_subgroup <- paste0(subgroup, 'E') + + # Acquire A variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... ) - - selected_vars <- vars[c('TotalPop', subgroup)] - out_names <- names(selected_vars) # save for output - in_subgroup <- paste0(subgroup, 'E') - - # Acquire A variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo_small, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - keep_geo_vars = TRUE, - ... + )) + + # Format output + if (geo_small == 'county') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + } + if (geo_small == 'tract') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo_small == 'cbg' | geo_small == 'block group') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), + cbg = gsub('[^0-9\\.]', '', cbg) ) + } + + # Grouping IDs for A computation + if (geo_large == 'state') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = STATEFP, + state = stringr::str_trim(state) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'county') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'tract') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP, TRACTCE), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) )) - - # Format output - if (geo_small == 'county') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') - } - if (geo_small == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } - if (geo_small == 'block group') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) - ) - } - - # Grouping IDs for A computation - if (geo_large == 'state') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = STATEFP, - state = stringr::str_trim(state) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'county') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'tract') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP, TRACTCE), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'cbsa') { - stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward - lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - cbsa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'csa') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - csa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - metro = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - - # Count of racial or ethnic subgroup populations - ## Count of racial or ethnic subgroup population - if (length(in_subgroup) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = .[, in_subgroup]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) - } - - # Compute A - ## From Atkinson (1970) https://doi.org/10.1016/0022-0531(70)90039-6 - ## A_{\epsilon}(x_{1},...,x_{n}) = \begin{Bmatrix} - ## 1 - (\frac{1}{n}\sum_{i=1}^{n}x_{i}^{1-\epsilon})^{1/(1-\epsilon)}/(\frac{1}{n}\sum_{i=1}^{n}x_{i}) & \mathrm{if\:} \epsilon \neq 1 \\ - ## 1 - (\prod_{i=1}^{n}x_{i})^{1/n}/(\frac{1}{n}\sum_{i=1}^{n}x_{i}) & \mathrm{if\:} \epsilon = 1 \\ - ## \end{Bmatrix} - ## Where the Atkinson index (A) is defined for a population subgroup count (x) of a given smaller geographical unit (i) for n smaller geographical units - ## and an inequality-aversion parameter (epsilon) - ## If denoting the Hölder mean (based on `Atkinson()` function in 'DescTools' package) by - ## M_{p}(x_{1},...,x_{n}) = \begin{Bmatrix} - ## (\frac{1}{n}\sum_{i=1}^{n}x_{i}^{p})^{1/p} & \mathrm{if\:} p \neq 0 \\ - ## (\prod_{i=1}^{n}x_{i})^{1/n} & \mathrm{if\:} p = 0 \\ - ## \end{Bmatrix} - ## then A is - ## A_{\epsilon}(x_{1},...,x_{n}) = 1 - \frac{M_{1-\epsilon}(x_{1},...,x_{n})}{M_{1}(x_{1},...,x_{n})} - - ## Compute - out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = a_fun, epsilon = epsilon, omit_NAs = omit_NAs, holder = holder) %>% - utils::stack(.) %>% + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% dplyr::mutate( - A = values, - oid = ind - ) %>% - dplyr::select(A, oid) - - # Warning for missingness of census characteristics - missingYN <- as.data.frame(out_dat[, c('TotalPopE', in_subgroup)]) - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, A) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, A) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, tract, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, A) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, cbsa, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, A) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, csa, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, A) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, metro, A) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, A) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'cbsa') { + stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward + lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + cbsa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'csa') { + stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + csa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'metro') { + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + metro = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + + # Count of racial or ethnic subgroup populations + ## Count of racial or ethnic subgroup population + if (length(in_subgroup) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = .[, in_subgroup]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) + } + + # Compute A + ## From Atkinson (1970) https://doi.org/10.1016/0022-0531(70)90039-6 + ## A_{\epsilon}(x_{1},...,x_{n}) = \begin{Bmatrix} + ## 1 - (\frac{1}{n}\sum_{i=1}^{n}x_{i}^{1-\epsilon})^{1/(1-\epsilon)}/(\frac{1}{n}\sum_{i=1}^{n}x_{i}) & \mathrm{if\:} \epsilon \neq 1 \\ + ## 1 - (\prod_{i=1}^{n}x_{i})^{1/n}/(\frac{1}{n}\sum_{i=1}^{n}x_{i}) & \mathrm{if\:} \epsilon = 1 \\ + ## \end{Bmatrix} + ## Where the Atkinson index (A) is defined for a population subgroup count (x) of a given smaller geographical unit (i) for n smaller geographical units + ## and an inequality-aversion parameter (epsilon) + ## If denoting the Hölder mean (based on `Atkinson()` function in 'DescTools' package) by + ## M_{p}(x_{1},...,x_{n}) = \begin{Bmatrix} + ## (\frac{1}{n}\sum_{i=1}^{n}x_{i}^{p})^{1/p} & \mathrm{if\:} p \neq 0 \\ + ## (\prod_{i=1}^{n}x_{i})^{1/n} & \mathrm{if\:} p = 0 \\ + ## \end{Bmatrix} + ## then A is + ## A_{\epsilon}(x_{1},...,x_{n}) = 1 - \frac{M_{1-\epsilon}(x_{1},...,x_{n})}{M_{1}(x_{1},...,x_{n})} + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = a_fun, epsilon = epsilon, omit_NAs = omit_NAs, holder = holder) %>% + utils::stack(.) %>% + dplyr::mutate( + A = values, + oid = ind + ) %>% + dplyr::select(A, oid) + + # Warning for missingness of census characteristics + missingYN <- as.data.frame(out_dat[, c('TotalPopE', in_subgroup)]) + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - + } + + # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) + if (geo_large == 'state') { out <- out %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out_dat <- out_dat %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(a = out, a_data = out_dat, missing = missingYN) - - return(out) + dplyr::select(oid, state, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, A) + } + if (geo_large == 'county') { + out <- out %>% + dplyr::select(oid, state, county, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, A) + } + if (geo_large == 'tract') { + out <- out %>% + dplyr::select(oid, state, county, tract, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, tract, A) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, A) } + if (geo_large == 'cbsa') { + out <- out %>% + dplyr::select(oid, cbsa, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, cbsa, A) + } + if (geo_large == 'csa') { + out <- out %>% + dplyr::select(oid, csa, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, csa, A) + } + if (geo_large == 'metro') { + out <- out %>% + dplyr::select(oid, metro, A) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, metro, A) + } + + out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(a = out, a_data = out_dat, missing = missingYN) + + return(out) +} diff --git a/R/bell.R b/R/bell.R index f309303..80237bb 100644 --- a/R/bell.R +++ b/R/bell.R @@ -3,7 +3,7 @@ #' Compute the aspatial Interaction Index (Bell) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param subgroup_ixn Character string specifying the racial or ethnic subgroup(s) as the interaction population. If the same as \code{subgroup}, will compute the simple isolation of the group. See Details for available choices. @@ -13,7 +13,7 @@ #' #' @details This function will compute the aspatial Interaction Index (_xPy\*_) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) \doi{10.2307/2574118}. This function provides the computation of _xPy\*_ for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -41,7 +41,7 @@ #' #' _xPy\*_ is some measure of the probability that a member of one subgroup(s) will meet or interact with a member of another subgroup(s) with higher values signifying higher probability of interaction (less isolation). _xPy\*_ can range in value from 0 to 1. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the _xPy\*_ value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the _xPy\*_ computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the _xPy\*_ computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the _xPy\*_ value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the _xPy\*_ computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the _xPy\*_ computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -57,7 +57,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -89,343 +89,359 @@ bell <- function(geo_large = 'county', quiet = FALSE, ...) { - # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + # Check arguments + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - match.arg( - subgroup_ixn, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + ) + match.arg( + subgroup_ixn, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - - # Select census variables - vars <- c( - TotalPop = 'B03002_001', - NHoL = 'B03002_002', - NHoLW = 'B03002_003', - NHoLB = 'B03002_004', - NHoLAIAN = 'B03002_005', - NHoLA = 'B03002_006', - NHoLNHOPI = 'B03002_007', - NHoLSOR = 'B03002_008', - NHoLTOMR = 'B03002_009', - NHoLTRiSOR = 'B03002_010', - NHoLTReSOR = 'B03002_011', - HoL = 'B03002_012', - HoLW = 'B03002_013', - HoLB = 'B03002_014', - HoLAIAN = 'B03002_015', - HoLA = 'B03002_016', - HoLNHOPI = 'B03002_017', - HoLSOR = 'B03002_018', - HoLTOMR = 'B03002_019', - HoLTRiSOR = 'B03002_020', - HoLTReSOR = 'B03002_021' + ) + + # Select census variables + vars <- c( + TotalPop = 'B03002_001', + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021' + ) + + selected_vars <- vars[c('TotalPop', subgroup, subgroup_ixn)] + out_names <- names(selected_vars) # save for output + in_subgroup <- paste0(subgroup, 'E') + in_subgroup_ixn <- paste0(subgroup_ixn, 'E') + + # Acquire xPy* variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... ) - - selected_vars <- vars[c('TotalPop', subgroup, subgroup_ixn)] - out_names <- names(selected_vars) # save for output - in_subgroup <- paste0(subgroup, 'E') - in_subgroup_ixn <- paste0(subgroup_ixn, 'E') - - # Acquire xPy* variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo_small, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - keep_geo_vars = TRUE, - ... + )) + + # Format output + if (geo_small == 'county') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + } + if (geo_small == 'tract') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo_small == 'cbg' | geo_small == 'block group') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), + cbg = gsub('[^0-9\\.]', '', cbg) ) + } + + # Grouping IDs for xPy* computation + if (geo_large == 'state') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = STATEFP, + state = stringr::str_trim(state) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'county') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'tract') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP, TRACTCE), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) )) - - # Format output - if (geo_small == 'county') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') - } - if (geo_small == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } - if (geo_small == 'block group') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) - ) - } - - # Grouping IDs for xPy* computation - if (geo_large == 'state') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = STATEFP, - state = stringr::str_trim(state) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'county') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'tract') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP, TRACTCE), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'cbsa') { - stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward - lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - cbsa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'csa') { - stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - csa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - metro = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - - # Count of racial or ethnic subgroup populations - ## Count of racial or ethnic comparison subgroup population - if (length(in_subgroup) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = .[, in_subgroup]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) - } - ## Count of racial or ethnic interaction subgroup population - if (length(in_subgroup_ixn) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ixn = .[, in_subgroup_ixn]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ixn = rowSums(.[, in_subgroup_ixn])) - } - - # Compute xPy* - ## From Bell (1954) https://doi.org/10.2307/2574118 - ## _{x}P_{y}^* = \sum_{i=1}^{k} \left ( \frac{x_{i}}{X}\right )\left ( \frac{y_{i}}{n_{i}}\right ) - ## Where for k geographical units i: - ## X denotes the total number of subgroup population in study (reference) area - ## x_{i} denotes the number of subgroup population X in geographical unit i - ## y_{i} denotes the number of subgroup population Y in geographical unit i - ## n_{i} denotes the total population of geographical unit i - ## If x_{i} = y_{i}, then computes the average isolation experienced by members of subgroup population X - - ## Compute - out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = xpy_star_fun, omit_NAs = omit_NAs) %>% - utils::stack(.) %>% + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% dplyr::mutate( - xPy_star = values, - oid = ind - ) %>% - dplyr::select(xPy_star, oid) - - # Warning for missingness of census characteristics - missingYN <- out_dat[, c('TotalPopE', in_subgroup, in_subgroup_ixn)] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, xPy_star) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, xPy_star) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, tract, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, xPy_star) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, cbsa, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, xPy_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, csa, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, xPy_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, metro, xPy_star) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, xPy_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'cbsa') { + stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward + lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + cbsa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'csa') { + stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + csa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'metro') { + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + metro = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + + # Count of racial or ethnic subgroup populations + ## Count of racial or ethnic comparison subgroup population + if (length(in_subgroup) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = .[, in_subgroup]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) + } + ## Count of racial or ethnic interaction subgroup population + if (length(in_subgroup_ixn) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ixn = .[, in_subgroup_ixn]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ixn = rowSums(.[, in_subgroup_ixn])) + } + + # Compute xPy* + ## From Bell (1954) https://doi.org/10.2307/2574118 + ## _{x}P_{y}^* = \sum_{i=1}^{k} \left ( \frac{x_{i}}{X}\right )\left ( \frac{y_{i}}{n_{i}}\right ) + ## Where for k geographical units i: + ## X denotes the total number of subgroup population in study (reference) area + ## x_{i} denotes the number of subgroup population X in geographical unit i + ## y_{i} denotes the number of subgroup population Y in geographical unit i + ## n_{i} denotes the total population of geographical unit i + ## If x_{i} = y_{i}, then computes the average isolation experienced by members of subgroup population X + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = xpy_star_fun, omit_NAs = omit_NAs) %>% + utils::stack(.) %>% + dplyr::mutate( + xPy_star = values, + oid = ind + ) %>% + dplyr::select(xPy_star, oid) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, c('TotalPopE', in_subgroup, in_subgroup_ixn)] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - + } + + # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) + if (geo_large == 'state') { out <- out %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out_dat <- out_dat %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(xpy_star = out, xpy_star_data = out_dat, missing = missingYN) - - return(out) + dplyr::select(oid, state, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, xPy_star) + } + if (geo_large == 'county') { + out <- out %>% + dplyr::select(oid, state, county, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, xPy_star) + } + if (geo_large == 'tract') { + out <- out %>% + dplyr::select(oid, state, county, tract, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, tract, xPy_star) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, xPy_star) } + if (geo_large == 'cbsa') { + out <- out %>% + dplyr::select(oid, cbsa, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, cbsa, xPy_star) + } + if (geo_large == 'csa') { + out <- out %>% + dplyr::select(oid, csa, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, csa, xPy_star) + } + if (geo_large == 'metro') { + out <- out %>% + dplyr::select(oid, metro, xPy_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, metro, xPy_star) + } + + out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(xpy_star = out, xpy_star_data = out_dat, missing = missingYN) + + return(out) +} diff --git a/R/bemanian_beyer.R b/R/bemanian_beyer.R index 481e9de..fa7a75e 100644 --- a/R/bemanian_beyer.R +++ b/R/bemanian_beyer.R @@ -1,9 +1,9 @@ -#' Local Exposure and Isolation metric based on Bemanian & Beyer (2017) +#' Local Exposure and Isolation based on Bemanian & Beyer (2017) #' -#' Compute the aspatial Local Exposure and Isolation (Bemanian & Beyer) metric of a selected racial or ethnic subgroup(s) and U.S. geographies. +#' Compute the aspatial Local Exposure and Isolation (Bemanian & Beyer) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param subgroup_ixn Character string specifying the racial or ethnic subgroup(s) as the interaction population. If the same as \code{subgroup}, will compute the simple isolation of the group. See Details for available choices. @@ -11,9 +11,9 @@ #' @param quiet Logical. If TRUE, will display messages about potential missing census information. The default is FALSE. #' @param ... Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics #' -#' @details This function will compute the aspatial Local Exposure and Isolation (\emph{LEx/Is}) metric of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. This function provides the computation of \emph{LEx/Is} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). +#' @details This function will compute the aspatial Local Exposure and Isolation (\emph{LEx/Is}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. This function provides the computation of \emph{LEx/Is} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -41,9 +41,9 @@ #' #' \emph{LEx/Is} is a measure of the probability that two individuals living within a specific smaller geographical unit (e.g., census tract) of either different (i.e., exposure) or the same (i.e., isolation) racial or ethnic subgroup(s) will interact, assuming that individuals within a smaller geographical unit are randomly mixed. \emph{LEx/Is} is standardized with a logit transformation and centered against an expected case that all races or ethnicities are evenly distributed across a larger geographical unit. (Note: will adjust data by 0.025 if probabilities are zero, one, or undefined. The output will include a warning if adjusted. See \code{\link[car]{logit}} for additional details.) #' -#' \emph{LEx/Is} can range from negative infinity to infinity. If \emph{LEx/Is} is zero then the estimated probability of the interaction between two people of the given subgroup(s) within a smaller geographical unit is equal to the expected probability if the subgroup(s) were perfectly mixed in the larger geographical unit. If \emph{LEx/Is} is greater than zero then the interaction is more likely to occur within the smaller geographical unit than in the larger geographical unit, and if \emph{LEx/Is} is less than zero then the interaction is less likely to occur within the smaller geographical unit than in the larger geographical unit. Note: the exponentiation of each \emph{LEx/Is} metric results in the odds ratio of the specific exposure or isolation of interest in a smaller geographical unit relative to the larger geographical unit. +#' \emph{LEx/Is} can range from negative infinity to infinity. If \emph{LEx/Is} is zero then the estimated probability of the interaction between two people of the given subgroup(s) within a smaller geographical unit is equal to the expected probability if the subgroup(s) were perfectly mixed in the larger geographical unit. If \emph{LEx/Is} is greater than zero then the interaction is more likely to occur within the smaller geographical unit than in the larger geographical unit, and if \emph{LEx/Is} is less than zero then the interaction is less likely to occur within the smaller geographical unit than in the larger geographical unit. Note: the exponentiation of each \emph{LEx/Is} results in the odds ratio of the specific exposure or isolation of interest in a smaller geographical unit relative to the larger geographical unit. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{LEx/Is} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LEx/Is} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LEx/Is} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{LEx/Is} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LEx/Is} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LEx/Is} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -60,7 +60,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -92,318 +92,348 @@ bemanian_beyer <- function(geo_large = 'county', quiet = FALSE, ...) { - # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + # Check arguments + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - match.arg( - subgroup_ixn, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + ) + match.arg( + subgroup_ixn, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - - # Select census variables - vars <- c( - TotalPop = 'B03002_001', - NHoL = 'B03002_002', - NHoLW = 'B03002_003', - NHoLB = 'B03002_004', - NHoLAIAN = 'B03002_005', - NHoLA = 'B03002_006', - NHoLNHOPI = 'B03002_007', - NHoLSOR = 'B03002_008', - NHoLTOMR = 'B03002_009', - NHoLTRiSOR = 'B03002_010', - NHoLTReSOR = 'B03002_011', - HoL = 'B03002_012', - HoLW = 'B03002_013', - HoLB = 'B03002_014', - HoLAIAN = 'B03002_015', - HoLA = 'B03002_016', - HoLNHOPI = 'B03002_017', - HoLSOR = 'B03002_018', - HoLTOMR = 'B03002_019', - HoLTRiSOR = 'B03002_020', - HoLTReSOR = 'B03002_021' + ) + + # Select census variables + vars <- c( + TotalPop = 'B03002_001', + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021' + ) + + selected_vars <- vars[c('TotalPop', subgroup, subgroup_ixn)] + out_names <- names(selected_vars) # save for output + in_subgroup <- paste0(subgroup, 'E') + in_subgroup_ixn <- paste0(subgroup_ixn, 'E') + + # Acquire LEx/Is variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... ) - - selected_vars <- vars[c('TotalPop', subgroup, subgroup_ixn)] - out_names <- names(selected_vars) # save for output - in_subgroup <- paste0(subgroup, 'E') - in_subgroup_ixn <- paste0(subgroup_ixn, 'E') - - # Acquire LEx/Is variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo_small, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - keep_geo_vars = TRUE, - ... + )) + + # Format output + if (geo_small == 'county') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + } + if (geo_small == 'tract') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo_small == 'cbg') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), + cbg = gsub('[^0-9\\.]', '', cbg) ) + } + + # Grouping IDs for LEx/Is computation + if (geo_large == 'state') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = STATEFP, + state = stringr::str_trim(state) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'county') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste(STATEFP, COUNTYFP, sep = ''), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'tract') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste(STATEFP, COUNTYFP, TRACTCE, sep = ''), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) )) - - # Format output - if (geo_small == 'county') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') - } - if (geo_small == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } - if (geo_small == 'block group') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) - ) - } - - # Grouping IDs for LEx/Is computation - if (geo_large == 'state') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = STATEFP, - state = stringr::str_trim(state) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'county') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste(STATEFP, COUNTYFP, sep = ''), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'tract') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste(STATEFP, COUNTYFP, TRACTCE, sep = ''), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'cbsa') { - stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward - lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - cbsa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'csa') { - stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - csa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - metro = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - - # Count of racial or ethnic subgroup populations - ## Count of racial or ethnic comparison subgroup population - if (length(in_subgroup) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = .[, in_subgroup]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) - } - ## Count of racial or ethnic interaction subgroup population - if (length(in_subgroup_ixn) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ixn = .[, in_subgroup_ixn]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ixn = rowSums(.[, in_subgroup_ixn])) - } - - # Compute LEx/Is - ## From Bemanian & Beyer (2017) https://doi.org/10.1158/1055-9965.EPI-16-0926 - ## E^*_{m,n}(i) = log\left(\frac{p_{im} \times p_{in}}{1 - p_{im} \times p_{in}}\right) - log\left(\frac{P_{m} \times P_{n}}{1 - P_{m} \times P_{n}}\right) - ## Where for smaller geographical unit i: - ## p_{im} denotes the number of subgroup population m in smaller geographical unit i - ## p_{in} denotes the number of subgroup population n in smaller geographical unit i - ## P_{m} denotes the number of subgroup population m in larger geographical unit within which the smaller geographic unit i is located - ## P_{n} denotes the number of subgroup population n in larger geographical unit within which the smaller geographic unit i is located - ## If m \ne n, then computes the exposure of members of subgroup populations m and n - ## If m = n, then computes the simple isolation experienced by members of subgroup population m - - ## Compute - out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = lexis_fun, omit_NAs = omit_NAs) %>% - do.call('rbind', .) - - # Warning for missingness of census characteristics - missingYN <- out_dat[, c('TotalPopE', in_subgroup, in_subgroup_ixn)] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(GEOID)) - - if (geo_small == 'state') { - out <- out %>% - dplyr::select(GEOID, state, LExIs) - } - if (geo_small == 'county') { - out <- out %>% - dplyr::select(GEOID, state, county, LExIs) - } - if (geo_small == 'tract') { - out <- out %>% - dplyr::select(GEOID, state, county, tract, LExIs) - } - if (geo_small == 'block group') { - out <- out %>% - dplyr::select(GEOID, state, county, tract, block.group, LExIs) - } - if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::select(GEOID, cbsa) %>% - dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% - dplyr::relocate(cbsa, .after = county) - } - if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::select(GEOID, csa) %>% - dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% - dplyr::relocate(csa, .after = county) - } - if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::select(GEOID, metro) %>% - dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% - dplyr::relocate(metro, .after = county) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'cbsa') { + stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward + lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + cbsa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'csa') { + stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + csa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'metro') { + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + metro = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + + # Count of racial or ethnic subgroup populations + ## Count of racial or ethnic comparison subgroup population + if (length(in_subgroup) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = .[, in_subgroup]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) + } + ## Count of racial or ethnic interaction subgroup population + if (length(in_subgroup_ixn) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ixn = .[, in_subgroup_ixn]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ixn = rowSums(.[, in_subgroup_ixn])) + } + + # Compute LEx/Is + ## From Bemanian & Beyer (2017) https://doi.org/10.1158/1055-9965.EPI-16-0926 + ## E^*_{m,n}(i) = log\left(\frac{p_{im} \times p_{in}}{1 - p_{im} \times p_{in}}\right) - log\left(\frac{P_{m} \times P_{n}}{1 - P_{m} \times P_{n}}\right) + ## Where for smaller geographical unit i: + ## p_{im} denotes the number of subgroup population m in smaller geographical unit i + ## p_{in} denotes the number of subgroup population n in smaller geographical unit i + ## P_{m} denotes the number of subgroup population m in larger geographical unit within which the smaller geographic unit i is located + ## P_{n} denotes the number of subgroup population n in larger geographical unit within which the smaller geographic unit i is located + ## If m \ne n, then computes the exposure of members of subgroup populations m and n + ## If m = n, then computes the simple isolation experienced by members of subgroup population m + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = lexis_fun, omit_NAs = omit_NAs) %>% + do.call('rbind', .) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, c('TotalPopE', in_subgroup, in_subgroup_ixn)] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - + } + + # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(GEOID)) + + if (geo_small == 'state') { out <- out %>% - unique(.) %>% - .[.$GEOID != 'NANA',] %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out_dat <- out_dat %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(lexis = out, lexis_data = out_dat, missing = missingYN) - - return(out) + dplyr::select(GEOID, state, LExIs) + } + if (geo_small == 'county') { + out <- out %>% + dplyr::select(GEOID, state, county, LExIs) + } + if (geo_small == 'tract') { + out <- out %>% + dplyr::select(GEOID, state, county, tract, LExIs) } + if (geo_small == 'cbg') { + out <- out %>% + dplyr::select(GEOID, state, county, tract, cbg, LExIs) + } + if (geo_large == 'place') { + out <- out_dat %>% + dplyr::select(GEOID, place) %>% + dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% + dplyr::relocate(place, .after = county) + } + if (geo_large == 'cbsa') { + out <- out_dat %>% + dplyr::select(GEOID, cbsa) %>% + dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% + dplyr::relocate(cbsa, .after = county) + } + if (geo_large == 'csa') { + out <- out_dat %>% + dplyr::select(GEOID, csa) %>% + dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% + dplyr::relocate(csa, .after = county) + } + if (geo_large == 'metro') { + out <- out_dat %>% + dplyr::select(GEOID, metro) %>% + dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% + dplyr::relocate(metro, .after = county) + } + + out <- out %>% + unique(.) %>% + .[.$GEOID != 'NANA',] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(lexis = out, lexis_data = out_dat, missing = missingYN) + + return(out) +} diff --git a/R/bravo.R b/R/bravo.R index c20bdea..5ef75fa 100644 --- a/R/bravo.R +++ b/R/bravo.R @@ -5,6 +5,7 @@ #' @param geo Character string specifying the geography of the data either census tracts \code{geo = 'tract'} (the default) or counties \code{geo = 'county'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the educational attainment category(ies). See Details for available choices. +#' @param crs Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}. #' @param quiet Logical. If TRUE, will display messages about potential missing census information. The default is FALSE. #' @param ... Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics #' @@ -33,7 +34,7 @@ #' #' @import dplyr #' @importFrom Matrix sparseMatrix -#' @importFrom sf st_drop_geometry st_geometry st_intersects +#' @importFrom sf st_drop_geometry st_geometry st_intersects st_transform #' @importFrom stats setNames #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs @@ -60,262 +61,266 @@ bravo <- function(geo = 'tract', year = 2020, subgroup, + crs = 'ESRI:102008', quiet = FALSE, ...) { - # Check arguments - match.arg(geo, choices = c('county', 'tract')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c('LtHS', 'HSGiE', 'SCoAD', 'BD', 'GoPD') + # Check arguments + match.arg(geo, choices = c('county', 'tract')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c('LtHS', 'HSGiE', 'SCoAD', 'BD', 'GoPD') + ) + + # Select census variables + vars <- c( + TotalPop = 'B06009_001', + LtHS = 'B06009_002', + HSGiE = 'B06009_003', + SCoAD = 'B06009_004', + BD = 'B06009_005', + GoPD = 'B06009_006' + ) + + selected_vars <- vars[c('TotalPop', subgroup)] + + if (year == 2009) { + vars <- matrix( + c( + 'TotalPop', + 'TotalPop', + 'B15002_001', + 'LtHS', + 'mNSC', + 'B15002_003', + 'LtHS', + 'mNt4G', + 'B15002_004', + 'LtHS', + 'm5t6G', + 'B15002_005', + 'LtHS', + 'm7t8G', + 'B15002_006', + 'LtHS', + 'm9G', + 'B15002_007', + 'LtHS', + 'm10G', + 'B15002_008', + 'LtHS', + 'm11G', + 'B15002_009', + 'LtHS', + 'm12GND', + 'B15002_010', + 'HSGiE', + 'mHSGGEDoA', + 'B15002_011', + 'SCoAD', + 'mSClt1Y', + 'B15002_012', + 'SCoAD', + 'mSC1oMYND', + 'B15002_013', + 'SCoAD', + 'mAD', + 'B15002_014', + 'BD', + 'mBD', + 'B15002_015', + 'GoPD', + 'mMD', + 'B15002_016', + 'GoPD', + 'mPSD', + 'B15002_017', + 'GoPD', + 'mDD', + 'B15002_018', + 'LtHS', + 'fNSC', + 'B15002_020', + 'LtHS', + 'fNt4G', + 'B15002_021', + 'LtHS', + 'f5t6G', + 'B15002_022', + 'LtHS', + 'f7t8G', + 'B15002_023', + 'LtHS', + 'f9G', + 'B15002_024', + 'LtHS', + 'f10G', + 'B15002_025', + 'LtHS', + 'f11G', + 'B15002_026', + 'LtHS', + 'f12GND', + 'B15002_027', + 'HSGiE', + 'fHSGGEDoA', + 'B15002_028', + 'SCoAD', + 'fSClt1Y', + 'B15002_029', + 'SCoAD', + 'fSC1oMYND', + 'B15002_030', + 'SCoAD', + 'fAD', + 'B15002_031', + 'BD', + 'fBD', + 'B15002_032', + 'GoPD', + 'fMD', + 'B15002_033', + 'GoPD', + 'fPSD', + 'B15002_034', + 'GoPD', + 'fDD', + 'B15002_035' + ), + nrow = 33, + ncol = 3, + byrow = TRUE ) - # Select census variables - vars <- c( - TotalPop = 'B06009_001', - LtHS = 'B06009_002', - HSGiE = 'B06009_003', - SCoAD = 'B06009_004', - BD = 'B06009_005', - GoPD = 'B06009_006' + selected_vars <- stats::setNames( + vars[vars[, 1] %in% c('TotalPop', subgroup) , 3], + vars[vars[, 1] %in% c('TotalPop', subgroup) , 2] ) - - selected_vars <- vars[c('TotalPop', subgroup)] - - if (year == 2009) { - vars <- matrix( - c( - 'TotalPop', - 'TotalPop', - 'B15002_001', - 'LtHS', - 'mNSC', - 'B15002_003', - 'LtHS', - 'mNt4G', - 'B15002_004', - 'LtHS', - 'm5t6G', - 'B15002_005', - 'LtHS', - 'm7t8G', - 'B15002_006', - 'LtHS', - 'm9G', - 'B15002_007', - 'LtHS', - 'm10G', - 'B15002_008', - 'LtHS', - 'm11G', - 'B15002_009', - 'LtHS', - 'm12GND', - 'B15002_010', - 'HSGiE', - 'mHSGGEDoA', - 'B15002_011', - 'SCoAD', - 'mSClt1Y', - 'B15002_012', - 'SCoAD', - 'mSC1oMYND', - 'B15002_013', - 'SCoAD', - 'mAD', - 'B15002_014', - 'BD', - 'mBD', - 'B15002_015', - 'GoPD', - 'mMD', - 'B15002_016', - 'GoPD', - 'mPSD', - 'B15002_017', - 'GoPD', - 'mDD', - 'B15002_018', - 'LtHS', - 'fNSC', - 'B15002_020', - 'LtHS', - 'fNt4G', - 'B15002_021', - 'LtHS', - 'f5t6G', - 'B15002_022', - 'LtHS', - 'f7t8G', - 'B15002_023', - 'LtHS', - 'f9G', - 'B15002_024', - 'LtHS', - 'f10G', - 'B15002_025', - 'LtHS', - 'f11G', - 'B15002_026', - 'LtHS', - 'f12GND', - 'B15002_027', - 'HSGiE', - 'fHSGGEDoA', - 'B15002_028', - 'SCoAD', - 'fSClt1Y', - 'B15002_029', - 'SCoAD', - 'fSC1oMYND', - 'B15002_030', - 'SCoAD', - 'fAD', - 'B15002_031', - 'BD', - 'fBD', - 'B15002_032', - 'GoPD', - 'fMD', - 'B15002_033', - 'GoPD', - 'fPSD', - 'B15002_034', - 'GoPD', - 'fDD', - 'B15002_035' - ), - nrow = 33, - ncol = 3, - byrow = TRUE - ) - - selected_vars <- stats::setNames( - vars[vars[, 1] %in% c('TotalPop', subgroup) , 3], - vars[vars[, 1] %in% c('TotalPop', subgroup) , 2] - ) - } - - out_names <- names(selected_vars) # save for output - prefix <- 'subgroup' - suffix <- seq(1:length(selected_vars[-1])) - names(selected_vars) <- c('TotalPop', paste0(prefix, suffix)) - in_names <- paste0(names(selected_vars), 'E') - - # Acquire EI variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - ... - ) - )) - - if (geo == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } else { - out_dat <- out_dat %>% - tidyr::separate(NAME, into = c('county', 'state'), sep = ',') - } - - out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(sf::st_drop_geometry(out_dat[, in_names[-1]]))) - - # Compute EI - ## From Bravo et al. (2021) https://doi.org/10.3390/ijerph18179384 - ## EI_{im} = (Sigma_{j∈∂_{i}} w_{ij} * T_{jm}) / (Sigma_{j∈∂_{i}} w_{ij} * T_{j}) - ## Where: - ## ∂_{i} denotes the set of index units i and its neighbors - ## Given M mutually exclusive subgroups of educational attainment categories, m indexes the subgroups of M - ## T_{i} denotes the total population in region i (TotalPop) - ## T_{im} denotes the population of the selected subgroup(s) (subgroup1, ...) - ## w_{ij} denotes a nXn first-order adjacency matrix, where n is the number of census geometries in the study area - ### and the entries of w_{ij} are set to 1 if a boundary is shared by region i and region j and zero otherwise - ### Entries of the main diagonal (since i∈∂_{i}, w_{ij} = w_{ii} when j = i) of w_{ij} are set to 1.5 - ### such that the weight of the index unit, i, is larger than the weights assigned to adjacent tracts - - ## Geospatial adjacency matrix (w_ij) - tmp <- sf::st_intersects(sf::st_geometry(out_dat), sparse = TRUE) - names(tmp) <- as.character(seq_len(nrow(out_dat))) - tmp_L <- length(tmp) - tmp_counts <- unlist(Map(length, tmp)) - tmp_i <- rep(1:tmp_L, tmp_counts) - tmp_j <- unlist(tmp) - w_ij <- Matrix::sparseMatrix( - i = tmp_i, - j = tmp_j, - x = 1, - dims = c(tmp_L, tmp_L) + } + + out_names <- names(selected_vars) # save for output + prefix <- 'subgroup' + suffix <- seq(1:length(selected_vars[-1])) + names(selected_vars) <- c('TotalPop', paste0(prefix, suffix)) + in_names <- paste0(names(selected_vars), 'E') + + # Acquire EI variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + ... ) - diag(w_ij) <- 1.5 - - ## Compute + )) + + if (geo == 'tract') { out_dat <- out_dat %>% - sf::st_drop_geometry() # drop geometries (can join back later) - out_tmp <- list() - for (i in 1:dim(w_ij)[1]) { - out_tmp[[i]] <- sum(as.matrix(w_ij[i,]) * out_dat[, 'subgroup']) / - sum(as.matrix(w_ij[i,]) * out_dat[, 'TotalPopE']) - } - out_dat$EI <- unlist(out_tmp) - - # Warning for missingness of census characteristics - missingYN <- out_dat[, in_names] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo == 'tract') { - out <- out_dat %>% - dplyr::select(c( - 'GEOID', - 'state', - 'county', - 'tract', - 'EI', - dplyr::all_of(in_names) - )) - names(out) <- c('GEOID', 'state', 'county', 'tract', 'EI', out_names) - } else { - out <- out_dat %>% - dplyr::select(c('GEOID', 'state', 'county', 'EI', dplyr::all_of(in_names))) - names(out) <- c('GEOID', 'state', 'county', 'EI', out_names) + tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } else { + out_dat <- out_dat %>% + tidyr::separate(NAME, into = c('county', 'state'), sep = ',') + } + + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(sf::st_drop_geometry(out_dat[, in_names[-1]]))) + + # Compute EI + ## From Bravo et al. (2021) https://doi.org/10.3390/ijerph18179384 + ## EI_{im} = (Sigma_{j∈∂_{i}} w_{ij} * T_{jm}) / (Sigma_{j∈∂_{i}} w_{ij} * T_{j}) + ## Where: + ## ∂_{i} denotes the set of index units i and its neighbors + ## Given M mutually exclusive subgroups of educational attainment categories, m indexes the subgroups of M + ## T_{i} denotes the total population in region i (TotalPop) + ## T_{im} denotes the population of the selected subgroup(s) (subgroup1, ...) + ## w_{ij} denotes a nXn first-order adjacency matrix, where n is the number of census geometries in the study area + ### and the entries of w_{ij} are set to 1 if a boundary is shared by region i and region j and zero otherwise + ### Entries of the main diagonal (since i∈∂_{i}, w_{ij} = w_{ii} when j = i) of w_{ij} are set to 1.5 + ### such that the weight of the index unit, i, is larger than the weights assigned to adjacent tracts + + ## Geospatial adjacency matrix (w_ij) + tmp <- out_dat %>% + sf::st_transform(crs = crs) %>% + sf::st_geometry() %>% + sf::st_intersects(sparse = TRUE) + names(tmp) <- as.character(seq_len(nrow(out_dat))) + tmp_L <- length(tmp) + tmp_counts <- unlist(Map(length, tmp)) + tmp_i <- rep(1:tmp_L, tmp_counts) + tmp_j <- unlist(tmp) + w_ij <- Matrix::sparseMatrix( + i = tmp_i, + j = tmp_j, + x = 1, + dims = c(tmp_L, tmp_L) + ) + diag(w_ij) <- 1.5 + + ## Compute + out_dat <- out_dat %>% + sf::st_drop_geometry() # drop geometries (can join back later) + out_tmp <- list() + for (i in 1:dim(w_ij)[1]) { + out_tmp[[i]] <- sum(as.matrix(w_ij[i,]) * out_dat[, 'subgroup']) / + sum(as.matrix(w_ij[i,]) * out_dat[, 'TotalPopE']) + } + out_dat$EI <- unlist(out_tmp) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, in_names] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - - out <- out %>% - dplyr::mutate( - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(ei = out, missing = missingYN) - - return(out) } + + # Format output + if (geo == 'tract') { + out <- out_dat %>% + dplyr::select(c( + GEOID, + state, + county, + tract, + EI, + dplyr::all_of(in_names) + )) + names(out) <- c('GEOID', 'state', 'county', 'tract', 'EI', out_names) + } else { + out <- out_dat %>% + dplyr::select(c(GEOID, state, county, EI, dplyr::all_of(in_names))) + names(out) <- c('GEOID', 'state', 'county', 'EI', out_names) + } + + out <- out %>% + dplyr::mutate( + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(ei = out, missing = missingYN) + + return(out) +} diff --git a/R/duncan.R b/R/duncan.R index 113a253..34d717a 100644 --- a/R/duncan.R +++ b/R/duncan.R @@ -3,7 +3,7 @@ #' Compute the aspatial Dissimilarity Index (Duncan & Duncan) of selected racial or ethnic subgroup(s) and U.S. geographies #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices. #' @param subgroup_ref Character string specifying the racial or ethnic subgroup(s) as the reference population. See Details for available choices. @@ -13,7 +13,7 @@ #' #' @details This function will compute the aspatial Dissimilarity Index (\emph{D}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Duncan & Duncan (1955) \doi{10.2307/2088328}. This function provides the computation of \emph{D} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -41,7 +41,7 @@ #' #' \emph{D} is a measure of the evenness of racial or ethnic residential segregation when comparing smaller geographical units to larger ones within which the smaller geographical units are located. \emph{D} can range in value from 0 to 1 and represents the proportion of racial or ethnic subgroup members that would have to change their area of residence to achieve an even distribution within the larger geographical area under conditions of maximum segregation. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -57,7 +57,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -90,342 +90,358 @@ duncan <- function(geo_large = 'county', quiet = FALSE, ...) { - # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) - stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward - match.arg( - subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + # Check arguments + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - match.arg( - subgroup_ref, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + ) + match.arg( + subgroup_ref, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - - # Select census variables - vars <- c( - NHoL = 'B03002_002', - NHoLW = 'B03002_003', - NHoLB = 'B03002_004', - NHoLAIAN = 'B03002_005', - NHoLA = 'B03002_006', - NHoLNHOPI = 'B03002_007', - NHoLSOR = 'B03002_008', - NHoLTOMR = 'B03002_009', - NHoLTRiSOR = 'B03002_010', - NHoLTReSOR = 'B03002_011', - HoL = 'B03002_012', - HoLW = 'B03002_013', - HoLB = 'B03002_014', - HoLAIAN = 'B03002_015', - HoLA = 'B03002_016', - HoLNHOPI = 'B03002_017', - HoLSOR = 'B03002_018', - HoLTOMR = 'B03002_019', - HoLTRiSOR = 'B03002_020', - HoLTReSOR = 'B03002_021' + ) + + # Select census variables + vars <- c( + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021' + ) + + selected_vars <- vars[c(subgroup, subgroup_ref)] + out_names <- names(selected_vars) # save for output + in_subgroup <- paste0(subgroup, 'E') + in_subgroup_ref <- paste0(subgroup_ref, 'E') + + # Acquire D variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... ) - - selected_vars <- vars[c(subgroup, subgroup_ref)] - out_names <- names(selected_vars) # save for output - in_subgroup <- paste0(subgroup, 'E') - in_subgroup_ref <- paste0(subgroup_ref, 'E') - - # Acquire D variables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo_small, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - keep_geo_vars = TRUE, - ... + )) + + # Format output + if (geo_small == 'county') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + } + if (geo_small == 'tract') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo_small == 'cbg' | geo_small == 'block group') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), + cbg = gsub('[^0-9\\.]', '', cbg) ) - )) - - # Format output - if (geo_small == 'county') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') - } - if (geo_small == 'tract') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } - if (geo_small == 'block group') { - out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) - ) - } - - # Grouping IDs for D computation - if (geo_large == 'state') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = STATEFP, - state = stringr::str_trim(state) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'tract') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP, TRACTCE), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'county') { - out_dat <- out_dat %>% - dplyr::mutate( - oid = paste0(STATEFP, COUNTYFP), - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'cbsa') { - stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward - lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - cbsa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'csa') { - stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - csa = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) - wlgeom <- sf::st_within(out_dat, lgeom) - out_dat <- out_dat %>% - dplyr::mutate( - oid = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist(), - metro = lapply(wlgeom, function(x) { - tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% - unlist() - ) %>% - sf::st_drop_geometry() - } - - # Count of racial or ethnic subgroup populations - ## Count of racial or ethnic comparison subgroup population - if (length(in_subgroup) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = .[, in_subgroup]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) - } - ## Count of racial or ethnic reference subgroup population - if (length(in_subgroup_ref) == 1) { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ref = .[, in_subgroup_ref]) - } else { - out_dat <- out_dat %>% - dplyr::mutate(subgroup_ref = rowSums(.[, in_subgroup_ref])) - } - - # Compute D - ## From Duncan & Duncan (1955) https://doi.org/10.2307/2088328 - ## D_{jt} = 1/2 \sum_{i=1}^{k} | \frac{x_{ijt}}{X_{jt}}-\frac{y_{ijt}}{Y_{jt}}| - ## Where for k smaller geographies: - ## D_{jt} denotes the D of larger geographical unit j at time t - ## x_{ijt} denotes the racial or ethnic subgroup population of smaller geographical unit i within larger geographical unit j at time t - ## X_{jt} denotes the racial or ethnic subgroup population of larger geographical unit j at time t - ## y_{ijt} denotes the racial or ethnic referent subgroup population of smaller geographical unit i within larger geographical unit j at time t - ## Y_{jt} denotes the racial or ethnic referent subgroup population of larger geographical unit j at time t - - ## Compute - out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = ddd_fun, omit_NAs = omit_NAs) %>% - utils::stack(.) %>% + } + + # Grouping IDs for D computation + if (geo_large == 'state') { + out_dat <- out_dat %>% dplyr::mutate( - D = values, - oid = ind + oid = STATEFP, + state = stringr::str_trim(state) ) %>% - dplyr::select(D, oid) - - # Warning for missingness of census characteristics - missingYN <- out_dat[, c(in_subgroup, in_subgroup_ref)] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' + sf::st_drop_geometry() + } + if (geo_large == 'tract') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP, TRACTCE), + state = stringr::str_trim(state), + county = stringr::str_trim(county) ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, D) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, D) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, tract, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, D) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, cbsa, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, csa, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, metro, D) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + sf::st_drop_geometry() + } + if (geo_large == 'county') { + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'cbsa') { + stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward + lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + cbsa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'csa') { + stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + csa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + if (geo_large == 'metro') { + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + metro = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } + + # Count of racial or ethnic subgroup populations + ## Count of racial or ethnic comparison subgroup population + if (length(in_subgroup) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = .[, in_subgroup]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) + } + ## Count of racial or ethnic reference subgroup population + if (length(in_subgroup_ref) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ref = .[, in_subgroup_ref]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup_ref = rowSums(.[, in_subgroup_ref])) + } + + # Compute D + ## From Duncan & Duncan (1955) https://doi.org/10.2307/2088328 + ## D_{jt} = 1/2 \sum_{i=1}^{k} | \frac{x_{ijt}}{X_{jt}}-\frac{y_{ijt}}{Y_{jt}}| + ## Where for k smaller geographies: + ## D_{jt} denotes the D of larger geographical unit j at time t + ## x_{ijt} denotes the racial or ethnic subgroup population of smaller geographical unit i within larger geographical unit j at time t + ## X_{jt} denotes the racial or ethnic subgroup population of larger geographical unit j at time t + ## y_{ijt} denotes the racial or ethnic referent subgroup population of smaller geographical unit i within larger geographical unit j at time t + ## Y_{jt} denotes the racial or ethnic referent subgroup population of larger geographical unit j at time t + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = ddd_fun, omit_NAs = omit_NAs) %>% + utils::stack(.) %>% + dplyr::mutate( + D = values, + oid = ind + ) %>% + dplyr::select(D, oid) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, c(in_subgroup, in_subgroup_ref)] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - + } + + # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) + if (geo_large == 'state') { out <- out %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out_dat <- out_dat %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(d = out, d_data = out_dat, missing = missingYN) - - return(out) + dplyr::select(oid, state, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, D) + } + if (geo_large == 'county') { + out <- out %>% + dplyr::select(oid, state, county, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, D) + } + if (geo_large == 'tract') { + out <- out %>% + dplyr::select(oid, state, county, tract, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, tract, D) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, D) } + if (geo_large == 'cbsa') { + out <- out %>% + dplyr::select(oid, cbsa, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, cbsa, D) + } + if (geo_large == 'csa') { + out <- out %>% + dplyr::select(oid, csa, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, csa, D) + } + if (geo_large == 'metro') { + out <- out %>% + dplyr::select(oid, metro, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, metro, D) + } + + out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(d = out, d_data = out_dat, missing = missingYN) + + return(out) +} diff --git a/R/duncan_cuzzort.R b/R/duncan_cuzzort.R new file mode 100644 index 0000000..2496d7d --- /dev/null +++ b/R/duncan_cuzzort.R @@ -0,0 +1,415 @@ +#' Absolute Centralization based on Duncan, Cuzzort, & Duncan (1961) and Massey & Denton (1988) +#' +#' Compute the aspatial Absolute Centralization (Duncan & Cuzzort) of a selected racial or ethnic subgroup(s) and U.S. geographies. +#' +#' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. +#' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. +#' @param subgroup Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices. +#' @param crs Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}. +#' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. +#' @param quiet Logical. If TRUE, will display messages about potential missing census information. The default is FALSE. +#' @param ... Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics +#' +#' @details This function will compute the aspatial Absolute Centralization (\emph{ACE}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and Massey & Denton (1988) \doi{10.1093/sf/67.2.281}. This function provides the computation of \emph{ACE} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). +#' +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' \itemize{ +#' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} +#' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} +#' \item \strong{B03002_004}: not Hispanic or Latino, Black or African American alone \code{'NHoLB'} +#' \item \strong{B03002_005}: not Hispanic or Latino, American Indian and Alaska Native alone \code{'NHoLAIAN'} +#' \item \strong{B03002_006}: not Hispanic or Latino, Asian alone \code{'NHoLA'} +#' \item \strong{B03002_007}: not Hispanic or Latino, Native Hawaiian and Other Pacific Islander alone \code{'NHoLNHOPI'} +#' \item \strong{B03002_008}: not Hispanic or Latino, Some other race alone \code{'NHoLSOR'} +#' \item \strong{B03002_009}: not Hispanic or Latino, Two or more races \code{'NHoLTOMR'} +#' \item \strong{B03002_010}: not Hispanic or Latino, Two races including Some other race \code{'NHoLTRiSOR'} +#' \item \strong{B03002_011}: not Hispanic or Latino, Two races excluding Some other race, and three or more races \code{'NHoLTReSOR'} +#' \item \strong{B03002_012}: Hispanic or Latino \code{'HoL'} +#' \item \strong{B03002_013}: Hispanic or Latino, white alone \code{'HoLW'} +#' \item \strong{B03002_014}: Hispanic or Latino, Black or African American alone \code{'HoLB'} +#' \item \strong{B03002_015}: Hispanic or Latino, American Indian and Alaska Native alone \code{'HoLAIAN'} +#' \item \strong{B03002_016}: Hispanic or Latino, Asian alone \code{'HoLA'} +#' \item \strong{B03002_017}: Hispanic or Latino, Native Hawaiian and Other Pacific Islander alone \code{'HoLNHOPI'} +#' \item \strong{B03002_018}: Hispanic or Latino, Some other race alone \code{'HoLSOR'} +#' \item \strong{B03002_019}: Hispanic or Latino, Two or more races \code{'HoLTOMR'} +#' \item \strong{B03002_020}: Hispanic or Latino, Two races including Some other race \code{'HoLTRiSOR'} +#' \item \strong{B03002_021}: Hispanic or Latino, Two races excluding Some other race, and three or more races \code{'HoLTReSOR'} +#' } +#' +#' Use the internal \code{state} and \code{county} arguments within the \code{\link[tidycensus]{get_acs}} function to specify geographic extent of the data output. +#' +#' \emph{ACE} is a measure of the degree to which racial or ethnic populations within smaller geographical units are located near the center of a larger geographical unit. \emph{ACE} can range in value from -1 to 1 and represents the spatial distribution of racial or ethnic populations within smaller geographical units compared to the distribution of land area around the center of a larger geographical unit. Positive values indicate a tendency for racial or ethnic populations to reside close to the center of a larger geographical unit, while negative values indicate a tendency to live in outlying areas. A score of 0 means that racial or ethnic populations have a uniform distribution throughout a larger geographical unit. \emph{ACE} gives the proportion of racial or ethnic populations required to change residence to achieve a uniform distribution of population around the center of a larger geographical unit. +#' +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{ACE} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{ACE} computation. +#' +#' \emph{Important consideration}: The original metric used the location of the central business district (CBD) to compute the metric, but the U.S. Census Bureau has not defined CBDs for U.S. cities since the 1982 Census of Retail Trade. Therefore, this function uses the the centroids of each larger geographical unit as the 'centre', but may not represent the current CBD. +#' +#' @return An object of class 'list'. This is a named list with the following components: +#' +#' \describe{ +#' \item{\code{ace}}{An object of class 'tbl' for the GEOID, name, and \emph{ACE} at specified larger census geographies.} +#' \item{\code{ace_data}}{An object of class 'tbl' for the raw census values at specified smaller census geographies.} +#' \item{\code{missing}}{An object of class 'tbl' of the count and proportion of missingness for each census variable used to compute \emph{ACE}.} +#' } +#' +#' @import dplyr +#' @importFrom sf st_centroid st_distance st_drop_geometry st_transform st_within +#' @importFrom stats complete.cases +#' @importFrom stringr str_trim +#' @importFrom tidycensus get_acs +#' @importFrom tidyr pivot_longer separate +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas counties metro_divisions places states tracts +#' @importFrom units drop_units set_units +#' @importFrom utils stack +#' @export +#' +#' @seealso \code{\link[tidycensus]{get_acs}} for additional arguments for geographic extent selection (i.e., \code{state} and \code{county}). +#' +#' @examples +#' \dontrun{ +#' # Wrapped in \dontrun{} because these examples require a Census API key. +#' +#' # Absolute Concentration of Black populations +#' ## of census tracts within counties within Georgia, U.S.A., counties (2020) +#' duncan_cuzzort( +#' geo_large = 'county', +#' geo_small = 'tract', +#' state = 'GA', +#' year = 2020, +#' subgroup = c('NHoLB', 'HoLB') +#' ) +#' +#' } +#' +duncan_cuzzort <- function(geo_large = 'county', + geo_small = 'tract', + year = 2020, + subgroup, + crs = 'ESRI:102008', + omit_NAs = TRUE, + quiet = FALSE, + ...) { + + # Check arguments + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) + stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward + match.arg( + subgroup, + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' + ) + ) + + # Select census variables + vars <- c( + NHoL = 'B03002_002', + NHoLW = 'B03002_003', + NHoLB = 'B03002_004', + NHoLAIAN = 'B03002_005', + NHoLA = 'B03002_006', + NHoLNHOPI = 'B03002_007', + NHoLSOR = 'B03002_008', + NHoLTOMR = 'B03002_009', + NHoLTRiSOR = 'B03002_010', + NHoLTReSOR = 'B03002_011', + HoL = 'B03002_012', + HoLW = 'B03002_013', + HoLB = 'B03002_014', + HoLAIAN = 'B03002_015', + HoLA = 'B03002_016', + HoLNHOPI = 'B03002_017', + HoLSOR = 'B03002_018', + HoLTOMR = 'B03002_019', + HoLTRiSOR = 'B03002_020', + HoLTReSOR = 'B03002_021' + ) + + selected_vars <- vars[subgroup] + out_names <- names(selected_vars) # save for output + in_subgroup <- paste0(subgroup, 'E') + + # Acquire ACE variables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... + ) + )) + + # Format output + if (geo_small == 'county') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + } + if (geo_small == 'tract') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) + } + if (geo_small == 'cbg' | geo_small == 'block group') { + out_dat <- out_dat %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate( + tract = gsub('[^0-9\\.]', '', tract), + cbg = gsub('[^0-9\\.]', '', cbg) + ) + } + + # Grouping IDs for ACE computation + if (geo_large == 'state') { + lgeom <- suppressMessages(suppressWarnings(tigris::states(year = year))) + out_dat <- out_dat %>% + dplyr::mutate( + oid = STATEFP, + state = stringr::str_trim(state) + ) + } + if (geo_large == 'tract') { + lgeom <- suppressMessages(suppressWarnings(tigris::tracts( + year = year, state = unique(out_dat$state) + ))) + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP, TRACTCE), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) + } + if (geo_large == 'county') { + lgeom <- suppressMessages(suppressWarnings(tigris::counties( + year = year, state = unique(out_dat$state) + ))) + out_dat <- out_dat %>% + dplyr::mutate( + oid = paste0(STATEFP, COUNTYFP), + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) + } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state) + ))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) + } + if (geo_large == 'cbsa') { + stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward + lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + cbsa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) + } + if (geo_large == 'csa') { + stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + csa = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) + } + if (geo_large == 'metro') { + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + metro = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) + } + + # Count of racial or ethnic subgroup populations + ## Count of racial or ethnic comparison subgroup population + if (length(in_subgroup) == 1) { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = as.data.frame(.)[, in_subgroup]) + } else { + out_dat <- out_dat %>% + dplyr::mutate(subgroup = rowSums(as.data.frame(.)[, in_subgroup])) + } + + # Compute ACE + ## From Duncan, Cuzzort, & Duncan (1961; LC:60007089) + ## ACE = \left ( \sum_{i=2}^{n}X_{i-1}A_{i} \right ) - \left ( \sum_{i=1}^{n}X_{i}A_{i-1} \right ) + ## Where for i smaller geographical units: + ## X_{i} is the cumulative proportion of the subgroup population through smaller geographical unit i + ## A_{i} is the cumulative proportion of land area through smaller geographical unit i + ## when smaller geographical units are ordered by increasing distance + ## from the center of a larger geographical unit + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = ace_fun, lgeom = lgeom, crs = crs, omit_NAs = omit_NAs) %>% + utils::stack(.) %>% + dplyr::mutate( + ACE = values, + oid = ind + ) %>% + dplyr::select(ACE, oid) %>% + sf::st_drop_geometry() + + # Warning for missingness of census characteristics + missingYN <- out_dat[, in_subgroup] %>% + sf::st_drop_geometry() + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') + } + } + + # Format output + out <- out_dat %>% + sf::st_drop_geometry() %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) + if (geo_large == 'state') { + out <- out %>% + dplyr::select(oid, state, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, ACE) + } + if (geo_large == 'county') { + out <- out %>% + dplyr::select(oid, state, county, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, ACE) + } + if (geo_large == 'tract') { + out <- out %>% + dplyr::select(oid, state, county, tract, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, tract, ACE) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, ACE) + } + if (geo_large == 'cbsa') { + out <- out %>% + dplyr::select(oid, cbsa, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, cbsa, ACE) + } + if (geo_large == 'csa') { + out <- out %>% + dplyr::select(oid, csa, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, csa, ACE) + } + if (geo_large == 'metro') { + out <- out %>% + dplyr::select(oid, metro, ACE) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, metro, ACE) + } + + out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(ace = out, ace_data = out_dat, missing = missingYN) + + return(out) +} diff --git a/R/gini.R b/R/gini.R index 48120b1..4c02620 100644 --- a/R/gini.R +++ b/R/gini.R @@ -3,7 +3,7 @@ #' Compute the aspatial racial or ethnic Gini Index and retrieve the aspatial income Gini Index #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will retrieve the aspatial Gini Index (\emph{G}) of U.S. census tracts or counties for a specified geographical extent (e.g., the entire U.S. or a single state) based on Gini (1921) \doi{10.2307/2223319} for income inequality (at smaller geographical units) and race or ethnicity inequality (at larger geographical units). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey estimates of \emph{G} for the geospatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available but are available from other U.S. Census Bureau surveys. The function will retrieve the provided income inequality metric (\strong{B19083}) and the twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey estimates of \emph{G} for the geospatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but are available from other U.S. Census Bureau surveys. The function will retrieve the provided income inequality metric (\strong{B19083}) and the twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone\code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' According to the U.S. Census Bureau \url{https://www.census.gov/topics/income-poverty/income-inequality/about/metrics/gini-index.html}: 'The Gini Index is a summary measure of income inequality. The Gini coefficient incorporates the detailed shares data into a single statistic, which summarizes the dispersion of income across the entire income distribution. The Gini coefficient ranges from 0, indicating perfect equality (where everyone receives an equal share), to 1, perfect inequality (where only one recipient or group of recipients receives all the income). The Gini Index is based on the difference between the Lorenz curve (the observed cumulative income distribution) and the notion of a perfectly equal income distribution.' For racial or ethnic inequality, *G* is a summary measure of racial or ethnic unevenness or the mean absolute difference between a selected subgroup proportions weighted across all pairs of geographic units, expressed as a proportion of the maximum weighted difference. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{V} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{V} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{V} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{V} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -87,36 +87,36 @@ gini <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, - several.ok = TRUE, - choices = c( - 'NHoL', - 'NHoLW', - 'NHoLB', - 'NHoLAIAN', - 'NHoLA', - 'NHoLNHOPI', - 'NHoLSOR', - 'NHoLTOMR', - 'NHoLTRiSOR', - 'NHoLTReSOR', - 'HoL', - 'HoLW', - 'HoLB', - 'HoLAIAN', - 'HoLA', - 'HoLNHOPI', - 'HoLSOR', - 'HoLTOMR', - 'HoLTRiSOR', - 'HoLTReSOR' - ) + several.ok = TRUE, + choices = c( + 'NHoL', + 'NHoLW', + 'NHoLB', + 'NHoLAIAN', + 'NHoLA', + 'NHoLNHOPI', + 'NHoLSOR', + 'NHoLTOMR', + 'NHoLTRiSOR', + 'NHoLTReSOR', + 'HoL', + 'HoLW', + 'HoLB', + 'HoLAIAN', + 'HoLA', + 'HoLNHOPI', + 'HoLSOR', + 'HoLTOMR', + 'HoLTRiSOR', + 'HoLTReSOR' ) - + ) + # Select census variable vars <- c( TotalPop = 'B03002_001', @@ -146,19 +146,19 @@ gini <- function(geo_large = 'county', selected_vars <- vars[c('G_inc', 'TotalPop', subgroup)] out_names <- names(selected_vars) # save for output in_subgroup <- paste0(subgroup, 'E') - - # Acquire Gvariables and sf geometries - out_dat <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo_small, - year = year, - output = 'wide', - variables = selected_vars, - geometry = TRUE, - keep_geo_vars = TRUE, - ... - ) - )) + + # Acquire Gvariables and sf geometries + out_dat <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo_small, + year = year, + output = 'wide', + variables = selected_vars, + geometry = TRUE, + keep_geo_vars = TRUE, + ... + ) + )) # Format output if (geo_small == 'county') { @@ -170,11 +170,11 @@ gini <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), block.group = gsub('[^0-9\\.]', '', block.group) + tract = gsub('[^0-9\\.]', '', tract), cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -202,6 +202,27 @@ gini <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -241,7 +262,7 @@ gini <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -269,121 +290,116 @@ gini <- function(geo_large = 'county', out_dat <- out_dat %>% dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) } - - # Compute G for race or ethnicity inequality - ## From Gini (1921) https://doi.org/10.2307/2223319 - ## G = \sum_{n}^{i=1}\sum_{n}^{j=1}\left [ t_{i}t_{j}\left| p_{i}-p_{j}\right| /2T^{2}P(1-P)\right ] - ## Where: - ## t_{i} is the total population of area i - ## t_{j} is the total population of area j - ## p_{i} is the proportion of the subgroup population of area i - ## p_{j} is the proportion of the subgroup population of area j - ## T is the total population of all smaller geographical units - ## P is the proportion of the subgroup population of all smaller geographical units - - ## Compute - out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = g_fun, omit_NAs = omit_NAs) %>% - utils::stack(.) %>% - dplyr::mutate(G_re = values, oid = ind) %>% - dplyr::select(G_re, oid) - # Warning for missingness of census characteristics - missingYN <- out_dat[, c('G_incE', 'TotalPopE', in_subgroup)] - names(missingYN) <- out_names - missingYN <- missingYN %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') - ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - } - - # Format output - if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, G_re) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, G_re) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, state, county, tract, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract,G_re) %>% - .[.$GEOID != 'NANA',] - } - if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, cbsa, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, G_re) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, csa, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, G_re) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) - } - if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% - dplyr::select(oid, metro, G_re) %>% - unique(.) %>% - dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, G_re) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + # Compute G for race or ethnicity inequality + ## From Gini (1921) https://doi.org/10.2307/2223319 + ## G = \sum_{n}^{i=1}\sum_{n}^{j=1}\left [ t_{i}t_{j}\left| p_{i}-p_{j}\right| /2T^{2}P(1-P)\right ] + ## Where: + ## t_{i} is the total population of area i + ## t_{j} is the total population of area j + ## p_{i} is the proportion of the subgroup population of area i + ## p_{j} is the proportion of the subgroup population of area j + ## T is the total population of all smaller geographical units + ## P is the proportion of the subgroup population of all smaller geographical units + + ## Compute + out_tmp <- out_dat %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = g_fun, omit_NAs = omit_NAs) %>% + utils::stack(.) %>% + dplyr::mutate(G_re = values, oid = ind) %>% + dplyr::select(G_re, oid) + + # Warning for missingness of census characteristics + missingYN <- out_dat[, c('G_incE', 'TotalPopE', in_subgroup)] + names(missingYN) <- out_names + missingYN <- missingYN %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - + } + + # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) + if (geo_large == 'state') { out <- out %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out_dat <- out_dat %>% - dplyr::rename(G_inc = G_incE) %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - - out <- list(g = out, g_data = out_dat, missing = missingYN) + dplyr::select(oid, state, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, G_re) + } + if (geo_large == 'county') { + out <- out %>% + dplyr::select(oid, state, county, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, G_re) + } + if (geo_large == 'tract') { + out <- out %>% + dplyr::select(oid, state, county, tract, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, state, county, tract,G_re) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, G_re) + } + if (geo_large == 'cbsa') { + out <- out %>% + dplyr::select(oid, cbsa, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, cbsa, G_re) + } + if (geo_large == 'csa') { + out <- out %>% + dplyr::select(oid, csa, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, csa, G_re) + } + if (geo_large == 'metro') { + out <- out %>% + dplyr::select(oid, metro, G_re) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, metro, G_re) + } + + out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out_dat <- out_dat %>% + dplyr::rename(G_inc = G_incE) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() + + out <- list(g = out, g_data = out_dat, missing = missingYN) return(out) } diff --git a/R/globals.R b/R/globals.R index fae714c..e1dceaa 100644 --- a/R/globals.R +++ b/R/globals.R @@ -118,6 +118,7 @@ globalVariables( 'STATEFP', 'COUNTYFP', 'TRACTCE', + 'place', 'cbsa', 'csa', 'metro', @@ -247,7 +248,9 @@ globalVariables( 'values', 'ind', 'oid', - 'block.group', + 'cbg', + 'RI', + 'EI', 'V', 'LQ', 'LExIs', @@ -261,6 +264,10 @@ globalVariables( 'G_re', 'xPx_star', 'xPy_star', - 'H' + 'H', + 'ACE', + 'C', + 'd', + 'crs' ) ) diff --git a/R/hoover.R b/R/hoover.R index a36b6ec..c893d02 100644 --- a/R/hoover.R +++ b/R/hoover.R @@ -1,9 +1,9 @@ -#' Delta based on Hoover (1941) and Duncan et al. (1961) +#' Delta based on Hoover (1941) and Duncan, Cuzzort, & Duncan (1961) #' #' Compute the aspatial Delta (Hoover) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Delta (\emph{DEL}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Hoover (1941) \doi{10.1017/S0022050700052980} and Duncan, Cuzzort, and Duncan (1961; LC:60007089). This function provides the computation of \emph{DEL} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' \emph{DEL} is a measure of the proportion of members of one subgroup(s) residing in geographic units with above average density of members of the subgroup(s). The index provides the proportion of a subgroup population that would have to move across geographic units to achieve a uniform density. \emph{DEL} can range in value from 0 to 1. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{DEL} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{DEL} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{DEL} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{DEL} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{DEL} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{DEL} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -87,8 +87,8 @@ hoover <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -169,11 +169,11 @@ hoover <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), block.group = gsub('[^0-9\\.]', '', block.group) + tract = gsub('[^0-9\\.]', '', tract), cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -204,6 +204,27 @@ hoover <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -243,7 +264,7 @@ hoover <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -283,7 +304,8 @@ hoover <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = del_fun, omit_NAs = omit_NAs) %>% utils::stack(.) %>% dplyr::mutate(DEL = values, oid = ind) %>% @@ -309,14 +331,14 @@ hoover <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, DEL) %>% - .[.$GEOID != 'NANA', ] + dplyr::select(GEOID, state, DEL) } if (geo_large == 'county') { out <- out_dat %>% @@ -324,8 +346,7 @@ hoover <- function(geo_large = 'county', dplyr::select(oid, state, county, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, DEL) %>% - .[.$GEOID != 'NANA', ] + dplyr::select(GEOID, state, county, DEL) } if (geo_large == 'tract') { out <- out_dat %>% @@ -333,8 +354,15 @@ hoover <- function(geo_large = 'county', dplyr::select(oid, state, county, tract, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, DEL) %>% - .[.$GEOID != 'NANA', ] + dplyr::select(GEOID, state, county, tract, DEL) + } + if (geo_large == 'place') { + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + dplyr::select(oid, place, DEL) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, DEL) } if (geo_large == 'cbsa') { out <- out_dat %>% @@ -342,10 +370,7 @@ hoover <- function(geo_large = 'county', dplyr::select(oid, cbsa, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, DEL) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, DEL) } if (geo_large == 'csa') { out <- out_dat %>% @@ -353,10 +378,7 @@ hoover <- function(geo_large = 'county', dplyr::select(oid, csa, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, DEL) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, DEL) } if (geo_large == 'metro') { out <- out_dat %>% @@ -364,13 +386,13 @@ hoover <- function(geo_large = 'county', dplyr::select(oid, metro, DEL) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, DEL) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, DEL) } out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/R/james_taeuber.R b/R/james_taeuber.R index 1fed059..6245231 100644 --- a/R/james_taeuber.R +++ b/R/james_taeuber.R @@ -3,7 +3,7 @@ #' Compute the aspatial Dissimilarity Index (James & Taeuber) of selected racial or ethnic subgroup(s) and U.S. geographies #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Dissimilarity Index (\emph{D}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on James & Taeuber (1985) \doi{10.2307/270845}. This function provides the computation of \emph{D} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,8 +40,8 @@ #' #' \emph{D} is a measure of the evenness of racial or ethnic residential segregation when comparing smaller geographical units to larger ones within which the smaller geographical units are located. \emph{D} can range in value from 0 to 1 and represents the proportion of racial or ethnic subgroup members that would have to change their area of residence to achieve an even distribution within the larger geographical area under conditions of maximum segregation. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. -#' +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. +#' #' @return An object of class 'list'. This is a named list with the following components: #' #' \describe{ @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -66,7 +66,7 @@ #' \dontrun{ #' # Wrapped in \dontrun{} because these examples require a Census API key. #' -#' # Dissimilarity Index (James & Taeuber) +#' # Dissimilarity Index (James & Taeuber) #' ## of Black populations #' ## of census tracts within counties within Georgia, U.S.A., counties (2020) #' james_taeuber( @@ -86,10 +86,10 @@ james_taeuber <- function(geo_large = 'county', omit_NAs = TRUE, quiet = FALSE, ...) { - # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, + choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -163,29 +163,35 @@ james_taeuber <- function(geo_large = 'county', # Format output if (geo_small == 'county') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('county', 'state'), sep = ',') + tidyr::separate(NAME.y, + into = c('county', 'state'), + sep = ',') } if (geo_small == 'tract') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, + into = c('tract', 'county', 'state'), + sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate( + NAME.y, + into = c('cbg', 'tract', 'county', 'state'), + sep = ',' + ) %>% dplyr::mutate( tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) + cbg = gsub('[^0-9\\.]', '', cbg) ) } # Grouping IDs for D computation if (geo_large == 'state') { out_dat <- out_dat %>% - dplyr::mutate( - oid = STATEFP, - state = stringr::str_trim(state) - ) %>% + dplyr::mutate(oid = STATEFP, + state = stringr::str_trim(state)) %>% sf::st_drop_geometry() } if (geo_large == 'tract') { @@ -206,61 +212,125 @@ james_taeuber <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state) + ))) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward - lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) + lgeom <- + suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% dplyr::mutate( - oid = lapply(wlgeom, function(x) { + oid = lapply(wlgeom, function(x) { tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist(), - cbsa = lapply(wlgeom, function(x) { + cbsa = lapply(wlgeom, function(x) { tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist() - ) %>% + ) %>% sf::st_drop_geometry() } if (geo_large == 'csa') { stopifnot(is.numeric(year), year >= 2011) # CSAs only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) + lgeom <- + suppressMessages(suppressWarnings(tigris::combined_statistical_areas(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% dplyr::mutate( - oid = lapply(wlgeom, function(x) { + oid = lapply(wlgeom, function(x) { tmp <- lgeom[x, 2] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist(), - csa = lapply(wlgeom, function(x) { + csa = lapply(wlgeom, function(x) { tmp <- lgeom[x, 3] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist() - ) %>% + ) %>% sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward - lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward + lgeom <- + suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% dplyr::mutate( - oid = lapply(wlgeom, function(x) { + oid = lapply(wlgeom, function(x) { tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist(), - metro = lapply(wlgeom, function(x) { + metro = lapply(wlgeom, function(x) { tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() - lapply(tmp, function(x) { if (length(x) == 0) NA else x }) - }) %>% + lapply(tmp, function(x) { + if (length(x) == 0) + NA + else + x + }) + }) %>% unlist() - ) %>% + ) %>% sf::st_drop_geometry() } @@ -273,25 +343,24 @@ james_taeuber <- function(geo_large = 'county', out_dat <- out_dat %>% dplyr::mutate(subgroup = rowSums(.[, in_subgroup])) } - + # Compute D ## From James & Taeuber (1985) https://doi.org/10.2307/270845 ## D = \frac{\sum_{n}^{i=1}t_{i}\left|p_{i}-P\right|}{2TP(1-P)} ## Where for i smaller geographies: - ## t_{i} is the total population of area i + ## t_{i} is the total population of area i ## p_{i} is the proportion of the subgroup population of area i ## T is the total population of all smaller geographical units ## P is the proportion of the subgroup population of all smaller geographical units ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = djt_fun, omit_NAs = omit_NAs) %>% utils::stack(.) %>% - dplyr::mutate( - D = values, - oid = ind - ) %>% + dplyr::mutate(D = values, + oid = ind) %>% dplyr::select(D, oid) # Warning for missingness of census characteristics @@ -307,7 +376,9 @@ james_taeuber <- function(geo_large = 'county', dplyr::summarise( total = dplyr::n(), n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + percent_missing = paste0(round(mean(is.na( + val + )) * 100, 2), ' %') ) if (quiet == FALSE) { @@ -318,68 +389,62 @@ james_taeuber <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, D) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, D) } if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, D) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, D) } if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, tract, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, D) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, tract, D) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, D) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, D) } if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, cbsa, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, D) } if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, csa, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, D) } if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, metro, D) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, D) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, D) } out <- out %>% + .[.$GEOID != 'NANA',] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() @@ -387,7 +452,9 @@ james_taeuber <- function(geo_large = 'county', dplyr::arrange(GEOID) %>% dplyr::as_tibble() - out <- list(d = out, d_data = out_dat, missing = missingYN) + out <- list(d = out, + d_data = out_dat, + missing = missingYN) return(out) } diff --git a/R/lieberson.R b/R/lieberson.R index ea23e19..6139a5c 100644 --- a/R/lieberson.R +++ b/R/lieberson.R @@ -3,7 +3,7 @@ #' Compute the aspatial Isolation Index (Lieberson) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Isolation Index (_xPx\*_) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and Bell (1954) \doi{10.2307/2574118}. This function provides the computation of _xPx\*_ for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' _xPx\*_ is some measure of the probability that a member of one subgroup(s) will meet or interact with a member of their subgroup(s) with higher values signifying higher probability of interaction (less isolation). _xPx\*_ can range in value from 0 to 1. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the _xPx\*_ value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the _xPx\*_ computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the _xPx\*_ computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the _xPx\*_ value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the _xPx\*_ computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the _xPx\*_ computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -87,8 +87,8 @@ lieberson <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -169,12 +169,12 @@ lieberson <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) + cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -205,6 +205,27 @@ lieberson <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -244,7 +265,7 @@ lieberson <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -283,7 +304,8 @@ lieberson <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = xpx_star_fun, omit_NAs = omit_NAs) %>% utils::stack(.) %>% dplyr::mutate( @@ -316,68 +338,62 @@ lieberson <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, xPx_star) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, xPx_star) } if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, xPx_star) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, xPx_star) } if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, tract, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, xPx_star) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, tract, xPx_star) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, xPx_star) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, xPx_star) } if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, cbsa, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, xPx_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, xPx_star) } if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, csa, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, xPx_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, xPx_star) } if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, metro, xPx_star) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, xPx_star) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, xPx_star) } out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/R/messer.R b/R/messer.R index f8d62ce..9dac0b8 100644 --- a/R/messer.R +++ b/R/messer.R @@ -210,7 +210,7 @@ messer <- function(geo = 'tract', ... ) )) - + if (geo == 'tract') { ndi_data <- ndi_data %>% tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% diff --git a/R/ndi-package.R b/R/ndi-package.R index 2de4f79..4974eb0 100644 --- a/R/ndi-package.R +++ b/R/ndi-package.R @@ -1,55 +1,65 @@ #' The ndi Package: Neighborhood Deprivation Indices #' -#' Computes various metrics of socio-economic deprivation and disparity in the United States based on information available from the U.S. Census Bureau. +#' Computes various indices of socioeconomic deprivation and disparity in the United States based on information available from the U.S. Census Bureau. #' -#' @details The 'ndi' package computes various metrics of socio-economic deprivation and disparity in the United States. Some metrics are considered "spatial" because they consider the values of neighboring (i.e., adjacent) census geographies in their computation, while other metrics are "aspatial" because they only consider the value within each census geography. Two types of aspatial neighborhood deprivation indices (\emph{NDI}) are available: (1) based on Messer et al. (2006) \doi{10.1007/s11524-006-9094-x} and (2) based on Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} and Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} who use variables chosen by Roux and Mair (2010) \doi{10.1111/j.1749-6632.2009.05333.x}. Both are a decomposition of multiple demographic characteristics from the U.S. Census Bureau American Community Survey 5-year estimates (ACS-5; 2006-2010 onward). Using data from the ACS-5 (2005-2009 onward), the package can also compute the (1) spatial Racial Isolation Index (\emph{RI}) based on Anthopolos et al. (2011) \doi{10.1016/j.sste.2011.06.002}, (2) spatial Educational Isolation Index (\emph{EI}) based on Bravo et al. (2021) \doi{10.3390/ijerph18179384}, (3) aspatial Index of Concentration at the Extremes (\emph{ICE}) based on Feldman et al. (2015) \doi{10.1136/jech-2015-205728} and Krieger et al. (2016) \doi{10.2105/AJPH.2015.302955}, (4) aspatial racial or ethnic Dissimilarity Index (\emph{DI}) based on Duncan & Duncan (1955) \doi{10.2307/2088328}, (5) aspatial income or racial or ethnic Atkinson Index (\emph{AI}) based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}, (6) aspatial racial or ethnic Isolation Index (\emph{II}) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) \doi{10.2307/2574118}, (7) aspatial racial or ethnic Correlation Ratio (\emph{V}) based on Bell (1954) \doi{10.2307/2574118} and White (1986) \doi{10.2307/3644339}, (8) aspatial racial or ethnic Location Quotient (\emph{LQ}) based on Merton (1939) \doi{10.2307/2084686} and Sudano et al. (2013) \doi{10.1016/j.healthplace.2012.09.015}, (9) aspatial racial or ethnic Local Exposure and Isolation (\emph{LEx/Is}) metric based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}, (10) aspatial racial or ethnic Delta (\emph{DEL}) based on Hoover (1941) \doi{10.1017/S0022050700052980} and Duncan et al. (1961; LC:60007089), and (11) an index of spatial proximity (\emph{SP}) based on White (1986) \doi{10.2307/3644339} and Blau (1977; ISBN-13:978-0-029-03660-0). Also using data from the ACS-5 (2005-2009 onward), the package can retrieve the aspatial Gini Index (\emph{G}) based on Gini (1921) \doi{10.2307/2223319}. +#' @details The 'ndi' package computes various indices of socioeconomic deprivation and disparity in the United States. Some indices are considered "spatial" because they consider the values of neighboring (i.e., adjacent) census geographies in their computation, while other indices are "aspatial" because they only consider the value within each census geography. Two types of aspatial neighborhood deprivation indices (\emph{NDI}) are available: (1) based on Messer et al. (2006) \doi{10.1007/s11524-006-9094-x} and (2) based on Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} and Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} who use variables chosen by Roux and Mair (2010) \doi{10.1111/j.1749-6632.2009.05333.x}. Both are a decomposition of multiple demographic characteristics from the U.S. Census Bureau American Community Survey 5-year estimates (ACS-5; 2006-2010 onward). Using data from the ACS-5 (2005-2009 onward), the package can also compute indices of racial or ethnic residential segregation, including but limited to those discussed in Massey & Denton (1988) \doi{10.1093/sf/67.2.281}, and additional indices of socioeconomic disparity. #' #' Key content of the 'ndi' package include:\cr #' -#' \bold{Metrics of Socio-Economic Deprivation and Disparity} +#' \strong{Neighborhood Deprivation Indices} #' -#' \code{\link{anthopolos}} Computes the spatial Racial Isolation Index (\emph{RI}) based on Anthopolos (2011) \doi{10.1016/j.sste.2011.06.002}. +#' \code{\link{messer}} Computes the aspatial Neighborhood Deprivation Index (\emph{NDI}) based on Messer et al. (2006) \doi{10.1007/s11524-006-9094-x}. +#' +#' \code{\link{powell_wiley}} Computes the aspatial Neighborhood Deprivation Index (\emph{NDI}) based on Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} and Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} who use variables chosen by Roux and Mair (2010) \doi{10.1111/j.1749-6632.2009.05333.x}. #' -#' \code{\link{atkinson}} Computes the aspatial income or racial or ethnic Atkinson Index (\emph{A}) based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}. +#' \strong{Indices of Racial or Ethnic Residential Segregation} #' -#' \code{\link{bell}} Computes the aspatial racial or ethnic Interaction Index (\emph{xPy\*}) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) \doi{10.2307/2574118}. +#'\code{\link{anthopolos}} Computes the spatial Racial Isolation Index (\emph{RI}) based on Anthopolos (2011) \doi{10.1016/j.sste.2011.06.002}. #' -#' \code{\link{bemanian_beyer}} Computes the aspatial racial or ethnic Local Exposure and Isolation (\emph{LEx/Is}) metric based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. +#' \code{\link{atkinson}} Computes the aspatial Atkinson Index (\emph{A}) based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}. #' -#' \code{\link{bravo}} Computes the spatial Educational Isolation Index (\emph{EI}) based on Bravo (2021) \doi{10.3390/ijerph18179384}. +#' \code{\link{bell}} Computes the aspatial Interaction Index (\emph{xPy\*}) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) \doi{10.2307/2574118}. #' -#' \code{\link{duncan}} Computes the aspatial racial or ethnic Dissimilarity Index (\emph{D}) based on Duncan & Duncan (1955) \doi{10.2307/2088328}. +#' \code{\link{bemanian_beyer}} Computes the aspatial Local Exposure and Isolation (\emph{LEx/Is}) based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. #' -#' \code{\link{gini}} Computes the aspatial Gini Index (\emph{G}) of racial or ethnic inequality and retrieves the aspatial Gini Index (\emph{G}) of income inequality based on Gini (1921) \doi{10.2307/2223319}. +#' \code{\link{duncan}} Computes the aspatial Dissimilarity Index (\emph{D}) based on Duncan & Duncan (1955) \doi{10.2307/2088328}. #' -#' \code{\link{hoover}} Computes the aspatial racial or ethnic Delta (\emph{DEL}) based on Hoover (1941) \doi{doi:10.1017/S0022050700052980} and Duncan et al. (1961; LC:60007089). +#' \code{\link{duncan_cuzzort}} Computes the aspatial Absolute Centralization (\emph{ACE}) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and Massey & Denton (1988) \doi{10.1093/sf/67.2.281}. #' -#' \code{\link{james_taeuber}} Computes the aspatial racial or ethnic Dissimilarity Index (\emph{D}) based on James & Taeuber (1985) \doi{10.2307/270845}. +#' \code{\link{gini}} Computes the aspatial Gini Index (\emph{G}) based on Gini (1921) \doi{10.2307/2223319}. +#' +#' \code{\link{hoover}} Computes the aspatial Delta (\emph{DEL}) based on Hoover (1941) \doi{doi:10.1017/S0022050700052980} and Duncan, Cuzzort, & Duncan (1961; LC:60007089). +#' +#' \code{\link{james_taeuber}} Computes the aspatial Dissimilarity Index (\emph{D}) based on James & Taeuber (1985) \doi{10.2307/270845}. #' #' \code{\link{krieger}} Computes the aspatial Index of Concentration at the Extremes based on Feldman et al. (2015) \doi{10.1136/jech-2015-205728} and Krieger et al. (2016) \doi{10.2105/AJPH.2015.302955}. #' -#' \code{\link{lieberson}} Computes the aspatial racial or ethnic Isolation Index (\emph{xPx\*}) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and Bell (1954) \doi{10.2307/2574118}. +#' \code{\link{lieberson}} Computes the aspatial Isolation Index (\emph{xPx\*}) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and Bell (1954) \doi{10.2307/2574118}. #' -#' \code{\link{messer}} Computes the aspatial Neighborhood Deprivation Index (\emph{NDI}) based on Messer et al. (2006) \doi{10.1007/s11524-006-9094-x}. +#' \code{\link{sudano}} Computes the aspatial Location Quotient (\emph{LQ}) based on Merton (1939) \doi{10.2307/2084686} and Sudano et al. (2013) \doi{10.1016/j.healthplace.2012.09.015}. #' -#' \code{\link{powell_wiley}} Computes the aspatial Neighborhood Deprivation Index (\emph{NDI}) based on Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} and Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} who use variables chosen by Roux and Mair (2010) \doi{10.1111/j.1749-6632.2009.05333.x}. +#' \code{\link{theil}} Computes the aspatial Entropy (\emph{H}) based on Theil (1972; ISBN-13:978-0-444-10378-9) and Theil & Finizza (1971) \doi{110.1080/0022250X.1971.9989795}. #' -#' \code{\link{sudano}} Computes the aspatial racial or ethnic Location Quotient (\emph{LQ}) based on Merton (1939) \doi{10.2307/2084686} and Sudano et al. (2013) \doi{10.1016/j.healthplace.2012.09.015}. +#' \code{\link{white}} Computes the aspatial Correlation Ratio (\emph{V}) based on Bell (1954) \doi{10.2307/2574118} and White (1986) \doi{10.2307/3644339}. #' -#' \code{\link{theil}} Computes the aspatial racial or ethnic Entropy (\emph{H}) based on Theil (1972; ISBN-13:978-0-444-10378-9) and Theil & Finizza (1971) \doi{110.1080/0022250X.1971.9989795}. +#' \code{\link{white_blau}} Computes an index of spatial proximity (\emph{SP}) based on White (1986) \doi{10.2307/3644339} and Blau (1977; ISBN-13:978-0-029-03660-0). #' -#' \code{\link{white}} Computes the aspatial racial or ethnic Correlation Ratio (\emph{V}) based on Bell (1954) \doi{10.2307/2574118} and White (1986) \doi{10.2307/3644339}. +#' \strong{Additional Indices of Socioeconomic Disparity} #' -#' \code{\link{white_blau}} Computes an index of spatial proximity (\emph{SP}) based on White (1986) \doi{10.2307/3644339} and Blau (1977; ISBN-13:978-0-029-03660-0). +#' \code{\link{atkinson}} Also computes the aspatial Atkinson Index (\emph{A}) of income based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}. +#' +#' \code{\link{bravo}} Computes the spatial Educational Isolation Index (\emph{EI}) based on Bravo (2021) \doi{10.3390/ijerph18179384}. +#' +#' \code{\link{gini}} Also retrieves the aspatial Gini Index (\emph{G}) of income inequality based on Gini (1921) \doi{10.2307/2223319}. #' -#' \bold{Pre-formatted U.S. Census Data} +#' \strong{Pre-formatted U.S. Census Data} #' #' \code{\link{DCtracts2020}} A sample dataset containing information about U.S. Census American Community Survey 5-year estimate data for the District of Columbia census tracts (2020). The data are obtained from the \code{\link[tidycensus]{get_acs}} function and formatted for the \code{\link{messer}} and \code{\link{powell_wiley}} functions input. #' #' @name ndi-package #' @aliases ndi-package ndi #' -#' @section Dependencies: The 'ndi' package relies heavily upon \code{\link{tidycensus}} to retrieve data from the U.S. Census Bureau American Community Survey five-year estimates and the \code{\link{psych}} for computing the neighborhood deprivation indices. The \code{\link{messer}} function builds upon code developed by Hruska et al. (2022) \doi{10.17605/OSF.IO/M2SAV} by fictionalizing, adding the percent of households earning <$30,000 per year to the NDI computation, and providing the option for computing the ACS-5 2006-2010 NDI values. There is no code companion to compute NDI included in Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} or Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002}, but the package author worked directly with the Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} authors to replicate their SAS code in R. The spatial metrics RI and EI rely on the \code{\link{sf}} and \code{\link{Matrix}} packages to compute the geospatial adjacency matrix between census geographies. Internal function to calculate AI is based on \code{\link[DescTools]{Atkinson}} function. There is no code companion to compute RI, EI, DI, II, V, LQ, or LEx/Is included in Anthopolos et al. (2011) \doi{10.1016/j.sste.2011.06.002}, Bravo et al. (2021) \doi{10.3390/ijerph18179384}, Duncan & Duncan (1955) \doi{10.2307/2088328}, Bell (1954) \doi{10.2307/2574118}, White (1986) \doi{10.2307/3644339}, Sudano et al. (2013) \doi{10.1016/j.healthplace.2012.09.015}, or Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}, respectively. +#' @section Dependencies: The 'ndi' package relies heavily upon \code{\link{tidycensus}} to retrieve data from the U.S. Census Bureau American Community Survey five-year estimates and the \code{\link{psych}} for computing the neighborhood deprivation indices. The \code{\link{messer}} function builds upon code developed by Hruska et al. (2022) \doi{10.17605/OSF.IO/M2SAV} by fictionalizing, adding the percent of households earning <$30,000 per year to the \emph{NDI} computation, and providing the option for computing the ACS-5 2006-2010 \emph{NDI} values. There is no code companion to compute \emph{NDI} included in Andrews et al. (2020) \doi{10.1080/17445647.2020.1750066} or Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002}, but the package author worked directly with the Slotman et al. (2022) \doi{10.1016/j.dib.2022.108002} authors to replicate their SAS code in \strong{R}. The indices of racial or ethnic residential segregation rely heavily on the \code{\link{sf}} and \code{\link{tigris}} packages to assign the smaller geographical units within larger geographical units and, occasionally, perform geospatial projection for distance-based metrics. The computation of \emph{RI} and \emph{EI} also relies on the \code{\link{Matrix}} package to compute the geospatial adjacency matrix between census geographies. Internal function to calculate \emph{AI} using the Hölder mean is based on \code{\link[DescTools]{Atkinson}} function. #' #' @author Ian D. Buller\cr \emph{DLH Corporation (formerly Social & Scientific Systems, Inc.), Bethesda, Maryland, USA (current); Occupational and Environmental Epidemiology Branch, Division of Cancer Epidemiology and Genetics, National Cancer Institute, National Institutes of Health, Rockville, Maryland, USA (original).} \cr #' @@ -63,12 +73,12 @@ #' @importFrom MASS ginv #' @importFrom Matrix sparseMatrix #' @importFrom psych alpha principal -#' @importFrom sf st_drop_geometry st_geometry st_intersects st_within +#' @importFrom sf st_drop_geometry st_geometry st_intersects st_transform st_within #' @importFrom stats complete.cases cor cov2cor loadings median na.omit promax quantile sd setNames #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas counties metro_divisions places states tracts #' @importFrom units drop_units set_units #' @importFrom utils stack NULL diff --git a/R/powell_wiley.R b/R/powell_wiley.R index 8708289..d6b6da6 100644 --- a/R/powell_wiley.R +++ b/R/powell_wiley.R @@ -80,388 +80,388 @@ powell_wiley <- function(geo = 'tract', df = NULL, ...) { - # Check arguments - if (!is.null(df) & - !inherits(df, c('tbl_df', 'tbl', 'data.frame'))) { - stop("'df' must be class 'data.frame' or 'tbl'") - } - - if (is.null(df)) { - # Check additional arguments - match.arg(geo, choices = c('county', 'tract')) - stopifnot(is.numeric(year), year >= 2010) # all variables available 2010 onward - - # Select census variables - vars <- c( - MedHHInc = 'B19013_001', - PctRecvIDR_num = 'B19054_002', - PctRecvIDR_den = 'B19054_001', - PctPubAsst_num = 'B19058_002', - PctPubAsst_den = 'B19058_001', - MedHomeVal = 'B25077_001', - PctMgmtBusScArti_num = 'C24060_002', - PctMgmtBusScArti_den = 'C24060_001', - PctFemHeadKids_num1 = 'B11005_007', - PctFemHeadKids_num2 = 'B11005_010', - PctFemHeadKids_den = 'B11005_001', - PctOwnerOcc = 'DP04_0046P', - PctNoPhone = 'DP04_0075P', - PctNComPlmb = 'DP04_0073P', - PctEduc_num25upHS = 'S1501_C01_009', - PctEduc_num25upSC = 'S1501_C01_010', - PctEduc_num25upAD = 'S1501_C01_011', - PctEduc_num25upBD = 'S1501_C01_012', - PctEduc_num25upGD = 'S1501_C01_013', - PctEduc_den25up = 'S1501_C01_006', - PctFamBelowPov = 'S1702_C02_001', - PctUnempl = 'S2301_C04_001', - TotalPopulation = 'B01001_001' - ) - - # Updated census variable definition(s) - if (year < 2015) { - vars <- c(vars[-13], PctNoPhone = 'DP04_0074P') - } - - # Acquire NDI variables - ndi_data <- suppressMessages(suppressWarnings( - tidycensus::get_acs( - geography = geo, - year = year, - output = 'wide', - variables = vars, - ... - ) - )) - - - if (geo == 'tract') { - ndi_data <- ndi_data %>% - tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% - dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) - } else { - ndi_data <- ndi_data %>% - tidyr::separate(NAME, into = c('county', 'state'), sep = ',') - } - - ndi_data <- ndi_data %>% - dplyr::mutate( - MedHHInc = MedHHIncE, - PctRecvIDR = PctRecvIDR_numE / PctRecvIDR_denE * 100, - PctPubAsst = PctPubAsst_numE / PctPubAsst_denE * 100, - MedHomeVal = MedHomeValE, - PctMgmtBusScArti = PctMgmtBusScArti_numE / PctMgmtBusScArti_denE * 100, - PctFemHeadKids = (PctFemHeadKids_num1E + PctFemHeadKids_num2E) / - PctFemHeadKids_denE * 100, - PctOwnerOcc = PctOwnerOccE, - PctNoPhone = PctNoPhoneE, - PctNComPlmb = PctNComPlmbE, - PctEducHSPlus = ( - PctEduc_num25upHSE + PctEduc_num25upSCE + PctEduc_num25upADE + PctEduc_num25upBDE + - PctEduc_num25upGDE - ) / PctEduc_den25upE * 100, - PctEducBchPlus = (PctEduc_num25upBDE + PctEduc_num25upGDE) / PctEduc_den25upE * 100, - PctFamBelowPov = PctFamBelowPovE, - PctUnempl = PctUnemplE, - TotalPop = TotalPopulationE - ) %>% - # Log transform median household income and median home value - # Reverse code percentages so that higher values represent more deprivation - # Round percentages to 1 decimal place - dplyr::mutate( - logMedHHInc = log(MedHHInc), - logMedHomeVal = log(MedHomeVal), - PctNoIDR = 100 - PctRecvIDR, - PctWorkClass = 100 - PctMgmtBusScArti, - PctNotOwnerOcc = 100 - PctOwnerOcc, - PctEducLTHS = 100 - PctEducHSPlus, - PctEducLTBch = 100 - PctEducBchPlus - ) %>% - # Z-standardize the percentages - dplyr::mutate( - PctNoIDRZ = scale(PctNoIDR), - PctPubAsstZ = scale(PctPubAsst), - PctWorkClassZ = scale(PctWorkClass), - PctFemHeadKidsZ = scale(PctFemHeadKids), - PctNotOwnerOccZ = scale(PctNotOwnerOcc), - PctNoPhoneZ = scale(PctNoPhone), - PctNComPlmbZ = scale(PctNComPlmb), - PctEducLTHSZ = scale(PctEducLTHS), - PctEducLTBchZ = scale(PctEducLTBch), - PctFamBelowPovZ = scale(PctFamBelowPov), - PctUnemplZ = scale(PctUnempl) - ) - - # generate NDI - ndi_data_pca <- ndi_data %>% - dplyr::select( - logMedHHInc, - PctNoIDRZ, - PctPubAsstZ, - logMedHomeVal, - PctWorkClassZ, - PctFemHeadKidsZ, - PctNotOwnerOccZ, - PctNoPhoneZ, - PctNComPlmbZ, - PctEducLTHSZ, - PctEducLTBchZ, - PctFamBelowPovZ, - PctUnemplZ - ) - } else { - # If inputing pre-formatted data: - ## rename first and second features (columns) with name to match above - colnames(df)[1:2] <- c('GEOID', 'TotalPop') - ndi_data <- dplyr::as_tibble(df) - ## omit the first two features (columns) typically an ID (e.g., GEOID or FIPS) and TotalPop - ndi_data_pca <- ndi_data[,-c(1:2)] - } - # Run a factor analysis using Promax (oblique) rotation and a minimum Eigenvalue of 1 - nfa <- eigen(stats::cor(ndi_data_pca, use = 'complete.obs')) - nfa <- sum(nfa$values > 1) # count of factors with a minimum Eigenvalue of 1 - fit <- psych::principal(ndi_data_pca, nfactors = nfa, rotate = 'none') - fit_rotate <- stats::promax(stats::loadings(fit), m = 3) - - # Calculate the factors using only variables with an absolute loading score > 0.4 for the first factor - ## If number of factors > 2, use structure matrix, else pattern matrix - if (nfa > 1) { - P_mat <- matrix(stats::loadings(fit_rotate), nrow = 13, ncol = nfa) - - # Structure matrix (S_mat) from under-the-hood of the psych::principal() function - rot.mat <- fit_rotate$rotmat # rotation matrix - ui <- solve(rot.mat) - Phi <- cov2cor(ui %*% t(ui)) # interfactor correlation - S_mat <- P_mat %*% Phi # pattern matrix multiplied by interfactor correlation - - } else { - P_mat <- matrix(fit_rotate, nrow = 13, ncol = 1) - Phi <- 1 - S_mat <- P_mat - } - - ## Variable correlation matrix (R_mat) - R_mat <- as.matrix(cor(ndi_data_pca[complete.cases(ndi_data_pca),])) - - ## standardized score coefficients or weight matrix (B_mat) - B_mat <- solve(R_mat, S_mat) + # Check arguments + if (!is.null(df) & + !inherits(df, c('tbl_df', 'tbl', 'data.frame'))) { + stop("'df' must be class 'data.frame' or 'tbl'") + } + + if (is.null(df)) { + # Check additional arguments + match.arg(geo, choices = c('county', 'tract')) + stopifnot(is.numeric(year), year >= 2010) # all variables available 2010 onward - # Additional PCA Information - fit_rotate$rotation <- 'promax' - fit_rotate$Phi <- Phi - fit_rotate$Structure <- S_mat + # Select census variables + vars <- c( + MedHHInc = 'B19013_001', + PctRecvIDR_num = 'B19054_002', + PctRecvIDR_den = 'B19054_001', + PctPubAsst_num = 'B19058_002', + PctPubAsst_den = 'B19058_001', + MedHomeVal = 'B25077_001', + PctMgmtBusScArti_num = 'C24060_002', + PctMgmtBusScArti_den = 'C24060_001', + PctFemHeadKids_num1 = 'B11005_007', + PctFemHeadKids_num2 = 'B11005_010', + PctFemHeadKids_den = 'B11005_001', + PctOwnerOcc = 'DP04_0046P', + PctNoPhone = 'DP04_0075P', + PctNComPlmb = 'DP04_0073P', + PctEduc_num25upHS = 'S1501_C01_009', + PctEduc_num25upSC = 'S1501_C01_010', + PctEduc_num25upAD = 'S1501_C01_011', + PctEduc_num25upBD = 'S1501_C01_012', + PctEduc_num25upGD = 'S1501_C01_013', + PctEduc_den25up = 'S1501_C01_006', + PctFamBelowPov = 'S1702_C02_001', + PctUnempl = 'S2301_C04_001', + TotalPopulation = 'B01001_001' + ) - if (nfa > 1) { - fit_rotate$communality <- rowSums(P_mat ^ 2) - } else { - fit_rotate$communality <- P_mat ^ 2 + # Updated census variable definition(s) + if (year < 2015) { + vars <- c(vars[-13], PctNoPhone = 'DP04_0074P') } - fit_rotate$uniqueness <- diag(R_mat) - fit_rotate$communality - if (nfa > 1) { - vx <- colSums(P_mat ^ 2) - } else { - vx <- sum(P_mat ^ 2) - } + # Acquire NDI variables + ndi_data <- suppressMessages(suppressWarnings( + tidycensus::get_acs( + geography = geo, + year = year, + output = 'wide', + variables = vars, + ... + ) + )) - vtotal <- sum(fit_rotate$communality + fit_rotate$uniqueness) - vx <- diag(Phi %*% t(P_mat) %*% P_mat) - names(vx) <- colnames(loadings) - varex <- rbind(`SS loadings` = vx) - varex <- rbind(varex, `Proportion Var` = vx / vtotal) - if (nfa > 1) { - varex <- rbind(varex, `Cumulative Var` = cumsum(vx / vtotal)) - varex <- rbind(varex, `Proportion Explained` = vx / sum(vx)) - varex <- rbind(varex, `Cumulative Proportion` = cumsum(vx / sum(vx))) - } - fit_rotate$Vaccounted <- varex - if (imp == TRUE) { - ndi_data_scrs <- as.matrix(ndi_data_pca) - miss <- which(is.na(ndi_data_scrs), arr.ind = TRUE) - item.med <- apply(ndi_data_scrs, 2, stats::median, na.rm = TRUE) - ndi_data_scrs[miss] <- item.med[miss[, 2]] + if (geo == 'tract') { + ndi_data <- ndi_data %>% + tidyr::separate(NAME, into = c('tract', 'county', 'state'), sep = ',') %>% + dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } else { - ndi_data_scrs <- ndi_data_pca + ndi_data <- ndi_data %>% + tidyr::separate(NAME, into = c('county', 'state'), sep = ',') } - scrs <- as.matrix( - scale(ndi_data_scrs[complete.cases(ndi_data_scrs), abs(S_mat[, 1]) > 0.4]) - ) %*% B_mat[abs(S_mat[, 1]) > 0.4, 1] + ndi_data <- ndi_data %>% + dplyr::mutate( + MedHHInc = MedHHIncE, + PctRecvIDR = PctRecvIDR_numE / PctRecvIDR_denE * 100, + PctPubAsst = PctPubAsst_numE / PctPubAsst_denE * 100, + MedHomeVal = MedHomeValE, + PctMgmtBusScArti = PctMgmtBusScArti_numE / PctMgmtBusScArti_denE * 100, + PctFemHeadKids = (PctFemHeadKids_num1E + PctFemHeadKids_num2E) / + PctFemHeadKids_denE * 100, + PctOwnerOcc = PctOwnerOccE, + PctNoPhone = PctNoPhoneE, + PctNComPlmb = PctNComPlmbE, + PctEducHSPlus = ( + PctEduc_num25upHSE + PctEduc_num25upSCE + PctEduc_num25upADE + PctEduc_num25upBDE + + PctEduc_num25upGDE + ) / PctEduc_den25upE * 100, + PctEducBchPlus = (PctEduc_num25upBDE + PctEduc_num25upGDE) / PctEduc_den25upE * 100, + PctFamBelowPov = PctFamBelowPovE, + PctUnempl = PctUnemplE, + TotalPop = TotalPopulationE + ) %>% + # Log transform median household income and median home value + # Reverse code percentages so that higher values represent more deprivation + # Round percentages to 1 decimal place + dplyr::mutate( + logMedHHInc = log(MedHHInc), + logMedHomeVal = log(MedHomeVal), + PctNoIDR = 100 - PctRecvIDR, + PctWorkClass = 100 - PctMgmtBusScArti, + PctNotOwnerOcc = 100 - PctOwnerOcc, + PctEducLTHS = 100 - PctEducHSPlus, + PctEducLTBch = 100 - PctEducBchPlus + ) %>% + # Z-standardize the percentages + dplyr::mutate( + PctNoIDRZ = scale(PctNoIDR), + PctPubAsstZ = scale(PctPubAsst), + PctWorkClassZ = scale(PctWorkClass), + PctFemHeadKidsZ = scale(PctFemHeadKids), + PctNotOwnerOccZ = scale(PctNotOwnerOcc), + PctNoPhoneZ = scale(PctNoPhone), + PctNComPlmbZ = scale(PctNComPlmb), + PctEducLTHSZ = scale(PctEducLTHS), + PctEducLTBchZ = scale(PctEducLTBch), + PctFamBelowPovZ = scale(PctFamBelowPov), + PctUnemplZ = scale(PctUnempl) + ) - ndi_data_NA <- ndi_data[complete.cases(ndi_data_scrs),] - ndi_data_NA$NDI <- c(scrs) + # generate NDI + ndi_data_pca <- ndi_data %>% + dplyr::select( + logMedHHInc, + PctNoIDRZ, + PctPubAsstZ, + logMedHomeVal, + PctWorkClassZ, + PctFemHeadKidsZ, + PctNotOwnerOccZ, + PctNoPhoneZ, + PctNComPlmbZ, + PctEducLTHSZ, + PctEducLTBchZ, + PctFamBelowPovZ, + PctUnemplZ + ) + } else { + # If inputing pre-formatted data: + ## rename first and second features (columns) with name to match above + colnames(df)[1:2] <- c('GEOID', 'TotalPop') + ndi_data <- dplyr::as_tibble(df) + ## omit the first two features (columns) typically an ID (e.g., GEOID or FIPS) and TotalPop + ndi_data_pca <- ndi_data[,-c(1:2)] + } + # Run a factor analysis using Promax (oblique) rotation and a minimum Eigenvalue of 1 + nfa <- eigen(stats::cor(ndi_data_pca, use = 'complete.obs')) + nfa <- sum(nfa$values > 1) # count of factors with a minimum Eigenvalue of 1 + fit <- psych::principal(ndi_data_pca, nfactors = nfa, rotate = 'none') + fit_rotate <- stats::promax(stats::loadings(fit), m = 3) + + # Calculate the factors using only variables with an absolute loading score > 0.4 for the first factor + ## If number of factors > 2, use structure matrix, else pattern matrix + if (nfa > 1) { + P_mat <- matrix(stats::loadings(fit_rotate), nrow = 13, ncol = nfa) - ndi_data_NDI <- ndi_data[, c('GEOID', 'TotalPop')] %>% - dplyr::left_join(ndi_data_NA[, c('GEOID', 'NDI')], by = dplyr::join_by(GEOID)) + # Structure matrix (S_mat) from under-the-hood of the psych::principal() function + rot.mat <- fit_rotate$rotmat # rotation matrix + ui <- solve(rot.mat) + Phi <- cov2cor(ui %*% t(ui)) # interfactor correlation + S_mat <- P_mat %*% Phi # pattern matrix multiplied by interfactor correlation - # Calculate Cronbach's alpha correlation coefficient among the factors and verify values are above 0.7. - if (nfa == 1) { - crnbch <- - "Only one factor with minimum Eigenvalue of 1. Cannot calculate Cronbach's alpha." - } else { - cronbach <- suppressMessages(psych::alpha( - ndi_data_pca[, abs(S_mat[, 1]) > 0.4], - check.keys = TRUE, - na.rm = TRUE, - warnings = FALSE - )) - crnbch <- cronbach$total$std.alpha + } else { + P_mat <- matrix(fit_rotate, nrow = 13, ncol = 1) + Phi <- 1 + S_mat <- P_mat + } + + ## Variable correlation matrix (R_mat) + R_mat <- as.matrix(cor(ndi_data_pca[complete.cases(ndi_data_pca),])) + + ## standardized score coefficients or weight matrix (B_mat) + B_mat <- solve(R_mat, S_mat) + + # Additional PCA Information + fit_rotate$rotation <- 'promax' + fit_rotate$Phi <- Phi + fit_rotate$Structure <- S_mat + + if (nfa > 1) { + fit_rotate$communality <- rowSums(P_mat ^ 2) + } else { + fit_rotate$communality <- P_mat ^ 2 + } + fit_rotate$uniqueness <- diag(R_mat) - fit_rotate$communality + + if (nfa > 1) { + vx <- colSums(P_mat ^ 2) + } else { + vx <- sum(P_mat ^ 2) + } + + vtotal <- sum(fit_rotate$communality + fit_rotate$uniqueness) + vx <- diag(Phi %*% t(P_mat) %*% P_mat) + names(vx) <- colnames(loadings) + varex <- rbind(`SS loadings` = vx) + varex <- rbind(varex, `Proportion Var` = vx / vtotal) + if (nfa > 1) { + varex <- rbind(varex, `Cumulative Var` = cumsum(vx / vtotal)) + varex <- rbind(varex, `Proportion Explained` = vx / sum(vx)) + varex <- rbind(varex, `Cumulative Proportion` = cumsum(vx / sum(vx))) + } + fit_rotate$Vaccounted <- varex + + if (imp == TRUE) { + ndi_data_scrs <- as.matrix(ndi_data_pca) + miss <- which(is.na(ndi_data_scrs), arr.ind = TRUE) + item.med <- apply(ndi_data_scrs, 2, stats::median, na.rm = TRUE) + ndi_data_scrs[miss] <- item.med[miss[, 2]] + } else { + ndi_data_scrs <- ndi_data_pca + } + + scrs <- as.matrix( + scale(ndi_data_scrs[complete.cases(ndi_data_scrs), abs(S_mat[, 1]) > 0.4]) + ) %*% B_mat[abs(S_mat[, 1]) > 0.4, 1] + + ndi_data_NA <- ndi_data[complete.cases(ndi_data_scrs),] + ndi_data_NA$NDI <- c(scrs) + + ndi_data_NDI <- ndi_data[, c('GEOID', 'TotalPop')] %>% + dplyr::left_join(ndi_data_NA[, c('GEOID', 'NDI')], by = dplyr::join_by(GEOID)) + + # Calculate Cronbach's alpha correlation coefficient among the factors and verify values are above 0.7. + if (nfa == 1) { + crnbch <- + "Only one factor with minimum Eigenvalue of 1. Cannot calculate Cronbach's alpha." + } else { + cronbach <- suppressMessages(psych::alpha( + ndi_data_pca[, abs(S_mat[, 1]) > 0.4], + check.keys = TRUE, + na.rm = TRUE, + warnings = FALSE + )) + crnbch <- cronbach$total$std.alpha + } + + # Warning for missingness of census characteristics + missingYN <- ndi_data_pca %>% + tidyr::pivot_longer( + cols = dplyr::everything(), + names_to = 'variable', + values_to = 'val' + ) %>% + dplyr::group_by(variable) %>% + dplyr::summarise( + total = dplyr::n(), + n_missing = sum(is.na(val)), + percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + ) + + if (quiet == FALSE) { + # Warning for missing census data + if (sum(missingYN$n_missing) > 0) { + message('Warning: Missing census data') } - # Warning for missingness of census characteristics - missingYN <- ndi_data_pca %>% - tidyr::pivot_longer( - cols = dplyr::everything(), - names_to = 'variable', - values_to = 'val' - ) %>% - dplyr::group_by(variable) %>% - dplyr::summarise( - total = dplyr::n(), - n_missing = sum(is.na(val)), - percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') + # Warning for Cronbach's alpha < 0.7 + if (cronbach$total$std.alpha < 0.7) { + message( + "Warning: Cronbach's alpha correlation coefficient among the factors is less than 0.7." ) - - if (quiet == FALSE) { - # Warning for missing census data - if (sum(missingYN$n_missing) > 0) { - message('Warning: Missing census data') - } - - # Warning for Cronbach's alpha < 0.7 - if (cronbach$total$std.alpha < 0.7) { - message( - "Warning: Cronbach's alpha correlation coefficient among the factors is less than 0.7." - ) - } - - # Warning for proportion of variance explained by FA1 - if (fit_rotate$Vaccounted[2] < 0.50) { - message('Warning: The proportion of variance explained by PC1 is less than 0.50.') - } } - # NDI quintiles weighted by tract population - NDIQuint <- ndi_data_NDI %>% - dplyr::mutate( - NDIQuint = cut( + # Warning for proportion of variance explained by FA1 + if (fit_rotate$Vaccounted[2] < 0.50) { + message('Warning: The proportion of variance explained by PC1 is less than 0.50.') + } + } + + # NDI quintiles weighted by tract population + NDIQuint <- ndi_data_NDI %>% + dplyr::mutate( + NDIQuint = cut( + NDI * log(TotalPop), + breaks = stats::quantile( NDI * log(TotalPop), - breaks = stats::quantile( - NDI * log(TotalPop), - probs = c(0, 0.2, 0.4, 0.6, 0.8, 1), - na.rm = TRUE - ), - labels = c( - '1-Least deprivation', - '2-BelowAvg deprivation', - '3-Average deprivation', - '4-AboveAvg deprivation', - '5-Most deprivation' - ), - include.lowest = TRUE + probs = c(0, 0.2, 0.4, 0.6, 0.8, 1), + na.rm = TRUE + ), + labels = c( + '1-Least deprivation', + '2-BelowAvg deprivation', + '3-Average deprivation', + '4-AboveAvg deprivation', + '5-Most deprivation' + ), + include.lowest = TRUE + ), + NDIQuint = factor( + replace( + as.character(NDIQuint), + is.na(NDIQuint) | + is.infinite(NDIQuint), + '9-NDI not avail' ), - NDIQuint = factor( - replace( - as.character(NDIQuint), - is.na(NDIQuint) | - is.infinite(NDIQuint), - '9-NDI not avail' - ), - c(levels(NDIQuint), '9-NDI not avail') + c(levels(NDIQuint), '9-NDI not avail') + ) + ) %>% + dplyr::select(NDI, NDIQuint) + + if (is.null(df)) { + # Format output + if (round_output == TRUE) { + ndi <- cbind(ndi_data, NDIQuint) %>% + dplyr::mutate( + PctRecvIDR = round(PctRecvIDR, digits = 1), + PctPubAsst = round(PctPubAsst, digits = 1), + PctMgmtBusScArti = round(PctMgmtBusScArti, digits = 1), + PctFemHeadKids = round(PctFemHeadKids, digits = 1), + PctOwnerOcc = round(PctOwnerOcc, digits = 1), + PctNoPhone = round(PctNoPhone, digits = 1), + PctNComPlmb = round(PctNComPlmb, digits = 1), + PctEducHSPlus = round(PctEducHSPlus, digits = 1), + PctEducBchPlus = round(PctEducBchPlus, digits = 1), + PctFamBelowPov = round(PctFamBelowPov, digits = 1), + PctUnempl = round(PctUnempl, digits = 1) ) - ) %>% - dplyr::select(NDI, NDIQuint) + } else { + ndi <- cbind(ndi_data, NDIQuint) + } - if (is.null(df)) { - # Format output - if (round_output == TRUE) { - ndi <- cbind(ndi_data, NDIQuint) %>% - dplyr::mutate( - PctRecvIDR = round(PctRecvIDR, digits = 1), - PctPubAsst = round(PctPubAsst, digits = 1), - PctMgmtBusScArti = round(PctMgmtBusScArti, digits = 1), - PctFemHeadKids = round(PctFemHeadKids, digits = 1), - PctOwnerOcc = round(PctOwnerOcc, digits = 1), - PctNoPhone = round(PctNoPhone, digits = 1), - PctNComPlmb = round(PctNComPlmb, digits = 1), - PctEducHSPlus = round(PctEducHSPlus, digits = 1), - PctEducBchPlus = round(PctEducBchPlus, digits = 1), - PctFamBelowPov = round(PctFamBelowPov, digits = 1), - PctUnempl = round(PctUnempl, digits = 1) - ) - } else { - ndi <- cbind(ndi_data, NDIQuint) - } - - if (geo == 'tract') { - ndi <- ndi %>% - dplyr::select( - GEOID, - state, - county, - tract, - NDI, - NDIQuint, - MedHHInc, - PctRecvIDR, - PctPubAsst, - MedHomeVal, - PctMgmtBusScArti, - PctFemHeadKids, - PctOwnerOcc, - PctNoPhone, - PctNComPlmb, - PctEducHSPlus, - PctEducBchPlus, - PctFamBelowPov, - PctUnempl, - TotalPop - ) - } else { - ndi <- ndi %>% - dplyr::select( - GEOID, - state, - county, - NDI, - NDIQuint, - MedHHInc, - PctRecvIDR, - PctPubAsst, - MedHomeVal, - PctMgmtBusScArti, - PctFemHeadKids, - PctOwnerOcc, - PctNoPhone, - PctNComPlmb, - PctEducHSPlus, - PctEducBchPlus, - PctFamBelowPov, - PctUnempl, - TotalPop - ) - } - + if (geo == 'tract') { ndi <- ndi %>% - dplyr::mutate( - state = stringr::str_trim(state), - county = stringr::str_trim(county) - ) %>% - dplyr::arrange(GEOID) %>% - dplyr::as_tibble() - + dplyr::select( + GEOID, + state, + county, + tract, + NDI, + NDIQuint, + MedHHInc, + PctRecvIDR, + PctPubAsst, + MedHomeVal, + PctMgmtBusScArti, + PctFemHeadKids, + PctOwnerOcc, + PctNoPhone, + PctNComPlmb, + PctEducHSPlus, + PctEducBchPlus, + PctFamBelowPov, + PctUnempl, + TotalPop + ) } else { - ndi <- cbind(df[, 1], NDIQuint, df[, 2:ncol(df)]) - ndi <- dplyr::as_tibble(ndi[order(ndi[, 1]),]) + ndi <- ndi %>% + dplyr::select( + GEOID, + state, + county, + NDI, + NDIQuint, + MedHHInc, + PctRecvIDR, + PctPubAsst, + MedHomeVal, + PctMgmtBusScArti, + PctFemHeadKids, + PctOwnerOcc, + PctNoPhone, + PctNComPlmb, + PctEducHSPlus, + PctEducBchPlus, + PctFamBelowPov, + PctUnempl, + TotalPop + ) } - out <- list( - ndi = ndi, - pca = fit_rotate, - missing = missingYN, - cronbach = crnbch - ) + ndi <- ndi %>% + dplyr::mutate( + state = stringr::str_trim(state), + county = stringr::str_trim(county) + ) %>% + dplyr::arrange(GEOID) %>% + dplyr::as_tibble() - return(out) + } else { + ndi <- cbind(df[, 1], NDIQuint, df[, 2:ncol(df)]) + ndi <- dplyr::as_tibble(ndi[order(ndi[, 1]),]) } + + out <- list( + ndi = ndi, + pca = fit_rotate, + missing = missingYN, + cronbach = crnbch + ) + + return(out) +} diff --git a/R/sudano.R b/R/sudano.R index 306fbb6..595cc8a 100644 --- a/R/sudano.R +++ b/R/sudano.R @@ -3,7 +3,7 @@ #' Compute the aspatial Location Quotient (Sudano) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Location Quotient (\emph{LQ}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Merton (1939) \doi{10.2307/2084686} and Sudano et al. (2013) \doi{10.1016/j.healthplace.2012.09.015}. This function provides the computation of \emph{LQ} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' \emph{LQ} is some measure of relative racial homogeneity of each smaller geographical units within a larger geographical unit. \emph{LQ} can range in value from 0 to infinity because it is ratio of two proportions in which the numerator is the proportion of subgroup population in a smaller geographical unit and the denominator is the proportion of subgroup population in its larger geographical unit. For example, a smaller geographical unit with an \emph{LQ} of 5 means that the proportion of the subgroup population living in the smaller geographical unit is five times the proportion of the subgroup population in its larger geographical unit. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{LQ} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LQ} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LQ} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{LQ} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LQ} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LQ} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -87,8 +87,8 @@ sudano <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -158,7 +158,7 @@ sudano <- function(geo_large = 'county', ... ) )) - + # Format output if (geo_small == 'county') { out_dat <- out_dat %>% @@ -169,12 +169,12 @@ sudano <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) + cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -205,6 +205,27 @@ sudano <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -244,7 +265,7 @@ sudano <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -281,7 +302,8 @@ sudano <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = lq_fun, omit_NAs = omit_NAs) %>% do.call('rbind', .) @@ -324,9 +346,15 @@ sudano <- function(geo_large = 'county', out <- out %>% dplyr::select(GEOID, state, county, tract, LQ) } - if (geo_small == 'block group') { + if (geo_small == 'cbg') { out <- out %>% - dplyr::select(GEOID, state, county, tract, block.group, LQ) + dplyr::select(GEOID, state, county, tract, cbg, LQ) + } + if (geo_large == 'place') { + out <- out_dat %>% + dplyr::select(GEOID, place) %>% + dplyr::left_join(out, ., by = dplyr::join_by(GEOID)) %>% + dplyr::relocate(place, .after = county) } if (geo_large == 'cbsa') { out <- out_dat %>% @@ -350,6 +378,8 @@ sudano <- function(geo_large = 'county', out <- out %>% unique(.) %>% .[.$GEOID != 'NANA',] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/R/theil.R b/R/theil.R index 0a16e1e..3e8a558 100644 --- a/R/theil.R +++ b/R/theil.R @@ -3,7 +3,7 @@ #' Compute the aspatial Entropy (Theil) of selected racial or ethnic subgroup(s) and U.S. geographies #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Entropy (\emph{H}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Theil (1972; ISBN-13:978-0-444-10378-9) and Theil & Finizza (1971) \doi{110.1080/0022250X.1971.9989795}. This function provides the computation of \emph{H} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' \emph{H} is a measure of the evenness of racial or ethnic residential segregation when comparing smaller geographical units to larger ones within which the smaller geographical units are located. \emph{H} can range in value from 0 to 1 and represents the (weighted) average deviation of each smaller geographical unit from the larger geographical unit's "entropy" or racial and ethnic diversity, which is greatest when each group is equally represented in the larger geographical unit. \emph{H} varies between 0, when all smaller geographical units have the same racial or ethnic composition as the larger geographical area (i.e., maximum integration), to a high of 1, when all smaller geographical units contain one group only (maximum segregation). #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{H} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{H} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{H} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{H} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{H} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{H} computation. #' #' Note: The computation differs from Massey & Denton (1988) \doi{10.1093/sf/67.2.281} by taking the absolute value of \code{(E-E_{i})} so extent of the output is \code{{0, 1}} as designed by Theil (1972; ISBN-13:978-0-444-10378-9) instead of \code{{-Inf, Inf}} as described in Massey & Denton (1988) \doi{10.1093/sf/67.2.281}. #' @@ -58,7 +58,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -90,8 +90,8 @@ theil <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -172,12 +172,12 @@ theil <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) + cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -208,6 +208,27 @@ theil <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -247,7 +268,7 @@ theil <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -294,7 +315,8 @@ theil <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = h_fun, omit_NAs = omit_NAs) %>% utils::stack(.) %>% dplyr::mutate( @@ -327,68 +349,62 @@ theil <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, H) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, H) } if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, H) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, H) } if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, tract, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, H) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, tract, H) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, H) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, H) } if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, cbsa, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, H) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, H) } if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, csa, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, H) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, H) } if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, metro, H) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, H) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, H) } out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/R/utils.R b/R/utils.R index 9fa5301..af9eb22 100644 --- a/R/utils.R +++ b/R/utils.R @@ -168,12 +168,13 @@ del_fun <- function(x, omit_NAs) { # Internal function for an index of spatial proximity ## White (1986) https://doi.org/10.2307/3644339 ## Returns NA value if only one smaller geography in a larger geography -sp_fun <- function(x, omit_NAs) { +sp_fun <- function(x, crs, omit_NAs) { xx <- x[ , c('TotalPopE', 'subgroup', 'subgroup_ref', 'ALAND')] if (omit_NAs == TRUE) { xx <- xx[stats::complete.cases(sf::st_drop_geometry(xx)), ] } if (nrow(sf::st_drop_geometry(x)) < 2 || any(sf::st_drop_geometry(xx) < 0) || any(is.na(sf::st_drop_geometry(xx)))) { NA } else { + xx <- xx %>% sf::st_transform(crs = crs) d_ij <- suppressWarnings(sf::st_distance(sf::st_centroid(xx), sf::st_centroid(xx))) diag(d_ij) <- sqrt(0.6 * xx$ALAND) c_ij <- -d_ij %>% @@ -265,3 +266,37 @@ h_fun <- function(x, omit_NAs) { return(H) } } + +# Internal function for Absolute Centralization +## Duncan, Cuzzort, & Duncan (1961; LC:60007089) +## Returns NA value if only one smaller geography in a larger geography +ace_fun <- function(x, lgeom, crs, omit_NAs) { + xx <- x[ , c('oid', 'subgroup', 'ALAND')] + if (omit_NAs == TRUE) { xx <- xx[stats::complete.cases(sf::st_drop_geometry(xx)), ] } + if (nrow(sf::st_drop_geometry(x)) < 2 || any(sf::st_drop_geometry(xx) < 0) || any(is.na(sf::st_drop_geometry(xx)))) { + NA + } else { + L <- lgeom %>% + dplyr::filter(GEOID == unique(xx$oid)) %>% + sf::st_transform(crs = crs) + C <- L %>% + sf::st_geometry() %>% + sf::st_centroid() + A <- L %>% + sf::st_drop_geometry() + xx <- xx %>% + sf::st_transform(crs = crs) %>% + dplyr::mutate(d = sf::st_distance(sf::st_geometry(.), C)) %>% + dplyr::arrange(d) %>% + sf::st_drop_geometry() + x_i <- xx$subgroup + x_n <- sum(x_i, na.rm = TRUE) + X_i <- cumsum(x_i / x_n) + A_i <- cumsum(xx$ALAND / A$ALAND) + I_i <- matrix(c(seq(1, (length(x_i)-1), 1), seq(2, length(x_i), 1)), ncol = 2) + Xi_1Ai <- sum(X_i[I_i[, 1]] * A_i[I_i[, 2]], na.rm = TRUE) + XiA1_1 <- sum(X_i[I_i[, 2]] * A_i[I_i[, 1]], na.rm = TRUE) + ACE <- Xi_1Ai - XiA1_1 + return(ACE) + } +} diff --git a/R/white.R b/R/white.R index 2ae7034..2da0a0b 100644 --- a/R/white.R +++ b/R/white.R @@ -3,7 +3,7 @@ #' Compute the aspatial Correlation Ratio (White) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s). See Details for available choices. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. @@ -12,7 +12,7 @@ #' #' @details This function will compute the aspatial Correlation Ratio (\emph{V} or \eqn{Eta^{2}}{Eta^2}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Bell (1954) \doi{10.2307/2574118} and White (1986) \doi{10.2307/3644339}. This function provides the computation of \emph{V} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -40,7 +40,7 @@ #' #' \emph{V} removes the asymmetry from the Isolation Index (Bell) by controlling for the effect of population composition. The Isolation Index (Bell) is some measure of the probability that a member of one subgroup(s) will meet or interact with a member of another subgroup(s) with higher values signifying higher probability of interaction (less isolation). \emph{V} can range in value from 0 to Inf. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{V} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{V} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{V} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{V} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -56,7 +56,7 @@ #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom utils stack #' @export #' @@ -87,8 +87,8 @@ white <- function(geo_large = 'county', ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'census block')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -169,11 +169,11 @@ white <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( - tract = gsub('[^0-9\\.]', '', tract), block.group = gsub('[^0-9\\.]', '', block.group) + tract = gsub('[^0-9\\.]', '', tract), cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -201,6 +201,27 @@ white <- function(geo_large = 'county', ) %>% sf::st_drop_geometry() } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) %>% + sf::st_drop_geometry() + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -240,7 +261,7 @@ white <- function(geo_large = 'county', sf::st_drop_geometry() } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -278,7 +299,8 @@ white <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% lapply(., FUN = v_fun, omit_NAs = omit_NAs) %>% utils::stack(.) %>% dplyr::mutate(V = values, oid = ind) %>% @@ -308,68 +330,62 @@ white <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, V) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, V) } if (geo_large == 'county') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, V) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, V) } if (geo_large == 'tract') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, tract, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, V) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, tract, V) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, V) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, V) } if (geo_large == 'cbsa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, cbsa, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, V) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, V) } if (geo_large == 'csa') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, csa, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, V) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, V) } if (geo_large == 'metro') { - out <- out_dat %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, metro, V) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, V) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, V) } out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/R/white_blau.R b/R/white_blau.R index 3f4767c..c087925 100644 --- a/R/white_blau.R +++ b/R/white_blau.R @@ -3,17 +3,18 @@ #' Compute an index of spatial proximity (White) of a selected racial or ethnic subgroup(s) and U.S. geographies. #' #' @param geo_large Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}. -#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}. +#' @param geo_small Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}. #' @param year Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available. #' @param subgroup Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices. #' @param subgroup_ref Character string specifying the racial or ethnic subgroup(s) as the reference population. See Details for available choices. +#' @param crs Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}. #' @param omit_NAs Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE. #' @param quiet Logical. If TRUE, will display messages about potential missing census information. The default is FALSE. #' @param ... Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics #' #' @details This function will compute an index of spatial proximity (\emph{SP}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on White (1986) \doi{10.2307/3644339} and Blau (1977; ISBN-13:978-0-029-03660-0). This function provides the computation of \emph{SP} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). #' -#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +#' The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: #' \itemize{ #' \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} #' \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -43,7 +44,7 @@ #' #' The metric uses the exponential transform of a distance matrix (kilometers) between smaller geographical area centroids, with a diagonal defined as \code{(0.6*a_{i})^{0.5}} where \code{a_{i}} is the area (square kilometers) of smaller geographical unit \code{i} as defined by White (1983) \doi{10.1086/227768}. #' -#' Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{SP} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{SP} computation. +#' Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{SP} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{SP} computation. #' #' @return An object of class 'list'. This is a named list with the following components: #' @@ -54,12 +55,12 @@ #' } #' #' @import dplyr -#' @importFrom sf st_centroid st_distance st_drop_geometry st_within +#' @importFrom sf st_centroid st_distance st_drop_geometry st_transform st_within #' @importFrom stats complete.cases #' @importFrom stringr str_trim #' @importFrom tidycensus get_acs #' @importFrom tidyr pivot_longer separate -#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions +#' @importFrom tigris combined_statistical_areas core_based_statistical_areas metro_divisions places #' @importFrom units drop_units set_units #' @importFrom utils stack #' @export @@ -88,13 +89,14 @@ white_blau <- function(geo_large = 'county', year = 2020, subgroup, subgroup_ref, + crs = 'ESRI:102008', omit_NAs = TRUE, quiet = FALSE, ...) { # Check arguments - match.arg(geo_large, choices = c('state', 'county', 'tract', 'cbsa', 'csa', 'metro')) - match.arg(geo_small, choices = c('county', 'tract', 'block group')) + match.arg(geo_large, choices = c('state', 'county', 'tract', 'place', 'cbsa', 'csa', 'metro')) + match.arg(geo_small, choices = c('county', 'tract', 'cbg', 'block group')) stopifnot(is.numeric(year), year >= 2009) # all variables available 2009 onward match.arg( subgroup, @@ -202,12 +204,12 @@ white_blau <- function(geo_large = 'county', tidyr::separate(NAME.y, into = c('tract', 'county', 'state'), sep = ',') %>% dplyr::mutate(tract = gsub('[^0-9\\.]', '', tract)) } - if (geo_small == 'block group') { + if (geo_small == 'cbg' | geo_small == 'block group') { out_dat <- out_dat %>% - tidyr::separate(NAME.y, into = c('block.group', 'tract', 'county', 'state'), sep = ',') %>% + tidyr::separate(NAME.y, into = c('cbg', 'tract', 'county', 'state'), sep = ',') %>% dplyr::mutate( tract = gsub('[^0-9\\.]', '', tract), - block.group = gsub('[^0-9\\.]', '', block.group) + cbg = gsub('[^0-9\\.]', '', cbg) ) } @@ -235,6 +237,26 @@ white_blau <- function(geo_large = 'county', county = stringr::str_trim(county) ) } + if (geo_large == 'place') { + stopifnot(is.numeric(year), year >= 2011) # Places only available 2011 onward + lgeom <- suppressMessages(suppressWarnings(tigris::places( + year = year, state = unique(out_dat$state)) + )) + wlgeom <- sf::st_within(out_dat, lgeom) + out_dat <- out_dat %>% + dplyr::mutate( + oid = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 4] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist(), + place = lapply(wlgeom, function(x) { + tmp <- lgeom[x, 5] %>% sf::st_drop_geometry() + lapply(tmp, function(x) { if (length(x) == 0) NA else x }) + }) %>% + unlist() + ) + } if (geo_large == 'cbsa') { stopifnot(is.numeric(year), year >= 2010) # CBSAs only available 2010 onward lgeom <- suppressMessages(suppressWarnings(tigris::core_based_statistical_areas(year = year))) @@ -272,7 +294,7 @@ white_blau <- function(geo_large = 'county', ) } if (geo_large == 'metro') { - stopifnot(is.numeric(year), year >= 2011) # Metro Divisions only available 2011 onward + stopifnot(is.numeric(year), year >= 2011) # Metropolitan Divisions only available 2011 onward lgeom <- suppressMessages(suppressWarnings(tigris::metro_divisions(year = year))) wlgeom <- sf::st_within(out_dat, lgeom) out_dat <- out_dat %>% @@ -320,8 +342,9 @@ white_blau <- function(geo_large = 'county', ## Compute out_tmp <- out_dat %>% - split(., f = list(out_dat$oid)) %>% - lapply(., FUN = sp_fun, omit_NAs = omit_NAs) %>% + .[.$oid != 'NANA', ] %>% + split(., f = list(.$oid)) %>% + lapply(., FUN = sp_fun, crs = crs, omit_NAs = omit_NAs) %>% utils::stack(.) %>% dplyr::mutate( SP = values, @@ -346,7 +369,7 @@ white_blau <- function(geo_large = 'county', n_missing = sum(is.na(val)), percent_missing = paste0(round(mean(is.na(val)) * 100, 2), ' %') ) - + if (quiet == FALSE) { # Warning for missing census data if (sum(missingYN$n_missing) > 0) { @@ -355,74 +378,63 @@ white_blau <- function(geo_large = 'county', } # Format output + out <- out_dat %>% + sf::st_drop_geometry() %>% + dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) if (geo_large == 'state') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, SP) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, SP) } if (geo_large == 'county') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, SP) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, SP) } if (geo_large == 'tract') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, state, county, tract, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, state, county, tract, SP) %>% - .[.$GEOID != 'NANA',] + dplyr::select(GEOID, state, county, tract, SP) + } + if (geo_large == 'place') { + out <- out %>% + dplyr::select(oid, place, SP) %>% + unique(.) %>% + dplyr::mutate(GEOID = oid) %>% + dplyr::select(GEOID, place, SP) } if (geo_large == 'cbsa') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, cbsa, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, cbsa, SP) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, cbsa, SP) } if (geo_large == 'csa') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, csa, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, csa, SP) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, csa, SP) } if (geo_large == 'metro') { - out <- out_dat %>% - sf::st_drop_geometry() %>% - dplyr::left_join(out_tmp, by = dplyr::join_by(oid)) %>% + out <- out %>% dplyr::select(oid, metro, SP) %>% unique(.) %>% dplyr::mutate(GEOID = oid) %>% - dplyr::select(GEOID, metro, SP) %>% - .[.$GEOID != 'NANA', ] %>% - dplyr::distinct(GEOID, .keep_all = TRUE) %>% - dplyr::filter(stats::complete.cases(.)) + dplyr::select(GEOID, metro, SP) } out <- out %>% + .[.$GEOID != 'NANA', ] %>% + dplyr::filter(!is.na(GEOID)) %>% + dplyr::distinct(GEOID, .keep_all = TRUE) %>% dplyr::arrange(GEOID) %>% dplyr::as_tibble() diff --git a/README.md b/README.md index baa2d4c..03c95a0 100644 --- a/README.md +++ b/README.md @@ -12,11 +12,11 @@ [![DOI](https://zenodo.org/badge/521439746.svg)](https://zenodo.org/badge/latestdoi/521439746) -**Date repository last updated**: 2024-08-24 +**Date repository last updated**: 2024-08-29 ### Overview -The *ndi* package is a suite of [**R**](https://cran.r-project.org/) functions to compute various metrics of socio-economic deprivation and disparity in the United States. Some metrics are considered 'spatial' because they consider the values of neighboring (i.e., adjacent) census geographies in their computation, while other metrics are 'aspatial' because they only consider the value within each census geography. Two types of aspatial neighborhood deprivation index (*NDI*) are available: (1) based on [Messer et al. (2006)](https://doi.org/10.1007/s11524-006-9094-x) and (2) based on [Andrews et al. (2020)](https://doi.org/10.1080/17445647.2020.1750066) and [Slotman et al. (2022)](https://doi.org/10.1016/j.dib.2022.108002) who use variables chosen by [Roux and Mair (2010)](https://doi.org/10.1111/j.1749-6632.2009.05333.x). Both are a decomposition of various demographic characteristics from the U.S. Census Bureau American Community Survey 5-year estimates (ACS-5; 2006-2010 onward) pulled by the [tidycensus](https://CRAN.R-project.org/package=tidycensus) package. Using data from the ACS-5 (2005-2009 onward), the *ndi* package can also compute the (1) spatial Racial Isolation Index (*RI*) based on [Anthopolos et al. (2011)](https://doi.org/10.1016/j.sste.2011.06.002), (2) spatial Educational Isolation Index (*EI*) based on [Bravo et al. (2021)](https://doi.org/10.3390/ijerph18179384), (3) aspatial Index of Concentration at the Extremes (*ICE*) based on [Feldman et al. (2015)](https://doi.org/10.1136/jech-2015-205728) and [Krieger et al. (2016)](https://doi.org/10.2105/AJPH.2015.302955), (4) aspatial racial or ethnic Dissimilarity Index (*D*) based on [Duncan & Duncan (1955)](https://doi.org/10.2307/2088328), (5) aspatial income or racial or ethnic Atkinson Index (*A*) based on [Atkinson (1970)](https://doi.org/10.1016/0022-0531(70)90039-6), (6) aspatial racial or ethnic Interaction Index (_xPy\*_) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and [Bell (1954)](https://doi.org/10.2307/2574118), (7) aspatial racial or ethnic Correlation Ratio (*V*) based on [Bell (1954)](https://doi.org/10.2307/2574118) and [White (1986)](https://doi.org/10.2307/3644339), (8) aspatial racial or ethnic Location Quotient (*LQ*) based on [Merton (1939)](https://doi.org/10.2307/2084686) and [Sudano et al. (2013)](https://doi.org/10.1016/j.healthplace.2012.09.015), (9) aspatial racial or ethnic Local Exposure and Isolation (*LEx/Is*) metric based on [Bemanian & Beyer (2017)](https://doi.org/10.1158/1055-9965.EPI-16-0926), (10) aspatial racial or ethnic Delta (*DEL*) based on [Hoover (1941)](https://doi.org/10.1017/S0022050700052980) and Duncan et al. (1961; LC:60007089), (11) an index of spatial proximity (*SP*) based on [White (1986)](https://doi.org/10.2307/3644339) and Blau (1977; ISBN-13:978-0-029-03660-0), and (12) the aspatial racial or ethnic Isolation Index (_xPx\*_) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and [Bell (1954)](https://doi.org/10.2307/2574118), the (13) aspatial racial or ethnic Gini Index (*G*) based on [Gini (1921)](https://doi.org/10.2307/2223319), (14) aspatial racial or ethnic Dissimilarity Index (*D*) based on [James & Taeuber (1985)](https://doi.org/10.2307/270845), and (15) the aspatial racial or ethnic Entropy (*H*) based on Theil (1972; ISBN:978-0-444-10378-9) and [Theil & Finizza (1971)](https://doi.org/110.1080/0022250X.1971.9989795). Also using data from the ACS-5 (2005-2009 onward), the *ndi* package can retrieve the aspatial income Gini Index (*G*) based on [Gini (1921)](https://doi.org/10.2307/2223319). +Computes various indices of socioeconomic deprivation and disparity in the United States. Some indices are considered "spatial" because they consider the values of neighboring (i.e., adjacent) census geographies in their computation, while other indices are "aspatial" because they only consider the value within each census geography. Two types of aspatial neighborhood deprivation indices (NDI) are available: including: (1) based on [Messer et al. (2006)](https://doi.org/10.1007/s11524-006-9094-x) and (2) based on Andrews et al. (2020)](https://doi.org/10.1080/17445647.2020.1750066) and [Slotman et al. (2022)](https://doi.org/10.1016/j.dib.2022.108002) who use variables chosen by [Roux and Mair (2010)](https://doi.org/:10.1111/j.1749-6632.2009.05333.x). Both are a decomposition of multiple demographic characteristics from the U.S. Census Bureau American Community Survey 5-year estimates (ACS-5; 2006-2010 onward). Using data from the ACS-5 (2005-2009 onward), the package can also compute indices of racial or ethnic residential segregation, including but limited to those discussed in [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281), and selected metrics of socioeconomic deprivation and disparity. ### Installation @@ -56,7 +56,7 @@ To install the development version from GitHub: bemanian_beyer -Compute the aspatial racial or ethnic Local Exposure and Isolation (LEx/Is) metric based on Bemanian & Beyer (2017) +Compute the aspatial racial or ethnic Local Exposure and Isolation (LEx/Is) based on Bemanian & Beyer (2017) bravo @@ -67,6 +67,10 @@ To install the development version from GitHub: Compute the aspatial racial or ethnic Dissimilarity Index (D) based on Duncan & Duncan (1955) +duncan_cuzzort +Compute the aspatial racial or ethnic Absolute Centralization (ACE) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and Massey & Denton (1988) + + gini Compute the aspatial racial or ethnic Gini Index (G) and retrieve the aspatial income Gini Index (G) based on Gini (1921) @@ -142,7 +146,7 @@ The repository also includes the code to create the project hexagon sticker. ### Author -* **Ian D. Buller** - *DLH, LLC (formerly Social & Scientific Systems, Inc.), Bethesda, Maryland (current)* - *Occupational and Environmental Epidemiology Branch, Division of Cancer Epidemiology and Genetics, National Cancer Institute, National Institutes of Health, Rockville, Maryland (original)* - [GitHub](https://github.com/idblr) - [ORCID](https://orcid.org/0000-0001-9477-8582) +* **Ian D. Buller** - *DLH, LLC (formerly Social & Scientific Systems, Inc. and DLH Corporation), Bethesda, Maryland (current)* - *Occupational and Environmental Epidemiology Branch, Division of Cancer Epidemiology and Genetics, National Cancer Institute, National Institutes of Health, Rockville, Maryland (original)* - [GitHub](https://github.com/idblr) - [ORCID](https://orcid.org/0000-0001-9477-8582) See also the list of [contributors](https://github.com/idblr/ndi/graphs/contributors) who participated in this package, including: @@ -154,7 +158,7 @@ See also the list of [contributors](https://github.com/idblr/ndi/graphs/contribu * **Davis Vaughan** - *Posit* - [GitHub](https://github.com/DavisVaughan) - [ORCID](https://orcid.org/0000-0003-4777-038X) -Thank you to those who suggested additional metrics, including: +Thank you to those who suggested additional indices, including: * **David Berrigan** - *Behavioral Research Program, Division of Cancer Control and Population Sciences, National Cancer Institute, National Institutes of Health, Rockville, Maryland* - [ORCID](https://orcid.org/0000-0002-5333-179X) @@ -449,15 +453,53 @@ table(NDI_2020_DC$NDIQuart, NDI_2020_DC$NDIQuint) ``` ``` r -# ------------------------------------------ # -# Compute aspatial race or ethnic Gini Index # -# ------------------------------------------ # +# ---------------------------------------------------- # +# Compute spatial Racial Isoliation Index (Anthopolos) # +# ---------------------------------------------------- # -# Gini Index based on Gini (1921) +# Racial Isolation Index based on Anthopolos et al. (2011) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone +RI_2020_DC <- anthopolos(state = 'DC', year = 2020, subgroup = 'NHoLB') + +# Obtain the 2020 census tracts from the 'tigris' package +tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) + +# Join the RI (Anthopolos) values to the census tract geometry +RI_2020_DC <- tract_2020_DC %>% + left_join(RI_2020_DC$ri, by = 'GEOID') + +ggplot() + + geom_sf( + data = RI_2020_DC, + aes(fill = RI), + color = 'white' + ) + + theme_bw() + + scale_fill_viridis_c() + + labs( + fill = 'Index (Continuous)', + caption = 'Source: U.S. Census ACS 2016-2020 estimates' + ) + + ggtitle( + 'Racial Isolation Index\n + Not Hispanic or Latino, Black or African American alone (Anthopolos)', + subtitle = 'Washington, D.C. tracts (not corrected for edge effects)' + ) +``` + +![](man/figures/ri.png) + +```r +# ----------------------------------------------------------- # +# Compute aspatial racial or ethnic Atkinson Index (Atkinson) # +# ----------------------------------------------------------- # + +# Atkinson Index based on Atkinson (1970) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone ## Selected large geography: census tract ## Selected small geography: census block group -G_2020_DC <- gini( +## Default epsilon (0.5 or over- and under-representation contribute equally) +A_2020_DC <- atkinson( geo_large = 'tract', geo_small = 'block group', state = 'DC', @@ -468,14 +510,14 @@ G_2020_DC <- gini( # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the G (Gini) values to the census tract geometry -G_2020_DC <- tract_2020_DC %>% - left_join(G_2020_DC$g, by = 'GEOID') +# Join the AI (Atkinson) values to the census tract geometry +A_2020_DC <- tract_2020_DC %>% + left_join(A_2020_DC$a, by = 'GEOID') ggplot() + geom_sf( - data = G_2020_DC, - aes(fill = G_re), + data = A_2020_DC, + aes(fill = A), color = 'white' ) + theme_bw() + @@ -485,95 +527,160 @@ ggplot() + caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Gini Index\n + 'Atkinson Index (Atkinson)\n Washington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic' + subtitle = expression(paste('Black non-Hispanic (', epsilon, ' = 0.5)')) ) ``` -![](man/figures/g_re.png) +![](man/figures/a.png) -``` r -# ------------------------------------ # -# Retrieve aspatial income Gini Index # -# ------------------------------------ # +```r +# -------------------------------------------------------------------------------- # +# Compute aspatial racial or ethnic Atkinson Index (Atkinson) with the Hölder mean # +# -------------------------------------------------------------------------------- # -# Gini Index based on Gini (1921) +# Atkinson Index based on Atkinson (1970) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: county (or district for DC) -## Selected small geography: census tract -G_2020_DC <- gini( - geo_large = 'county', - geo_small = 'tract', +## Selected large geography: census tract +## Selected small geography: census block group +## Default epsilon (0.5 or over- and under-representation contribute equally) +## Using the Hölder mean based on the `Atkinson()` function from 'DescTools' package +A_2020_DC <- atkinson( + geo_large = 'tract', + geo_small = 'block group', state = 'DC', year = 2020, - subgroup = 'NHoLB' + subgroup = 'NHoLB', + holder = TRUE ) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the G (Gini) values found in `g_data` to the census tract geometry -G_2020_DC <- tract_2020_DC %>% - left_join(G_2020_DC$g_data , by = 'GEOID') +# Join the AI (Atkinson) values to the census tract geometry +A_2020_DC <- tract_2020_DC %>% + left_join(A_2020_DC$a, by = 'GEOID') ggplot() + geom_sf( - data = G_2020_DC, - aes(fill = G_inc), + data = A_2020_DC, + aes(fill = A), color = 'white' ) + theme_bw() + - scale_fill_viridis_c() + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Gini Index\n - Washington, D.C. census tracts', - subtitle = 'Income' + 'Atkinson Index (Atkinson) with Hölder mean\n + Washington, D.C. census block groups to tracts', + subtitle = expression(paste('Black non-Hispanic (', epsilon, ' = 0.5)')) ) ``` -![](man/figures/g_inc.png) +![](man/figures/a_holder.png) -``` r -# ---------------------------------------------------- # -# Compute spatial Racial Isoliation Index (Anthopolos) # -# ---------------------------------------------------- # +```r +# ---------------------------------------------------------- # +# Compute aspatial racial or ethnic Interaction Index (Bell) # +# ---------------------------------------------------------- # -# Racial Isolation Index based on Anthopolos et al. (2011) +# Interaction Index based on Shevky & Williams (1949) and Bell (1954) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone -RI_2020_DC <- anthopolos(state = 'DC', year = 2020, subgroup = 'NHoLB') +## Selected interaction subgroup: Not Hispanic or Latino, Black or African American alone +## Selected large geography: census tract +## Selected small geography: census block group +xPy_star_2020_DC <- bell( + geo_large = 'tract', + geo_small = 'block group', + state = 'DC', + year = 2020, + subgroup = 'NHoLB', + subgroup_ixn = 'NHoLW' +) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the RI (Anthopolos) values to the census tract geometry -RI_2020_DC <- tract_2020_DC %>% - left_join(RI_2020_DC$ri, by = 'GEOID') +# Join the xPy* (Bell) values to the census tract geometry +xPy_star_2020_DC <- tract_2020_DC %>% + left_join(xPy_star_2020_DC$xpy_star, by = 'GEOID') ggplot() + geom_sf( - data = RI_2020_DC, - aes(fill = RI), + data = xPy_star_2020_DC, + aes(fill = xPy_star), color = 'white' ) + theme_bw() + - scale_fill_viridis_c() + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Racial Isolation Index\n - Not Hispanic or Latino, Black or African American alone (Anthopolos)', - subtitle = 'Washington, D.C. tracts (not corrected for edge effects)' + 'Interaction Index (Bell)\n + Washington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic vs. white non-Hispanic' ) ``` -![](man/figures/ri.png) +![](man/figures/xpy_star.png) + +```r +# --------------------------------------------------------------------------------- # +# Compute aspatial racial or ethnic Local Exposure and Isolation (Bemanian & Beyer) # +# --------------------------------------------------------------------------------- # + +# Local Exposure and Isolation based on Bemanian & Beyer (2017) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone +## Selected interaction subgroup: Not Hispanic or Latino, Black or African American alone +## Selected large geography: state +## Selected small geography: census tract +LExIs_2020_DC <- bemanian_beyer( + geo_large = 'state', + geo_small = 'tract', + state = 'DC', + year = 2020, + subgroup = 'NHoLB', + subgroup_ixn = 'NHoLW' +) + +# Obtain the 2020 census tracts from the 'tigris' package +tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) + +# Join the LEx/Is (Bemanian & Beyer) values to the census tract geometry +LExIs_2020_DC <- tract_2020_DC %>% + left_join(LExIs_2020_DC$lexis, by = 'GEOID') + +ggplot() + + geom_sf( + data = LExIs_2020_DC, + aes(fill = LExIs), + color = 'white' + ) + + theme_bw() + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + midpoint = 0 + ) + + labs( + fill = 'Index (Continuous)', + caption = 'Source: U.S. Census ACS 2016-2020 estimates' + ) + + ggtitle( + 'Local Exposure and Isolation (Bemanian & Beyer)\n + Washington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic vs. white non-Hispanic' + ) +``` + +![](man/figures/lexis.png) ``` r # ---------------------------------------------------- # @@ -611,192 +718,221 @@ ggplot() + ![](man/figures/ei.png) -``` r -# ----------------------------------------------------------------- # -# Compute aspatial Index of Concentration at the Extremes (Krieger) # -# ----------------------------------------------------------------- # - -# Five Indices of Concentration at the Extremes based on Feldman et al. (2015) and -# Krieger et al. (2016) +```r +# ----------------------------------------------------------------------- # +# Compute aspatial racial or ethnic Dissimilarity Index (Duncan & Duncan) # +# ----------------------------------------------------------------------- # -ICE_2020_DC <- krieger(state = 'DC', year = 2020) +# Dissimilarity Index based on Duncan & Duncan (1955) +## Selected subgroup comparison: Not Hispanic or Latino, Black or African American alone +## Selected subgroup reference: Not Hispanic or Latino, white alone +## Selected large geography: census tract +## Selected small geography: census block group +D_2020_DC <- duncan( + geo_large = 'tract', + geo_small = 'block group', + state = 'DC', + year = 2020, + subgroup = 'NHoLB', + subgroup_ref = 'NHoLW' +) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the ICEs (Krieger) values to the census tract geometry -ICE_2020_DC <- tract_2020_DC %>% - left_join(ICE_2020_DC$ice, by = 'GEOID') +# Join the D (Duncan & Duncan) values to the census tract geometry +D_2020_DC <- tract_2020_DC %>% + left_join(D_2020_DC$d, by = 'GEOID') -# Plot ICE for Income ggplot() + geom_sf( - data = ICE_2020_DC, - aes(fill = ICE_inc), + data = D_2020_DC, + aes(fill = D), color = 'white' ) + theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - limits = c(-1, 1) - ) + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Index of Concentration at the Extremes\nIncome (Krieger)', - subtitle = '80th income percentile vs. 20th income percentile' + 'Dissimilarity Index (Duncan & Duncan)\nWashington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic vs. white non-Hispanic' ) ``` -![](man/figures/ice1.png) +![](man/figures/ddd.png) ```r -# Plot ICE for Education -ggplot() + - geom_sf( - data = ICE_2020_DC, - aes(fill = ICE_edu), - color = 'white' - ) + - theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - limits = c(-1, 1) - ) + - labs( - fill = 'Index (Continuous)', - caption = 'Source: U.S. Census ACS 2016-2020 estimates' - ) + - ggtitle( - 'Index of Concentration at the Extremes\nEducation (Krieger)', - subtitle = 'less than high school vs. four-year college degree or more' - ) -``` +# ----------------------------------------------------------- # +# Compute aspatial Absolute Centralization (Duncan & Cuzzort) # +# ----------------------------------------------------------- # -![](man/figures/ice2.png) +# Absolute Centralization based on Duncan, Cuzzort, & Duncan (1961) and Massey & Denton (1988) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone +## Selected large geography: census tract +## Selected small geography: census block group +ACE_2020_DC <- duncan_cuzzort( + geo_large = 'tract', + geo_small = 'block group', + state = 'DC', + year = 2020, + subgroup = 'NHoLB' +) + +# Obtain the 2020 census tracts from the 'tigris' package +tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) + +# Join the ACE (Duncan & Cuzzort) values to the census tract geometry +ACE_2020_DC <- tract_2020_DC %>% + left_join(ACE_2020_DC$ace, by = 'GEOID') -```r -# Plot ICE for Race or Ethnicity ggplot() + geom_sf( - data = ICE_2020_DC, - aes(fill = ICE_rewb), + data = ACE_2020_DC, + aes(fill = ACE), color = 'white' ) + theme_bw() + scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + midpoint = 0, limits = c(-1, 1) - ) + + ) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Index of Concentration at the Extremes\nRace pr Ethnicity (Krieger)', - subtitle = 'white non-Hispanic vs. black non-Hispanic' + 'Absolute Centralization (Duncan & Cuzzort)\n + Washington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/ice3.png) +![](man/figures/ace.png) + +``` r +# ------------------------------------------ # +# Compute aspatial race or ethnic Gini Index # +# ------------------------------------------ # + +# Gini Index based on Gini (1921) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone +## Selected large geography: census tract +## Selected small geography: census block group +G_2020_DC <- gini( + geo_large = 'tract', + geo_small = 'block group', + state = 'DC', + year = 2020, + subgroup = 'NHoLB' +) + +# Obtain the 2020 census tracts from the 'tigris' package +tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) + +# Join the G (Gini) values to the census tract geometry +G_2020_DC <- tract_2020_DC %>% + left_join(G_2020_DC$g, by = 'GEOID') -``` -# Plot ICE for Income and Race or Ethnicity Combined -## white non-Hispanic in 80th income percentile vs. -## black (including Hispanic) in 20th income percentile ggplot() + geom_sf( - data = ICE_2020_DC, - aes(fill = ICE_wbinc), + data = G_2020_DC, + aes(fill = G_re), color = 'white' ) + theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - limits = c(-1, 1) - ) + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Index of Concentration at the Extremes\nIncome and race or ethnicity combined (Krieger)', - subtitle = 'white non-Hispanic in 80th income percentile vs. - black (incl. Hispanic) in 20th inc. percentile' + 'Gini Index\n + Washington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/ice4.png) +![](man/figures/g_re.png) + +``` r +# ------------------------------------ # +# Retrieve aspatial income Gini Index # +# ------------------------------------ # + +# Gini Index based on Gini (1921) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone +## Selected large geography: county (or district for DC) +## Selected small geography: census tract +G_2020_DC <- gini( + geo_large = 'county', + geo_small = 'tract', + state = 'DC', + year = 2020, + subgroup = 'NHoLB' +) + +# Obtain the 2020 census tracts from the 'tigris' package +tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) + +# Join the G (Gini) values found in `g_data` to the census tract geometry +G_2020_DC <- tract_2020_DC %>% + left_join(G_2020_DC$g_data , by = 'GEOID') -```r -# Plot ICE for Income and Race or Ethnicity Combined -## white non-Hispanic in 80th income percentile vs. white non-Hispanic in 20th income percentile ggplot() + geom_sf( - data = ICE_2020_DC, - aes(fill = ICE_wpcinc), + data = G_2020_DC, + aes(fill = G_inc), color = 'white' ) + theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - limits = c(-1, 1) - ) + + scale_fill_viridis_c() + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Index of Concentration at the Extremes\nIncome and race or ethnicity combined (Krieger)', - subtitle = 'white non-Hispanic in 80th income percentile vs. - white non-Hispanic in 20th income percentile' + 'Gini Index\n + Washington, D.C. census tracts', + subtitle = 'Income' ) ``` -![](man/figures/ice5.png) +![](man/figures/g_inc.png) ```r -# ----------------------------------------------------------------------- # -# Compute aspatial racial or ethnic Dissimilarity Index (Duncan & Duncan) # -# ----------------------------------------------------------------------- # +# ------------------------------------------------ # +# Compute aspatial racial or ethnic Delta (Hoover) # +# ------------------------------------------------ # -# Dissimilarity Index based on Duncan & Duncan (1955) -## Selected subgroup comparison: Not Hispanic or Latino, Black or African American alone -## Selected subgroup reference: Not Hispanic or Latino, white alone +# Delta based on Hoover (1941) and Duncan, Cuzzort, & Duncan (1961) +## Selected subgroup: Not Hispanic or Latino, Black or African American alone ## Selected large geography: census tract ## Selected small geography: census block group -D_2020_DC <- duncan( +DEL_2020_DC <- hoover( geo_large = 'tract', geo_small = 'block group', state = 'DC', year = 2020, - subgroup = 'NHoLB', - subgroup_ref = 'NHoLW' + subgroup = 'NHoLB' ) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the D (Duncan & Duncan) values to the census tract geometry -D_2020_DC <- tract_2020_DC %>% - left_join(D_2020_DC$d, by = 'GEOID') +# Join the DEL (Hoover) values to the census tract geometry +DEL_2020_DC <- tract_2020_DC %>% + left_join(DEL_2020_DC$del, by = 'GEOID') ggplot() + geom_sf( - data = D_2020_DC, - aes(fill = D), + data = DEL_2020_DC, + aes(fill = DEL), color = 'white' ) + theme_bw() + @@ -806,12 +942,13 @@ ggplot() + caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Dissimilarity Index (Duncan & Duncan)\nWashington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic vs. white non-Hispanic' + 'Delta (Hoover)\n + Washington, D.C. census block groups to tracts', + subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/ddd.png) +![](man/figures/del.png) ```r # ----------------------------------------------------------------------- # @@ -857,158 +994,172 @@ ggplot() + ![](man/figures/djt.png) +``` r +# ----------------------------------------------------------------- # +# Compute aspatial Index of Concentration at the Extremes (Krieger) # +# ----------------------------------------------------------------- # -```r -# ----------------------------------------------------------- # -# Compute aspatial racial or ethnic Atkinson Index (Atkinson) # -# ----------------------------------------------------------- # +# Five Indices of Concentration at the Extremes based on Feldman et al. (2015) and +# Krieger et al. (2016) -# Atkinson Index based on Atkinson (1970) -## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: census tract -## Selected small geography: census block group -## Default epsilon (0.5 or over- and under-representation contribute equally) -A_2020_DC <- atkinson( - geo_large = 'tract', - geo_small = 'block group', - state = 'DC', - year = 2020, - subgroup = 'NHoLB' -) +ICE_2020_DC <- krieger(state = 'DC', year = 2020) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the AI (Atkinson) values to the census tract geometry -A_2020_DC <- tract_2020_DC %>% - left_join(A_2020_DC$a, by = 'GEOID') +# Join the ICEs (Krieger) values to the census tract geometry +ICE_2020_DC <- tract_2020_DC %>% + left_join(ICE_2020_DC$ice, by = 'GEOID') +# Plot ICE for Income ggplot() + geom_sf( - data = A_2020_DC, - aes(fill = A), + data = ICE_2020_DC, + aes(fill = ICE_inc), color = 'white' ) + theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + limits = c(-1, 1) + ) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Atkinson Index (Atkinson)\n - Washington, D.C. census block groups to tracts', - subtitle = expression(paste('Black non-Hispanic (', epsilon, ' = 0.5)')) + 'Index of Concentration at the Extremes\nIncome (Krieger)', + subtitle = '80th income percentile vs. 20th income percentile' ) ``` -![](man/figures/a.png) +![](man/figures/ice1.png) ```r -# -------------------------------------------------------------------------------- # -# Compute aspatial racial or ethnic Atkinson Index (Atkinson) with the Hölder mean # -# -------------------------------------------------------------------------------- # +# Plot ICE for Education +ggplot() + + geom_sf( + data = ICE_2020_DC, + aes(fill = ICE_edu), + color = 'white' + ) + + theme_bw() + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + limits = c(-1, 1) + ) + + labs( + fill = 'Index (Continuous)', + caption = 'Source: U.S. Census ACS 2016-2020 estimates' + ) + + ggtitle( + 'Index of Concentration at the Extremes\nEducation (Krieger)', + subtitle = 'less than high school vs. four-year college degree or more' + ) +``` -# Atkinson Index based on Atkinson (1970) -## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: census tract -## Selected small geography: census block group -## Default epsilon (0.5 or over- and under-representation contribute equally) -## Using the Hölder mean based on the `Atkinson()` function from 'DescTools' package -A_2020_DC <- atkinson( - geo_large = 'tract', - geo_small = 'block group', - state = 'DC', - year = 2020, - subgroup = 'NHoLB', - holder = TRUE -) +![](man/figures/ice2.png) -# Obtain the 2020 census tracts from the 'tigris' package -tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) +```r +# Plot ICE for Race or Ethnicity +ggplot() + + geom_sf( + data = ICE_2020_DC, + aes(fill = ICE_rewb), + color = 'white' + ) + + theme_bw() + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + limits = c(-1, 1) + ) + + labs( + fill = 'Index (Continuous)', + caption = 'Source: U.S. Census ACS 2016-2020 estimates' + ) + + ggtitle( + 'Index of Concentration at the Extremes\nRace pr Ethnicity (Krieger)', + subtitle = 'white non-Hispanic vs. black non-Hispanic' + ) +``` -# Join the AI (Atkinson) values to the census tract geometry -A_2020_DC <- tract_2020_DC %>% - left_join(A_2020_DC$a, by = 'GEOID') +![](man/figures/ice3.png) +``` +# Plot ICE for Income and Race or Ethnicity Combined +## white non-Hispanic in 80th income percentile vs. +## black (including Hispanic) in 20th income percentile ggplot() + geom_sf( - data = A_2020_DC, - aes(fill = A), + data = ICE_2020_DC, + aes(fill = ICE_wbinc), color = 'white' ) + theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + limits = c(-1, 1) + ) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Atkinson Index (Atkinson) with Hölder mean\n - Washington, D.C. census block groups to tracts', - subtitle = expression(paste('Black non-Hispanic (', epsilon, ' = 0.5)')) + 'Index of Concentration at the Extremes\nIncome and race or ethnicity combined (Krieger)', + subtitle = 'white non-Hispanic in 80th income percentile vs. + black (incl. Hispanic) in 20th inc. percentile' ) ``` -![](man/figures/a_holder.png) +![](man/figures/ice4.png) ```r -# ---------------------------------------------------------- # -# Compute aspatial racial or ethnic Interaction Index (Bell) # -# ---------------------------------------------------------- # - -# Interaction Index based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) -## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected interaction subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: census tract -## Selected small geography: census block group -xPy_star_2020_DC <- bell( - geo_large = 'tract', - geo_small = 'block group', - state = 'DC', - year = 2020, - subgroup = 'NHoLB', - subgroup_ixn = 'NHoLW' -) - -# Obtain the 2020 census tracts from the 'tigris' package -tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) - -# Join the xPy* (Bell) values to the census tract geometry -xPy_star_2020_DC <- tract_2020_DC %>% - left_join(xPy_star_2020_DC$xpy_star, by = 'GEOID') - +# Plot ICE for Income and Race or Ethnicity Combined +## white non-Hispanic in 80th income percentile vs. white non-Hispanic in 20th income percentile ggplot() + geom_sf( - data = xPy_star_2020_DC, - aes(fill = xPy_star), + data = ICE_2020_DC, + aes(fill = ICE_wpcinc), color = 'white' ) + theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + limits = c(-1, 1) + ) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Interaction Index (Bell)\n - Washington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic vs. white non-Hispanic' + 'Index of Concentration at the Extremes\nIncome and race or ethnicity combined (Krieger)', + subtitle = 'white non-Hispanic in 80th income percentile vs. + white non-Hispanic in 20th income percentile' ) ``` -![](man/figures/xpy_star.png) +![](man/figures/ice5.png) ```r -# ----------------------------------------------------------- # -# Compute aspatial racial or ethnic Correlation Ratio (White) # -# ----------------------------------------------------------- # +# ------------------------------------------------------------- # +# Compute aspatial racial or ethnic Isolation Index (Lieberson) # +# ------------------------------------------------------------- # -# Correlation Ratio based on Bell (1954) and White (1986) +# Interaction Index based on Lieberson (1981) and Bell (1954) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone ## Selected large geography: census tract ## Selected small geography: census block group -V_2020_DC <- white( +xPx_star_2020_DC <- lieberson( geo_large = 'tract', geo_small = 'block group', state = 'DC', @@ -1019,35 +1170,30 @@ V_2020_DC <- white( # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the V (White) values to the census tract geometry -V_2020_DC <- tract_2020_DC %>% - left_join(V_2020_DC$v, by = 'GEOID') +# Join the xPx* (Lieberson) values to the census tract geometry +xPx_star_2020_DC <- tract_2020_DC %>% + left_join(xPx_star_2020_DC$xpx_star, by = 'GEOID') ggplot() + geom_sf( - data = V_2020_DC, - aes(fill = V), + data = xPx_star_2020_DC, + aes(fill = xPx_star), color = 'white' ) + theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - midpoint = 0 - ) + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Correlation Ratio (White)\n + 'Isolation Index (Lieberson)\n Washington, D.C. census block groups to tracts', subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/v.png) +![](man/figures/xpx_star.png) ```r # ------------------------------------------------------------ # @@ -1095,67 +1241,60 @@ ggplot() + ![](man/figures/lq.png) ```r -# ---------------------------------------------------------------------------------------- # -# Compute aspatial racial or ethnic Local Exposure and Isolation (Bemanian & Beyer) metric # -# ---------------------------------------------------------------------------------------- # +# ------------------------------------------------- # +# Compute aspatial racial or ethnic Entropy (Theil) # +# ------------------------------------------------- # -# Local Exposure and Isolation metric based on Bemanian & Beyer (2017) +# Entropy based on Theil (1972) and Theil & Finizza (1971) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected interaction subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: state -## Selected small geography: census tract -LExIs_2020_DC <- bemanian_beyer( - geo_large = 'state', - geo_small = 'tract', +## Selected large geography: census tract +## Selected small geography: census block group +H_2020_DC <- theil( + geo_large = 'tract', + geo_small = 'block group', state = 'DC', year = 2020, - subgroup = 'NHoLB', - subgroup_ixn = 'NHoLW' + subgroup = 'NHoLB' ) # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the LEx/Is (Bemanian & Beyer) values to the census tract geometry -LExIs_2020_DC <- tract_2020_DC %>% - left_join(LExIs_2020_DC$lexis, by = 'GEOID') +# Join the H (Theil) values to the census tract geometry +H_2020_DC <- tract_2020_DC %>% + left_join(H_2020_DC$h, by = 'GEOID') ggplot() + geom_sf( - data = LExIs_2020_DC, - aes(fill = LExIs), + data = H_2020_DC, + aes(fill = H), color = 'white' ) + theme_bw() + - scale_fill_gradient2( - low = '#998ec3', - mid = '#f7f7f7', - high = '#f1a340', - midpoint = 0 - ) + + scale_fill_viridis_c(limits = c(0, 1)) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Local Exposure and Isolation (Bemanian & Beyer) metric\n + 'Entropy (Theil)\n Washington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic vs. white non-Hispanic' + subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/lexis.png) +![](man/figures/h.png) ```r -# ------------------------------------------------ # -# Compute aspatial racial or ethnic Delta (Hoover) # -# ------------------------------------------------ # +# ----------------------------------------------------------- # +# Compute aspatial racial or ethnic Correlation Ratio (White) # +# ----------------------------------------------------------- # -# Delta based on Hoover (1941) and Duncan et al. (1961) +# Correlation Ratio based on Bell (1954) and White (1986) ## Selected subgroup: Not Hispanic or Latino, Black or African American alone ## Selected large geography: census tract ## Selected small geography: census block group -DEL_2020_DC <- hoover( +V_2020_DC <- white( geo_large = 'tract', geo_small = 'block group', state = 'DC', @@ -1166,30 +1305,35 @@ DEL_2020_DC <- hoover( # Obtain the 2020 census tracts from the 'tigris' package tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) -# Join the DEL (Hoover) values to the census tract geometry -DEL_2020_DC <- tract_2020_DC %>% - left_join(DEL_2020_DC$del, by = 'GEOID') +# Join the V (White) values to the census tract geometry +V_2020_DC <- tract_2020_DC %>% + left_join(V_2020_DC$v, by = 'GEOID') ggplot() + geom_sf( - data = DEL_2020_DC, - aes(fill = DEL), + data = V_2020_DC, + aes(fill = V), color = 'white' ) + theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + + scale_fill_gradient2( + low = '#998ec3', + mid = '#f7f7f7', + high = '#f1a340', + midpoint = 0 + ) + labs( fill = 'Index (Continuous)', caption = 'Source: U.S. Census ACS 2016-2020 estimates' ) + ggtitle( - 'Delta (Hoover)\n + 'Correlation Ratio (White)\n Washington, D.C. census block groups to tracts', subtitle = 'Black non-Hispanic' ) ``` -![](man/figures/del.png) +![](man/figures/v.png) ```r # --------------------------------------------- # @@ -1242,98 +1386,9 @@ ggplot() + ![](man/figures/sp.png) -```r -# ------------------------------------------------------------- # -# Compute aspatial racial or ethnic Isolation Index (Lieberson) # -# ------------------------------------------------------------- # - -# Interaction Index based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and Bell (1954) -## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: census tract -## Selected small geography: census block group -xPx_star_2020_DC <- lieberson( - geo_large = 'tract', - geo_small = 'block group', - state = 'DC', - year = 2020, - subgroup = 'NHoLB' -) - -# Obtain the 2020 census tracts from the 'tigris' package -tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) - -# Join the xPx* (Lieberson) values to the census tract geometry -xPx_star_2020_DC <- tract_2020_DC %>% - left_join(xPx_star_2020_DC$xpx_star, by = 'GEOID') - -ggplot() + - geom_sf( - data = xPx_star_2020_DC, - aes(fill = xPx_star), - color = 'white' - ) + - theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + - labs( - fill = 'Index (Continuous)', - caption = 'Source: U.S. Census ACS 2016-2020 estimates' - ) + - ggtitle( - 'Isolation Index (Lieberson)\n - Washington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic' - ) -``` - -![](man/figures/xpx_star.png) - -```r -# ------------------------------------------------- # -# Compute aspatial racial or ethnic Entropy (Theil) # -# ------------------------------------------------- # - -# Entropy based on Theil (1972; ISBN:978-0-444-10378-9) and Theil & Finizza (1971) -## Selected subgroup: Not Hispanic or Latino, Black or African American alone -## Selected large geography: census tract -## Selected small geography: census block group -H_2020_DC <- theil( - geo_large = 'tract', - geo_small = 'block group', - state = 'DC', - year = 2020, - subgroup = 'NHoLB' -) - -# Obtain the 2020 census tracts from the 'tigris' package -tract_2020_DC <- tracts(state = 'DC', year = 2020, cb = TRUE) - -# Join the H (Theil) values to the census tract geometry -H_2020_DC <- tract_2020_DC %>% - left_join(H_2020_DC$h, by = 'GEOID') - -ggplot() + - geom_sf( - data = H_2020_DC, - aes(fill = H), - color = 'white' - ) + - theme_bw() + - scale_fill_viridis_c(limits = c(0, 1)) + - labs( - fill = 'Index (Continuous)', - caption = 'Source: U.S. Census ACS 2016-2020 estimates' - ) + - ggtitle( - 'Entropy (Theil)\nWashington, D.C. census block groups to tracts', - subtitle = 'Black non-Hispanic' - ) -``` - -![](man/figures/h.png) - ### Funding -This package was originally developed while the author was a postdoctoral fellow supported by the [Cancer Prevention Fellowship Program](https://cpfp.cancer.gov) at the [National Cancer Institute](https://www.cancer.gov). Any modifications since December 05, 2022 were made while the author was an employee of [DLH, LLC](https://www.dlhcorp.com) (formerly Social & Scientific Systems, Inc.). +This package was originally developed while the author was a postdoctoral fellow supported by the [Cancer Prevention Fellowship Program](https://cpfp.cancer.gov) at the [National Cancer Institute](https://www.cancer.gov). Any modifications since December 05, 2022 were made while the author was an employee of [DLH, LLC](https://www.dlhcorp.com) (formerly Social & Scientific Systems, Inc. and DLH Corporation). ### Acknowledgments diff --git a/cran-comments.md b/cran-comments.md index 43f8db4..7a405ba 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,26 +1,35 @@ ## This is the seventh resubmission * Actions taken since previous submission: - * Added `hoover()` function to compute the aspatial racial or ethnic Delta (*DEL*) based on [Hoover (1941)](https://doi.org/10.1017/S0022050700052980) and Duncan et al. (1961; LC:60007089) - * Added `white_blau()` function to compute an index of spatial proximity (*SP*) based on [White (1986)](https://doi.org/10.2307/3644339) and Blau (1977; ISBN-13:978-0-029-03660-0) - * Added `lieberson()` function to compute the aspatial racial or ethnic Isolation Index (_xPx\*_) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and and [Bell (1954)](https://doi.org/10.2307/2574118) + * Added `duncan_cuzzort()` function to compute the aspatial racial or ethnic Absolute Centralization (*ACE*) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281) + * Added `hoover()` function to compute the aspatial racial or ethnic Delta (*DEL*) based on [Hoover (1941)](https://doi.org/10.1017/S0022050700052980) and Duncan, Cuzzort, & Duncan (1961; LC:60007089) * Added `james_taeuber()` function to compute the aspatial racial or ethnic Dissimilarity Index (*D*) based on [James & Taeuber (1985)](https://doi.org/10.2307/270845) + * Added `lieberson()` function to compute the aspatial racial or ethnic Isolation Index (_xPx\*_) based on Lieberson (1981; ISBN-13:978-1-032-53884-6) and and [Bell (1954)](https://doi.org/10.2307/2574118) * Added `theil()` function the aspatial racial or ethnic Entropy (*H*) based on Theil (1972; ISBN:978-0-444-10378-9) and [Theil & Finizza (1971)](https://doi.org/110.1080/0022250X.1971.9989795) - * Added `geo_large = 'cbsa'` for Core Based Statistical Areas, `geo_large = 'csa'` for Combined Statistical Areas, and `geo_large = 'metro'` for Metropolitan Divisions as the larger geographical unit in `atkinson()`, `bell()`, `bemanian_beyer()`, `duncan()`, `hoover()`, `lieberson()`, `sudano()`, and `white()`, `white_blau()` functions. + * Added `white_blau()` function to compute an index of spatial proximity (*SP*) based on [White (1986)](https://doi.org/10.2307/3644339) and Blau (1977; ISBN-13:978-0-029-03660-0) + * Added `geo_large = 'place'` for census-designated places, `geo_large = 'cbsa'` for core-based statistical areas, `geo_large = 'csa'` for combined statistical areas, and `geo_large = 'metro'` for metropolitan divisions as the larger geographical unit in `atkinson()`, `bell()`, `bemanian_beyer()`, `duncan()`, `duncan_cuzzort()`, `hoover()`, `james_taeuber()`, `lieberson()`, `sudano()`, `theil()`, and `white()`, `white_blau()` functions. + * Added census block group computation for `anthopolos()` by specifying `geo == 'cbg'` or `geo == 'block group'` * Added `holder` argument to `atkinson()` function to toggle the computation with or without the Hölder mean. The function can now compute *A* without the Hölder mean. The default is `holder = FALSE`. + * Added `crs` argument to `anthopolos()`, `bravo()`, and `white_blau()` functions to provide spatial projection of the distance-based metrics * The `gini()` function now computes the aspatial racial or ethnic Gini Index (*G*) based on [Gini (1921)](https://doi.org/10.2307/2223319) as the main outcome. Arguments `geo_large`, `geo_small`, `subgroup`, and `omit_NAs` were added and argument `geo` was deprecated. The `gini()` function still retrieves the original output of the aspatial income Gini Index (*G*) at each smaller geography and is moved from the `g` output to `g_data` output. - * `bell()` function computes the Interaction Index (Bell) not the Isolation Index as previously documented. Updated documentation throughout + * Specifying census block groups in `geo` or `geo_small` arguments is now `'block group'` or `'cbg'` to match internal `get_acs()` function from the [tidycensus](https://CRAN.R-project.org/package=tidycensus) package + * `bell()` function computes the Interaction Index (Bell) not the Isolation Index as previously documented. Updated documentation throughout. * Fixed bug in `bell()`, `bemanian_beyer()`, `duncan()`, `sudano()`, and `white()` functions when a smaller geography contains n=0 total population, will assign a value of zero (0) in the internal calculation instead of NA + * Fixed bug in `atkinson()` function to properly compute the income Atkinson Index * Renamed *AI* as *A*, *DI* as *D*, *Gini* as *G*, and *II* as _xPy\*_ to align with the definitions from [Massey & Denton (1988)](https://doi.org/10.1093/sf/67.2.281). The output for `atkinson()` now produces `a` instead of `ai`. The output for `duncan()` now produces `d` instead of `ai`. The output for `gini()` now produces `g` instead of `gini`. The output for `bell()` now produces `xPy_star` instead of `II`. The internal functions `ai_fun()`, `di_fun()` and `ii_fun()` were renamed `a_fun()`, `ddd_fun()` and `xpy_star_fun()`, respectively. * `tigris` and `units` are now Imports - * 'package.R' deprecated. Replaced with 'ndi-package.R' + * Reformatted functions for consistent internal structure + * 'package.R' deprecated. Replaced with 'ndi-package.R' and reordered the contents + * Consolidated DESCRIPTION * Re-formatted code and documentation throughout for consistent readability * Renamed 'race/ethnicity' or 'racial/ethnic' to 'race or ethnicity' or 'racial or ethnic' throughout documentation to use more modern, inclusive, and appropriate language * Updated documentation about value range of *V* (White) from `{0 to 1}` to `{-Inf to Inf}` - * Added examples for `gini()`, `james_taeuber()`, `lieberson()`, `hoover()`, `theil()`, and `white_blau()` functions in vignette and README + * Split up vignette into three separate vignettes: 'ndi1', 'ndi2', and 'ndi3' for the *NDI*, racial or ethnic residential segregation, and additional socioeconomic disparity indices, respectively + * Added examples for `atkinson()`, `duncan_cuzzort()`, `gini()`, `hoover()`, `james_taeuber()`, `lieberson()`, `theil()`, and `white_blau()` functions in vignettes and README * Added example for `holder` argument in `atkinson()` function in README - * Reformatted functions for consistent internal structure - * Updated examples in vignette to showcase a larger variety of U.S. states + * Reordered the README examples alphabetically + * Reordered the vignette examples to group the racial or ethnic residential segregation indices + * Updated examples in vignettes to showcase a larger variety of U.S. states * Updated examples in functions to better describe the metrics * Updated documentation formatting of metric names in all functions diff --git a/inst/CITATION b/inst/CITATION index 2d98b10..a2e8dfc 100755 --- a/inst/CITATION +++ b/inst/CITATION @@ -536,7 +536,7 @@ bibentry(bibtype = 'Book', ) bibentry(bibtype = 'Article', - title = 'A note on the measurement of racial integration of schools by means of informational conceptsFootnote', + title = 'A note on the measurement of racial integration of schools by means of informational concepts', author = c(as.person('Henri Theil'), as.person('Anthony J. Finizza')), journal = 'Journal of Mathematical Sociology', @@ -547,9 +547,47 @@ bibentry(bibtype = 'Article', textVersion = paste('Henri Theil & Anthony J. Finizza (1971).', - 'A note on the measurement of racial integration of schools by means of informational conceptsFootnote.', + 'A note on the measurement of racial integration of schools by means of informational concepts.', 'Journal of Mathematical Sociology, 1, 187-194.', 'DOI:10.1080/0022250X.1971.9989795'), header = 'And (2):' ) + +bibentry(bibtype = 'Book', + title = 'Statistical Geography: Problems in Analyzing Area Data', + author = c(as.person('Otis D. Duncan'), + as.person('Ray P. Cuzzort'), + as.person('Beverly Duncan')), + year = '1961', + publisher = 'Free Press', + lc = '60007089', + + textVersion = + paste('Otis D. Duncan, Ray P. Cuzzort, & Beverly Duncan (1961).', + 'Statistical Geography: Problems in Analyzing Area Data.', + 'Free Press', + 'LC:60007089'), + + header = 'If you computed ACE (Duncan & Cuzzort) values, please also cite (1):' +) + +bibentry(bibtype = 'Article', + title = 'The Dimensions of Residential Segregation', + author = c(as.person('Douglas S. Massey'), + as.person('Nancy A. Denton')), + journal = 'Social Forces', + year = '1988', + volume = '67', + issue = '2', + pages = '281--315', + doi = '10.1093/sf/67.2.281', + + textVersion = + paste('Douglas S. Massey & Nancy A. Denton (1988).', + 'The Dimensions of Residential Segregation.', + 'Social Forces, 67(1), 281-315.', + 'DOI:10.1093/sf/67.2.281'), + + header = 'And (2):' +) diff --git a/man/anthopolos.Rd b/man/anthopolos.Rd index 2895b6b..348d8ed 100644 --- a/man/anthopolos.Rd +++ b/man/anthopolos.Rd @@ -4,15 +4,24 @@ \alias{anthopolos} \title{Racial Isolation Index based on Anthopolos et al. (2011)} \usage{ -anthopolos(geo = "tract", year = 2020, subgroup, quiet = FALSE, ...) +anthopolos( + geo = "tract", + year = 2020, + subgroup, + crs = "ESRI:102008", + quiet = FALSE, + ... +) } \arguments{ -\item{geo}{Character string specifying the geography of the data either census tracts \code{geo = 'tract'} (the default) or counties \code{geo = 'county'}.} +\item{geo}{Character string specifying the geography of the data either counties \code{geo = 'county'}, census tracts \code{geo = 'tract'} (the default), or census block groups \code{geo = 'cbg'}.} \item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} \item{subgroup}{Character string specifying the racial or ethnic subgroup(s). See Details for available choices.} +\item{crs}{Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}.} + \item{quiet}{Logical. If TRUE, will display messages about potential missing census information. The default is FALSE.} \item{...}{Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics} diff --git a/man/atkinson.Rd b/man/atkinson.Rd index b097d0f..05f62ef 100644 --- a/man/atkinson.Rd +++ b/man/atkinson.Rd @@ -19,7 +19,7 @@ atkinson( \arguments{ \item{geo_large}{Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}.} -\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}.} +\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}.} \item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} @@ -50,7 +50,7 @@ Compute the aspatial Atkinson Index of income or selected racial or ethnic subgr \details{ This function will compute the aspatial Atkinson Index (\emph{A}) of income or selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Atkinson (1970) \doi{10.1016/0022-0531(70)90039-6}. This function provides the computation of \emph{A} for median household income and any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). -The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. When \code{subgroup = 'MedHHInc'}, the metric will be computed for median household income ('B19013_001'). The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. When \code{subgroup = 'MedHHInc'}, the metric will be computed for median household income ('B19013_001') using the Hölder mean. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: \itemize{ \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -80,7 +80,7 @@ Use the internal \code{state} and \code{county} arguments within the \code{\link The \code{epsilon} argument that determines how to weight the increments to inequality contributed by different proportions of the Lorenz curve. A user must explicitly decide how heavily to weight smaller geographical units at different points on the Lorenz curve (i.e., whether the index should take greater account of differences among units of over- or under-representation). The \code{epsilon} argument must have values between 0 and 1.0. For \code{0 <= epsilon < 0.5} or less 'inequality-averse,' smaller geographical units with a subgroup proportion smaller than the subgroup proportion of the larger geographical unit contribute more to inequality ('over-representation'). For \code{0.5 < epsilon <= 1.0} or more 'inequality-averse,' smaller geographical units with a subgroup proportion larger than the subgroup proportion of the larger geographical unit contribute more to inequality ('under-representation'). If \code{epsilon = 0.5} (the default), units of over- and under-representation contribute equally to the index. See Section 2.3 of Saint-Jacques et al. (2020) \doi{10.48550/arXiv.2002.05819} for one method to select \code{epsilon}. -Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{A} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{A} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{A} computation. +Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{A} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{A} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{A} computation. } \examples{ \dontrun{ @@ -94,7 +94,17 @@ Larger geographies available include state \code{geo_large = 'state'}, county \c state = 'GA', year = 2020, subgroup = c('NHoLB', 'HoLB') - ) + ) + + # Atkinson Index of median household income + ## of census tracts within counties within Georgia, U.S.A., counties (2020) + atkinson( + geo_large = 'county', + geo_small = 'tract', + state = 'GA', + year = 2020, + subgroup = 'MedHHInc' + ) } diff --git a/man/bell.Rd b/man/bell.Rd index b1ddb1e..ba971c7 100644 --- a/man/bell.Rd +++ b/man/bell.Rd @@ -18,7 +18,7 @@ bell( \arguments{ \item{geo_large}{Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}.} -\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}.} +\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}.} \item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} @@ -47,7 +47,7 @@ Compute the aspatial Interaction Index (Bell) of a selected racial or ethnic sub \details{ This function will compute the aspatial Interaction Index (\emph{xPy\*}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Shevky & Williams (1949; ISBN-13:978-0-837-15637-8) and Bell (1954) \doi{10.2307/2574118}. This function provides the computation of \emph{xPy\*} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). -The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: \itemize{ \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -75,7 +75,7 @@ Use the internal \code{state} and \code{county} arguments within the \code{\link \emph{xPy\*} is some measure of the probability that a member of one subgroup(s) will meet or interact with a member of another subgroup(s) with higher values signifying higher probability of interaction (less isolation). \emph{xPy\*} can range in value from 0 to 1. -Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{xPy\*} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{xPy\*} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{xPy\*} computation. +Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{xPy\*} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{xPy\*} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{xPy\*} computation. } \examples{ \dontrun{ diff --git a/man/bemanian_beyer.Rd b/man/bemanian_beyer.Rd index a4af420..2eb59ce 100644 --- a/man/bemanian_beyer.Rd +++ b/man/bemanian_beyer.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/bemanian_beyer.R \name{bemanian_beyer} \alias{bemanian_beyer} -\title{Local Exposure and Isolation metric based on Bemanian & Beyer (2017)} +\title{Local Exposure and Isolation based on Bemanian & Beyer (2017)} \usage{ bemanian_beyer( geo_large = "county", @@ -18,7 +18,7 @@ bemanian_beyer( \arguments{ \item{geo_large}{Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}.} -\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}.} +\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}.} \item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} @@ -42,12 +42,12 @@ An object of class 'list'. This is a named list with the following components: } } \description{ -Compute the aspatial Local Exposure and Isolation (Bemanian & Beyer) metric of a selected racial or ethnic subgroup(s) and U.S. geographies. +Compute the aspatial Local Exposure and Isolation (Bemanian & Beyer) of a selected racial or ethnic subgroup(s) and U.S. geographies. } \details{ -This function will compute the aspatial Local Exposure and Isolation (\emph{LEx/Is}) metric of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. This function provides the computation of \emph{LEx/Is} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). +This function will compute the aspatial Local Exposure and Isolation (\emph{LEx/Is}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Bemanian & Beyer (2017) \doi{10.1158/1055-9965.EPI-16-0926}. This function provides the computation of \emph{LEx/Is} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). -The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: \itemize{ \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -75,9 +75,9 @@ Use the internal \code{state} and \code{county} arguments within the \code{\link \emph{LEx/Is} is a measure of the probability that two individuals living within a specific smaller geographical unit (e.g., census tract) of either different (i.e., exposure) or the same (i.e., isolation) racial or ethnic subgroup(s) will interact, assuming that individuals within a smaller geographical unit are randomly mixed. \emph{LEx/Is} is standardized with a logit transformation and centered against an expected case that all races or ethnicities are evenly distributed across a larger geographical unit. (Note: will adjust data by 0.025 if probabilities are zero, one, or undefined. The output will include a warning if adjusted. See \code{\link[car]{logit}} for additional details.) -\emph{LEx/Is} can range from negative infinity to infinity. If \emph{LEx/Is} is zero then the estimated probability of the interaction between two people of the given subgroup(s) within a smaller geographical unit is equal to the expected probability if the subgroup(s) were perfectly mixed in the larger geographical unit. If \emph{LEx/Is} is greater than zero then the interaction is more likely to occur within the smaller geographical unit than in the larger geographical unit, and if \emph{LEx/Is} is less than zero then the interaction is less likely to occur within the smaller geographical unit than in the larger geographical unit. Note: the exponentiation of each \emph{LEx/Is} metric results in the odds ratio of the specific exposure or isolation of interest in a smaller geographical unit relative to the larger geographical unit. +\emph{LEx/Is} can range from negative infinity to infinity. If \emph{LEx/Is} is zero then the estimated probability of the interaction between two people of the given subgroup(s) within a smaller geographical unit is equal to the expected probability if the subgroup(s) were perfectly mixed in the larger geographical unit. If \emph{LEx/Is} is greater than zero then the interaction is more likely to occur within the smaller geographical unit than in the larger geographical unit, and if \emph{LEx/Is} is less than zero then the interaction is less likely to occur within the smaller geographical unit than in the larger geographical unit. Note: the exponentiation of each \emph{LEx/Is} results in the odds ratio of the specific exposure or isolation of interest in a smaller geographical unit relative to the larger geographical unit. -Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{LEx/Is} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LEx/Is} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LEx/Is} computation. +Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{LEx/Is} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{LEx/Is} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{LEx/Is} computation. } \examples{ \dontrun{ diff --git a/man/bravo.Rd b/man/bravo.Rd index 1559273..39c16f3 100644 --- a/man/bravo.Rd +++ b/man/bravo.Rd @@ -4,7 +4,14 @@ \alias{bravo} \title{Educational Isolation Index based on Bravo et al. (2021)} \usage{ -bravo(geo = "tract", year = 2020, subgroup, quiet = FALSE, ...) +bravo( + geo = "tract", + year = 2020, + subgroup, + crs = "ESRI:102008", + quiet = FALSE, + ... +) } \arguments{ \item{geo}{Character string specifying the geography of the data either census tracts \code{geo = 'tract'} (the default) or counties \code{geo = 'county'}.} @@ -13,6 +20,8 @@ bravo(geo = "tract", year = 2020, subgroup, quiet = FALSE, ...) \item{subgroup}{Character string specifying the educational attainment category(ies). See Details for available choices.} +\item{crs}{Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}.} + \item{quiet}{Logical. If TRUE, will display messages about potential missing census information. The default is FALSE.} \item{...}{Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics} diff --git a/man/duncan.Rd b/man/duncan.Rd index b38a167..e674ce1 100644 --- a/man/duncan.Rd +++ b/man/duncan.Rd @@ -18,7 +18,7 @@ duncan( \arguments{ \item{geo_large}{Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}.} -\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_large = 'tract'}.} +\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}.} \item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} @@ -47,7 +47,7 @@ Compute the aspatial Dissimilarity Index (Duncan & Duncan) of selected racial or \details{ This function will compute the aspatial Dissimilarity Index (\emph{D}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Duncan & Duncan (1955) \doi{10.2307/2088328}. This function provides the computation of \emph{D} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). -The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'csa'} or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the aspatial computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: \itemize{ \item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} \item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} @@ -75,7 +75,7 @@ Use the internal \code{state} and \code{county} arguments within the \code{\link \emph{D} is a measure of the evenness of racial or ethnic residential segregation when comparing smaller geographical units to larger ones within which the smaller geographical units are located. \emph{D} can range in value from 0 to 1 and represents the proportion of racial or ethnic subgroup members that would have to change their area of residence to achieve an even distribution within the larger geographical area under conditions of maximum segregation. -Larger geographies available include state \code{geo_large = 'state'}, county \code{geo_large = 'county'}, census tract \code{geo_large = 'tract'}, Core Based Statistical Area \code{geo_large = 'cbsa'}, Combined Statistical Area \code{geo_large = 'csa'}, and Metropolitan Division \code{geo_large = 'metro'} levels. Smaller geographies available include, county \code{geo_small = 'county'}, census tract \code{geo_small = 'tract'}, and census block group \code{geo_small = 'block group'} levels. If a larger geographical area is comprised of only one smaller geographical area (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is Combined Based Statistical Areas \code{geo_large = 'csa'} or Core Based Statistical Areas \code{geo_large = 'cbsa'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. +Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{D} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{D} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{D} computation. } \examples{ \dontrun{ diff --git a/man/duncan_cuzzort.Rd b/man/duncan_cuzzort.Rd new file mode 100644 index 0000000..03d06b3 --- /dev/null +++ b/man/duncan_cuzzort.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/duncan_cuzzort.R +\name{duncan_cuzzort} +\alias{duncan_cuzzort} +\title{Absolute Centralization based on Duncan, Cuzzort, & Duncan (1961) and Massey & Denton (1988)} +\usage{ +duncan_cuzzort( + geo_large = "county", + geo_small = "tract", + year = 2020, + subgroup, + crs = "ESRI:102008", + omit_NAs = TRUE, + quiet = FALSE, + ... +) +} +\arguments{ +\item{geo_large}{Character string specifying the larger geographical unit of the data. The default is counties \code{geo_large = 'county'}.} + +\item{geo_small}{Character string specifying the smaller geographical unit of the data. The default is census tracts \code{geo_small = 'tract'}.} + +\item{year}{Numeric. The year to compute the estimate. The default is 2020, and the years 2009 onward are currently available.} + +\item{subgroup}{Character string specifying the racial or ethnic subgroup(s) as the comparison population. See Details for available choices.} + +\item{crs}{Numeric or character string specifying the coordinate reference system to compute the distance-based metric. The default is Albers North America \code{crs = 'ESRI:102008'}.} + +\item{omit_NAs}{Logical. If FALSE, will compute index for a larger geographical unit only if all of its smaller geographical units have values. The default is TRUE.} + +\item{quiet}{Logical. If TRUE, will display messages about potential missing census information. The default is FALSE.} + +\item{...}{Arguments passed to \code{\link[tidycensus]{get_acs}} to select state, county, and other arguments for census characteristics} +} +\value{ +An object of class 'list'. This is a named list with the following components: + +\describe{ +\item{\code{ace}}{An object of class 'tbl' for the GEOID, name, and \emph{ACE} at specified larger census geographies.} +\item{\code{ace_data}}{An object of class 'tbl' for the raw census values at specified smaller census geographies.} +\item{\code{missing}}{An object of class 'tbl' of the count and proportion of missingness for each census variable used to compute \emph{ACE}.} +} +} +\description{ +Compute the aspatial Absolute Centralization (Duncan & Cuzzort) of a selected racial or ethnic subgroup(s) and U.S. geographies. +} +\details{ +This function will compute the aspatial Absolute Centralization (\emph{ACE}) of selected racial or ethnic subgroups and U.S. geographies for a specified geographical extent (e.g., the entire U.S. or a single state) based on Duncan, Cuzzort, & Duncan (1961; LC:60007089) and Massey & Denton (1988) \doi{10.1093/sf/67.2.281}. This function provides the computation of \emph{ACE} for any of the U.S. Census Bureau race or ethnicity subgroups (including Hispanic and non-Hispanic individuals). + +The function uses the \code{\link[tidycensus]{get_acs}} function to obtain U.S. Census Bureau 5-year American Community Survey characteristics used for the computation. The yearly estimates are available for 2009 onward when ACS-5 data are available (2010 onward for \code{geo_large = 'cbsa'} and 2011 onward for \code{geo_large = 'place'}, \code{geo_large = 'csa'}, or \code{geo_large = 'metro'}) but may be available from other U.S. Census Bureau surveys. The twenty racial or ethnic subgroups (U.S. Census Bureau definitions) are: +\itemize{ +\item \strong{B03002_002}: not Hispanic or Latino \code{'NHoL'} +\item \strong{B03002_003}: not Hispanic or Latino, white alone \code{'NHoLW'} +\item \strong{B03002_004}: not Hispanic or Latino, Black or African American alone \code{'NHoLB'} +\item \strong{B03002_005}: not Hispanic or Latino, American Indian and Alaska Native alone \code{'NHoLAIAN'} +\item \strong{B03002_006}: not Hispanic or Latino, Asian alone \code{'NHoLA'} +\item \strong{B03002_007}: not Hispanic or Latino, Native Hawaiian and Other Pacific Islander alone \code{'NHoLNHOPI'} +\item \strong{B03002_008}: not Hispanic or Latino, Some other race alone \code{'NHoLSOR'} +\item \strong{B03002_009}: not Hispanic or Latino, Two or more races \code{'NHoLTOMR'} +\item \strong{B03002_010}: not Hispanic or Latino, Two races including Some other race \code{'NHoLTRiSOR'} +\item \strong{B03002_011}: not Hispanic or Latino, Two races excluding Some other race, and three or more races \code{'NHoLTReSOR'} +\item \strong{B03002_012}: Hispanic or Latino \code{'HoL'} +\item \strong{B03002_013}: Hispanic or Latino, white alone \code{'HoLW'} +\item \strong{B03002_014}: Hispanic or Latino, Black or African American alone \code{'HoLB'} +\item \strong{B03002_015}: Hispanic or Latino, American Indian and Alaska Native alone \code{'HoLAIAN'} +\item \strong{B03002_016}: Hispanic or Latino, Asian alone \code{'HoLA'} +\item \strong{B03002_017}: Hispanic or Latino, Native Hawaiian and Other Pacific Islander alone \code{'HoLNHOPI'} +\item \strong{B03002_018}: Hispanic or Latino, Some other race alone \code{'HoLSOR'} +\item \strong{B03002_019}: Hispanic or Latino, Two or more races \code{'HoLTOMR'} +\item \strong{B03002_020}: Hispanic or Latino, Two races including Some other race \code{'HoLTRiSOR'} +\item \strong{B03002_021}: Hispanic or Latino, Two races excluding Some other race, and three or more races \code{'HoLTReSOR'} +} + +Use the internal \code{state} and \code{county} arguments within the \code{\link[tidycensus]{get_acs}} function to specify geographic extent of the data output. + +\emph{ACE} is a measure of the degree to which racial or ethnic populations within smaller geographical units are located near the center of a larger geographical unit. \emph{ACE} can range in value from -1 to 1 and represents the spatial distribution of racial or ethnic populations within smaller geographical units compared to the distribution of land area around the center of a larger geographical unit. Positive values indicate a tendency for racial or ethnic populations to reside close to the center of a larger geographical unit, while negative values indicate a tendency to live in outlying areas. A score of 0 means that racial or ethnic populations have a uniform distribution throughout a larger geographical unit. \emph{ACE} gives the proportion of racial or ethnic populations required to change residence to achieve a uniform distribution of population around the center of a larger geographical unit. + +Larger geographical units available include states \code{geo_large = 'state'}, counties \code{geo_large = 'county'}, census tracts \code{geo_large = 'tract'}, census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, and metropolitan divisions \code{geo_large = 'metro'}. Smaller geographical units available include, counties \code{geo_small = 'county'}, census tracts \code{geo_small = 'tract'}, and census block groups \code{geo_small = 'cbg'}. If a larger geographical unit is comprised of only one smaller geographical unit (e.g., a U.S county contains only one census tract), then the \emph{ACE} value returned is NA. If the larger geographical unit is census-designated places \code{geo_large = 'place'}, core-based statistical areas \code{geo_large = 'cbsa'}, combined statistical areas \code{geo_large = 'csa'}, or metropolitan divisions \code{geo_large = 'metro'}, only the smaller geographical units completely within a larger geographical unit are considered in the \emph{V} computation (see internal \code{\link[sf]{st_within}} function for more information) and recommend specifying all states within which the interested larger geographical unit are located using the internal \code{state} argument to ensure all appropriate smaller geographical units are included in the \emph{ACE} computation. + +\emph{Important consideration}: The original metric used the location of the central business district (CBD) to compute the metric, but the U.S. Census Bureau has not defined CBDs for U.S. cities since the 1982 Census of Retail Trade. Therefore, this function uses the the centroids of each larger geographical unit as the 'centre', but may not represent the current CBD. +} +\examples{ +\dontrun{ +# Wrapped in \dontrun{} because these examples require a Census API key. + + # Absolute Concentration of Black populations + ## of census tracts within counties within Georgia, U.S.A., counties (2020) + duncan_cuzzort( + geo_large = 'county', + geo_small = 'tract', + state = 'GA', + year = 2020, + subgroup = c('NHoLB', 'HoLB') + ) + +} + +} +\seealso{ +\code{\link[tidycensus]{get_acs}} for additional arguments for geographic extent selection (i.e., \code{state} and \code{county}). +} diff --git a/man/figures/ace.png b/man/figures/ace.png new file mode 100644 index 0000000000000000000000000000000000000000..ca49fa343c852a6b7514e101084ee038a3bc1034 GIT binary patch literal 286207 zcmd>mcRbep|F4!3O$k|*t&D6EEoE;)QbclPgp}+kvMPJ8>=oIvlI)pLk&=)yBBJc` z{B(c6zw$Fwiut0RcC#^d-tBC=kKm(?4o8?=-d1Jj z>Z<{j3D+&&=lSi}!?4}MT|wkv<>1G)wbBOb>bbZZPItAB_y30v z&LE|>laaY|hlYemIW0`ij<%@AN!?wT?3;L(+tSi1nJQcm<_oZy>jt(z9eSQ;KNF^E|))(Y_P@ijFyiHeGj zlxU_Z^;Nsc#NW!!&bF|yFfcF}`1=(lYB@eU+?{yFdue{cFUa~28P`7F#>U3Z&d!S^ zRwtYmloHhnE&B3rynD8`wibK*j_8!~b}^mKkx!LQm&$LO($&}04E1JR=m{py2bpu@ z%-7A^CVzeJrlFx335pi8u5wu}wi&Kp;;73%8rkDL@Z_3Kxrb>Vo*%1MUS1w8z)RO>StZ;)r{qXp>ZjgpR?7!mLC3SFzj1`kRqDy>VUmLEjF+if(KQ&O7j$q25lcDsAGEMv}i zTbaQco_Tp`X*T!dP;zSO!nZe9hh9C{{@}EKMdagV*AN+9@tgIUT>H*=@6;|Da+490v^R7L6_8h>Y?Eh+Z2NQsE_zI%6Pe!Q2GmT#Z+5jBz4 zco`XS@d(w{IzL)5%l=zfV`DRU3bD7lA`MI8yml~-Ty03}z>Ct5sqpd;9wI64fdkej3;N(~tCt*nD}7XM0gv`Y`s`fUeBV zrB9AwycdhjyE)1Xo~d!2d&GEm?yIu!`M+=X0Ov^o+cJYb76tP+Pi5)p=?DDwwS@7W z8QvV>dphx3Zx*fgy)L|aoEgXYadZ8aSFc`u{J7egcxHX+UA5!Fq@J4EOBWhCI`NyI zU$(~{_lqzmd-66}KDhL`sq6acowyqT2Si9O-8VQJH;>L@S=u9oPM|pWa6y3Np_qA=P);nI(UZG5lFWmZ5#of{7(5Kg^ zPyxb&gS)XW#@eDA1eDI6eccqy>Ai#D+PD(&p4@$m+9`Io;$-^y`j#eyhrer$6e|1d zxpkLewX3DC^9F&5w>jl^rkTr3#(OewDmyjqou2*q^X}3wZV~<;Gefm4&CT~)*&lXv zcL%dOyZ0V`zbR^<(n(B8%3yJ^e7efc-k!#p8vC@WstQ{lwJN1*>1(ugP*Bk3!NXb` zaNjsNwc?Lm^%@U(7Zw(VB7P{`qQ6jn(toIaJ9)$jr{bifq}jO;ZcTwRdxFHEVoo1I6A-nEa zo2rwej{-XCvH17v%P6Xivz-c$~JiKf}AaziuTiO=)KU^+A7BBx+8To2N{9 zRg=yI41D}p_Mm!ofx%Jk-mmn`7!KvA$$_$NccVv6zrGDkPpk6jy||TOz$Yf^Ms|gi zrV{J>`0)i-W(ixij%S1QbW#p8Z*W6Gkg=ZV!GrFU8ml#R1y^b|%E-vr zHf8G-%*<|9%e;`QLY`5)y$fBnDWS5mQcmwx0FA$qwYALEda6;gGJ`5q+kdYKC9x(i zU!D~FHawiPB7jzDyNEu`-m;ghR={m-k(2({&!35;P4ivp>a3)%7fEv4$KE~BIM>+PI#6KNfrEslx$!pp`{&P{Sm;A%yjD<^?)(@CY%=j;&w7i4 zXu0jpn>WsH9oN@RlrUmE-htvS`!NTqZ0jY3s-EowZre0*X5q15K8mX?-{&GS^p!`dE` z_Zl1Jtm5B2yA-{WnVdX=OB-}u&Phu%L&1rOiRmvi7qaXxeDdT;MTHcv`GMOZxtGf8 zc~M3r!h1$r!q=zQ*QS#mOJ}MldFAF#qsHM(7TqG}=i__y@S$$OwKgn8f3fAoG!-UX z9jd&jW&f`h{%V85>*~6?5$>#MGIwY1ugG$$#w8#AHQCo)f8Ck%)_;A-i%C4z=_GZc zg3z&cBi6QfnfPVkIEza1HnA?wc;~KXmyX-Y%gH_Lk1!6IQRrd`Y;A3=_1>i#DVXB2 zyr80@vUBIoA3uKJob}@^J3CiYO+VVE>lHE7)RZo)a^Ktga;2lTNdNPz4g0olp^Z6y z=b7B%v8Dj+in+`Ff|v7`AF9>m8;ad}aJoiT^iRA|`Ryr2M#hkMKR-V}j%J}O;#8|` zc}{ljV&0VvcQr0mI)<*?#yXCaY}l|tDmaCFN9nEadt36$%F0;JKkBhn_&xEC|Jbp> zF^+xP>oPRc8hwrlFAjOLe5!WqaEl)(zoTmQ`=XQ6vi-!{(6F#^C9MAu9-ihr@yz^! zf~F#!Y~53?if?aS508z_F{jQoto-7&*p-YDgrgSTWa2#AI*0<5zJq4pzHQ|c(whf1 zVFQfm*xbCS#uw6L!XRpqS6uuyXbpFGZf>qO)%?9W$Bl+4Ve?n{7DShfJJI{>+t^sz zi;ws3-^c#{Iq>VX5B2)u7|Yag?+*5vKR>Suw);?Xrf<9S;?__kJ1^Q#8hiZd)tj|D zW7+-V{B}E>zSayMszv5Zm?_b~>Uy+(5N+$FH(3Dnm26+%?Z=NF|FNOAzyC!=MU4N+ z`I!9T;;(bbuQPAN$jQkiND7hi(aU4MhlhvnVibQe#u_F#M$2c=8EIi?7}p+kJ;={b z(ZnQqLHLOI@O=Zm%g>FstX~=$8VU>wdd2xc%JNf1q*65w-A0af@6S#ri+&vC=OX#x?FAjewDau1w1xM|A#-l#8y)s#x#J37FCg$dM*H-TG9&cD-;Jm*&v{zW=p?Z{$ z%}xf-$zNE4WHqi^&kkD*zXtM7kB?toW;n< z=wh+OkObdUjD($rrslhBy(Dgr(}@7%yC^A#P&aii5a z@87@Q&#Qm-+__@Q4{skHU6%>xyL8x-^_>51HoZ8u_nYeK>I@AH2W~F*kAD5?=;V}^ zoSeS%tksOVPEgC}pxe63*|Ycit#fj6a5>87n1!!D*>J}9$Uff3nG2NN!4-F2cK5!t@@hsbsGfGaj zLHflOWq=^InG2<*rC@8!;y14V^5V5vSvx?>Ufrkg7`u11pCK!QPVK8-VCv>N!FUGA zJM;8*6NzhMj1smZY4NUKg3l1QE}f+GQF3D_vq-=Y7FBy#&5}%Nxli3%<%!gZ6KLNN z!NEytTqc5j*hQjN1J|vsRb`Jm{z^}M4Wy%7UszB8ymbj2Qe8dJfbRm=K2uXuA0MAn zr%q{I^z-!eOcj$sVVa(tR2r@M@L?H6BQi3w*@Tjk67?OcmARDE9wU*&U6Sf(cUo}? zuhlDXwD1cJ;a4s%*iy9ww^Gf zySBEn2zCg#%@NGb&c0>KmK=k!AOm&#p6R#~PH{4B(yXjW+1X&d;K2ZsBO@aO>Al{0 zQbe$$m0{uQ{i^iM^j>dz&TCh&JX`uu#3&x;bh4sLY0^%Yzb8UP%5R&|V9XW0;;Rjh zOgzp%VpI=cZHuNhW(-78=`9XJ$$fDDesW4mlZoJH*)5QO-u8ZwYi(t<3dN>u6%}6t zzO;7gqAgm+RDnxF^7`4pW5UH zIA3!0c*YkL6!fQk>FUxTwcZ1w8&@*W96o#VW?p~J$mpoLHUp#pY`@H7qqb$(U$i-{ zt4sP`Pum+C(=V3rMNVP`w34{@Z6|SA9yyYQ^L|4?R6?T6v?a{MSy8d2uu!-t@W`d% z*I@1$N&ENhOE&j^1Qh|bJU9?Lf;YTnapW=p|8|~Tz~5qm%4=u)H<^5-=N1rnazI6y zo0ZiwCNR#34p08&i?MQ_Xui!Cl%4)Nim2E{&G$BKEqsk`1p1h)1Aeq4zE!bPJTNX! zrMKJsfU;~4OZ)bZ;)h7)919ZJ;b;Ou+;faNDl_#IKX%ZiK!nJu4@|W=?a!J|>gC}X z1>Z`q^ud|^{P_ycEXYQq_)|lLYxcI8&F$^aw6ntc83n1XT3hG3bn={v7_TRB1W>QE zIM;OVE7BF6^lCrwQT(~yf+Mo>ruh8=wKUdtH>v`m3bmPYI{JYD+ ziUd}#Ep~u71HzpC(HGRH=*GK7g-^4yvyg_;>z!AZ>|I@@X#u+v00L5Z-)3Ey#x5NR z0$@@W>0g{111f6T!pqBxBhvK7f(v&S{QKwZ?3Xa?M4)hU-^)HDU%$3T9P>1={nnWX zLaL{yml1FoFbU$slibfzZfh$q?`=AFEh#*sgee*A3Q zHL$^M;V6aCrJ=6yYpIgnXU?2yy0W@7zeQf>GOpJ|fR(kDt?wX({aK(66kG+qvYSJ% zfbM%fz2-f7^lNM6-0)+WAWFB@`3r(vt0^WNTaMNW*pK($Hk#?xCM%~ z9UBVh9r?vGw?$R+i*aPfj*kw~($XdZf`S^8ynlHJJyc7&N2Yq2Z%-;RZP30@ZrZZn z_SU7iRHewLF6Y`vy_vC+_Pz%B#&tNydwKfj#yXl3+TT=y?tdu1W6k&H+Z)zi;p*id z#|2AqSZ`1Do2$NUZ|9Seig8Y3lai7W71deR|7zWxstlEhQYBLG!8mPpb93|fw>L>6 zt>X}7*r|`XlbE*mN~lX|{I~}V;|XUP4<{!lY2UuUxOID#)wcYjeZ2k6%_PVXlEFoJ zc?mpX+MK(?;tcqv-{lgzQyDwp&E@jjIsJ{HKfDzUq9SJ)InH-jzk3#&`t{6nmtSwr zn+Wjowz2hn-sW&Nz4-og)$$|8Bl0;32?z7D36a87FmkrwS9s9kzC2V}s7b59g<93N zw{8s-TQV$4r#mP)TovK1Y<51@6;i7E_U;+l&GS|bAItBszvm*VM+Aegiu;gZg~KUn z&ASc`Y9D3fvD72M1qOUT*U42E4N9zH+r``4+ra`qdu)H;5$zXU+k1;k-I9i+94A!< z&`Hgqqzg$C2v6&L#^JOji>_pfjvwZDj8-MNcBtm}#!=hxH;%*g0nR$v>Ph5%oWej@ zK&TNhYUd-3B5=3pgAc0ioxX=+^WDF@#QL&eL}X+Wr;OwCf`VmmqoM{Qz1zTedFTki-p&J{vLGGtlLOmy?6EIcSRx1 z*jg}c^nHUoJVAY$IUT8Aca#2)2kbq2@YLAbBSDv47iGqFhl}7!qxBVM(!x zal3AqsoU~Y2^3OI7k+W{3}9uBF)iB18CKb;Db|tv4pDn)Tb!-Fd8A*+Wu_Mnes`Ea zlP8U@$B@;kCyfUeQDj0;0pU~R)2nhWGmM`5{d-Kp@uk?H^BMA8EYeD{*Rf#qF#<*& z?fv&b0~=nyo&+?9U|8$5qoAmWy}I(|&_;TLd=rXw=2C1)R?p+NC!za~y|~5&q? zAaqTsElT9>GsVjN)O+_DE2(J3&!qG{*Z8sF&Ye5bo8G9|Xl=C=GX(#*rPHmeufLN{ z;0n4hUd8Rt%uuRwv;&9A{5FmT6CodHLQm{y#KpzWo;~}-x>Akj-LCLbVWA<3m4&H` zg6}i6j|_JUQx%2x?7YiHzu~bQiNqsuwil(RNGbB{Bnc6kwV$-o{x7aJ4ZN`TquR+N8M6KY z$~;HB_hS|rE36#LEJXeQ`6ry*zh5St^8CZ5sND+nZ?d4Et9!Vq(t@0lV-$$B) z*VlemH?c#3(vnS7Q<|-1=WA1P*r}PsDPq~*^GA3`aCrE6a`bo0%oqU=<~=_Gwz5wJ zpLwERL<)_FAark{&(R6EyDdNC@VcbH!G8tP4^SA0@;Sa=b90J{ijc18MdG?3*Qmxz zE2r$Hq3KOijfbi`Smko@$%R}c`>P^{jx{^GbmMsMpZ8KZG)Us%<9jxn_SeQqC+g(4 z=FlTh?6D6hNgYn72B_xJpIDCPX;2^E3uBmC)K zHYzq1Zm|Fu4G+Jdp|Q72fQ#!JFv^Yt!hgOcJ$`n%S|vx&;=O?F42zc$esYCQgob

baH{zd-8cGt{`#9sfsX95^=a`W@^;qLtU^(#3!8R!p< zbRC-pQy0Y}*jsfRTLEjOUl=#swt$ji&)ulnObx%B4`@qQrO4(xq!`sd zx=&x+15$&&Im0+!^XXHZ+s=$;rr9!;rv84(!-tK5cQU(8?VutOJJ-4L>g$Jl23>w% z!X40Z;}E%P4!wMFOf$o%*2|=GVBBQ>wEYJyu6^~bU6Jwe);EXm1NMf8)Ap@}JbChR zeU-sezHF=3gpZP};zTS5R>-V9W^sAC8uY<nuvJfQ)+ci9=$xWz$=$ASSb296TyXINEq8XPV6_3n< z#cuB!Fb-nKdVL=_PriUe+tQo4swyLKm3)pcq}>&o4S0$Z_QKKO;*v}6fkq2y=+En( ztYwMbH%i@`${swBjhA*g%*rYxBm}`~FzNiRsitctCbyq`F9q;KQJ5~U*Et6njS!Ts65yw z)D+Mw;1#=mI&|@Lie8bQDTzyQyy0&t@+NcJaLSr!1gfgE0yUsEwrU%d6%-ZAj6&?6 zdcAln;b94(wgHU{d*SKRr|IeG=)p`<4o?pJh!nE>s>H&=a{2OQ(2-eqO$tgBb+ z1^lzJZa{}kOXH-i$zE_T^9cxm5t7s|*$kGkytsJR$;oZDi4(Ylb)p}Km%Wvhmy7E< zmUJWt=Vaozsg3F4&{w@EpZf<)8?|bEprk&ca$V>%b3P!hto>@@!3!nW=Zk}{MKX?t z2OUfI@xw|bR=&*8EBFeHU3zhZ+V+r0z&*$=zkht((iA6emAy~B!|hbF^M>y1{yM=$ zH=kn#UVj_m6Y|W~lh*62({4?lq4_J%w|5i7)FJ@2>^w+vyQH6o$Huk!16pG8B&CbI zP;BAx!>cbzNJs$9#RbDEJuWO9;<$Hh;e$0i<@6PU9Q`7~1sfUR^32G{fUc1H^T?Mk zUm6nvJ6G*c@Ch8* zHGEu4?}lAFoanW*r$S)F)3lG+8BK-e-G8#LXYMuR?-8!R#S7U!{itw@n|>IEtVter zk>rJ+Gc)3lcB-qZQ@6>iuN0`Yjc}Ab*LZz=eGB*817+e+LN77dU0_6TU}txMZ0c`m z$Pj==jRc{Fm47EpORfCG#6(H4RrHX!NC?Iw2OA-ud+o5lgoX!R?{)wFzJ2?gSLff2 zT!1xUqN?5HZ>O(LSmFKm}_}D$w=V<086{T%Q8u7lfR-60#m*7NFA2eH+`EH%v6+@g? zk2Jjpex~De^y{`XM61)11P53(D7|@a()QcCjhEOcDO$8^z;%Wsf##3 z^$!Ux!lMZsY&OZqnMK9q)6Gk8`uzj{_C`WiT*XdFS4kMD9dh5WsWCTQkE;kC>EX*= zcW&Mk$R4H>Ie)lA{U~bTj`v~vvE$f1p*{^&KQrJXY+LB3n>KEQgYWpgi+woj35Qa| zN%HBzYD6I}d1@*uE2pSL#JjCU`d+nidg;t4e$$<5ZA@l;Na82I2v@bR-KONUG|e+v zj~OL2=5Nlam${Zogk0-NAjxC|sQE6;q+DA)!2gwR_MZ#}}D=D%)j{_Ie(=9GhgS^G2rreF2HZ8t$A+QS-LO79Q zzWYeucx)TDDC>r$6hGTypCH0S371l^)P6!I?gS&fmxRmGEn{P}Tv~z@g7vRVTwWJ+ zmHY;NNZ?}wLGv!ax@)>5nYBNx^o9BPOJDr>)5X6QZ~gUZj*H81~9fvB~c=tSExzBt)RlC!Bvy8#ZO=de&B8A};o+U2}Tw*H#f{ciuv!$>%WAnN6 z$}bVr!6er9`gN|3S5GoEnZ>MPX3wzmobi7H$4t;+<&RC=@1p=4C=wTo97`%H4Dwo! zQC;GZUV%P<%- z!heMp93%yXhT7w)W4WuH7iV#-3_9!T9*kFfhfq2-)wZR!widm3aU|0B+`@}h@b-@b z1Ers#!7fY>c5t>03>c8uj7ck8Yw1;CI0Ri~3Jwn9@tn@=q*9V{=y3oSI#|@Sz-}`P0t%>cT$hs4y>qNlC2)Z=`kM#%$S zMt@qDS_E35uViFpd+FLth)U9>YVBhQ#~5E+Rl z)U}^p*ef>Y$beorS{h@A=wBn-Uw)s~Gc>e!vag^l!GLeD;;v9U4K2T+5_#FVhs_#Z zbUsl538kgtN00iCy+BXT?0pMH`Xzp&>fS+J*%Rwq_@QETTlkr>TAvut{*<2Q#Pdp^?1v!(wJ64173k-1Igy_JD$H(m<&VM0Nec`}XhGxWtW&M0&s9O)z$o znP}^(H+>)AP(O@${o&1<=Rmy%ov&VbII6`9n)B0Xl#7#R zB0vaQe(OlYFo{~wt^We4OV7poEMBF&)3%8hiXgE}tvl56r*4Wyz;J$+a$SY#3M|b6a_wzajlV$<|%W-waYv z!tg>puU1x^H`vKSUzr_gf<-+P24jX0K|#F8)42a@@#$w>VT~Pj*lJg#8+O8WWShvt zilU$`jqOJAz~BD^AqR! z76G{bpwY6(q}D$lp*kQe_x@NFTh(*lJ8ORGUn%2K`}Vh-`{da8GnFnhLxiZ%pEupB zr}(UxsFrP58D)@86b+Wig#ZcgR@;?P z`0?#=CoZ-;+zbosvh&X^5|6rr*cH>oWI!Fd63=YqOIPE$3oh~AI$cJ8bx$= zs(Ci-hNa4U{PxkZ5jff~yoyOmVW#kMe*bJ>(X3P}8XmNMQ(Nmvx;y*(_c~-|ktw4x z1Lobk^R71Rv>ifI_5WTdM?pn(>&_j{@XcGd?t+Za;aPY(@qNB2rARRH87Qv3A!mdJ zHc8QU9uJivZSRD2Okx>k2QhDH@yo2ZqIJ!W=53~SRyuPAGz@f55e{Vv*V4SL?IS6X zCh7GSq-z^%LPJ9@!Sw1@m0?0mOXAqxS^=1B?3aht*l$zt2a)eMa8$qWp~08oVY{DS zWR-tHrBe)eO~=UC>hf%#>BEEYJY>lW^78?jP@f?sAK&j=}(7-i0S-n zcY}m+tV_7VxUcbIN9d6YjR$*|wh=doW&3`2mR{*QknZZ)u$+hioa1P<50^1Z3vC(1~qYwj~FYB>$WT3Rg2}ljqnu=2x&laNTfjP zO^vt&K*y(F#7I5Y5!mGB<_7CL+Jb-_fW1&CkDU*DmY6{FHHhoZ`1t5`haZp(8h42V5VX`;al7iSXbJ-==jgII5xkw}}{CnCBO&Q4$(-;KW0L0SU5A9)ORN`P? zNHNjjW^j1)3k!&ydr7d4TJii%Otk zxX0LanQ=4!*k3U2(yNqUe6i5cIbg#;Q9-(G9Gslgaqhx}cZkBkK`bhWIBHO;#t}>r zB(DQo`SVycooSWB?>#z&#(kgbDO}d+gVJdu2zYFlL@cse9TId7>P!+tF!Jj;vm}4a zA)Qoeol)-tM{w#4l^r5$=$%P+6M~USMFoksq0b>q(HUoP`}Trayi2`|^7-=(=-D?^ zgWZPj+deds{$Ou!uU)103h&fZk7U3f)ZZR~Lfa!wB?;p}FFA}N1-Jvfd?J*+88mFM zQ0ZaeR<`ux!*@e=WVJkL86B}0l0>9JL9hIjhzTN@IwCf9Rx!Khy(jEH{}EHk`x0{P zn)Z52{v<+QjUo28=S?5nh?)8I3*7kKkrIT1x)=jN=LnH%Py#qJxIajzN3m%@r9C8M zAL%`#wB)UCPokrQ>%aa7cDoV(k0cHPX~Z{FCTIf5#I z<4IQ<{_K9 zTz0v zY!cC3fKdKGA#yyuQJ@vnKlE}&l|&*D*~RsV0l*-Dri&iEz4*GK1Or?AbFw zQ^H9GA?t86*s^A=auY?;>QhCT?PxP1ixQHO`uh5!=3OSxJ>dtSc^$es>t=VFTT)W; z;K7#-4c;+Y24w=;SGwgO_?+8e#^CLlu0BS-kR7%;#;oQIQwNZiSgPMU|U(r+)X(eHTr=u&@A( zJ>H#0L>Q40VLf~p5{G|BfjfJ}uk&ntd_Q2=v4~k206b4lO(A;&?m*Z`Fm~4})9Ok? zT4zSIzB+@-;&S>s3iq&{W8>t^Qci>%fzV|0b!_`r*B-O=1!$+wRSQ;0)a=RA6`l2J zA7Af4KsAPO*Ek%TC96He9nYk~e8z*NT|3Cs%3!cVGDqc+fw}}(hy!m zZmul$89&@l}pyA#=~LU?vI1uf@r zEp>H~qB3Zny-2Q?b|4XOJ(Bp+ZW4KgIn0ehESps9)xaGiW(TT-4uJ=^#!UF~zZhbMVhAkyS|i z4dt=1vlAYojB1Ry4IZ1?wu|hfHV`@LvW9^{tAIb^<#>Nc7%0VZ<0Z%hj{WPA!U(rx zqc?Zp_W3=2EcW*bgK$21E^^R$QS8_u+wynvNx;F5C<7p-aVz<5ACxi$(1pVSwm4z`~!UrN7aX_?Vd1 z%G1Omkh%X|MdJU6uP6Jw?Ee<7e|{vBPqg{ZAK4!Kx8FYSH?sGyUp}b;P3k|s{`-Tq z+j{8n*PUnN<(tr*_%2ti;M@S%RJyJr4_SefFfgPQR9q}8Gy<4lXEe?JYi6vlCYt)C zA`o=jIuAGZF~Kbi4AEdB-$Nf7@Bx`iMxJ(ctuo|}@I-icmJ`z0sq~O|sk^6BoiWao zsNt1q1eHBAJW(HXI2ZCCoO!4DabiG&=7MJL_11(GqtbympY1 z6e{e?*UB4zOaEOMcZKcNDrEe~FQC*w{vQYezlRvH#tlmxu}n2ekesXwhe6PZ>?1mV zZBvua`uJDR0f2ZN-;lQLErcYBJ`ML>%-)cPI#Maskv>yfU0oeTI6gi;B0`Q2;gU9} zK^V!fGBssaVeTb*?*DBPimc}O(IbXNe55a_8uPAuv@An^Su3%(6+7geA+FosTa444 zAp3ze=zEnqsAuWpuh8r!LK_idYy6C%kYD;tnO@*EfC-Ds%P<(DCHYxmAS}7LxuLCN z_sJE&vi$e-l6BF4} zGg}ZufD73n6Wg7p8eD_yP7qgJ@tW>kx|ODIRvtNX1xJwh(EnhXXF74Nc^|!Ayn#_-YOR- zK?lg44^A7IH)XjTk(Q2|&_;q*e!;j3p2%Ng|5g4Z5vOKH{%N$}uonGTNBm{PT{7&{ z?UfL1frgRUq8Aq0GK$-bDJoSBjV=U<@W(j^ETMaY`c<#Y`pNYj`9Dn~l|XuGyNicF z64;592Oo}%6JXed9DQ~T9jxQ6%w)H#Jm$r9o=n8?J$MkM`!e1%m?1(}n&hLlcM*jQ z=1~5V?F4H5V-6wy`ISXGtNUT-?>{YK7lLQH#Kq3gnZ0?BuXP~H8@Xi0jKoMn}HnF>iF99+Xo)i8oGI3PrWMv`Uq96~9 zp`ipY9S@_#I90^h%^8#gR!_+9U(4oqdBYr1B$`%+-Dd6kkP^^LF)f5@pOISywI(^4 zt)`^Z>Z9a%5XOwg5yL1fRC?m<>>MZULb`hO3?Cy#wDj~MpOpQr)WkKML9zRF(mtPK z(7O}<*29?NzY98~CkCr!XpypUnIET#zXe9wcm-#4F?$Qy>F0TQ5z;P_A}QqSNC!6e=?p|Y5L#Cd5BlTm%9!2x8wD9&zR_?Tvx>7i=eWX5d(F2 ziiEDA?#7yY3&^mvw{G6N-e1TapR>t5k9-$1F*9T<5A)2yq0~J(q27nomD~hlOxrA? zGXoV71C=8|xDDu)SLgl;g2aoR!`#=mn)db|cu&I~SYAX?y36+WbvUBD0nZf|7mqmY zLgnp_Yy`!gotrEBj6~Xw^o-49r;h68z3k|CY#?~!?a@TTI0x7wSkXpyoW>q9GX~Q6gXy)y709s^y&8YuO9F#v|WiwH+o|1kzgu8?VuD*SAeez&!PrD zdi1CY0=$-14~}1VR~L}uh^eMdl9b4P3poctRro+R-h!qp`7D^E~*Zr$n~6T|o;3rS(PIq;&FaDUMhaG$X5;7xW!m;61A zkf!n`SJeJD03WEl(0XVX7+Ufz5aj|Vngf(YQYm<1XEoX^5Hq(7ki-h0sKNH5E&cud zJTjV_W+CR*H#hrI!YS;@&^)hrO;AV(Ia^pbsPNMq92~HYaD)KqF?PD}y}RMvyApko zkFrl+AMdnqfe#BF=!5~g5=>^902ZC&I1=21wLAAWlon`C7*3_74#?2s`PN5*RsAdE zw!pH!3l8Q-%MX*9>(HT7dO=v5M3iWpB&#=1A5>X;LCXRbB&M$d0|UWLpws~`y#egO z$lh;cMqYuSRA>}Fnf$dsS^UJ^SvCoacleu%%1V2yB?wpGu45jEa9qqc@!4EP(+mWS zoEjz@`_Rv!R|u1O8XFqY+}78?ZY(+z?xjcXPu|uWRGLToU_X>20u_{*U`7e0ZZD6^ zxra_HV}QnBRhq6=@J(%__`*yP?#Ks~!M4TSQk7mz#?zskhN1DfzuGxzbyIz3ysJk?1T;p6rM~AA@%IfmtxuKPRX90fO1w#F5;YE5L2xi~{?2i8K zLlXutnuTQ*<>U?yHg#HkdF_MEu`B*^jv5zs&FGIG&xG1oT>lJV&H6RV-PWbcn#=6Q zAbPfp;uNs{_Q}NNL9FV!{323>Cd9zt^}!b)TegWx93S$GJd28o!U+B^BqI~w@k0Zb zr(falJdEC-iIEYJsWde%-LQ{kcAO;@NY(YUzY98|0VJ2&I+G#!yrcxJ@shcD#=;4#L)YX{WTiB2dMQ=!7hK6jG7cAo_s!$0#6HfJ0 zXKQD@#mgYG+TOz^Ub*F{3PAm-`p3S$UxGK}S7MkO7*8(vVx<~uG}hk7v=8e6DU#H5 z27+2hPJcgr-r(k=r+Yc9Mr3QoJ~bq6=kqe!&u^G*9apq_{8K}j<2(;-8X{IlTf#y@ zo?N{eB)ocrdSRRIo$u;yPePoyPn?Kl)YQ^OYZ(6W<+lqgtWy!6N zNRZQtpJP6+`B9lD#;q)v@U!lr<3{>W|8Q{8HB=wY>L{tZg1IAC)zcQlYcN=YH|Wku^m{2My`tZFx`VoZwa@71!5Y3%5j9w-xve+{J|HY6mO z+qCuoCw>tw!JFJ%b_2anD8NGGl9vY%57_}i;(~n}DTiuLV$yPo3!yuh{fo1D=o=-A&*;y$W zuRcnmnC2iB_3JJqnm(N!*Xdxb`Y${R!ZSJ4h088 z|09z{^S=Z>$P+3>3hO6>-wWPh_At7pe;IC&; zm!qu#T6Z)yaveE>4?Woa;3|C-Rf{QR93c)rA0KXBUTx-wgk2FYeW_ceQ&4hu@5MP3e|_88wNf{HVn!mxhtOTxSG~0XioVS@FtozBPn5Q;sNo^`O)c74R!Uz z{%hSZ+Mu;!j0Rj#iUy=VqrdhRnsO!u&%W)w*BC&*@QE9cqQEerCV?lxErm>|E*p$7 zClV<$HQU$GkM-0Ffx1T-~bTc*T;nQv@R{W4qjvZoH`)$+wS z8(ryOjBvE@LAPXLni?BBZ|a1tA0>FD-%r1Z@o(qzRK4(Xt*PMfz=L_oM_+G#Av#}# z5Pa=VFq!%|uj4~HqKt#O6>m?zR~PY!j%J`WLMMpoIyBh&tt*9cp0~HLMxYf{vT)=w zM=-BJ=@b1?=-4DT?!_wx)vhkQtRD!xlXEd#$qq%Ebd^Mk*|u#P7ayNa01CwD@bDQ~ zo#VT!s{*K#F%4eCddt+rq!9MBzqzStifH`N7OXAFcn>vOxrqVFlAV(e2jE)P%7j7A{!q^FjHRk6O*#AFmzI+1ngDFxAK8MQ46tUF#= z$E8x2b%-WoW=!>8V_8C+NcCoF7Ce8B1FRJ-9>28ItM zw+pa}mCV9kANL3nQMrjdnj@?-r8y zNgUT!Osc=!4L~!xCU#t0Jbl%zBi{l#Yw30LES-QEc)NjaHN85nNV#h~rq;R-kuuaj z&!lN@?BWHN5zXa_^OdVEqs=r^O+mR1LR7<}qbZ_M{btiBiRSVWGBShh?T`H3=Et>r zuak=r1JXD89FhC!jb8;SBwf|ml|rNno0{GP*aUk;zVFm7;dpv6Ed$*Cd5iMg<3- zsZ_TA)_G`(qS-`{^eh3uGBbet(|6u;HavzqGURYhNDQ2X)sb52>ZgiMn>%vf?{KBg z-DWCV%2hbHj2?F05*oXGzgQZ-Ix1&TB{YYwNOtwd39kdFn<<8hB1A0@(7O?;l#PD30O1P( zS9OP9L+SYS@kQ#+Srj3YLNJO6rASArtD8wNH(~!@C0Q>InV6dD>FbjQ@BeG(swFwi zWq5WT77+>UFCh)?&NN7u49ED8$`}ulhbH#bv9XtAWw-pE!X0Yb+^bWY!NbLMkU=~) zHnz9Q{LufhfSCc*&O3#*x0(U{i844ZL_5fG9eE|2IQof}iAmYir=zfGY47}}H2n`* zE>!fy(uD+2D2iJ5;ZCr|zKFn#ykz@K@qs^#nnB7dZ*`2F3CO$Ugc+JUo2IvpsAG z6`L`VByFT4hkQD2B|yz&_rwTQrVR@3)1;&_LO*bEaj{RuAk_yHiMhs9W-w>@+uAok zoM_5U3&yyTAT+}b%f*6B8TT zBy>JeEnTJXrFXh)`e(2oyua!9&sim6XHofy4rnJ^Dd#+mT+csKQ-OatxOjRu+|}yq z@3$g8vBnlc63-)g!ybLDNY=)&TQu|W6(L(5>4#3dCR|B@9l@djCrwk-xS-zG#meGh z)dGa>&YJLfgx%$CG>YoI&A?_h&>Qrq3LLtL@|5Ly9@6P)5Tb2@ja0qI^6;55&TpS) zx*&j*exSi!j1#u+qDAcZ42D1R&tv^89iB&CGlS@GQN5>8lMG$mIC4!kI3-E z7NtwWjx;{to+B?vX3zFd|Jt7oQ_s>R10tLFN$hri z7+4L9^*mKBc>Y}EcD&$B>&QQ=XZFo+gBK{~!L-abE}q`KTB!qhOv8QUMhxN+MOBzEsxgue;HvaGvL!wS^7QQ z!5Nj4!%N@V)U?NB0wL8e)B!PVkB#U^hj*v^)mS^Em;KF{QAqDk(cUJKwQ>Q)xv>QW zc2G-8ubet{Z~S^4+lD(=OwV4*gA^gkAwn|7$Fo2L36Sp`K`0M9ak$Kw;L+67yO^cK zfl{E`_GIg6maU+dnH0jyo$XM_L~qu4m0=rf%yH|u zvP(Vv+JASZ2wl9}Y}Y<<}?6`9F>`DV$*XJ`t=cJwzWIv*kki z`2(@JAC9QgaFOE4ntq-^4h~;;zt;5kM;-XwBB!)KtQ+G#b?r+# zeXL|4NIRe(b^AZYufCT{sQana@Nd_~d0zh2t(sBIPHKqXcmMToY3U1<#G-xIE>aey z)P@n^BHlXn^zE}|##5D68dBfqRSi8ho-c2<{|AU|CMM@bt}9a2zQ)HBoSN0E1e=7M z(;f1ty!?3Ir6mYSBPAo9`-!0Y?69^VNbA0~bxs;ztU5V#3 zx-|CAo~1FsM>dEq;nFsgNzQ-q<1tdTrtsC=5UEXk7{QEbnp3)NA(YH`GHPB?Quz{#+kn=el_-^XNbA zCv~;pa`>y`=plpW{{=JVz~UiKMRYI#BcWDM zv*fggkO;JGe$^%U2A_hu3vPV4HsK+3p8)OOK>k#uZ~1IfNpOh8jhC0cY&O4h2>{5X z4nc$WHomDG8lXKS|EER3s_Dsg3-PPBTK)~%+u+yfRiu!G;bQtO_?Ab+KCa1_b4+f$ z6>%u&(!Sf0$}toi5CF4Q{}9!&XK&JazSOps*47DM`JCMWr;5)k4(8mItWg7nlXj)~Zx<_zDpJs+`cc`Mieg}p4Vpnf3Sfy_;R21occJ3WB z#F#u$rC|=o&&UMC%D+=g_rj{wwjJxZ+okk8U6uLnuZ2?_hIH&xr;;=iqV@<1@y1zh zVXdPVtK;||b4Xu~1Fu%tlw9g7dzV&Ay0ha&$}PHnSyKvy_ewUI4^=OPDp^mtOg-RG zoJ#NBQ$VVpFC#)Dv(n{dV?&82_`zCo-Zi=^Rpm$cv*(jS6UlZmL!mZeG&$7j16zLI zpxoUDP zfbYEMj^D<`&wm~2yQMtv>bZ~{KYQ}q#&568RhjGlptjoI%Wuxl0D*z4r%xB-vRLTZ zQb6=F{x<9LfIvuP&Ok(2QdRBhH)2N zsO(GwVJ3e=HIX-S{p&RA^Y7+q@!wA`)>|H{4=p_w@K9%4wy1aPo`L8>`QgHRIHqk}+NSkz%0kg(aG64Sur?u?|}oYn8eAU zutBRb3aBn5CYhO;K^#T6+=oJ&nn1%xab*O^(V^iXW4L6bEOD>zsUH#!KA9IszDi@ zoQ5aD(JZX+TpBb$jgp~}-trHH$g}HZ`@bh^Y;jz&QFfRefN>{C5+XZv*{ z*<#1H3&!)FTV1Sw1(`3qH#{U}c>AZ^r)kDkLrmo{K>Y(m_en=C7|=;L{IN^>o;RQ5VX$RIIIQ{Q4D8P zUYS7o{u7Dlm9HT%&2*)Ls2Uj zR0aZD7cd^B`)2|nsC+CcDk`JZKO{w61_{f+<+~97P_u5ym~}a6`@LJOCs~Qc;P{J! zixtN!^M70XkPYGpGB=14yOr;Lp(%{t)Mq^Rv+GDvlE@69c<9*S{8?{dJaR-VblJc= z>VS)hg?~uM^ENI4L8gfu1N)hl>V3Y;{@=U3RIT4mzemp2~|I(nm_c)UfU1@85j1Mf1N?%PSE?@|t2SG;RUqZ1<<65Sx8w zOEfxKS|J9|h3j?2K#OLY7E`AZNa36&bPZ*1#Q)`^Q&eZWemr9_O^3aNDxYqVM=w7< zGqKr9Bcr|+cVYWAbGU|Nkw+T_z5s)1=vBmqwC#E7GvYQ=CbD$+dF!`254Hy-mz6Ud zG>}^I9Zfts;fIB+|GSVq)MDeLg(N2ylFyWJi6_2r`%B5&D-X*Bo3+JRt)OtUPwF~O@bjw*-j>wT($Z!-n@4jm z_7oeWSg{SbxE5gnR!VwTa zGzu7m9U!zDG3kU>XJ7+C`yG0(#T875>(#WXgl@-`$y%BKVI$)Y~Id z-+FIu_8jUjAyj4h`aUX&j7bSP^sg>4H5etD?JWYvUv@dVkIYs%Mt`j{@TRAAc@1V_ zeC8Du760)Pw9Ma(Ycm|IuWDBnHxikV(;ux}ch2FvJ88dr_ioS~|8|C=tdG!XrJ>>M zH{6dm3=NezK$?i1=7WN)tV-2mUc+LthH2^B`G~Awub{oH6dWTapqh3o@;N8nO)ztEYmW>kk9zLuS zJN$vhz%8cD4MWfZCkm5@e^Z*zFHh&b%S)XAcWfsV9_GIASBn^(2(S3wifNbRw#k{9 z5#ZEwH#w0`(H^P(v9!>+(&%(Q^EX!qbj{)=vE)I%JQrWf8{PG0T!cs?YC+`NE8pKO zPnC1ND4eJg&Odr@DCT3b#fMn*YM-_wu|G&TmT~b_Mu@oQ+fw;jj3+DgCH^kVlcpCX z9D~^_!}s1u`<(ejMcpy%Zu0y6Zo0P%<>hM&4zxYvdew8(J4a5c+dY`CdiGY%v(#*R zfg5SXo7SD{+4e)2fk=@Iq;1!8ZzU&J(Jym_fGQv@I?S)YvMBaRc2cpZzVeblq* zThS^Ju;~zaTyUZ9`N7C+r_uMDQB|?oU>IC|%0bvaAOK2?$NQL5!UvhQd_eG2&sCTl z=`;{%fAUbxbcS2^&8`CnF8X+&{{%ne(#MQzg!D;7WXi||Sf47~{) za|((Qgk>kd$l+U9j2!3=qDj8pnvQzgtd@wuSl5y*jqyMjy9ZqNR<}j}p z?2;K$W2T#V`F7!cdU}17&njo;>nRh+%G9985j$UHj^x0lk?5(r{{aW=PjFpY)bcPVr_#Hdh=8vFxkP%711eFU+3yBX zqSw)G4EyUH2deiyzVy`hoM+j#D8Vi>PYE~pF3eQbNfir}dj)h~Y z6nBu5?f}1Q5((a+ko%=&14F}S6J9`$lm8IV*>FpN?H)UcU09ah=Q`k!2MR#{2V8_p zxwhzDw@<3$MRd0z%DmO25}h#Nty(v_<6+haD0B^IN||AlhQlA<)7&`uYa9E6%gBYg zJcU8+57sj~hO}nfeHx4tJT;our{{Owf)jq)qB}(+=*%4G3blY33nHVd`udeCCmm5v zVT`Hyo##8(oAqV@jmvpC)Si!G#_LoH=83PUHz6FTG`x?hIQ5qcpxmB!Xp1C5MckPH zgw@Kchqruyc8zgvR=-#Wy-)-YBo*z?ot-NnlRGfCWtlu|55KYu<(Wb1bO#5T&@J1x zEnwUHX;e~BxC(YemMsK$xTqhtmxHOS)+m4e{LA#7yfe=~72TAqaExX_l$%rF*zy5s z7oB=zRa~b#vU?2;xXb9$CnEDZUCe$Z@09QdjD?nd%Z?u4J}C>+kcziB5q{Ou#r=Yu zTes<>b04`se{P6-*L&D{g}QOsd-ltJciz`4+3lA6sGW5hGyW(t(H%H27+(gLrapDx zxYCu9ut^uQw^G!HwR{<5($1U0tlMxuaK{mhXGFI zWM_XlG@%p`vFq$HQBl1qXXr;p^O=;ROP8Se)#?OP95E>Pz2=XQqCX|Z@l(oS&`ZBl zU!1^00xc3Cgh?OfTd+semk5{I`BoH_W4ROB9#N2Pt328HO7EZvHkE_XHzvWD2cK$W zLTxV`X47}>3wk_F=t3a%T)~XtPw;$*+#r4f2X=6J@KTBnY*SG#72UlCbEz@}tx$je z%efFoEyEXKSn_gfO1iiOx{@jvhl&Y+CiH-5aF*;eRmhlU~4Nt7FiC?9u0bbf65Q@7fUZvopO=!A>{ z)+MW;umtgW4BDm1+Y3Ou(77hRoj;!bfrhZUt)yUenH*1%Jq9u%!l%3!={sseLN!gu zTmAV3CWwtG_v`pm#(v%zvu9=}`B2$b<-J$?8D-_=?NtnztKDaUcm$bTX6YuseajAy zcmkf-Z@BFzZ-3#Fu)VKTMI_Jr;KAgI`f^PSKMS7yfGqEho{w*8l4sdN`dMo3x`kic z{u39id7VZLTRr!bUzb+DQ7ZML_Xq2J3kN-!+vLPptOzzA_#c3JYfiY2zu(O8+?L5_ zxSGAwz6juy54YBW9UGgJG8AxaLiITtHijT6w5!jKlMm?y=ASZ8?6nN9l*m_$X?mWC zy|*3`Y1rchb%A=1juqIyk792Fl#ouGZ~&VV7}x@Y9Y72Ld(Y}*C?e&pt&|aMUVWFJ z=wQ&Osbh;u$}ywTQ{=*IY@de{;u3xXy9uy7A-Xi?u+Xixw}kJg^b zZ9kl;v51#dw1Nn|{JK;5?`aK4-`+I6$R?J+Vn&fe=Y47}C;?7XCOiG(g zSlGHYb-GPF9#Z;kt2;JbX~MGohS|P_M2t$kqD}UvWDO{ri&)MA zbc{@GN*@7F{w zUP0aJy55R-$VZMO*M}6HdTye>@;?^xzU#Z&6_aA~A4uNI6nVperse2P(5l97pqFvf zL|h^4cuj4&MGgcQH1bq#$1%)Cs#BRQED@Mmree%;j zu3E`(6%jm!QzvfS+HkagK1eMxaH`M~iT50JmNkYdhBiK;Cs&C>YTgogLlzNMvBgfD zX!zT9q~Jf03w*B)&kDNhLt!lvQNAv4o{AU2579LFZE5eVyRi))P6#qR_yLj<;$$~F znWyIp`0eKTZ2jed5xd&mx8(HAKV!GFmE22^a#9_X6K|zbTCWV-5#~EiXTR_*+jWbq zqN2u8t{9|l^EKxfl38o7S8?9d`8gGRjDAN!8-pgDN10sP)KOiZnVJI9ZjYwA@SBI_ znHmB!sPRx;8fSLU^!@gu*)&>R|6%-?ZpwSZea9|;qEr&ujUg{|LS|=Yfj6W5Bh11Q zkMbBdY>mVXgvW3=RNj5P8ki_bLC&h75&UXD4b4f9MW=JQ=8k`w#*p*@Lx4bjD;m6L z$tU_(8yeyuRB(-`d9<>O%K$(CkITVJkU{K!EIp8n$97I(6EG{o zVlU7+){;>4fXYCCK|Y8=925`S1_m1%pw_^4a-j33pamNX3#50rp>u(S#?@h2h8xpcjeJED z%NJap0*tEFEXJt}(6=bWJBWb`%-=5A(i8-;I0 zNwzRtFoF@$sKCJ9k&#Y-1xQJOdb~id29)HerWZ*RG1d%wb-=ZE#snWOew-O?Eg|>$ zSA(7F;ScR@_jgG6?iAI=Zxtg>5q9A)q%#m;!@CcX$jvZ)fT*JLzv6sYC+$8J+??lL z+OO*KvZCc3f{k3;jp8GpQG|68yfd*9#ui;}axxb*yHpjEiNyp0QtaA2`v6%2a2ADK zw*YXJe){Aje9+)hjt-B(+d@24a3~`{%fYH6%fFJHr;;FxZ~+`!Fg$dA zUGe_63szVdd1v!E7|>N3_D%TGQPU4M_LCL5G7P2?DMo7~qjDqWmMWJ;}EHou0!5TtqR~+{k#GzhW%PS_Pp9c%JtKQ)B z6a(V-)UI6@G$ZrsA8jXb$oooPDU!7@pFF84m;;l@PErWhu;5hQi~cvN*dyk3)zvT1 zIxBNX*RaH31v)z@xrtVx&E0>XcRoF$kZ- zrCWHpgnaJLBgQS5`syP7jdq{b2DOfHi;kl0I>3pmH^F|=pOUQY3WVZp1%-t{#;buV zS2j`JOVFJW?~X8_9Xny@=J-!)L%vx}?00=vtUt)wph7zdA0qSOcbg%&M5pJTM38lz zzzl?nHK8Ylrlmd}JQ58s_!2gw%)){;;&=sk`lkjS+S)6`fdUv4x2~B_gr3uY^?l@* z5YzOvG+$Tzd2DTwK8E4y%#liA?K#eU)YNx2L20?^=KCS0_8SnV$N}vNO50FbwSn*! zJ6)%{^?SSpm1WT#OWSpC>fm1xMgdZ&CTd^>ngLIp5@sHNyM(hTqT5Jzn)B@fUQhPy zU`XRuukgqF`G3NXU;;fqxEyAt2w}&*Ak9<4|B$_LUAroi5M z`N}^;nyVu&j?Dh7?SBTxem(e~Z!RO|)JQ+iIPoageokw$5XM3J@ya;=-($u8AO8jH z;kg|ysot9q)7^i?+=V>D99SjjGbrvo+usgNpz^E4glBc|C)yo5w|WytbKt8) z7e_xThJ9(b80e(=ay_i_%80Zr#h$Y@LEjDJ>^ck_yMtDrm)FtZ2rqg<;N%OlFHys^ z{`+^C3w?#zE_i?raTU~n-x3c?RMgZ0gM%F)Ux_9Od$h|)(G1`zoM*I;&gk#cpFQYL z$^H&w|0q5hWo~0A6RruVItLGrl1nc@BL)$tYYDPJ_FH$YeNWdz*eU&95NdFW5CF1s zQc~xA0ap_A{Q~86I`>uxN_~e<-*74CnrU1_)_EPSYynD9M{NB6T9}vX!LqHtVlWzN zD|qaf^4_yNn+RqJ@iWTpPxQ+_3vhcze9%(p@_6tSn=g;o|48omfKw}8YLBvRa zy5gW0$a@wvSP*5D_-xlr40g0RcDf^G!DZ57=Kn5(M+kyiNwM3%i{Bg4FMgNF0SmJV z(->c#Fd>%gASX{zNhtqFAufW<3zU5(@Qh{7^lh8P+RIT;Q&G7CYe#tvA#x2|Hrx<_ z3*+^W`w2ecq*;2ewNv}?i}rIYb`mkZ{W42W@-{W)y1-4v5TFQzO z+G<~@(0A^B9*v$07`_X0LH=r%NLVB#y@QLFC!$w?AAOe5gyX3yE6Z%v$WX;ZN&!`E zU0teL@*z!B<><-R?g{d5un2OUMS&}&EH5WVP}JkR;$mYn5atqE;fQc>LtR;C2YQSH zT(6`4HMfUUL0&(c(wkb0P_|e{s&sauXva}sHD%k_w@6x9rPY|dYSo=vFMH;Qm{>=R zs5H1Z1Ug)D`N))#o%^FVOOZ#Xf&$<0?OWYe*S>dGZFNG^ZV>}(@wQm+C_v5QQvuM= z!N?vQET>XbOHf2a8}e}w1%#5Z192z>Kk({)O+x!69~_6iHx|Np@G*DkA@&}80)+BR z1RZpjvZmtzJFrJ;IH+|aq$3$oLSb7g1NJzeY><|mKowwXz>{R4qr<35uZqDn$Bhm& znB&5bc@1jO2u*aws)1F+7utRCgN5eUbczx6U^ex`zQ-p!P=h5k4iEhB~Rh#2gG_1?{j7hza#$xz;!`I1<;d|(`@RCxA|xSf{yeXV5_?R zb(qWdFbd;1){ zGjXJbwKysUS2&U0Fr?R67l%OiRxL#e!I#>Qk`e&^FN`^_3Uod-s@^2EfQIK+?7|?# zeYL-(IcjtY+Dr3;FM#!Cg_Rk*z{vzPpvP&N`w=yqi6#((>~z@Q@|dqDyDN@Iic9*3 zld`W+-n*ze#;#o3xBOUo9Vk(~ri4^o?i{L0fPsvf#LQBPcf0DGgLoz}gETQC`6J`l zk7>uoGR`CU=De#hxhvz0?Rt|qSw*wG`w5QV4z_k7B}F)ha?=2aF(ceW+UJ;7)90lE zbbkL@5)TTahPwT5PS@%iur~rtGjUu`P<4xFUrM<=dW;Q0UvHU>$Y;jgU`*2(1ZK#s z>53-V)j`ZC$TT+q8;$(q0{3i-w&aC|=#h@%a@nAWYi9-hDKU=Y7nOqD6)@w7M`X(e zNeN|9%Z2rLU=7Ne<@~dV1gd>orE-0C=f2BU)R%GGA-!t)Z8s2FT;5;^2xU?S4p%Yv z2+5is%I)l>OhkR>@XG8Zi;$2GcjueyAFXYiot;(kU@(N@NWD4=JRo7LHkhTWbB;)9 zjsP@d2~mY32;3Yr$a?dN zhq+;8PsuTErP$GlJ)jArK%_!`=|8dG=g~pIEDZPhM7g6KgIPM3AkYus-QrWaI*!Hm z);KoW-6Y9Jpq!{`=ySf#gD913E9n;cs!IwIC&1|zpEX!SBDz5P2t$bYbe%*xu)>T` zf8qjV&!4}b5N0DM_|zwY?Se{`H6do#Uqm$8iFQ7A0W<)=Lk*KnKt1$6n&rJ{5TYS1 z_~^jNsO0S;p&};gr26)==guuGEXZ++gT(v6>cr*^P2y&6_Jlk{f`h)&#Y9#F ze}5Y(_Pa3Uk=9%#4jjwl0VBWx1;4;2F*Y`yvkoKx6U=}{d>?>w)Fm{U#25bX_hk>$ zG0W1sn~EO$8;Uehict`wq6Y7lG0jL+KovAD1j>vP6mL?9u{-8!q)s6aqi_YcIdT-;vO%d=to8nGm(6woQap0mxbk%%*MX> zMHOj@0a%S~9tuC5>0cuwh(M7~o-kfT?>i3Tf7TRM$oUd}+ER1t&Z4Jjc3*olA#o3& zv(Hh4iK#oUKZ5cCIcZwLp@B7b>N^bvRdR0lPFJmh3*`xlW2!5fz!U{urH z&n(ORHoMCC@?V!@En&Of$Y8~|iUcwwofRJOw`86B{ zEaeXiKw#5E|Fopu|STFox?Y|BRhV%!S*$os-^m3n$T{S9~4!gWQ8>%IMixTvP1X zZO(^BAuL!>7ndg{9jNPO8aeT4%|?scy*FmY1U%Juk>S3Wt}*A9E6o}(P(ovX!L%_D z-RUB4phNN=y*8rF$+pCvy~X;SiYsh)oa-b44yxox*98iw>LoZ6ryDgc=W<#Kx%BC6 z|6@%!VUW~-O9|$?cjHMR<-Ygefkn$JqU?*DNgQK6(5JBdb=|Q%%hjFp>+jC-?Wx-O zi-n6T4R0p=&k58CaqhLAsSQG)Ga}L*Vc3on=kT21tq5QP2o-F2?8dO7`u4pLeg1F~kC-0bz9u85G zh8*j`v?hQToJ4lJy(9s$KHm_Qu&7WCELPT}9kIRemL}zZZ`&zp`<}f2q@3q$*Uu+w zzKDuIx;;6A3|AxSMx>a#3(g0CEB{j!+~fAILEn54B7GhGO-eKs0dkoG?q=MAhL{J0 zX----F>diLGp5C1#z5iPg!5GM8n9EjD{Q2aVbq78A_4vJGh~CrF5=(|2sd_6iViYj zTLAuIWxWEwkE<3(rUOs~8h%Ohw+LD?#C2-6g+SZS!~o;gws}Zh%9BVJe}C=by$Uwg z2}y{TZw%#BPl?YAf>(w(W?>$RdjMRxgw~qYcT;+=7IJif$-;=g^zeI%KdAFEVulFks!Ozwi4@D;|r1B>Q9=?P- z&yNhu4mjPb3b)RavO6u141Pq#V6Qq{QV_?Zndm zkE=%w6%PRk=j-;;J>Qn&prXlGCW)1h@Cv@~#fS;F}3Z8U*{M#AIhXH~GhAYfoK_uH@iZIJ8nc~15?4ztQA$-Mo!@g-*;%M*IH!qNMcpVO_7ow5 z)aLd*a5AIb>@dor;m&vO)X*sgp>6EP)Bqn;L2&Zwmv8{&oH=E}BZbUQjf{*$_cXTu z#84kk(PS;m848p^+Uy00dMr;Plhz@cZf2`~5Ifu9I#L!6xaxw~;PkQB19Y31SMw4# zN~|$hnb+|=#(x6d?30_7JFK*LXv+s;Nev9e5DS6jI`iXnzSoM#Bm0VgUR8tc?O1;i zO^tD@WxPwElxxcexP!ih?YIJ>>sFNB&tAQe&}D)_JF3j#SlMhiKOZJdLN3?ndiryIVj#TA32&>0LYM3@;{tx?ID*$gwGNb*GH+gFK92xsV) zy$)-z(0g;O8&hLP#rg2$_?G58FH>=-g&a5cFKkYbqv_kTQx>C?9_Z%wDKzNHb0Dch zQlF`}|Ki>fa0Y$%^GkaeqgR(AWX-^wUt_u!eu_75bP^_OD?x~VWCS%&#`y- zL*>00XXobB)3nA=e0ekOdn}EXrfJ@O6!O5NF(Sae#k=J402~ccv<~NfLNo$l39-!@ zF#!P(Y&(@D{1U#@(pP&N+6YiZa)Z~a{fVADK}68~+{B5t7jQ#r^H9r&B{)9#8zw|? z7%NgCA&}gKg%^Ms!WU~q9cBQz3N|rR^u)aiK>6u5u0Mad0HEJNVi^Pg^t54p`=J+y zZ^OY|@D*RojNIAZ!Dm*g=32RRsz%GRZio!OH3nawHg{rka{PiY~nF$aj_% z9D!n$BsKAAU(I8&|0J*HHk3;WX3Gl7M~k&v=Z@RH^=1UDcxEcC%oxYkHr9GVX#>y6 zz;y_e67)?9Trspt+kb>mB}NRtN@05&rKFHc9z^Prze+FmFsyuAlwINJqhmvR$2vJ8 zI=VB*QuC;10pk`Ztrs?1HL~#z?W7lBcWiGx4&FWFjL zDfEFaWDr~6E_E%$6~)A@4>DVOn)Z?VNIw|-d-;xZi8s6z0eB$KzmMAtiX$k_m`suO zr5}n{MD_d~<_ot}|H5E}$8+xC;w&ht2dCyxbKr@l!^Rc!5y$2Ml?2(%KP_{gY0m{m z(Af?^8j;N!Xj-GpdJQZW19Me#^J-8BZ`!`Et565^5~AEF z!b5q5S`%>&H=HG49l?}FB-upn`~8!~*#CO{Z<|MU?Z#PF=p&iIzQ9kx5o`7M1{57{ zn!17cUm@vj%_FO4z)=pUIYGFxf(s(LDzKS6J5%SDrE?7KYSyPa{LSFZK-5OQJ^x$Nk& zt^!{~yg=^_`s)&|7N+=6Xm{v>m;!THgz<+~{=|ktoc;5{bIB6hOwOH0a?S0_b8o4syg=p6z1={N(_Mk z6Tea{H3BLCtfFZ5Ub150^NP>x36>F5Mswp4iF zPp4u#fB;nAs$5KiS)RRAR5B*8NNhvblk{EsSB}$yl9ph5`t)g3jE+6)hD{J?z^~!Z ze10JYIbp}+&2OG!lJv9H3AsKT83;6QZuXCRJ1#P{O=)6&x~quX#2r@zTeVB`V83EJt( z9^l-Oq@bpUwoy=kvL=hXq=F`d{Q;3?f!z{F^dj)%33)1@6GPu(ZnA}Wj+M~Bllzww zkPQk$qS!~zir~&RyeqlvSB`=VeQ2zaY_exy+kgC_L0sJ{ML-fLr=Idt0#EV)Z3p3+ z_3F>Qz9JNh0E&IWOpT2TQ5V==IRxyP09z3lFT{A)yP@xbITbm<^^|7`(f1(LZHNPO zLiVV2{ZFK845F!w(d(Y+pBP?R05}KYLjUT~o*u{&k-VRveT;j^(MeZyIB8mSP_*!a- zT^LX4M1=sz=}qPwl7pjLKAm}ZOL{+l|B0@9~cb8xUIH}Kah5v7Vcl3x03tO+YufF?KgBRIU5$&d%-JsP3 zmBZU=igG^q0ca&*9EHGOeX>!jCsCCG72P6fZ9R-LG+u3x9CoevIw^&l6kCPD&QT56Mzj~4wuxCT}eYU8V7vE!Rd#)_2 z5C`=PTUhh%qjwvXkl2M8kl^1cp8zi1YWmy75Rq2NPq5gDGBLr(nKL$U?dT)Uz z2Z<<#2E!WoDfjhbRN(9cP}fMKaw%mIf;{1nrE*qY z{*l_LYh7Lk!o?@P@_RE9=pI%&mL1Y#To+&eAshuJJqi`yq$9;IYxcoYXzBQ`e%?r( zkxr5d24H15z`2H-GMG~Xy;==n&A#@`g$qyAcAZtW{-KNCHCqLjBQ?CCmJS>ug|WT1 z5dQ`Gq?3ooGLj-uaK1o*0B`Luj^BiV1w|=4W5x?JQ7l`$8!Z0Ey0?E>D7z0XE1ZHF z2L(nZrqUvATe@mSkvHyqk4zu_D8%F6Kohx?arC-jW7?Wt?et`5iGA*mp7T>&zHCdlj7Zm=#m zp5kEYSD!9uX|YogjGFkc_lBbr6PTa+;Au*uYc(7TUqP53a`#M~bVQACQP;m2SI2qf=mn`G(Y`124xkM54bcbK)w?TiCviN`qSTUIot;P@(X-3j2!Q-v<-*^LDQk`j?QV1@j9} zho@cUNn~UZtO#UP@VcsAFB2QOo%$Na2QcB#1MfPnia^T3QV6KkoAK72JF*l)1{ZV^ zmo)y#OB`1`Lla&=oU3Zvas{e-w3;n{zpHq#kT+cwR4pKoM{N>;gv0R)2;@LF5KT99 zZPLLh%kn@g9f9ElY(rufddw&zbMT#T_n0v5MfD;br@ZSH2%yXGO9-1(d$q~?dm9-4 zbUcn>>12t~J^i8Nr}Y>xZjhW$L0#r@CNXpXleGWu4j`NC&e@o0f>QV*Ob0|=5P>#G z%%WNrTO2*39tp4l8`%`qRqf^P$P~Z@44(`{nKPK4i&0wcTyh+AnAM31pJc%GJ@H|v zGUD%!Z&1iM>A20@md)HF3C$@2h{A34{pyE(*)D5h0<#bM6{eF4%7CCzNwf~0d6}_) z`KFspTwGsCIU;!G+09%*IK<&N>z{Q_lCbQ8Gpe-2gjP4A>foenXAv;m1!BwR=Js!57O?&1->8M5+ZS<&m#M>S6yCh)jMv zgMHhUWBHVE3%ahpK0e%^!&>p~8~WWz(H?s?yf@?>Wu|w~=AuTfTfMdGEOP452t$$e z`WX65lUKx6W3!iIpEn(e$xMIhSz8e@{G_Rs>YgfaE_e##tzLU4hUpQ8zqW@F)3?=;>}pV{7663 z7D>QaZB1>Dk(S4YMsAQeg#;65fXJ&g6p)Op?L$x5eSkegqX-@;TTez(#<|rM%NMA0 z6qKBznGRRvWszK>O9=I{L}yvb$Z*q5LIqPr5Qpg~=Kv*4-bG2-Q~Gnb0ZcT&!ZL&g zAWjc*wKn*B)o;#&$^$Y3k;TxRx^_CM=Sw5PZ@eTd0%cN=5`;7(A!R8n+^W12waPVk zAr);`n860Y0svK;3aGfKad_wiL$Xyk@g!XzGl=Ww2Yj?TL6EfL7XIcc#Z>f4iUc+U zc;QL8TriiPrl<_tE&r(qQuev^QVjbe{T>Ax%KAz(b5Ap=lf9Z zW0-+aT-?AzV{ZxO+|V%}VDUiMxVwFS?C)-{1cHaRo|l!?f$FENZ4$C&AX*1SUDS5n zg755)a;-Yy1r!Xi4TBe#&?8b4?Hd^pw{AO?ECLNYm}^-XML^jrG_^ce7CLKxTD~Z{ z(whCSvYj|H1O4inOXvQx^oLI0b$?~mY>ONP-4p5!mw_htgmOw>!UI6nIGoUN=nz5l8EO&8tAgi7@nskS`+^c}pGmaGl#-Vlu?;GRdgxpDT-8(mMJXK>${3rTrRZ9_PNZx;^Z)Y5uh zJ^c4N**A+eV&`-N6CnzmzFr9^Z{SMNO78nAg`^h;`)25nUu;A&OO!FS2W8QL#CRSy zmLEUm>V2D|MO3jnzrE)qgoLM3b;kK@zl&lSnH(Pbf;K4&W1xuK4Z_Hq8u&b6=i zvi*iel??J2a$am zX(0Ms*dJ~G;>h))(GS~D6f6TDgTy3o(}TNqK?3e3z650izlca%9G)1e4KP1T0lK)>JO8zy)|C4Z$lf-quvR0p$-vg}9T-m0 zm8-~$3>|5IPWouCWfJ*R^j>U;L!X03lnX~v`1j$qe82vnC#x^W1#y^+jNUZoLGsh= zM{^|((Utk3j?B!O{cA6vA#q}(4x6x&KRT@V+t_qJze@I5<=khh?>|YjA_xZel}s&F z9#bl+Fxhlxwxn+sy9eu2F??XZWjpDGPP-im8mv-gNV;Z#fC($hoby?HW15EbGt%F? zlzfPL9o>@M?C&3;ts5`E&vb-0SXZIyRY*Gh1JVgqWV7oDj&1Q0WEjg6()=&m3ARvE zg{k=SE3iInjayw3F-&fgkzM0gy+8LmL0(nHnU4}9W)lr^p?wusNnb_QiH0p0!KyNu zf`Imjl+bU;NI=QDU$kDF^w)3uNq^mA3QlaqKfg{ba&sDET z`bU}+28X5h)04_#uh!KEcug}uK-KB!(Tkm*KCP5j9(kozBIKtIoRY?YP?aJh(=Cm} z+CTeho4t*%FfjBlICZF)e&(Bquzq3_2@PkEWqJ9|%FSV=iD$nY}}1CU)$>^7EBdd3s$#?B&H4RCOxW2PVEKk*>3=j`Zw>rIgRV z3v#30%;xea{bp@>5{mIRa!z~M|7Bow_ZPWoT zE!NaZzl>%0;JwFY^N$m;?D}$*)KW~bw)b+4R##=km#~yw8zf$8rD0>juse2ss+3ax za=wE4?3ia$!HelP8Gou)EJp%3nD}M3$JYOzenVFpm3QOKsO!{i123D!rnd{#l}$YZ z^b4Im!-*`ceupkRclxo@?m9W+SwE?i6xHqp=gA9jEiA=Z z*WD()pX>wig7D-&bvBCS3QDXNFZ6d7eOWiRYBmbYaB_yO>Iv@imDkl<61QnbedoE` zvGDO?QQ|hz?Hi`<#zuOXP+lwIZhJZ9s4T06xSRO6zK?al>J$C8kMs@7$|0soijSJ} zjbo>OHk>aM&(E&2XChsK)e+Jw6r(h&-wI}y3h12==qRLj<;flPU;7BMc6)r8Ve)vI z%d~N8!2Omnik_1%q!lztmr#5n7U%1D9raJ>%eGOBn800fD0avfJ{680I-$2pZ*IMP z4KKOsr}(hHb6SSAqfR{P-Yotuu=e+hw}`)|^U~2&M^B5EeY!j8o77R!UR|~dL}~3I zF7ZUCao{^Am*4pNxyUH_qM4cDk&}Nv;9uecD&qrFI`>gzKds)xLPaLAkZZgUPvvDN$dKw3)kSBN1O52VuEOsvr6 z|5#V=x-$3i=HDd`AiYl6o3W|AeTR3~r1AWG-^&5p##*x{&O9>=eygkYl0AO_-nzIg zVn#lqF!YIh+b5@xqS=hlSi_>R*k{k`igq`SVW z^1Cv%W^C|!-EFITW$d0~dYzOPNFTv#a|`!o<-_onA*wL+xL%2L=%b1L&b7zJYfAd- zJx!iFOFiaw>Q>JN;u%+6yy4p|SlFfwo#G7J=UFHp@T;6tfp1aM= z#JSBn+03rZ<+W}zy>AY!U0E&Z%5F5~cbm_@H;&aX?i;oLUDVlbDL(&OWADZaE{a1c zLDK^xzN!9e4^EDWcyI~YgVHyX?P#p@PL%GPH?q`Ar4wDA8^U&DO*a#yiq%k`E@1m? zVjjj#@-kimr%$aTEB>8T>a$6;f6;{dPsH~5fGl2#XB0M5Z^1nMY|tt8reTNVa-P8+ zRh-$NSnj>{ecNs+(BP?xecdNa8{c8T5qjz*eS*%Q1Dm4%^9CQCp(5d#>BJtlQ|H;@ zex&5yN#zT2pYNUR*39+4HIhX#hgo(Ht4(BvRH5ZQcQh4QEvoVcSfUljdFvysIUjuN zuujcw&1!tSx%t`?6LY~C@9S0jW+uzV;&^;RaP$j)ia(R=#Wtnf=S8@DVa2|aw26oO zS(FPXH(z?`S>G=HJNWkgsKhu44Rx+-`dcj9;AiPQoa_It@fp$@A5}Lmjk9_?@$^9~ z#{*d@p>`JYlIwdq-sZY4bPU_8z!f-!RF1v9kX_hZu7ttC3}Y+upHwEu$d&f)e>P1&Qr=yOAJhMP~aZLcBiv92W27gL!i zKfXJ#M?*t+urw~sQ-t1^Z^UHf<;3XNrCp4s2hW_(>MI0C$=65NEd^u>oKXCL2l?B+ zN4mVps%oykGb+9=_V1>oBCPay+LzR_H{C(?uxV{IiDwKR&ac3zcpdV%H^OuIs;AJ} zmN`xGTvz&>o1OTS5BO$T>98k=xjJ227*?$7vwEg2c8qn^g1rc5@UvH2kgi`rb4(+Q zdaC1LoUrf=108#MScX}h(@3=E_vl9&zj#RD(o33nmfs$Ua3%!=3CD9kv~Us{>lpcy z!{F|`_l{dCuW82ujgr#mRY&ACRC*r?+77KsY4ooIh4(XCl^9b~~?J($=Gz8Vy8Kg@1;(l{%(^Kop~*muXY%tjZ>$m}Ye{8AtTso6p-@$|ri0~C9n16_a{Fh2wX&88 zfhtokWRDy^wC9daN3&XHLFaOJ!}FCZwda>OGpg9e(<~f+BwCU}lwmT-YW#ELSUY+m zPW4N*9p-uQ58dZWx!?2cY))>O4A+di9h~b^NRwcET>k8>RU>_=u61t*SutOlE8q1U zRrw;E=RT?x9&88h@Qx>CAWY-YjQ;&Sel@%bbwl%$#6^=?2@>~7%^hj2$9Fx0qw*T> znEo^c9vpqu74ev#eIhUSQ)H(vv5+pxiiz}M&PeKJhj;89`%eB+Dx48^O@~X&VT}%P zwqcugl3MldP1J;)aqTLTsuaY_iYD6i$A4ACF?I>>+U>_+N_pr|kMfDgUWIzn9w}D2 zejGbIHoh*x_(udDn*E;$%Nsw=i5E~wOVm*bRIeP5+!gxBZq?|EOG(KRQ>{!?f=Qiv z8udu;r19l+Isegz(d`ccUJg8`ic~ig^AS&;SBZu4>2cbGv-%e4gx_g37tmAW|7|6i?5ochNxf#ukEI9? z-1bCXx6C-g)I288WpwtM=$t4Ds;?Xxt|kC;n-lL8?>bL&5C6V4e{kAFPe$Fx{VDT z5WRf6*x>#KuQkK|Noof7@4|hpV;pH&tV$;TWkIMPq7qrYdw0nP~b-O&9;9$fXnNv)MOw2be9a;O} zBGR>P)tAQAQh)C5PNz#yiwbsr`#2yAi*FsQcrP$P@bIdaO`{_AA9q*LBWd%qe8)6} z3(y_%QLzyD8s+}oCO_iN*B`gS?@%IF_&IrN4i}7iC1>{uJ^agA>AD{l!Lntl$~uXo z(%#>|shgMFai&G~h-rK3(~mWb7bS0}nsXaPR;dSxiiYA8p}?rRqom#Wl9yO1x4;=b z`b71!d}Bwh?-~B%AjM+#`TCxnN~-;BpSjyw%@3z*NhS9DSfKewwYiTf-=&I{?Pu^| zwVLZ+Y+4Zq-rl&j5_(z>kWV|A)qHmJ3hI#r7g{utb{J`Ol7Z?r> zv7|Q%uKX?;ZO&!87$yIuP?*gkF)L~5zTHw?)8u|( zx|-FJSxb+&&BAI|aoWVfjFq}+3Rj6|={Kt14VjuBIn=R$+*^UIq@QAE>?x7L9DZ8) z$bh1oK8-D|D?g{+c#7=Suk*aJJCahsXl)m8J|;FV15@amCyg#EFH-|KY$p~A0#X)h zj0EUtIv1z!R@2klyOwoGyznrMQtuQOKWahXz(FX>q6v{LEayP|ZwrMM*I1Gcl5 zsK~r>&$DvJwaNvm47^$#p0VkWW3?!KgKS`Nbm_U6oA~mj#r6?j8CH+qX?B;DD|a-$ zSuXq3;ycW?nfQ!nN9J5-GDK^OL_M@V%nDB0)@Gbpk4=t`A)YyDuR7Vj?C z(X4hP|FvdvdpzVZ1Aoi-2S@n_r;&mpmIpVt@yPIvZGG4(IF=z4{mgUKMpOu!XAFIl zC1l$q{Oh>h7nh0b1j=ol+E>#Dqvg}q5{fi(Sa9)c=Fm5H>~-#aS(Y#z>;D~|R>ex) zE~sqRIHknu7De)@8ib!QOm*(Rd-Dj}Yt6oh?8e*5--Zrjf0kZ}q^ux!im*#s^QjF) zR@s0``=gfTc?&N+T}GBCjdg<7zIYSi5MJN2vp#+vuI@Rz)3w6t{ zSXLhl7ag%c7f%h|f#V2PwB6m@KEmGKv~^+L;#yi=fxz}PE0jA&+%kDpemCz87Rqgg zj~f1+|Fi6|Yt+4@;W&fBy)W8g-3O~leyez#l;jtGAgYSM?C%>xeJ0wMhKD^0TIKXT z#SiYtO61H>`1IiFFiK;b6ipS<8dEU4Y;(o^Cd$)-+PwF z?5P|$bW8gwrd!*aTt_0sElr)?rFK(ZObyzz`>^Z)h3?4Z#4OFXRS~y9_Nk}z%X*&m zYP3U%O*{AdS{lnmEAG6W>;!e$C;y;?0R~@`h4ECKZ*vO@I-RF3KS8!}L$9k52Wu3) zo>`u~JEn1?=~j%G$nX2-{hn&;M7)b$i&h)9(`+KMV)ehDC|^3)WslrMr<+E+;D${O zjmgMxj!k>}Zl0x{GL6HOI)fiC3d<(voBk*gk5tUcN~1kOLZe?E)|hz-_idSd$2eA| z@r{J1zalxQVCdr+{xh5#&i(rzouOaZcNY%v9aMa5ZuMG)*~fZ>Jt3twzHad*&3QIw z?X{3iO&~Ha&C{;OF_lS8WTow!JeQbt>AAS4)9C1!^4`q~G*cS;Hd4?t97#wFI8^<5 zaIc5si?|%VAY6}rej@Z7rZj5)T!_m?Ig~#>&Uk*y{mvbhw z%+l%IuJ5~(&-K-KG5MeQ%D5bB$IH8A>L_O93m>j64kNJ_Dla{v+o7t&mwEa3+2*tQ z90}H)t?r9c>GRhLC89+|%yO75+s!>|tqxb@dNxt{iEu_1)%!fQ52Kk&u@NBovot!w zmE7S)Ez3fgIv9DjxrSKc|AnWk4vVsT+WZs+47wB%Sb?QmI(1Q&SOm!hLApUY1r^X; zz@T&K1&O7X4y79;mIfuIrKP`Tk@xej_j)fq&+IvKX70IX&dlacT^6myOnpsh>BRQ* z!RNM*)cvWf$aIcZy~dnQ?E{wqt$;CJ3N-;0cIl30CIo66R0_h%scA~SG2>@QuZ~YpewWyHV zvLf48G#7}w>zb4HBr&sM5C^|w)-_-_x1tZ9zjNvLW%0LUwMWZCgf(7Ic$2SlW4#Q} zWK>fNf9I$4pWo>|DCaD*@|R!?w)3$Y`;-(NS#+D<&*G%HxAWtSFD8q>Syu$^ww@U) zmEHQ3B0#CG%bp$S*qMZuV0D1wyq?ClZ7WoNwtR9lF83P&sOY|nZ;>2(pYkR4>%n6h z9N^K5DW+dUo&N56fT8P`OPk;MKm_G3X}t~0-f1|ErfV~y28hV2Zi~)RA(cyDD)tEf zWfg6UHdd;{bfYK-%pkl4Dt<80@Y=JY0>AO z7zq3y_^^vUXM{C73luVh&0g$rhg%Zep>*PPT>FNRE+=Pb=iM5_1b+zECE_x?u(A$G zY*cC^Z(9V0rQ0NJF!!ZpZ(MmXKWtut&R#O1XT`MprdZreYS5ykIlXY#Z}RX_dH#n8 zbJIbIC37P)RMcdETO4bepyMk^RMYK(?9-+K#Jv9Ulxd2DqQ*jKw;bMb5+r`W-_+}! z1FA~wIt**Ityz6V_0Pv3$d&Q{|S~5B?b%DSyMJ+4& z+L}?e%vHqNJMC8TJUemn)Xy05KAXyJa+1qH%=Z{TrP_C&^O}?G1H?xySC7!<#q;T+ zEW8@$zm) zD%U~1DIxLmJhCP`_ zm1a{^zI&welYffuMTTFH?UGx0yLe|6!m3ORE?|c>a*)>Uc;iOzuYE3Vy|mKP_^q)v zN{${R=^%ta>@9+Ok$Dpno1OM#`&^a;ml)#!e+TbA5qj&XZ>Pu_GAiMGtqv7~>!de` z(H_M5MLqOT{`Yb5i{&Ug2&W^y>1>@fz*#-f6BzItO%)O1u zVJyva;L|MY?(~w)4>#Ue#eX7@1NUD3K}nfXww-HC2-?Qol;Y0qQaeN4o|-spQOyKJ zxLZQuh`!uEyNV~GitJgb{>HJAD4P3WUd?vXqC5|LN@Yg1Z4wF=fKfg8y?@z-*Mk@? zRD|l!rZOCSHMja@)^qxm4cO`*5B^&frxS57eu{AW*ViTMKKv8BTz?eEjR46HSm>UN zQcF5^JUppF&Dw^|IggPIO3$W1eNBPh8dK&kRkyr9g|eF2tq@%u2S6FRv!tX|^hMX+ z@FB!A8#Cn5yMTwxm)4syg2WG=#~9lFUE|>A*Mskowwte$wG|yhY6svm)f2vd7k&WD zlo-QRY)lz$-Gc|@4F}dz`=_AaJn)8w=dol@>7JZo%dDFZ=Exq-sjXcOV-A_DeVrj- zVKY6&vGvmL&)-!8fYhnIv70LAkiW~mw(beZY*$$_9K?2i*O&dll8oP$H|q*`m8@K5 z?Gpy%(yBp~O%%JH$(TsF_gmRYBgzg!TU<@bP`?we~MV3lB#qEg_rXU-QtoNc*35oSCW z5Io=Cjtw~SP6`511}Q{9tOEW|RiZ-?H$!$#bKFP*%;Zu4aZNJbPx>xbB|OvB&k( z-I4RvL#ETQQ-L9j&XBDlopH9aMk>~2qcaU~9Zw;mUKP^+RM7syQ$12`^R7o0uC>;3 z@E(77fu7&%`Y{Lwi`8Pc1kQ)g{r1NKUo&=pDw|2R&r7LaT0fVn%N+dJ(wE`=sMd>r zw(ejScu_ZNS+R!l;-8k-Y_9TJQW|oPK*IQc0B9m_V6t+2`0|EK;FVq=AktZ9UVBjc zC3>A{H%c=bJUDZ@_@Qd@r6g~_c|f7xbK{e>uY)pW7Pg`Gd=`cwnrAB=L5N)+UWyK} z3WwQym%>ZanqDPX3^Tt%H$JgxiviEgiZ%FSO$<={%RX08QJUH|Va1^wHp4@QgvZ5r z*Yol@{wginNOnNk{{T_=y1aUlWX7b&{pHCzj06Zfc_$6k(A#BkJ6%TUpAVs5U-cVOn z3-(JoZ&dys%l`-#Gk8=eY_P!p^Ha@ZtiWsP%=x-SjHAtmj{|VXr1pFL;IvPX{k|zy z6P4!4|E{qp<))S0KI|s6NqG;&fvmJnil6#z^KiOHJth5b6MFElH}psyv@^6 zzeALgqbI6T9z#?uvi@1mB7MBnV%pSbtPYSerVJM+%@DV*=E#o`7?Sd3q&S>%^8d}G z4y*z#?M13=CMiV-+`77CsBdpJ(OeaBDaOqYfEWxCKpxmazr}fIz5Mz@=J(tpLMSCC z1_A+C+N0P6pMwfzq*5LYvc1&l2uLT#8Z35doWe|%I#}VW0Y<#9;wX4J5rd~dwxSERkB)zMs>5it`Xn`!`50kt z)kxB^hvhsKZi;Qbm*&w7Z_x{uvpbp(j}0)HQ)(gUYxj(L)lPl8d_qVDXdnwG-B60?R&P!2Z@8x@j zP^v-weiL9V`Yf9&v^_LCTa8YLXk|9E`;>3B7)Hm_jDt&}Adu~_pv|kJpD#*bRzC?p zAow;+t+=&p{s>Y_XO_>g>=wD86^urvKeI!@Iu+y`s$;NPn`8|@=nUXMNJx6g{yTaz zJMHLr*rgCJ@LFDw$`PV+KRU*O69lCU)+qX!UZgc;1WFtb{c#J;r^^2B85jVA>J!b` z+HC*sQ$9BywpzT9jsL2x%?6rsv@@YG87spn&}*Sz@Aymt9Kc#*FxBz#3kuHdZJ|8Q za>H+HKtpjLQK^0+PDD@{CEWlQVgYGe)E<~nvqH;KbBoLYUyZ2sldb%NJ^ve|&Yy&s z69~JqF ze|4(p{5vUN&vev{WmS3k8KjY;(%tIdX~3V}(hQ>qg}|^Ej~Mu5Pf`G(GK4eQLQ$Vb z)bIz~vznK}89Y;I|5J_P-fL{X??ra8n*snTKd+3y*dfjErKCZ4#W*xZNG71p-Itf* z@Yk`1wowrUBh!*1gp-DFWia-+a!x2;Y3Dd9lk20gIeX4kHc-9l3sG{4l-u^_6F>iK z&2C&^Oo69(l~%8U3Tbe6)1i$j%^-x`((8R?zk=rvsH(Mic^((kEDu_J$H&kIGb#3ysUeeRZt|0=NrfvWB_`>c4_B*sOq|4#Z+ z(L?3)y@zTWz{*TC0!Pyyjrso;T*M9|c#6o&P62QSTG}#WNG#RrQ#-~W1?_QwR>`u{ z4_ffp8A4Ir^a{bG>hCnWh^qS`80ud|im6TE3+sR>0eFKb9IAppcy5r!J+2<}?1zJZ zA!zTiy1FFl_i=~vD`q+A%g!QF{^^z}JZq(pEoG8#<9grZt~tvADSna4JAmwO+TTSY z;VAWf>0+a(7!Fd@4q){X3oIURuz`BVvR3sXN_(iFfe$MOvt?x*0Dc7c^Nk39Ggr*h z^{j~^KWvVLVAOW{SlalBkVYO@s-|8U;9!c`n>`TLOfmXd8*bS{g=w)*t~{ArM#=ck zb}c{Zyb#S0e=qHG7Qj?4qHknx1v39+N{ueZ!<)_Iq}|UF9VjL=q}jOkfyv+y?{gFC zpkLC7;3&h_Phu+e|9aLdFX;j4RN$0-#2K!Uy_Vq6G~N0E>p%NcgTA}idv?651yu|*cFc-1V8gHQCJ(@8Z`KFwFV6X$ zeBVwOr7LBd$v_Ck{d_BL6JtWMpOhn+^vB@nTe3rPoaavSUVXw?XZ@kN(^&S!Rr`oP zXx;%Jo1I704~CA~-}#%PBSjnTm_xwRvsyr|;7I91cPFn-L`%;kInZ#(6zChKN9;%UFYBn<` zI!QLw7ZrP>PXH@cM3ZC?ec^*P>qy<`1;=c#))=^++Bqh{pGzaLg8|rk2ZeEryN{Z+;~K>p&@=f`snS z0kvGkE4?Jn28^(wzEh4Hk%>;N13Q}ve~ZBLlJCqCPyAEHzfN%-sI^_oLT)U%z# zgvG8LnX|fl%?}q9ruOC966se6x>2t6JSsqks(PNhTpf7*kz@~5uLN4_UZlDR5G(p*4MtcVcJI-@ zo}y7?0Xb8?@IB~W<9C=2|J--I{CwTd>4Fsc^BjM8HnK6Q?NU8d+%8WfZ>q$tm0ekB z2;M?CjNZ(QvP6Hc>5WzY{S!VDe&oH8^!LZ@?Cg!*nyQ(LI^R9N(p;KKXMD zm zBheB2Bl2I($14j|Q0`CZdBIVosaD~ybsbN}Kh_&hu3y+WQM@#2uR4Ibr=|bxU72s~ ziHI;?V3)GNxTiJ=Akqb3jjYHBk4Z-`_jYBE?o?HyYIbnC>ns)i2Eq!_do=Z=Nj-%I zYq6wa7jA8r@8Y&f2|l?>fSZm6aOc*vfn6XoBK@l@m3@pW3?JNWZNQhxM!!)+qc*$2zbFFWGaM3-K+ zF=e!S!M%Oc!5fu5k70au3ebQ)q*0p~+*x9aO;}U%@(lQUI5Djv^LFWkaqqlQV9kw+ zVl2}S6gK+4&dUwvr>P$UjR?}{w{7wEA1kz(KEB4=?EjfTnhNcHU`=vxQTb$mXQ6PT zdlvxOVD+8+Qw=?B%Z=a{#q_aRV{JyKwTRM5j~aATE|=>^`&M`?t8;cDN4VSbZDchv z=#^>O%5_FbuxwgxuJ|VdR5QH+nV$jY#%_+LvODQz*dR&>G{t!N;)PWFSCm7tUUby> zG1~ip^=>f^N9J3TIK)fMAkP_X6)l*Q$gf#Pp7?5ZF3ELo1Pv>6?=Z2O z<~Pe9Jggf#^OR-aS>3oeg(ko|e}k9oKLOB%_)?Oqa?WrEI7Z%%Q85h>wXnCOuWuKc zP9E+72I4TBa^$r{cbIr1QeCihNX5EZYF#CmwCjH4g2OpO3R$dgHh$@% zcmQ_1Jk?w6+X*(~=qsz?)MS}8IBP>eQQ|#d4`nFF#&xSi<;mU?dj%@|LW8!Q5co0OKM*$F3a>= zrJS&$%r|xPZd=OWw<@gliO`3bzM~e17q7Zg>vr!yQMSY zF1aa#0-x09`a1pvk5^_EsW6ol$%jFjT&O6Vi*@}=+olv#S6!lFC?!^sX-ax?)$Ng( zU}CTDKW4s?#2qCRHYalrF-kYWD<-GV^8@_w5Ilvl9TXA_G{ z9G6bRk~Ycr8X@Y4d#lnp>JFgX<6|$f{T|t{fuw3M0yluNjzLZ~U_j2;^`%2dO=NS& z@&9ZGLV#-Qc~jcGq58Ok^7Ce^z}AZ=7jLlG_@!qAMNrxV)uFKBk}3cO>3{&Q)9aZ! z=-a!46i0e^NQKs99Cnrtz(n!aq_pnbwAk)jZkC*B8^oYJ}1z&MjxW{WkW zC~i}~%U!Tow;pim0CZaf2?_Gc*jTARreRw~q9v~BMh{Ien5%KYKHwB$&jTEL3jHp) zw`v-;-6dBOAj(SQnza&4Wll9Ro0OLeR2kNJQ1@&jJ)|_05B)eSuf31BB*})Ium6uA z&rYJFdF=Ha38~H*dWFn3i!G>X6KKF_*$f??|Hy;W0nIHt3azOw1wVd9&; zw=HjimB0lZa0C9Z<^6FJdO{O&um&TE$cynim!}B=yr7;&mn!?beaUlj`=QyltT{xI z+BX@0@7`ZJNm!(sK0FQVWjb57vQ^nZ;=z~YQuA$kvwUoNX3gM+n*nIHwXpeN*^T2s z%fn`yL3g|=fAax?`8V3;-I|ejtLikmh}?M#!}0k6Tb;DyE!zd&->*@rKd@s+`c!v7 z^mIz@Z-#Ga(=Mhc>9ZCRaggU0QU5+Sw*+ub@8m;;9d}<3(wqhXH_#xZcN^*8b06=) zzeVF!yHl_gcNG`w-|z&|C{X(+B9H%8ARC#R&*y_uz<5HMnOV>=;kK z7)U#fNp&@a<=WziEr|LO3l_|3*Za1Sjun>$$4q!GI}e?M$6p8TkqXq9*E@iMm+ZcU zZF-BP=*1qw0L+k5>FTt!Dpxt^CXtw7gqZqiHP=eq^o(<%Ybg6P%kD5pUzURK`}Fkv zfAPH^IRLKnzg&+*?p%Se-Wu`Uf#gLa5Q4XFx%sH0)DcSb7&W;NS0L}RX9U!T9&axJ zsavaGF=aVEIEn9i*$f)W!Bunu= z4X8Jn`5UNj&_>rK1*GYb2QKG7&ghI8AHL{)@=O_WqU_*g^w?eK*I<2I39x3<#F^*( zKl~wxhYyrtg4z}d1&`+Kcbbo29=UWru@+UIa=xtyw0^w)oWlF>!mq$KBDL7keQFey zSQeJ_oqTQSX|~#ki?`Db5@sc1S#xnj13=g-zoP>NXeK+qt?min4x6Fm`F2uw@v6ns zJ|6b%`WrQ@CQvg-Po=1F@9AEBkUNE9>06jZ73EcwsJwQqj;v;SYC&zwx%|mZYg=Q(84qXfUR)#Tyg$;W~e#OMuA=9)wuEAR- zdG2Gy_>aExKO55uHD?Y^;N^AJO{3IYdr{ufH3#c(paof|^<#Z|yDt0u!360nLUHNNUnQaBNl1DGa@S|w z_~eJo(n&{RM~~BU&cn6uXLE&4HkhOx;E{sX6UZ#fk{duLM zr{*@TKAg5ne~;z?&*S>H)eenxRGj$Zd$6%9MNwE&aajtka|O^_5wmFE8W-c9XjJk& z9?0MrfJ-gqg}jB`)G&{xomyr)Ur^sTZ9Dh(_KBFD$Bm=@E;ZEF)QnI9>G-y$wUf`C zjZwiA-cstSc8o3f^anNJTO6DXBVZGJ{K3fy&%0{J=nO&y#i37|{DwKtr9jj{C6%I|y=Q(La%#)g<<_{IsWK2x()$6A~{bzD=rg!<>lse^(kOj6?({du;?I)AU0X?Xy#Su3)qPZS}g&eB~-!k0r<&l6NAM!rztC$i%93tRF+uM zDQ~5b%40nLkur6@*C3nnDKxb3K{`-a+VVZ4kThBoDE(O;iaT5)%qofO>=dU9 z7bh`5v4*_UkvamD3aC}6JBZW}yh8^Z6eHcB&9AkH?RR6UU`cR+W4Y3#alcXNr^%o3 zh=1BUYKgZZ(%Ra0N@3adtw2xMMghH^jC0THk{DC(L|e&@XicDsFH)}IJTJgI8O9%% zHN4IycfK$+4FiG3%HqNbaZb)MRyEuZyWy2)DCM=Z=`p+YHEb_`q*_-;rgg;w3Jsrd zDHh9#A`);xH=N;p+6~jGnpO5fz;5=oUjV9$qGdgNZS)0kHwgb=QuMAR<+fWc{cq}) zw1Pt1H7qjZ4Nm-X{2>VJ<^ckRuN1fi%w=~!5VfO4b2 zEw|M1smiI3tD)DRVoKH1zRo!PIkn~PNu9W)x|5Vwvy!>FA#-}0uQvw7N}T)L#Jt#N z-8W(Xs>S86;*IqkoM8OdJ7#lwPc_PH_u94&<+JzbBOe-@e4S$rNf#jATU#?|zAJ^I z)vgL7GMDc3IMBNH0hj`R|768Dndb1=b9@5of7Vq45XzwCvN%4p$?RZ~tGi)ukR9Oub@QR`80CNXDMi=EO2k(Rqyc5!n=%=F|h`R z>ZHTG5u3|{dxSr@SF4Gt2m}^){EQQgH9}p#hHn-yH3Mte1TrXXF-jb$iieX5C zO${)x^DX-wJy)}%d9OeZq(g(k0ic&7zbwy68c{IxzorRXNEaEE*;4aIdb2Vd*O*4f zC;nEoSmA(wMxdMuFiJc+`Z~A*JN&%^I@7gjB=eut9!IPIPC);#N9K<L6RR|6`T#D=WU|F(?G{O#?!5o8Q@|_7jo5< zP8=QbZ+cW0d&R@HeUb;NU-ibKIs4%1Q4!3y8cS0_x2~eGgp$M{}HIks(v zp$X|lCT>lS7ze-0;P2@&23+l<%I~gQ>7JMBNP&l1skiYwGQ9zlccBs!^>q7dfFbWec?Ix4wGd;PRPC;o!&f`3AW- zSjdE@C%~lwh4Uzfv(g3jTDs@@&-FVjH-EhKPt=AekpHg6K6=`*#?|X>RfnnNM9KJe z169ko;~&;KGGoxyXPZ-=O>}@4Czq88-$?u2?|VKycu{g8N{Qd%PN0P5p_x5(um-iL z?30}7US5zz70Ff9bipU$vH>}@2bOgdx}8Buu8JC5Xy9@*r6%vqC-u>ZuG)ww9gx+a z94D7sL8~JI&fdM%1J&DWfzOqL(_|U0(gdaHz_~GOVXVstz+BlsoRBEK@_ibfm&*mE ztaEKsn?_6pWuF@;uTJ^;EEOOqDbUmxKYCa!1Wy2QwUg))jIYXgj4WE2K7Y5I3bx zA)|HDqe$mURj6Q-N-~q2x0-(9bock168Nkfwd`~^<+My@>&}_Z=gyBm1pNKbaG2O| z7~1eRG;8%DJ0FZ^B@QQw%pX~{y%W6^sKZ^%lssG-_B9puG#_gx)(_>x0#8ooR}hCs zKl8z6Yi^oxD@SBz)WK6m+{9K)8rpZv!Zf*{vzavOYo4uvZZM|rlEpav)kdS#vTdO1 zFdkPu3@g*=br>26dO~mZj`^9!(+aW|IG~Q3VbG-LT;82jaUS2X_qZZJ>K^dlOy^rn zbq4{5u>oUluknbfNDsKu0#=E!K-?o}LO+xUzRT0(YaF8;c+JoNrJD5Fro=X2!&9(60KVlD4++`YojPQ^u@H7)&`j`{ueO_7zQ;1*%6225;<$j=$CZP5m zp$Z;541CT{Mm(!SUQt_G(CJY8f~@PF#FAxK@xf-z_tLDcDpH#A-R}>gcOml?4X5if zr&BZ9!^dy)4$e}}4^x00JskI0^!5% zUUzF!dXP~vc17mf4->7s&c+6xdS^KbZZRW55Lc{PnL0tANN3AB!+apl_xcnFcW-5^ zDShTh*|Tzt|L)4ADti+$0oG&d{qG^w;K=Dr{^M4u423Wwf?Hz2i^{T zW+x%4DVUXV6@%^~3L>{L#p!(o0gdJ&Q#{~|J|Vpy5YvcY-#m8Rx4?_ zBbPoBx95I4yyL*GTkcrz~C{NeS?Bsbc;lao%y+#0Gt z)G48R7o&RoO3k<0b?a;BQ)n(+nPT3Yyo1@)gHO#~GppV)jXj9C=@pD_?36k0O=ebi zwz!KI6R3Lblhk6Ys#nF72ZM0Kigw}UQ!Ikl_`1e#Cv47>qX8-LuU)}tEhhD3r3jG} zT{yRy<`7IIXNi_7zDm2#Bt`vidioLeGZBqRJvn7KmhYn)nkX=2_9b8EwQgzA$3hAa zkqMO+eO*T9VT!aeVj^=9X1A}6NjF@9j6yL+2XQ2TCVuy_pzu@cPH0j4@C(dzjt=FI zH|@8Ox{qRosqUwc%=V+1d?&#TrTza9L(F3jK zr*RhT#AabwQQ|8Y8j|n537K3$QE(M>bVM%s;);TzX>PQLTFKd3=Tg%nK~UC!b<5bD z$iOUD>GJp7QZFpBpQQn3D#9G4V`3ES?SVsUGaU4}IisVZBH|-EN0ay&Add1rVLj|V4KzdRK3UOixciSuA=s4!+!=wZ=nJ7=hsC1`{e5P| zryN&UAOT`U?>vfd+FZlT{R-sm%pq=ZIx4-a=5{wvG;Pw#v=lJuAVAn(|p z7K)%;oyaUMY1%K^B}fd?!KQ}TMd>UauCKuj1+Rc764nr(CU zy~&JNku8Z4VT*`sbXF@p!~3_IT+LR?TQc(13#fGvaWpx#>%R?5HxF zcGp(-(rz#n#(KFaNyi>ujK&CYAgtxzUrW34f*3IxKg333<+CXBlo*gC!aG{cs~4VA zMjUE5Hdg(@?vB18i(47cWeGnPYeDxc00@S=PsT^;Y5&_szKd-XuoF_a4Ol=OVG-YD zcbueUj3)5Z>$U0|1fp5m=Xh7pQnZx|jX-31-zdgDLd1xyIgg#oyz`M;WTwdu zsH~Q?2ue0K?#x@ELR=w5%Tb|C5OWFH?^#d;Fg;Y?>x~RhATtXs2fYptjq+19ROwzxh}o z^w%L#Fu7a$9Ey-$3+^O(BOTUsWr=cOvhVDm^zn3Oscjk$zWeT598k6kYxgBmfi(~j z|KjdMW^EDr+#_5Q_&wq;(p@54znxj;fT?;q8F|5Y0` zK+m9?*g4-C8#Zxx#Tlpl)X*KG#C!7Fo-tP-yYZgXlB#_kP5Lb~wE{VLIMi|(G2E0H z6X+|r6Rm4Bwvl+Wz#rf&V|VmlEkH-NlUEbNf6CQ|&&~=kEV4ou$E(`!W(3OHO|_X7 zBirfouq($kRr1}egeHrS2N&41mDn#(=|y(x!Vl4s_mxP3ZtXQ-;Iq;$A1yjb+M))IsEMuPy@`Y zAf22n^xxwK{bzb*@a-SIsm4j5d;!ymgEJC_n(&m9fd_`n9R%cK1j4^{BPBV}PQT4N zGlWwHE8LZ5^J@|BW2q5e;RV&~cO{4aw#@d{OOCRa*P=Qnfww3Pw+^ z3US>)yZL_$&{bZ}c=st>^9D=O!yR8^6i1{<%Dw4CrAgmSnPJ` z|0LMGffwSr8E`mW|Kqj}HRth2U{_u!(?J2-FR#LhGP85A!-=JpHVS;vEGlK^>+^%L zWRmOOv7&q;86qMqHq+l>Hz&VV^|Q=$Fof43T0sGFRfy*cIdCa0mOR02ANt~mg6iW^8Vxn>2a}w&{1+)ayi`t{m52d$+1NS4(wom#1#r{Y@**RO`pPeWk1bxxOmEKrN!WK*k zLU$Sk$RGV>T-~pCizjdVoS>A)W;^@i&tQ?-^(+%Ie(oDA1I^u5e|$x`!0Z%|=H3L6 zjs4_ZvTz26WQVprc^iA;#%7_kZGuz5&4gr<<|Jvplz2zn>A2Nt}!&y+dQC!k8e^SkzXVBr^Fr)>8!xqY5vFQ4O=3$loL}7Ig-|6m~_dy>`lX zvkr3k{+>XH6n|$NF>355G;q6N5Pc{riybJr>0c)XuXI4Ll3UqxOuvpk-e8G}_~;xQ z6`~Z(LJ`iN`&;iS2Pe8uiJg!uG!g*)irqF;w^7nFI2+htwgF68P(+J4-6cnI#`AiE zNKyw_zG9^R7|FpyrQi>=@xzZytvCoq{00W(SS(i5tvg)WIp$J40vIZjj{lP{XiE{+ zQjQa{V`~cf`?jgI|Q zJ#mzg(`-ch%rw9ZlS8tAzmF>p79{ZfivN?~qF{GCPStD9tk`|#bIU%)_vB>hno(jD zD0XM{m=8J|eEuqK3|?L?nCI177P3T|_iFF{vz+3u{XzYJ`G;PTVP%q$z>?b$p3H zOTknJA#XzQD8xK$7=G<7EaF-Z$rsI|WF_3VC}vZgUgw9NmPU440JPUePZ6KEkgKU- z^qtOFtmfd#WCumMVK&S=wm}pv!{%wX$4Vr~CpL8!_ibf^e!H}Sh;$>g0{%8J0o~UJ zh8g2=z+8{MZl{3biOaVv@>%%Qog(IH2ce7=Pr0M^NUFW^pq3pP3wtiS`4pS1N^d5m zV>f$GO01>m2HL!?HGP_(lV12mDLdNMD$$rJSC%~}Zcww*X*J5t=B|e`^97jUzG?j% z0-3uVC8V3d+>gsq)Z!r8H(#`mQ5%x^^X+OkexT8VlnYIGvxet*LUpYoNSyq5%2zgl z5F_7R8HyRMwc-r}Q(3-Upt~t(qt~+GJ^l#6OpJgez$RrlEvOYCQLNB_KDu~r!2|TG zA9dw0cvmAZDPlnrYvDwuuaa9*E++$ovLKfGem~!8<_xXBj&A|R`YA#Fy9ZLhJ@^J1 z?f{JEpq@QI%%t%r$F;R&aAd-JAR`e-l2!)!;d(7)MGbnw1O#}pZ3`uK(}8fvvz6$c z$Z_|yl7l4 zEIwZ8OFOPTe#^7rj2K+~gmhC4;yLNu);Lr0NqW0otbXewW|Z^ar<3vhvuIHTtW;%j z7Z_GC4d+wvE2vOfX;5Tt@b1bX9*F@^2#E7Kx=&HkJq8%e^POK14AAcO<}XanGyWEGFre~9J}9GxPy z5mg{3W=V3D`9akIPh^GCzn6{ahf`=wqO*1OhsTK?&fq%Kn_!ZsLR+^{T+x-miVWCA zElupo4TGk09-msw^Ys=S+Lz_S`8$MT<*)bG>Q{^pJ9P^TDn23BMs;GN3`$)~O(Myq z9u}nwixFLjB7i=VdqYQ%`U$nFBlJt(4AIVSejxU|CfgP9El{3HgG~GW5Rn<6w9pDm zR&!(CMC&6o7!67n*{}}GPh-2r84PtWbXbV&mwY<+F}H*;n(8Jqc6^nYViAMI$Kj6( zmbD9ghJpFyh|y0D%X&h;sxs}{%DbJP$y|J2p8H}e-l0??GHZy+#Xhxc%sRTgDfEA) zEb6V^#vmC#4WAKf{p$yU0{wC!v}_8HwS?D*AkF3>U~;g@*9^mN-3z#fZre%D5D1r9 zcxC{2ZL1SmK>j1uXwQ^l9;w9X4vY!v6Mta%a?0Gq5@#bq7$+`Y zDiBno`*hm~2t24BnZIP~?XAm9eR?=cVoWB;t(_>??>kixCb-~&raP#OY_)=kM2iyV zAP7m|<)*K^^qpUc8`C2il`0+%Fu>u=0G#*0e1hcnm@g0>eeMZ0+?K|+-GnN|Ms@dQ zk7fbg4GUKQ=(D3@e57eAYGxq5{s_N6rceJfWuE418A1f|3`IdXLuV`XAN*YC=8_E)Yl91Z_%M=l!qba%subIPF!?RF<1h6 z0g0RCKinasc^^v~4DdY>q9PHwXvRA?!EyJ7t=`HDXX^OYEB(GFII&Gi_n9L6&R9Ot z0sY;(lE9!;U`o_8uIPl?5`dm%^7)kfFcICTZ)*|7 zs7J(DlC3W*>9*d`n~k6rpkFUT*oUo=z_v67hS4aZlmrZyKgsdWH1+< z9w^R#7%o|g{9^xHsyurAFT-6a;iLTfqZ!XQ{N^7p9Rjg-wcSX8e&IUfrdJ!whkLX9 zUF=lPJ;X8em!7iU`841+9|4bLcT%%fKs&4yxz>^okv8V?P^`6Em=FtvOEfc>~er!HRxiV=<(qBAPQQ;=yiVh1BD^6Xfb^ zar@Q+@~dI4%fuo|K$rvyQVDPyHgc@1qnwJbi&fFhTL^$Ys;)GDl01e|_3E~?4^`pP zpho$u0nZutbaNUCHHHX8meTIXBD6z+ zWNy^aHzL_0ppmuu-vaX4(@mgj{PAXAZ$h{gIL6rg32#dKeBQr)6GvnKE%jR+N~u2b zb6O&?SsSDYCo&lwJI&pC%um~-XAczO@dU+{cs0hVWpZ}1AL%>%gzS^H6~wB=iOO9) z^$mY^=LR@#NlvbIMv3=>PHr9P(DA*j1AnApHGDoc;u8X)w#HSHWxXJB+hF<^*8|N? z&xYeEA|}6Ar*16Gz$lPPVBT6usfW3%WhBYx!Q4BSrBno{FKK-p1O%9f=Hf)>-2zuW zWS&XXb7dsQHkKMy_VxcAQlrf6rZ>+-i;0J>!^}6c4exDRP&ot~8npe-BHsn%EBA>s z^3X)XkfqUdt}oc3lif112s)azWBtmUTPhyK#pAssHSN6qIl!+^=0J&4U2-{7=3p`s zRs5i@Wc4i%Zi&k0CD{<}pQ$ylSat=h2{$WrZE~&aw71F@eQ#k~vr`~sfOYu~<)N3j zpmRt4`QJMXn#$-X{ySTlyMydUCmW9)yoJs3el@9tK0=5HvO63L_v=56Pm(D94NO;M z4fREw6!n|DP7*a}vS~qUiw?&~tGsXz8qJw4siAX$@5pC}%S+qJcs-drldI!?H>#xWC@;reca2`PFE z=dQd~AlJxRF>6%%aA6q6-zM&mB(-ZTK=!Ncu^*#aEYgcqgRW7|p?2e5z<-rB+F%*c zxA^Wq@UVT^l4pEs3o=bi_+gdf89_pJ8F-f&WXXcB0;F&PJFeF|p0hwFodfJA8_qhY zmTOI97e;yo$jq5nUps8PV;0E#Oj()p^<5S;E66Tfb+=)w9CqhOpNyB2Tmwz*`qV|i zSRx!#4udp19+JpLF;pB=UDn8M<0(BCA@tEv<0|(k+H!tORpvag z&1N`EHjn7wvZolq`j=w7^6Xd)3?+EqCtzqB76{AKG@;Le4iuXmVz83LQJRp~_hIDW zf;xCy8xe#!@msUJ`%0m3Coh3dIJETf+-;QPy&IOc%%T(&!h2)yN{3ut2DkH5NH+Ki zPU*+$yq?P<1rzdNDpBhD);t<*?3b^w2^=E+ecM#kw)-9KP9!U7<1^0nRq)~vgY9(O zm_9ch5S3%1aa?M_ObQBLll1P{MpH4ipCsr>-G0ERm=Mp+X!BdEt^1J@B}l4NEUr?W zHnAzalT6OD?4c`sFP?Cs;7Nl_vZ~i5WKC5AAgg>|X=_~BwJvp=h-crFiR%3uJy=r& zaPLFSctjs|6Q~akeW0QjFBbnBPZj@Hf8?%Y^c*Rfj|n@AlG4-ycKb;@61u2P42o!3 zILnLqT>f72KXXM2#AK-z`gQ{%Hp5u7O{c0P@jHQe@r`c--miH)YMeN3MzHoQX#=jQ zhs1&^G$_EwDlJ$SllI&;qH>Vre^O61!?l85r4Nrb^YLMA${r3~_V;-cvpS=IASfc% zvm4B`=m@e>b?^w5D{HvwhkQbRy)?O$>~Agj*5kVkbNvUIYgz``cY=R;JsAMZ=&xV8lPT}TJ^hX6hx_xAN^K}Bma3(yw`WVq(OO`q zGJ}Dk{=aFv#9-P$jvK+`Nyrl9hKSp?t%V*?wy-l!>AHE&iMVEwHFt6uB2PQy*0;IE|{YNP9U0OU2&41iGFiqQh&^6s_Z z(+W>BmOr!ux91KaeY(^CEXc^-?o&+yz04$6XpJp9qPlo`!H&4Bcc9T?;_u^jJB)v7 zz%_+bENC`!a={!#>>hQqdbqzMPff2wQ~cMUf`ZH`P$c?;@xP;I!yo-;6Av581ATQ8 zJ6>V_+&v#owB}#Np$g#XU@DS>_oK(_@#a4fj-qbcVZ{(ut@n+{@ouF5Z{!e>XWBs# z^paHkcE!Ymn81fb80b*2{dcC<@XbDC0^=hq$7BB?b07s^%8rhjdGDVd6_)-5p^BYXrQ3ef z>WT1qob8fx{J=I&B2*ac<82dg@^q@nGi~I*wSvFpk`wG+w}eHU<;VY_?a;F~7X99B zlRy~)KKc|T6aoSXL0ht>`mVnB5OZ5Oo3&Y=;+ATm!giA6uQk29Y-;<)8y`N^v8b7D z{Mj~b8(G7X|~=D%|%MPr+W4clq z@?D0q=2>gN%}a8JK*nrVA+LqWYsfYp^^t3?zNLZ82WXQp<}_;7nLEjpX)eAG8v0M) zy~hrNZV~*s$F7$D@I{r)2Ckn31S)B57Z`#cSO^H4q`!CVm59;gKp$k;qp#m(l$7io60#tyXf1&53nGms z%_#~}n;j_Ob$H%l!CJCye-Z1wvB>zPYNcs%HeUpcJi*oJ0#s)zJ2T2h@LO{A(hmb}<8bqm)?k=Ufn*o&WkZute zq=p{4yQLexdpy41?_B4PbDiUXndiChz1LoQ?Y(f%e9?kajGvo*z=wjZok(v0$1ZTE z-W~j!xHl$xU)zcG;?==kP?B zB(b7son?vcLNO~*G%@BoT|93@-{-bgtUVlS>827jBrv<|6zY8Vkqi2}l&CtZim3M$67;u9z%^Qi5=7Tiz|>YNQInY+7)>dWPvv5>^Q~7dF$FFd*qse zl9<5zJ(9{)mrGLky?1x=yF_oQ$5gi?K0C6soitquhhz_tPfx8lZFBl#F_sN*n7Ky> z?VK!HP~x<>e}4XVJQ1T1y-M=OFZCoEC61ug*zKb9gC#Xn3MxEe_BKH&C5SiZHN~pN zHbbB%DSAc*uU?3hq%zc<#_Gk2X5bsl8E9*^TI?0dab(;L*%*f`cu$qS5y31ypJyDi z0`~RoiyNih_-{VkIURQ>{G^FZKT6{^c_t}A?Fq-UR$R$B^g<=%e7B0lMb?~N3h9DA z!T%z#K8PvLAs{o@M+V>&7#JA8szlY6t|&HCe@$3_q_S{iYYbX##x+WXh&MSEC?n%{ z0ufe?-=o-b*@<~BnzBpmGGfAOx8$uTBz|iIKEEAtKswJmF_5a@$7}rZUCs(lujF$A z--P%CliZv9hPw7h)qv9L5p}>RtyCpfY=S{B-Y!t?}?Ure+(E6G%s<1^G z3crqhL8GgB&WangK9i}$ThA=KHS20SASnFiD1IqTm_(7>G627h2r7R(o)oW3Rp)U5C zj+)XPEL~S|AKbKQ7uW^PgNdsHI?df~@t0&W$AZhdGR@bTj~*jl++J}Fd=~^MutV}~ zRE3x{-s!s_TJV>UQlO)a*>ikPV`TXp@MT?3em#Gu=mYh^51C1IR`8MJVepy^@He)K z2&c*juXym-`d2{6*W0BwG;<^Mn*+p%LdSC^y_Eqfq-X^cp#~(3 z8u{D45YX&XcuZ?0uw^bGDH@3|d11(6AWzF&MC1H?Cx~{rrnt{g5k<;pz>)BqXXeS< zB|l~J&ki|#8bXqea`Mko9A68LR4TvMU(UWNZ{a=4#6t0GXvN-25f{1$U#|)Kp57m^ zzA7>7L0$2br1Jp|sQO>uQ(To;{d@tBH5-`w^aM(eN8lYwBaSDlYnW79K0p7sg7-WZ z!njWSZ(A7#4VrkJYVDSMoF38}{ey*oAG19A7jFth0_ZvEo4e|zxMC9mwb3{r0@U$+ zDe%TP>t~aAzeArFndF^-b`Ji%Nl6?6(#i>Q0Wp3mGxzepK8L{Ui~h4?m3yUb4nmn@%V{O zDs=O=y5U=7q)lkZ%;(EcPO&~u23mptVN^_zgKQrF1{7Q=%DCbryms}D0tliOqzxwP$HM^gbq zDZPo$-5v?d-U}`CH*?G1d6_B^hE~q~)PfUT&BmkkgD7R!uu!Umgpe zE=Eb^t_WYB`jNYz06kS1=vgu8x5uBN6=<^DQ?}rznE?+b;95HC^~imRL8k`zNUA$* z`jVoZtXc}Vt$=52(;pvZxaItJ3p7CMazH(dUPjz60HldmL z+OG({(ha{2qgskE-;uW1UwSt+9YkVCkT8~Ts$22J;Wy&b6Cd4b=j$hI+@qeBP)y=Q zF}3JVMFiI@{85&6t(k&6A9II2B>yc~$0)X$1Kyzmy9vFnhJeaDR05p{Ye02s1HRMC z%j^20_uBR6jeFgeyZ!zB*i6+Qfkj>vPV11^=L`Wz}Z#VLvfSj<17!j$aj6{hn;X zgwN|{E{ohdf%Tk4-B#s8N=2=@9|aAet$XpecQk?AV|M zs?;#gZ~SePEYuV)1EG{`R=}9e;LO`bKq&oAm_9a3RJ5lkwgzjAbO5W|#_QX>ax2PA zDqU3f*?xyz-~Gf@njcz|;pYMiP{C=X@on!9)Jf+Lm#ynn?N%rfSB-H*zE z1*FTf_9LOgAtmy&K0nY_#1{j!9w8$6a<8ua)|KcE9IC+j_yJjV&X8I)_xoUdwpd=)xcL5tdirbndQF6lMXOH-4D0z!p=roFtuhVh_Qy87=Mk@`1{q;F` z+Pkpu7L~1>O7zJ&OQ61Y9(&5_N>2=K$tOlI3MR|oRxsoppWeRuZ?nHzH{b3UkL;kl z+q#nb`8ThJe89bRqwU79@!^jyrn+4OX~1gzKC*5;km2sV?334yYngG|qorQ{d#4xR z3!cvtHjR=SF2U;#QJU9VGgl%0&zu$`&{~vsa*qqR{boTKQVMVZ(Tb@jt+ZEX#n-j& zJ>U)w0w+i*QM4-^xZIEUR=;(Oyem|3*culTZPVRty4q+;6h7J5>td!&1JC?CT;w4| z8ua_0ua8`3!Bsq)+HpSy26N|-?1SGg!X_OTLfXk3wDuh!&rKq!khW|QtXHM$mauFj zx2)xa~!y9_YC5xXdIek%pTT)gaztL;cbEBH^>ubkgF}Y9P`BKH8UYgj$x((IXe# z?7b%;FTw$L#af02NcgMB5v6c9O&0JUP7ge6 zw1$>5HIj{~f6oe{)i;+AzePo*sn^9nxaGlB$91gD);~?-m-Anf5q+4f4)XGg_DHkg z)}4!`xKMwH98a^wH3%n3uDjq!Oj^{hiZN>dyTC>Er)~%Rjo4AFSt$hFfeFR+ds0nq z^8vKm;Dtx^mH`7=)%y7-qUGRz@$b~z>=C;nUW@vX*{elWNsA6LR`nzn;5>K$s3aZR zez6n$dkrsTALBfZzqj!ek8U_XqsrG;ZVEo0NaO2&aocb;jRnUW7n#8X@jE@fWgqJA z-6_g5$3Uac><0-=@F!q{xOl=+NGK@DdApqrxmfW^CA*7YT6WEPvv zD-E-2o^?1su=^bWcICQlfpq*Y@cKaqa)}!lKXWb!lV5~fPIaPG-i~OJTNI?acbB4u zjYs1q0lz&=q(BZUnsGdt^Rs9?U0$}pdyYN8Q7UWO@udUNE@zt-{H+c|ioD@?|8msJ zlvT?AFx`C;z6zNvdfJQbfKX+F3K6qq(T#0Sn<6bK2~6TAFku@F3d8SSDpSrX6_;*A z{{_vT^Fv2r>583b#TNPbXnW&fp~dN$Z^t~3xxlse4mzs2>w%=9x7CA8ZLad+v6 zq?X-QYe47%bHN%d^V+gu2KsFfG&-u>!Agm<5a1;ZzS^|Q^!_u-S`Y)t-3}BCnc}+Q zwC%^pfsJ>=(RjWPt?LhTu6IJSh3vN-97o$;H(H-X8mAl z%EGcz-?|eCb&FMR{j?ZYo_>@NugyUY09$&iO=L-?2YolAQl-|c|g7T2(8073p) zAio~v4paxm#m`(e`xiq(Lx%HqfaYU{7)c-&G4pX5SgazPrmUV?OjP#hct!6O)oqVg zTP*%>=sBPPShfwQFOCZI0uw=;Em9B$)8OpfO>vgtK9a~B;hizU^e!#Qe zCR2zy9QHr$kkRt>cYlTy8)+mt`q^?`xQ@MfbWJf=H(kL6&ruoVD1DP-5bq#qu*`0w zk;TGna|;lHadw{#`IhzmF8zMRHFa%TkA^p{OAPKVz~nfp_ggd{XjWW+S^W==OEIdU zp`m9B{=nNAt&Q3TN0!aSy( zR;ECR?iJXViKGG^v5j-Sq)5=#8IAY-_b)|&m6hBY|5$|J=dUOYe*OZSd$Vk)E=`3|WkT@JyV|2a#^h7t8ytVZ9z$idpW@i~oc&$W^+hbxgh2>d11x@L zYzJl03i1oua6N!2L5fM;>o!3Z)PNJoT>s}6F!nv;pE*T3H0~#3!A32bF45nE_fRFT z9RrO{aV`}B@=}~B>dpBB4h(A(u%><3R0<3=(STG>Pw$cNMG32~{}sRpZmS~XwczKb z9@nqPIyC{0<-rRfmwQhwf12o=kEen^B5K<~9rx7zWUi&9#ik)r9BrREC@(D7LL5m& zLAj#UFnRl%f}Zb+NwELR)Lw?n0#2hq-de`laZ6jvbQwVoB=0ctn-!DB3?#S3lysaAufHfcCg%KA#2dMs@U7scwoxmMCvW8LMo6YyLMvNns8^Va>u6LjtYP*J zbNrs^h>nMwTb)KBm-`0rwk@&%AYvCZO!@EocwP_iI)Iz!F^8>_qmqvrX9wpA0EFTZ z<5!b@LI>Z`%GVb!ULb2gZauL{J)eZG&sfy&A`tzPQ4NdK%oLP{DSt3AWR_EDMMOk^ zAlEGMdBSI6^vHtL*q-oM8K4w_Kh0BVx@g4^lly%_(0BMgqWbe}b1k1-cnrm;G7Lwy zh6;}vXbY@{QjqWYtK#AcUv^G@V>C-Tg)`CRKc}_!8j73q-u&g~;|wO%zg7?g{q6&W z_=Wb3aJ;KSwXie=fqNJwqqcJkITe+x3D480rDG-NU_30w`udB(>`3&I4p+8P5H&z? zV+>kU?%{`_Wc+gcTjk8|yFoU5DUt9n3oCTij zs3L8C4h~zCIxN}p7uKP^r+-E?P%AHjaBeqKR;R_}aeY2x;XY&d#CHzd(XA?S$Jws{ z+ZXz%J}h|+N`+5Ee6Xkt@;IZ~_9_*Nw_z`Yk9qh(r@PGxDth(Wef7(8OdnhzH4hiB z3Q7%NeBZZ4Mxnz?;aq2(rmbwC$+e?PL;U1(B^zO!ioe8qESXm%9aL%^p{UT%q{I|Q zN<_5!r|@sUc@49rfakoY2k+wTQ!4|}&IYP5uwqLtji zzrgE9+n<|`TAnV&rMhg_q@H%e-2Zry1J|Te@Iyq=5h4YUl{Omc{BzzA*XCw$LTrFj z^!1v&N1jJe0%(hFhq)i5i@uj9qp{_1pO~0F0tM4@AVU!kKv~)KR|Z|N$=028?&pan zMMh?tksvi!KP%F*?x2P&f5Ncs`uX!Uz8JFRwi}U#nd_!#(8#RkYwU;`UpYG(&hA&4 zrcUxs@iJh#6Equw7osQpFJ(-JFOhN!fR5*dvzR4-86Kp9Q2|Iv921?@V5P`o=&BH0 zfTDK96X(D5`+8>MS82|zTem<_CU)6{2GR3D%>bAYPM;1-hfkq+u9Mi{*$AX{&0EHtNX9j-HIT*}Kl4h#$_AjXL00S7u z6BbQ1A6jtaKvS20yIRlGv|HochuL)wr28Ztn{1E_Y?e*a-P@J#swh79g4?+J##l}3D1KWH43r28w>?-s0Mtnxr)52Elr0DfIMD+jygA)Z zy>`8<17lbyO^d?`Sh5`|`cfvaZ5}-84x3&;!!b2o>~Yu6J?LScCbJt-0I6^e)W+)9 zMlg`NKv3_!tn$W1Bc)K@<@mF!#r@No={gpiV{p5`Lyq)Mahwl8`9d0NqIP!B)WZ~* zy#T+rYsE_N8k9qP`@}^60D*@oLRSGU{^{n+gF40B_qp%y`#^Mz!3}uTJoFng-5x9zfe40xH%0MU5ty%I za%$I7V4JSngM0Tx!MZUn;**au__v#hVeq*sK&s3kB1X{0*_Q}_dMiMACgbn`B+1>zD&vFO1~GhEyay=F{5b5 zLj(M^$(f1_AMn%Uk%dnixZ%oWY#DDXnzipkjf%0i*`2ClZ60XPB*8<)wo z4KMyu>wUWFr?(H|z)8@Q&|8p;d7KtcJ@A=IdUKmnYk?{D6M~uU98lirQqWjZnuG zpr48b6%0f4LIwYXC?ZbC*3zSD^A0Ipc>v<_RTiEP0Zl!pV`zosmX(>&3`=}uz7Is* zF~>NkHxDlVey3Gh z_0#hYQtHez(t~uNa~1Zndb}H{${G{!MKF$0Hp6rAr-igm?DA}+=|hwIC4gBoDXx1R z>^ffLOR}QCi`;lFbXZJbk)I#09~{*xs|AGpEYKBR^?|imqjK zd*A4WXBib=Apb4|{9;&sxsO1X_aH!lT~QLxNIlP&39j{ zriYzv0fsNV!)*c(blJj}YoM&8kj&aDb_2s<=OJjY9+EA*pk3Z ziPQq6wsaqE0o`^QM z4d_#j2qA^V`&+IgJDi2Q42)&eR1t1y{DuZPfTWXg*lmC2QlL@zI099BYN-oo#3X=k z0Z>E>hUt3W<-T_ZY{1DD)?DikgDyZqT^v2&o@AMly;yxKyhnPE%=R6aXXSSVdgCMQ z>|j<FQqkU)h8oM=XwQHd zp0xe4tm9V-*#=wOx*v4^AeT(=A2Nk)aE>{<|LgOv(wbe@mx52aiLUt0flOsR`rd~v zke|DBu71p1)is^hA@0NhPG&EzY0?5+gDb`IP)RB>cd0eGyEO<76|9TUG+u65$WODb zOcFMoh+WUEfb4bI*Y|G0!3TH8d8F>*2rXSYGYuAR0yRZZ1q$WN>?zd<^fVO ziSYBw-7pVX7^fUDLne6@=;;|vbqdj11+h2wsh zuVW@71ZGutnXmVln}A-|KS%9V<8i}Ivg^o)^YM{0`Ui$WK=Mf1#avJ!d_LBT1O?Rf z5_l;SJiB$W4?(@*9Db|s1{ko^ct#3h|HEG&bf(uS8XYMymm!!T+_v-2j91^oLiE}d z11n#3!eVftVE5an@8P{mY0vu(F`FuiYt#wIfiCalrwPy)paTWb%=OCeapMfLl{&Fcur=$+7XED zrfYY-VBrbCC^`dB(6jSBDIe6NTL3cUy{AvE;Z^H~+v({&fsx@+Tak#r!S$9LkT&yl zjwK!aysHK{9Fh8%@s} z6v{j$8I{j?ubS2*DCv|n7%TMT&q&K&P*T)AEwciMr_QDH-DW(#Bz3aM!o;uT?6*hf zU4Z>xoi8OuA|%BY?<$-3#VR1iKY+52?W#_N!y= z8P|P4{VU7UeAo?Cy#Vjz?ZV4Vai9_W15jfH*tF2}2PCLWKt-BQR+py8JOx$2%n5>f z9rk&;`5yVjHTW_65xzFtAOzPe#cHm1wC<-I*Mr-;!H)CeLyh&42Us232x_)JI_6Wg zhv@bIps2tfLs!T9Nd98Id#9jVR)*xuXRo>wlpwjaDltY25q;03oS+W2W4h!2nP(BQ z*F|CnHca&8GRZz*XP`c}=FBUVpbP}`RkY_AFC=NNNPnbkZPi|rEdA)>WIYA~m7utd z^@hrolvVgoi-t)sCn6(Pa*#t((J=B&hG&4^ou36j2yI(;_qVE?zAne{h21x6Pk;I) zD%rw!U*lN`Z6y=V^2;EaBG{z1Ln@L3ElvG@^X4}jhJd$dUg|BG9Z)S!g6S)CL;|&Z zWbcX&;O3qIsd2Gm8^gK{T^2fHnU0ps^}i)=0MF)`>z`)Y6h|m#DS+Z=1OsNy(IAg| zC+jx41%(cA05)F&fC&iCxB0{CfD>#0NF9(ZWR^c~lzrIRTk2{;LmyCua8ElfpouU5 z&czgL``+BU9M-uU25l^M9v+^ihD5M+e&iYWIpEE0{@MC9AJJ-5!?9a^zNc2f6F>51 z7T)t7w(h=E5F;f?m!uQD%P=K4-j}P87!S7Bpp@h&*2SdgbZGleNc{?}j7$fmlG6O? zl#0gwo z_>*!3F13yz5F9$l^TjDIZamt4Gqj^NHj8soSwc=M?7b)0gil~%H|nBzy5;#+2gk}e({YEnU|~Kpo8` znJ7h)f!`=vz@f6{Pm5YJ?5UBLQhV1s$!(gEEpYsQsigg8;%T`X1nbuw;8aJl*Hhv5*r;~*?JB&N5&v) zf>)Y<(|%L|sH5O|AUG{&zdiiM>nYHv+#r|SJ9RBpn*?n^Fu49!R22+bf+BQcxZxJY zmr&><0*uf1!SHAdM}j@It!X)1z3n?XvrIFS1&il1V|18_I{s^3zH%W0L+IsR*+#wZ zzxrE61yaQqqUTA6d7r|P6W$@ni_BrtN_<8mp=UV3S>66;JuB6?hP!7C6Jb9ZVhhBE5`PJ!NGQWEXO0#I;L~{ z_VVuntk=wFeNLH8sC2pkzou%GaZMugvL}no{4=492HF!z4B4ZxK7j4d0T$GL+731- zzUGc4(~lvaVcDf^Lzc>FDOwr23rEY;H@dFfW1XlT*m4`|i6`(&kFl<|J^hBFj|fGopcVFGn$@QqsBi z(_55UrgHBqC@VWFD}+BuMO&*!qPFC9BV{|)<^E72vM4z-v+J()X&*^aR-sYm(o<>4 zsZ^Q1bBiJOrxGxFTDXnu?Uv2Rz~DeO63bn+dq;UwqZyR%6{SqdJ`e=_rz8GWg`W6I z$Oxc|TgGJ%4voI&dw+ZdBH8WMFZwd6fK|gJ6Te?(PBay;bouY+zc$~*qpnNYI%<5S z2&}qUC#Xb#=6b$>lr$d)XA%2Wjmm@6Kj3Si%0h{Z%2FQDnli#yTb*s0$T2BKTiN~i z;IVY{om!>xzXHmoJ{8ga!umH!+^6)%j~_!OUqez#FQ$gzb#O@Z;1DK78q2Ts*XJx{ zI$-?rv*(BouV37U zTT;btd@JnCT(7Uoj}vDwf=A+hijGpOuy6l{BoPsnlD))~rmHx5kgS2C7FLSnp{9JY z3<|ZN2t`G@j&6Ir1KT`OGCKZtjeJ)MjgyMgJ?#EV2ML{@{Vg82XPsEX5ebksUD3wK zkA~f*5WxL^eYmMS!TWad7JDh_KmFq>R>J}7Eet-dgm&@Hj$fe_%rSXZoYY_k;37x< zO37=$jlgkrJ2}%?aQt6x*8x%o$*cDYiy|HMwBupVz5#@b$-(6(0V?41M7ED5o z-C3P@sC`{C4Ljc9FVj;a;=$ZXxk%4F1)kT@J{XUCX6JiLya(W8cSO#4{AVg7vO zf6^p<9cDKK#+QedsF2X;5TiFbYf?2Dg;b*Wz7gy88y zir?3KclE1{Cm^mqDJvPJS#Rqtm$HV-$~|?o&DbbK8DsK4}v>iV%c-a$mq_mrWh3pTN|_A z;rdD)caX?tshK3GOZ8W?&}I&SnXk;r6-I}GQY0Tm#?Ys#V*@<(as$YRr`eM5`xJq< zu#M?dG}*VD>3_(XajH z#0@c?Q_{oiw39hS&*^2%^nzOoq4Z+GaP5^hB0c-l(wPJ=76xC_?s##M?plF?^8`aJ zHYPnaC%ebdk)n%S6=u3~e|9&=uT)|gR^Xg*uJb;)d?lL{Tkut@6;ak9(df#jg`w{~ zu?ZT!vyi*|E~Dsm7@Vasxgg&rmuZ)$wqLM1ypI>>jAiq9g775*RaP#|j`&>YLQ?b> zC>5}}hCM7<(+wW9s;SkdEJetQvr|SY()nNsbm8kAOhY12Qc@9j`FgUl<-~M^bDf|M zD<^~`yflmhc#V@VKY2~iMB@H(EOnj#aYH2Wd%IXZqrpBhpphUsK*H#a=x|_5z{a@< zU*cM8+4so?M&EN83BAc3VW$J|)P$mBa3dT(adCo8Z$ULSbfC6$Bmd9!4};7biS;Ff z016Ls#S?pe}x{{!g@BN;gt)jxdEQ_>_ zs1WQ-Qa7y`%h_7spm3Ic4+b(#wrwsm%zhPC_UFB&S&*WqyUl#pNu$VyVr{RhM$5V| z&Pq3!T`oAYidau{jU22)BYGj#)Iqc&YP*H7+&TLadIk3*@5ICT;urSO)RxZl93MFzJs6F` znCm>8KR5~U2xb)zWPMjF)P5kXb@9phb?lWG^0ZLZe#hhNBoI~&AL@Ijn%}T(g&b@j z9ol}BO5UBd(gQ6xR5sd&b|h;u2(? zu8ns@-B6Zng0GWgce;y6>3c~NJ2w-f_i90uRG@2@YE)&|;B5=3hzA+b2#)^tFO>m< z-ncaBV@KN`S-S7FTs+?Sij`Sq@nH#vRR}^Mko2;3!Q<#a2R*7&Xosqm)(Yf>iAC&e zJ~8uwczqJj*Wtl~R$s5_>ACXO{n_`hRa^E6Y<@d|qW_k8$oI$eCy`$8;aPsAVxYfn z>aok;4oblTFqA>st}blGoFD=H*3ur8+~6ei$#@YWJ)0aQwIo)lFi}DnT&gJfJxCUd zHZS1!UB&w*NiXrUtW$vDy!$sHHbl%IAGwyHxjcQC^G>Qf-fG6XxeVc&$8-VyP|P?N z9SYGMFI-nxF%cPu+tM7|qL-gmrLlbB&yQ=n^p-tT7k@A-_my$YTjOVtVzz`sK6tpI zHBv7)3!YOjdsF!SU+Hx@)=b1L(^w|pfSm5tf!q$qPFeEF&3{lo<3UHXl4}VMjDsGy zFC&&5$?K1ym_>UZnFTJJ!aVb9x-+6tMU`v}nX~XVTu&1x3maIE;i0L00yW==g(*8C zFVB4AM>lVJ`W9i_0vrOJaW$%&vxFL*j%#xJ%r13Dmu(BN7beKtQ|9KbguLyKl`*{B z>Ro_K(*^uSu~YuA`yW`-Ce>)U32ZAe_0vfEZ{y*GJj`Ab;OnZvH6zcCD_0cYJ;N|A z92Zp79BB23cm(2^h!!smC0*RnFG>D~JS$L4Fd!mjl5F5S&83iTrhDos&tIx}?*6L6 zTq_f`2@hj6tT{tC6iJWuc}TGKS=75pV+s+gHeH`6WH%NGTG*;Rj(B-AF7#X3#~Iq7 z&EHIvq|+($BrN4mC6m`otC;NHGfMW=#Rr4S$Htv+TZJv+Hn}&xXoj6($nHysmiPNW zE3i{-Baj{86Rt={9kRCV)|$Tne?(!)RQ;aRD$E13pPwcpdY}fo$ua{UZe!m~?7{0? zg-1Ss;9c=qgxl;))I4#c(>o5aQqQut4@#a&qu(MVR3~=Bny72zZgfj#<#QAO5y5NQ zP2EK$akKUCXO&wdLm={2Gz~x zN3wcal8*HR@g85qAK#M@YTfLEJAK^n(4H7kEighkb3e)+wa?Y9s>fSz54NUBeLrO9 zf2|myX0O$mrv&guu;{oRH1*Kge~(8EB?Y-frAa$beX@g50kmg`8LRf z;$1I4o??G2ni+LI9oD9FJ{dk~j$6oVx>hbh#IY;ka73xw#t~l+ldeeUFZos&{oc&Wv+-_{dPlRY(IB=ox3evpq9OnI`P&Zu#fXly0YtIK3s0=(Eu1 zeme7nP*;qoDmx?ZieP6GVLpwP+q%u&e?3D6=drj47%MBuskTB15(Rc;>SCgbd8fWG zo~e1EKA0zb$bm9O#>JdlHdsI81*Q6Cxm&F7iM5QV#>PHjb(st#qN;-XNn`-3jcDQ_ zZS1K~^1gw(s`6F?48EmJ-e|KDvr})y&RpcId<{2G;+fH^ufVx5BX~$h7qzp7)F3$sW9!=NCgQfbLT45rJ{&&wqM2( zXy%EN!i(S>-uFm6vNtvT8Fgf4nH#`GnSxbxltq>HYH)?PKfPie-j1u~b7v$O7fMA5 z(0}aaDpuJ=G2XOa9-D!>`i5>s^Sh=aR3UfM@xb(9^V0O3!%TfmnWiJTyTeYuzUwc$ z;)R04rEc5>nPs!oB`MEj#o}LBbkusUd}p_U?ir8O{<8i%#PNmZa2dEGR=?b7(dXDu zV2j{cfeo@DUV0DlnVj>G#dzM^*$g=Ts-Xml7_cU8Sv;pjd=8E9X@@wGA#;*ILNa zq#2i7qR%E5v`ubmNR?`1mrU_oC*6{Xqc=q~w*x=XKpXRLr^QyIji?5fZ{t`tEB}vvX|`a61R?Zeuw=#eg|ZMU(bnO+f=-)@ ztZgs7-(`CY5U%+YW+jz`r!x;c|3T0aFjQO0$BN88QjXabvTQ!GFmJfLRBbvOZ$vRy zi%U{ZUtE7s)KJO1T&#K|GqpgcpWYJaUtO!eBjF%wkxSbHp-aG=Mg(c?KK;iCXC2J0 z-2d-cP8RFWt2g_tW!$H*MzSwL+TntIM$Kc1{vRC4FKh2p@ND?AMm(4hlGaO05~88Z z95TA)IWU<$E5p<780Eg+J~i3Pf>M;$OICEMDP<;@KF`bR`eBb`7uTFPC7p3uJFLMh4)xF4h0Lcto~S9G;V1VtYoL~E;mq>=pX8@r8Y~!Ro}5t z6l$7H&R^~-O(m~Qi%#U8jE>@xyO$mKy&`$^Z89W;;8FzB&djikzQ?)K`m|?fyXo?} z$$CF?i`FAxFn^}@Xo}mM4Jq!ol-+dhJiJBLBN3IXRyqP+H`NeiU4$oMoMzIXOzoct z{=sNp06E46{RsJz-lq6krBy=x{d1unm$i-GIhTUdki43`NBS~>1swDJLSDeL;werDP+EZ;=`N~{} zXk1FSnuC=SYbO#IJ>_F-5f|LQNuQ+eFewFN_5!MwuTL4kip+{}NMVg#5|eMQeAUK# zkB>1!Qz#REs;S9NOa|<2Urb^j3-JFf`$!KHzTfta84-_4^w;8S=$p0sEThR^8pcOU z;y#+qv(jbFx)HFo{e*dDdI`?E0xM%fsNozG##QNDgr5DZVM#)@5~*IA-wSSLMerrb zzdHI@cb3<|@t+wChKjKWg9^q5tv3sCj7h8v6)R$_K*}z^{^e*^?07G4-x|-(Q@mWl zLb$dn@|1%hSbFM6ox~tp2O>sikXThzp&NW>=VH7laaGV{Vk}@PdEPqlFgmLgPeB=F zr`(R4|AQuNgS%30Lb{(n-7D}+c#Muuge+x~%3Ff40XMcU-SfYD`_Yc?OymxR)^7#2 z(#m7ec8M~hm~{vBScl5zKllhqR?9z{$%;yKY)3yQwI32F9X@)K_ykO6fML4$xA?5% zpbpS$&Mh#4(b{Jh;V1?UZ7Zo(9PcMuV}38f!JE2T=4>F~-Ee&WSYgINS7~$mW1iSV zEA`RG)PMQnXP~Lp*GC^Oy>UnQ6VzV9Dp*7P4}6y(!KK&_Z26eHL8v*u%N1V1g!t`E z)hML5(fcAk(%(B?)n&_c@+e^T)%Or^%&}?t`YmX^f3wMo+L=ubnplGdE-!K{f2I+Y z%dun)#~zfF4Yr!v>5xl~;X`;jh<3S}|64|+=JOzL`$j<~?!3OhgttCrZYSRqc5xZp zLZ(LDNS5&FYWb|KPdJ%vN#l`azY}u;De;FwOlm`0W!stFe9XU85rdW>ufG^C>wwBow#(1#XsU zviU<81z|+otO*k9<0_dHl$jOb8*q6ogKvYLHfwsBvGxTY0$53s5@~(SQZsqA=xOwW z`=g0ghaMRjYDdl8UZI13-n=1Cb6eiVQE}Zhktiq6n9_M^xZ%~tvB69o3t4uDoL6P< z4;3Q4wVLukVBrJid!mo|1k$OKTIxT(b5C%Fs8$_^T_j6|{ zm9ve{KL+_^a@RwhCR*2Nng7vjYOxO(-`_YGC!vAF>4qfr&;xoP*RGqkh^KF@nuA8u z0(j)%dX|Oy2bjJ{q^)KmB4l;6*r@CsC=eRSPnro3B=7MU2=zmN5?DgD#^y=%#<(}` z51Gb2<0e9`;J3=bt;!aV!EK)u`Ei<}zR!;C|A^pNT@h?$j7uN=c^(k-HJ*5BNl-6p zEJ37+!F?*kQ>4pWAGiP1>bj3Eh*F+3rc}Dc#zdVG;MEwTj^51bLj9pENT*v902^!=eSLr)s-W=*9tQa@)damr2$z`Wp6?7V8vhi_b&9l2@SA>~&IZ#}svof-x z&~?PKzli7KT<{EX7ZyQ2AADx2RH2yR#qh(C?6|kB}fQX03RZ3BuN^|I70hl@C!->fat}=gHbyMadCf;bbHfQ>qIL6fYnOx7-=U$jJbIVk2X(@fbCpP5w_)zXX~A ztF=T}9j&}htDEhm>)Fc$;Q-f$87OgvYBiAigc2 z^N23ebomJhv;>8xkizX&A!7!aKF<^_St^hkTsLnlzf2x6e>s)3T*6Aj&nUSL|ID29 z{2%jgNoS&#d_#>PA}fkGGGHH@LWb5LSON2US&Fi&3I{sXy)v`h7yYjyFs*WnrCy+i zX|>L}m7Rb5RFgOvAPe@5M=x^`t1*q!FqN9kbD&1csq2VVM}UeUM)f%MFh!N#n+H_a z8ol;Kh>A&`e~Zh3F*7ddw-!oS8g^KOjFt@MC%%LSRd?Yw$p)zS(J0amRc?U(G+tyV zO0i9w;;lsYzRp-JFky3NN36^2R@5o;wlR)+O*zPJx6-5$rGp+$j6vQjQVsmnUkWRe z)*}QNjALREHqFOHk18GZ=Qk;hiCpL}FZByz)mVs*O&dL0 zsxEEUri-w^(`z1^HJyNcWhkx4E?nkAFVM}8UW8*eUm7?lrIHKRo@iN3v>HKi;3u|x zWDosj+|4{()!eSu7L*10e#i{y(|*-BI-*c!q`ng=L=prc(nKsd~qi_bF<^og$QFrz&J~N%Aw_oz{9o zwDfO5Ct5WyDL85%{JADkD+wqDi8WMSpr2REAW%!BG@U5dpG)S|t~o9|C(ZUR;tZ5&Qzk96 z*OtpR>ovjxc4wp5R?Vl>_tR-FN!O+@DZp|BNFoUh$;(Z{1jFDvlJZKi+5_3!_i6SjN? zUNj$!?+sh2%%CJM(XwJ-xkuUygP;Wxkl$wu6!;*D736ZQtA%({Feepc;>IFNMU3Jf zz{XZDvZWKbX;->M7p)?H|HyxrS7SM^wc8bAROmg+iuj>5$B>K{#2PC8f|8Gi=LC2z zoTKMbi-Cx<%3-f+#_6<7o?O1Yhtnu|P+zMJH=$KOn;~Jw^(T)Vjn}_B`3H(VhX#Cf zh2R6~ml;+3rj^llpilj54S>M0oC3n{_`lS%hMh53b!#ADNHMYB71x6 z6brxmJrLD_ZD`@C`Uhq5?rP8OB+MfnX8&*P4%L6JOct_2_ z^Lk|`_dH3B8FWtU7b={@f~ZI7NI&EbnOp1fM99!YrCwj4#Z$f6gKHmiW*k>CEt>2_ zHjadmtl&1MxpT_fDiWq+{cn-9C3<)AR+4P~-8`=Fp^Cy#;Dl)60c-;s*U%Y{4E*sg z4otp3d8ED8l0Fp%v9f*7X@6m>$oO!rRb!V4S0U>7u=wRnq#{?zZI`b$;xJ!G2Y3eg zsh68Dv|=Tg)$62E(xqD438xzv`qKl~PxETFyd$Zyb!e`K+v`XPn&n6^S7w&9oZZw_gMsvOArbF;NQ?7Hl z!)y=bH9qMdk;rcOU!VUE2YAtibTA2;aWt^$nk&Ioe5{9xM?9-N1aEqpUyPX0)9TrT z5Dp%%rU`3b!UrjyW?rmZKnCw~>?{QkiD0sx;Cc=b>lGCB?3y*uPPw@ZSg`WdD#x)N zEfy+yq>fU*2$|hlob|@N83NgOxz$RLHirx_c>MN!D?hJB-1}giB!o$2tO^B$Vc>6I z?BWJSO|F41(sh5iN43dm>xlbE#g5S3b+6R$E&1_*xHHcOEfF3oto_XGscpE#ziaaf zV5QG*dGj~!cZhb?V@Fx>PSShh%9spF2=)7Xm1}o``MihbF?Ih6rMSIQ9qyEptS~6! z5ZxPe1^nR=VeL2Q%$zDqNIk>Af7Zin_v7Ieq3?=`Y;OsOGN%$=tD5g<^6*{gZ)2xG zs7LtD8lTsa2|Hh1CfiSj40+Wq@;dGK%qmK)B(54u^*%?Q{&+k%^b}=_(fgSzNqhUn za>I2haIOL2AkL!U5QQEmNls37Joq7H@$~wz<5r6Lec@b@ATpN*;X`|8Jrk3lL&rN0 z;c*VWFQt;J-2OW9e2E3iEIz*hUoo%d{J`aVVWKX;NOXRhyo69#LawUjw;d!vh9*4% z@RBTSPIFi=Q^tTIy;U23oF3->YswS$GpMHnt2nX-SD@!iCzohJ?8O6wT8atM=jnFM zTEGjF@$1%RYbQd9sOb6#Q{9e%d^$uH?Q$E@J+J1TByMs6N6WQipmGOtz~*~hf}^Lv zndfTjxarz0#mvun5=HDxZ$G;+;^PPl_}7>=<(Y)v>Eob+XhWd!a)!AAg=MCh8yt1) z06WbJ;$e*iRP!Nb3%}DQ-`=-&52o-9kMx~&`@`f298ZwWum(=1%iba6P*&n_SwOBK za%g&tP_95qge!Wz_3f+^D!MoP_IO*Ha$dfvd+y?lWq1v1r(mNy8BCyozY14BQ{4TitxO#m0JHm^ zM{+adEdW+;Izgf>P8*-7K!?5m$JBSnQ~kdGt5l?Ngovc0%#4neolb{189DZrW5lud zRz`LzE1W~&*du$BtdL{x?Ch1j`Q6_2`96OA*?8!F-Pe7M=XG7r=Pj-)&?xJwPcBTR zVfH00g4eBcRAM1M_BY`)3896%poqImB#U^W^05QCk5Dp#(@<6AnIanSEKNSvTj-1J zB<-sW5_AK#ey!YdIwXLfpWjm))-S_+w%u_i8MUNB330bwiH*Z1GIpmAG z`nOg6b+S|VTqia&JL^UZ!WpD}kn?B@>SIa<0DFLa=`&9_FK0OFQtYV*U6elj5ddt*v7M8nfppE{0^a(ji6j>AgDfI=iULs7*^s1l0w9NJ&YFp7-(gETbp;VnvPf z+8tQa_Ggd_D=NDG=zRPiDi?osl34PoVWb``3i&Z` zY_&U{>>$gHUMuo^PqSo3+xg^gS#E$nvvrx62MIR698e;2x6qo=T$og(DfpQ#Yk`4e z`M+dR^}FxlRJ2w&0j}~cu(!XMzlXhvyGhr^F~c6-%A)^K{a6I-R3&XuS^5`qOS^%& z`rxEjOIOt+`)%#}R)in#y)zm5>pi}i4F6)Hl0?f{=GY=4X+{&7t|1VGX2zhV!x`)7 z6swHR02hKUmyZ7>_Hw1lHEG4S>NTuiIPqrfTdQo+H>$7fSe+^^o&?{j=;yGEf9M!* z=>v6vHh>)&EwOsl(B^3{`x#2hnlU0l#((8+b!Ty=pP6NBuB|$o-d$a8JU#~StT5&- zt&pr4N(M%d#?wUL1WVdj{bc6B3LmR} z0!U>73uXEuSlY-+%!vMt)y>y6=>sk5e1S4~T0*pw;iHeyx?b6obDYeSn{Utz@85Ne z&jtmM0}aT%_hom-;y)LWbu)k1Jx!zki&K3Sb~{}Wm3(w-`W=`Oj_g<1ntx{@6PiDh z&BBxsS!K{C!AzN9ZNeO&UE67zV zT<+Cd&!6+0xeF&TW3l=!qqNZy^6tl>dG$u{H4A+!%zwV3EO_;#jI2|?zbw8)aD zm!={D>0B{S+ELiwo=OeGwED_7Nuk6vOihD%2R_;s34Q(UE z7s4zR{F^+;?vL|0yxz&sU$#+h#Iz0uXd*qUKiEeI&#^`T&^6MmZhHuzdU@LqfIJic z3v8hp0nazHW^?dXU>d{R@xZ8#?m1{V{5FcYMG-Poia3Wj3~U3osye4hLo1beLDx{C4KM^Yv` z&_e`c&?}Q)W7;pnnkt>wZom?NQ;4ovSadwJ`}a!So_?S*Fw1r{6RtCx&7vDHq}wpL z@*hC)f$U4+a#5=z-8`Zfh!2xF!G_GLkzzDAbkbrPe)16pYv;+hGc$05G?g!O zyI~;K9>2XQ^}bP(RoNMH{?MOzElB3ayXaZ^_dd*cqsvP=>=VFS3O+qMXs_^>$e+AY z2uI_JU$;%npL-@OZvjq=0mpV1*7!jYXWjcES6D^d%CesPC9PVzGD-aHhR~A!C%H}~ zSiWzuLRtE{%T4%i?Bnsrwich2!(*sLOBXQt3v6E&CO&>DS`|3B^SEx}2(?`+D(V## zw=35hWt-chtq2F>WoOIZGco#Bhnz8!)u*5~4uU0E0@y}RvuCZ~-*?qoZ0)EZI-bc+ z#97n43Z+6Lgw{g`JKlb5ahdfr2<6%!ZTb{hFaVlGD5Y>1p>bAFQAk^vl~uG|l=T4X zRk!at-XQkPe$38`Gd5i`LGJ#-`(w+5Pl`?)5Cv>omquDiM?UXA$9@d*w6Ys>gm}68 z`B{bK+P|@^OkMTjlRdHvSkq8r*901==s6VoB9LOeX!@wymFX?ysX?e?jw=%vmgLUJ z*F*?MkM=-+0f%d^a94x(@DO=YF|q}r+P6?K>X}*sYdTvWhdV5(dMNx2r9s)?2}y_A zay5%^{asReEznbIepk}@tW6s-dY5rlG=II@{X5;Wti<#hCgApS?j_Nh|+I)v%?}`L78%gL)rxuy)h+wOo;Fu^q5>?Ipg!`1Tp|%fcs{pBu zCF5`2|393Hg*|ucwz&}YucBWvvVX2Xr0&p_5Om*Bfg~tqj51@j>F|~UL`gX7SwPSF ztGG+z#hzH>jsISe-vl}oyQ$!BiY*LT;n7oWMh7jVocyl8{IXi_HCf%G2=l~)6o9zQ zWG{}Ya?gx=CN4K@;7Z6hsG2INhpg!SS+k&sisiX^3V@F4!xJg}dtR z<&gZ1Pa5PH)RPOZK04Q6RbvkKcVA`q%tpH@QdOmmDL64PWgw!L4Bz8V{Ula9gxZgk z?>*XO(OlzHqVjRRFBWgDKgTpulN(UU!MJe^V>!vuR7e;JgW~%xfipf z`j7bA=@;i!7D6Q+4T%+0XMjW@FN0H{U^m)t) zdU65$YAKyBp0#SXX^>wlz_v~`HF(A1uwrajxv}I0rbbAedW3`VM%VPSo^Y?@M)uJg zOVKBSeEsaYH8*4Z`h)H7OpArDS^qaf!sG^63*0L{-IsT|(Wp0aS@@kJU+kyE;O&i( zpy&T^E6;%-6q%&H3!_QT0mtL_V9e@3lTniaW2rYU;iT}8u%Scwp^(Le5e`AI=R^@c z8Rwop2mvLVbdwMbugk!W?eL@p7m$Xe?Fn+j7IWvkRBU_Lofm4$A{>L9eHskAv{t=c zk}5F}89t55@Cc!`=k_?MY@V*CT(S)fELg!Pdfk(bTSEmFxkS7}eu7=H_7z}YjEM4i z(?{JOg~|~32`o}WP~E$@7M5R4xPP8&ODNbkD`@GEV>8Zk4CLK^yOEuAMj){tP zK)b2#;`uW8VOmFC-oltjf}aXKJ$Olf-jQWQ%9R>8BS>BoBSf-NL@%H zEu5oncb6}HgDaOG3~sd^)_P;zaug`hVwrLUMcn@F<6et-c<(8ck|4?0MeWO`m9Z$l zEq`>zwi=)aMUkBRtlYNp~Hq`%@sklrxU7Pv{Kg=`a=36uu$~VJN z{sY72c|giHR}cy46%0dRR{i3hb5v-fP*{JEXitZ%89V-Na7pgF(;8>)ru0G`WP70Y z$l9B|{}tf_xkj!ECAo!fB2ikH%KfX?pl>H|n+U<27#hPd^}6nO4%Q@E_!dEw5^Hw& zV~(lt4d8_Ihn)Udr~~#!bMhb+i`~S5QHE|E67Ksn9|L_#yABPOAQg5IBJH&{4O!lk z6W9mLc&g@c)lit<`vkrwjS>8wWssaD5T)9yBR`qZKVi=Ku^I!y^T}TGmGnFANZVS2z&r1K=Sj*mMf(kulP(?|;-%?^EJ zNS7kkzDamm#1Yy+o9tYIz2OM6|2QN$&lz=#ye7fZ^|UjNM)x+i#>cC50Tn4}s4G%% zQd~1_GT)dAgDg8}*69>XWk#ZqxAiqYoDaJ1Y1UQ{8rUxoD`ObynoxVZGXjWbP6u{0 zxjFqQIq6ZCzmu|bFXwT;rCd;ncO{egbLVgJzI7c8e$r@IftLzJ5Q6M$yzKdMzl)CN z*%-n)7m9|B|BR_bwc0_6d&(E=C0<%`fpd%SDyHsO)0&z`kw-2*5n8_r&>!eET6Z`3 zi)d5}r#-_+8ixbaF@c4bL4v#XpguiUO`Bgog^HuC{Kcj;ca&|E<9$2{G)3{3aIK9D zyYgMzDkS|o;gcBmfnq0NFy1zB##C_&tfU%RTU&d3pH56nWaZVEZ@8Eq9&L88Mzr+z zzo$(r2?)<8tYJTgUH#wq_!a~lrqIurmC|8rvkF4OnqZjIVK*hNDQY_`nPv)56x{{R zIk=Igl5;k(2NX(7D1YC*>)p0H1AY`qs6D%sK2y;g1CN|(Y&6PY5q@8VrSJ&{=R5K& z(BV@vPVOjm$S-YjTLaJL3Sr+>IaoE?yk|J5u-3+gP#g`%J}ho=_in2FbmFBIRMdpE z7s&+MY-o3PcdO(2!&;NI8U5NnTbg8~MC5m(#Hs?xb650gT7@{azj3<#E~p zhirhzsV<6{Vomoy=bB_ao!z-TdHGg#awl#sGSp$~H|FYXg~O&!rX!loPZE{X~pzj|3@e8}O! zVEwsv8oRc(hRI1h6$K-TOw-F}HI?=FNmlJa)|nF5TJ7n{8RgmPlOr0s9Au9ffd*k~Xg^oa2 z>b^o%$37y{j+Y=z!w~y@ylO%>6xNQ|sCjzratvRdL+Pk+9X@*huH{s${36dZ3gQMXMZ&`J{iy&cq4_~`k(rnu z#N*G&P&oaZjw$E_%n?A@yL$W1of;r^adu0dHk}HBfBs8(aX6}U{+xPG(#kj7YvjkVQdj-cKA3bU%v^v(?9TH@zRj8AE~DO)BWw@$6N)5? zEULNag26T#Cp1_8a{Xs-Dt|$S@^rb#1HTspj;49BNkft^92g{hWAU%i(c>1yvwixb z-(%J8XEy?DEXT5F>4*F2*|sn^qS(mw?Xs2tFNJ|MsH9ZF-&9&s5!jkbzgVos(ALUU z!mVd>4TV)?a1w4IM*(bECor^>lb|ARCY~$GG1U)PL@@YXIMTXOKURzSe_+yqSn^}3 z^S0aZj<@FI*a#P=u`mTJpJDS_RW9-n9BA+BBYI811*(IDM#(YCK^qM|X-}&a@E#A| z_ms1&2!5{P0)(Hn2<6=hucxYaG^u{-7r{tD^2EKhVPYHg~Bx5bju3;XB9}Hy-`pm zcK>c9=J*Va2i^R$*S@!;e_9dC=K*$O$K0U>CU;g5Iu0UOAs_4f*?*VO3_v6oCO@J0 z=&Txgy3%c&yhCx?Z@UY)1kDpiKQkdMuw775s<%byjSSKMHjP?e^=*#}b+b zn|${p;TSoRri;@);09n#3R$lHkR0147fh7^fiV83|KP;ym%?vPHdAW6Dg?<;fC-!f zkP9@Er#<(cQ#W1lNbR|ye5FYP_9@0!UCT~Nd^f4vZRPm*81&?Tg#gk(mNw^fyp2yv zl2riZpMN~RooC{Ffq{mBg=T$&#QU_GhApcJ{vXWW^DSf*Z0dED`OCt%L*}%qd%djd_!R-VbeZjb)8~e3})Q=^^*-} zsB}-_Nn}=4PF`f_^F=42H-sQc{|R~3#cau?|9UcKYbQj(FoiVLh@Mkla`+#^_i3_s zF`;C+#UB?N_?g_+d=pJ?=;k_H4c3u)f&hbQ`vnOcgkjp`?pRbD%&vsd*a{Q&KKQw; zlYKpDF!WMK*$ZT@(c${yI!(JGB?slu-D-=aR*5}Bk3E}8MPGk8_VU^ZN?6$FuKYaq^4L$XR%5 zE8>keww}J-Pa5m9HYrH0$~`p&UX{lQ7C(M-=SYNhBaQkFm|cocO&;UV;1dWBx0}mwW7Mr zMKTyYUC38>ceDNDj9OEA4+6ZA);B zj(0PY8kwlh;J^V-oEi($Wxt%*r1=0p3%{{_7pchrZgB?LGUiXY>7E!aQ1ip%u1d5U zIatc_<#|>pTbld4a^Mo&PFZwqmL|HHoOP!67kFxG2cK!@6(4)`u9EUBE=PWMP0W29 z(N$&H=&q=tJqm*obMKv;oB+y$-a%gpx2^d)-^-7z$L@2p7j>5Rt=lj$@aWD=AYd-a z9S(y3YSbJMOXxY8gyPleN;SoK+T6-isiaIW19>7|upf~L`r;_G-)>#ySQz?T@D|&pNe^qHWU1h)Je zHndaPv>Y6x_|O`lW4y5Y?DCAderTp9O{viGcwDLc?bG&5{zT7>?Y6vClX8z^oVGaE zug9|NDRN(myHOwRC)w@%KA6TO_xVvWRA|LTC!UL zM4!4rv3nS;^m-BT*&O3gdwiGhe_awB$j1bgkStm}EN+Z)mX4`!wf9|$ieOK!v9*c# zQ>tpx_td^QMF^RG|hN0|MsJ zmPulYf4PlwR>y<|J9Yxu<{^WiT9{ZG0@vu+*A=sABicqbw_WO8HuyoMkj>OCa?e6& zUA>GSZ_iCl;mVlVef83<>Am-7Rh%RSqVTP0L5BB3Z*dgz3cEw9+-PHElp>YKr+00W zP9JDAN%EcfED0>cj8}P?>-{ZNiLi#iEtb3^oc$#;%iS zzR@<96UFhIO#Pr>^Yyz+2{vC0L&F&XTqnHX(&{qZe-qT>3Z7CP$2Pq2abUYe&?TMv zh7V@LRRJ3wV^Lc|X{Z;#>PrHP2<;Q?4QkAp$Y{(3xK{HjGV2$^UJ;DDf ztCUcDz379Kk0`pH@R+ZWpfh++{J{L^PgYQ&E;)@OOQ~}R?ezRawo_6j|AXAoM_^c6 zm>epWNQ*y}Y#KDT($znx{B`xi&dyFsWX2NyOLOQth{7P_xzpkNefjg3XEPqKep!+y z4_fGN%GMvXL%K&Mj}%=A_b3WV(o%#KLhYF{F`_uJ{gQTJZ#6bmGGuo)obkj3ckuJz4eO=DS-#>d_HC6=2nnx4+yq>yi( z8>*?f-Y9^lrjTc4)lr29VtazWla^s+K2TJ89UlPU;lAI~g!&*0j2ReH4#lugQGWEh z&wY!gK?sed6+M~yxY77nLX1W*r4$_s6Nt^RlI`n)FFTgeaW<|CEA-gzdn_(s9}9h2 zUA-p!7fpP1`#b3%6|CE$A2dWVkoSOaIg+_YtGDKp`~&W?NW+IeOnWj1whMas>V(5# zwD!50QfB*pkngs4VzfPog2VIpuRV+^wtUKJNdL78-(gBv@2CZtnZlPUsgXXh% zq&;O>$|eS^t_IDoCz}K;l_EG=gf}GyBQ9CuGr9E~a5vx(`10D?quUCA9F5gc*HkO< zaD3uEGff=o=o|60PnnB^yNjMjciTg21+Al|sql(Tsl|D1iYmEx9k!q&5mk6lWZiS5 zbV~g1NVI21D%6~*te}H7X+)*c8rA0<{aH_0nb!FUxFClZuGED*5sc?9eDhfr{->9Z z0-e6J`RlVhczRo7vKf)xCK>INLI09kvltc|QYi2rm5m*O(&y1x-7w^o-pqP* zjl1y=o%)41kWadqM|az2JYBOAm7D{ckaGvG-bG}r7;Q|g$NvTXKU0HncdtQ)fl