I used read_csv() from readr, which is part of the
Tidyverse. The original file contains 3,142 rows and 35
columns. Each row represents a county or county equivalent.
counties_raw <- read_csv("acs_2015_county_data_revised.csv", show_col_types = FALSE)
tibble(rows = nrow(counties_raw), columns = ncol(counties_raw))## # A tibble: 1 × 2
## rows columns
## <int> <int>
## 1 3142 35The census ID is an identifier, so I changed it from numeric to character and padded it to five digits. This preserves leading zeros and avoids treating the ID as a measurement. State and county can remain character variables; the measurements can remain numeric. I did not convert percentage values to proportions because the questions use a 0–100 scale.
counties <- counties_raw %>%
mutate(census_id = str_pad(as.character(census_id), width = 5, pad = "0"))
glimpse(counties)## Rows: 3,142
## Columns: 35
## $ census_id <chr> "01001", "01003", "01005", "01007", "01009", "01011", "01013", "01015", "01…
## $ state <chr> "Alabama", "Alabama", "Alabama", "Alabama", "Alabama", "Alabama", "Alabama"…
## $ county <chr> "Autauga", "Baldwin", "Barbour", "Bibb", "Blount", "Bullock", "Butler", "Ca…
## $ total_pop <dbl> 55221, 195121, 26932, 22604, 57710, 10678, 20354, 116648, 34079, 26008, 438…
## $ men <dbl> 26745, 95314, 14497, 12073, 28512, 5660, 9502, 56274, 16258, 12975, 21619, …
## $ women <dbl> 28476, 99807, 12435, 10531, 29198, 5018, 10852, 60374, 17821, 13033, 22200,…
## $ hispanic <dbl> 2.6, 4.5, 4.6, 2.2, 8.6, 4.4, 1.2, 3.5, 0.4, 1.5, 7.6, 0.4, 0.3, 3.2, 2.3, …
## $ white <dbl> 75.8, 83.1, 46.2, 74.5, 87.9, 22.2, 53.3, 73.0, 57.3, 91.7, 80.5, 55.9, 53.…
## $ black <dbl> 18.5, 9.5, 46.7, 21.4, 1.5, 70.7, 43.8, 20.3, 40.3, 4.8, 10.2, 42.9, 45.3, …
## $ native <dbl> 0.4, 0.6, 0.2, 0.4, 0.3, 1.2, 0.1, 0.2, 0.2, 0.6, 0.4, 0.0, 0.0, 0.7, 0.2, …
## $ asian <dbl> 1.0, 0.7, 0.4, 0.1, 0.1, 0.2, 0.4, 0.9, 0.8, 0.3, 0.3, 0.0, 0.4, 0.0, 0.4, …
## $ pacific <dbl> 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, …
## $ citizen <dbl> 40725, 147695, 20714, 17495, 42345, 8057, 15581, 88612, 26462, 20600, 31728…
## $ income <dbl> 51281, 50254, 32964, 38678, 45813, 31938, 32229, 41703, 34177, 36296, 41627…
## $ income_per_cap <dbl> 24974, 27317, 16824, 18431, 20532, 17580, 18390, 21374, 21071, 21811, 21399…
## $ poverty <dbl> 12.9, 13.4, 26.7, 16.8, 16.7, 24.6, 25.4, 20.5, 21.6, 19.2, 19.1, 23.4, 24.…
## $ child_poverty <dbl> 18.6, 19.2, 45.3, 27.9, 27.2, 38.4, 39.2, 31.6, 37.2, 30.1, 30.6, 34.4, 29.…
## $ professional <dbl> 33.2, 33.1, 26.8, 21.5, 28.5, 18.8, 27.5, 27.3, 23.3, 29.3, 27.2, 24.9, 21.…
## $ service <dbl> 17.0, 17.7, 16.1, 17.9, 14.1, 15.0, 16.6, 17.7, 14.5, 16.0, 14.3, 15.4, 15.…
## $ office <dbl> 24.2, 27.1, 23.1, 17.8, 23.9, 19.7, 21.9, 24.2, 26.3, 19.5, 23.7, 19.6, 25.…
## $ construction <dbl> 8.6, 10.8, 10.8, 19.0, 13.5, 20.1, 10.3, 10.5, 11.5, 13.7, 15.3, 18.3, 11.6…
## $ production <dbl> 17.1, 11.2, 23.1, 23.7, 19.9, 26.4, 23.7, 20.4, 24.4, 21.5, 19.5, 21.8, 26.…
## $ drive <dbl> 87.5, 84.7, 83.8, 83.2, 84.9, 74.9, 84.5, 85.3, 85.1, 83.9, 81.2, 85.5, 82.…
## $ carpool <dbl> 8.8, 8.8, 10.9, 13.5, 11.2, 14.9, 12.4, 9.4, 11.9, 12.1, 14.2, 10.3, 12.8, …
## $ transit <dbl> 0.1, 0.1, 0.4, 0.5, 0.4, 0.7, 0.0, 0.2, 0.2, 0.2, 0.2, 0.1, 0.2, 0.6, 0.1, …
## $ walk <dbl> 0.5, 1.0, 1.8, 0.6, 0.9, 5.0, 0.8, 1.2, 0.3, 0.6, 1.1, 1.9, 1.3, 1.8, 0.2, …
## $ other_transp <dbl> 1.3, 1.4, 1.5, 1.5, 0.4, 1.7, 0.6, 1.2, 0.4, 0.7, 1.4, 1.4, 2.6, 0.9, 1.0, …
## $ work_at_home <dbl> 1.8, 3.9, 1.6, 0.7, 2.3, 2.8, 1.7, 2.7, 2.1, 2.5, 1.9, 0.8, 1.1, 2.1, 3.4, …
## $ mean_commute <dbl> 26.5, 26.4, 24.1, 28.8, 34.9, 27.5, 24.6, 24.1, 25.1, 27.4, 32.0, 30.7, 23.…
## $ employed <dbl> 23986, 85953, 8597, 8294, 22189, 3865, 7813, 47401, 13689, 10155, 17895, 44…
## $ private_work <dbl> 73.6, 81.5, 71.8, 76.8, 82.0, 79.5, 77.4, 74.1, 85.1, 73.1, 80.3, 77.5, 83.…
## $ public_work <dbl> 20.9, 12.3, 20.8, 16.1, 13.5, 15.1, 16.2, 20.8, 12.1, 18.5, 15.2, 16.8, 13.…
## $ self_employed <dbl> 5.5, 5.8, 7.3, 6.7, 4.2, 5.4, 6.2, 5.0, 2.8, 7.9, 4.1, 5.4, 3.3, 7.8, 8.4, …
## $ family_work <dbl> 0.0, 0.4, 0.1, 0.4, 0.4, 0.0, 0.2, 0.1, 0.0, 0.5, 0.5, 0.3, 0.0, 0.0, 0.0, …
## $ unemployment <dbl> 7.6, 7.5, 17.6, 8.3, 7.7, 18.0, 10.9, 12.3, 8.9, 7.9, 9.1, 13.6, 19.4, 9.4,…There are two missing cells: child poverty for Kalawao County, Hawaii, and household income for Loving County, Texas. I removed these two observations, leaving 3,140 counties for all subsequent questions. This removes about 0.064% of the original rows. A national mean or median would be a weak substitute for these small counties. Keeping one complete-case dataset also makes the later counts consistent. This choice does exclude their valid measurements from later questions, and it has a noticeable effect on Hawaii’s averages because Hawaii has few counties.
missing_counts <- counties %>%
summarise(across(everything(), ~ sum(is.na(.x)))) %>%
pivot_longer(everything(), names_to = "variable", values_to = "missing") %>%
filter(missing > 0)
knitr::kable(missing_counts)| variable | missing |
|---|---|
| income | 1 |
| child_poverty | 1 |
counties %>% filter(if_any(everything(), is.na)) %>%
select(census_id, county, state, income, child_poverty) %>% knitr::kable()| census_id | county | state | income | child_poverty |
|---|---|---|---|---|
| 15005 | Kalawao | Hawaii | 66250 | NA |
| 48301 | Loving | Texas | NA | 0 |
counties <- counties %>% drop_na()
tibble(rows_remaining = nrow(counties), missing_cells = sum(is.na(counties)))## # A tibble: 1 × 2
## rows_remaining missing_cells
## <int> <int>
## 1 3140 0I used summary() to review the cleaned data. Population
is strongly skewed: the largest county has 10,038,388 residents. Some
commuting measures are also unusual, including a maximum walking share
of 71.2% and a maximum public transit share of 61.7%. These are possible
county characteristics, so I kept them rather than removing observations
solely because they are extreme. All individual percentage variables are
between 0 and 100, and men plus women equals total population in every
retained row. The employed variable contains counts despite being
described as a percentage in the dictionary; its values are consistent
with counts, so I did not cap it at 100.
summary(counties)## census_id state county total_pop
## Length :3140 Length :3140 Length :3140 Min. : 267
## N.unique :3140 N.unique : 51 N.unique :1849 1st Qu.: 11036
## N.blank : 0 N.blank : 0 N.blank : 0 Median : 25793
## Min.nchar: 5 Min.nchar: 4 Min.nchar: 3 Mean : 100801
## Max.nchar: 5 Max.nchar: 20 Max.nchar: 33 3rd Qu.: 67620
## Max. :10038388
## men women hispanic white
## Min. : 136 Min. : 131 Min. : 0.000 Min. : 0.90
## 1st Qu.: 5551 1st Qu.: 5488 1st Qu.: 1.900 1st Qu.:65.67
## Median : 12838 Median : 12916 Median : 3.700 Median :84.65
## Mean : 49597 Mean : 51204 Mean : 8.819 Mean :77.31
## 3rd Qu.: 33328 3rd Qu.: 34123 3rd Qu.: 9.000 3rd Qu.:93.33
## Max. :4945351 Max. :5093037 Max. :98.700 Max. :99.80
## black native asian pacific
## Min. : 0.000 Min. : 0.000 Min. : 0.000 Min. : 0.00000
## 1st Qu.: 0.600 1st Qu.: 0.100 1st Qu.: 0.200 1st Qu.: 0.00000
## Median : 2.100 Median : 0.300 Median : 0.500 Median : 0.00000
## Mean : 8.885 Mean : 1.763 Mean : 1.253 Mean : 0.07357
## 3rd Qu.:10.200 3rd Qu.: 0.600 3rd Qu.: 1.200 3rd Qu.: 0.00000
## Max. :85.900 Max. :92.100 Max. :41.600 Max. :11.10000
## citizen income income_per_cap poverty
## Min. : 199 Min. : 19328 Min. : 8292 Min. : 1.4
## 1st Qu.: 8276 1st Qu.: 38826 1st Qu.:20470 1st Qu.:12.0
## Median : 19454 Median : 45094 Median :23574 Median :16.0
## Mean : 70849 Mean : 46824 Mean :24331 Mean :16.7
## 3rd Qu.: 50795 3rd Qu.: 52248 3rd Qu.:27138 3rd Qu.:20.3
## Max. :6046749 Max. :123453 Max. :65600 Max. :53.3
## child_poverty professional service office
## Min. : 0.00 Min. :13.50 Min. : 5.00 Min. : 4.10
## 1st Qu.:16.10 1st Qu.:26.70 1st Qu.:15.90 1st Qu.:20.20
## Median :22.50 Median :30.00 Median :18.00 Median :22.40
## Mean :23.29 Mean :31.05 Mean :18.25 Mean :22.13
## 3rd Qu.:29.50 3rd Qu.:34.42 3rd Qu.:20.20 3rd Qu.:24.30
## Max. :72.30 Max. :74.00 Max. :36.60 Max. :35.40
## construction production drive carpool
## Min. : 1.70 Min. : 0.00 Min. : 5.2 Min. : 0.00
## 1st Qu.: 9.80 1st Qu.:11.50 1st Qu.:76.6 1st Qu.: 8.50
## Median :12.20 Median :15.40 Median :80.6 Median : 9.90
## Mean :12.75 Mean :15.82 Mean :79.1 Mean :10.33
## 3rd Qu.:15.00 3rd Qu.:19.40 3rd Qu.:83.6 3rd Qu.:11.90
## Max. :40.30 Max. :55.60 Max. :94.6 Max. :29.90
## transit walk other_transp work_at_home
## Min. : 0.0000 Min. : 0.000 Min. : 0.00 Min. : 0.000
## 1st Qu.: 0.1000 1st Qu.: 1.400 1st Qu.: 0.90 1st Qu.: 2.800
## Median : 0.4000 Median : 2.400 Median : 1.30 Median : 4.000
## Mean : 0.9681 Mean : 3.294 Mean : 1.61 Mean : 4.694
## 3rd Qu.: 0.8000 3rd Qu.: 4.000 3rd Qu.: 1.90 3rd Qu.: 5.700
## Max. :61.7000 Max. :71.200 Max. :39.10 Max. :37.200
## mean_commute employed private_work public_work
## Min. : 4.90 Min. : 166 Min. :29.50 Min. : 5.80
## 1st Qu.:19.30 1st Qu.: 4532 1st Qu.:70.90 1st Qu.:13.07
## Median :22.90 Median : 10657 Median :75.85 Median :16.10
## Mean :23.15 Mean : 46416 Mean :74.45 Mean :17.33
## 3rd Qu.:26.60 3rd Qu.: 29272 3rd Qu.:79.80 3rd Qu.:20.10
## Max. :44.00 Max. :4635465 Max. :88.30 Max. :66.20
## self_employed family_work unemployment
## Min. : 0.000 Min. :0.0000 Min. : 0.000
## 1st Qu.: 5.400 1st Qu.:0.1000 1st Qu.: 5.500
## Median : 6.900 Median :0.2000 Median : 7.500
## Mean : 7.922 Mean :0.2917 Mean : 7.815
## 3rd Qu.: 9.400 3rd Qu.:0.3000 3rd Qu.: 9.700
## Max. :36.600 Max. :9.8000 Max. :29.400percent_vars <- c("hispanic", "white", "black", "native", "asian", "pacific",
"poverty", "child_poverty", "professional", "service", "office",
"construction", "production", "drive", "carpool", "transit", "walk",
"other_transp", "work_at_home", "private_work", "public_work",
"self_employed", "family_work", "unemployment")
counties %>% summarise(
invalid_percent_rows = sum(if_any(all_of(percent_vars), ~ .x < 0 | .x > 100)),
inconsistent_population_rows = sum(men + women != total_pop),
employed_above_population = sum(employed > total_pop),
duplicate_ids = sum(duplicated(census_id)))## # A tibble: 1 × 4
## invalid_percent_rows inconsistent_population_rows employed_above_population
## <int> <int> <int>
## 1 0 0 0
## duplicate_ids
## <int>
## 1 0No additional rows were removed or values replaced after these checks. The race totals are checked separately in Question 9.
counties %>% filter(women > men) %>% summarise(counties = n())## # A tibble: 1 × 1
## counties
## <int>
## 1 19841,984 counties have more women than men. Counties with equal numbers do not meet the strict inequality.
counties %>% filter(unemployment < 10) %>% summarise(counties = n())## # A tibble: 1 × 1
## counties
## <int>
## 1 24192,419 counties have unemployment below 10%. A value of 10 means 10%, so the cutoff is 10 rather than 0.10.
I used the requested top_n() function, then sorted the
results from longest to shortest commute. top_n() includes
ties at its cutoff; this selection returns exactly ten counties.
result <- counties %>% top_n(10, wt = mean_commute) %>%
arrange(desc(mean_commute), census_id) %>%
select(census_id, county, state, mean_commute)
knitr::kable(result, digits = 4)| census_id | county | state | mean_commute |
|---|---|---|---|
| 42103 | Pike | Pennsylvania | 44.0 |
| 36005 | Bronx | New York | 43.0 |
| 24017 | Charles | Maryland | 42.8 |
| 51187 | Warren | Virginia | 42.7 |
| 36081 | Queens | New York | 42.6 |
| 36085 | Richmond | New York | 42.6 |
| 51193 | Westmoreland | Virginia | 42.5 |
| 08093 | Park | Colorado | 42.4 |
| 36047 | Kings | New York | 41.7 |
| 54015 | Clay | West Virginia | 41.4 |
Pike County, Pennsylvania, has the longest mean commute at 44.0 minutes. These are county averages, not individual commute times.
counties <- counties %>% mutate(women_pct = 100 * women / total_pop)
result <- counties %>% arrange(women_pct, census_id) %>%
slice_head(n = 10) %>% select(census_id, county, state, women_pct)
knitr::kable(result, digits = 4)| census_id | county | state | women_pct |
|---|---|---|---|
| 42053 | Forest | Pennsylvania | 26.7775 |
| 08011 | Bent | Colorado | 31.3656 |
| 51183 | Sussex | Virginia | 31.4734 |
| 13309 | Wheeler | Georgia | 32.1016 |
| 06035 | Lassen | California | 33.1659 |
| 48095 | Concho | Texas | 33.2844 |
| 13053 | Chattahoochee | Georgia | 33.3557 |
| 02013 | Aleutians East Borough | Alaska | 33.4746 |
| 22125 | West Feliciana | Louisiana | 33.6490 |
| 32027 | Pershing | Nevada | 33.7251 |
Forest County, Pennsylvania, has the lowest share of women, about 26.78%. I calculated the percentage using the county’s total population and sorted the unrounded results.
I added the six variables specified in the question. Each source percentage has one decimal place, so rounding the sum to one decimal avoids floating-point artifacts when comparing it with 100.
counties <- counties %>% mutate(
race_sum = round(hispanic + white + black + native + asian + pacific, 1))result <- counties %>% arrange(race_sum, census_id) %>%
slice_head(n = 10) %>% select(census_id, county, state, race_sum)
knitr::kable(result, digits = 4)| census_id | county | state | race_sum |
|---|---|---|---|
| 15001 | Hawaii | Hawaii | 76.4 |
| 15009 | Maui | Hawaii | 79.2 |
| 40097 | Mayes | Oklahoma | 79.7 |
| 15003 | Honolulu | Hawaii | 81.5 |
| 40123 | Pontotoc | Oklahoma | 82.8 |
| 47061 | Grundy | Tennessee | 83.0 |
| 02282 | Yakutat City and Borough | Alaska | 83.4 |
| 40069 | Johnston | Oklahoma | 84.0 |
| 15007 | Kauai | Hawaii | 84.1 |
| 40003 | Alfalfa | Oklahoma | 85.1 |
These six categories do not necessarily describe the entire population. In particular, the file does not provide separate columns for multiracial residents or every other race category. I kept low totals rather than rescaling them to 100%. A low total alone is not evidence of a data-entry error.
state_race <- counties %>% group_by(state) %>%
summarise(mean_race_sum = mean(race_sum), .groups = "drop")
result <- state_race %>% arrange(mean_race_sum, state) %>% slice_head(n = 1)
knitr::kable(result, digits = 4)| state | mean_race_sum |
|---|---|
| Hawaii | 80.3 |
Hawaii has the lowest average at 80.30% across its retained counties. This is an unweighted county average; it is not a statewide population percentage.
result <- counties %>% filter(race_sum > 100) %>%
arrange(state, county) %>% select(census_id, county, state, race_sum)
knitr::kable(result, digits = 4)| census_id | county | state | race_sum |
|---|---|---|---|
| 31073 | Gosper | Nebraska | 100.1 |
| 31091 | Hooker | Nebraska | 100.1 |
| 31125 | Nance | Nebraska | 100.1 |
| 48017 | Bailey | Texas | 100.1 |
| 48137 | Edwards | Texas | 100.1 |
Five counties have a total above 100%, and each totals 100.1%. Because the component values are rounded to one decimal, this small excess can arise from rounding. I kept the supplied values instead of forcing the totals to equal 100%.
I interpret this as asking whether the average county total for a state equals 100%, consistent with the state comparison in 9b. Adding county percentages directly across a state would not produce a meaningful statewide percentage.
state_race %>% filter(near(mean_race_sum, 100)) %>%
summarise(states = n())## # A tibble: 1 × 1
## states
## <int>
## 1 0# Alternative reading: states containing at least one county totaling 100%.
counties %>% filter(near(race_sum, 100)) %>%
summarise(states_with_a_100_percent_county = n_distinct(state))## # A tibble: 1 × 1
## states_with_a_100_percent_county
## <int>
## 1 16Zero states have an average county total equal to 100%. If the question instead means states containing at least one county whose total is 100%, the answer is 16 states. The comparisons use a small numerical tolerance without rounding state averages to whole percentages.
counties <- counties %>% mutate(carpool_rank = min_rank(desc(carpool)))min_rank(desc(carpool)) gives rank 1 to the highest
carpool percentage. Tied counties receive the same rank, with gaps after
ties. For example, the lowest carpool percentage is shared, so the
bottom rank need not equal the number of rows.
result <- counties %>% arrange(carpool_rank, census_id) %>%
slice_head(n = 10) %>%
select(census_id, county, state, carpool, carpool_rank)
knitr::kable(result, digits = 4)| census_id | county | state | carpool | carpool_rank |
|---|---|---|---|---|
| 13061 | Clay | Georgia | 29.9 | 1 |
| 18087 | LaGrange | Indiana | 27.0 | 2 |
| 13165 | Jenkins | Georgia | 25.3 | 3 |
| 05133 | Sevier | Arkansas | 24.4 | 4 |
| 20175 | Seward | Kansas | 23.4 | 5 |
| 48079 | Cochran | Texas | 22.8 | 6 |
| 48247 | Jim Hogg | Texas | 22.6 | 7 |
| 48393 | Roberts | Texas | 22.4 | 8 |
| 39075 | Holmes | Ohio | 21.8 | 9 |
| 21197 | Powell | Kentucky | 21.6 | 10 |
result <- counties %>% arrange(desc(carpool_rank), census_id) %>%
slice_head(n = 10) %>%
select(census_id, county, state, carpool, carpool_rank)
knitr::kable(result, digits = 4)| census_id | county | state | carpool | carpool_rank |
|---|---|---|---|---|
| 48261 | Kenedy | Texas | 0.0 | 3139 |
| 48269 | King | Texas | 0.0 | 3139 |
| 48235 | Irion | Texas | 0.9 | 3138 |
| 31183 | Wheeler | Nebraska | 1.3 | 3137 |
| 36061 | New York | New York | 1.9 | 3136 |
| 13309 | Wheeler | Georgia | 2.3 | 3134 |
| 38029 | Emmons | North Dakota | 2.3 | 3134 |
| 30019 | Daniels | Montana | 2.6 | 3132 |
| 31057 | Dundy | Nebraska | 2.6 | 3132 |
| 46069 | Hyde | South Dakota | 2.8 | 3130 |
For both lists, census ID breaks ordering ties so that each table contains exactly ten rows. This does not change the assigned ranks. The highest carpool percentage is 29.9%, while the lowest is 0%.
state_carpool <- counties %>% group_by(state) %>%
summarise(mean_carpool_rank = mean(carpool_rank),
mean_carpool = mean(carpool), .groups = "drop") %>%
arrange(mean_carpool_rank, state)
result <- state_carpool %>% slice_head(n = 1)
knitr::kable(result, digits = 4)| state | mean_carpool_rank | mean_carpool |
|---|---|---|
| Hawaii | 651.25 | 12.75 |
Hawaii has the best average county rank, 651.25. A smaller average rank indicates better placement. This result uses four retained Hawaii counties after the missing-value removal.
result <- state_carpool %>% slice_head(n = 5)
knitr::kable(result, digits = 4)| state | mean_carpool_rank | mean_carpool |
|---|---|---|
| Hawaii | 651.250 | 12.7500 |
| Arizona | 970.400 | 11.5600 |
| Utah | 1018.931 | 11.8655 |
| Arkansas | 1054.307 | 11.9013 |
| Alaska | 1086.379 | 12.1345 |
Using average county rank, the top five states are Hawaii, Arizona, Utah, Arkansas, and Alaska. I used the same definition as in 10d. The mean carpool percentages are included for context, but the ordering is based on average rank. Each county has equal weight, so these results do not represent the share of all commuters in each state who carpool.