This graph shows population changes in Davidson, Montgomery, Rutherford, Williamson and Wilson counties in 2013, 2018 and 2023. Data come from the U.S. Census Bureau’s American Community Survey (ACS) five-year estimates.
This graph shows the percentage of commuters in each of the five counties who travel 30 minutes or longer to work. The data compare commuting patterns in 2013, 2018 and 2023 using ACS five-year estimates.
This graph compares the percentage of primary jobs held by residents of each county that are located within their home county versus another Tennessee county. Data come from the U.S. Census Bureau’s Census OnTheMap employment statistics for 2013, 2018 and 2023. Jobs located outside Tennessee are not included.
This interactive graph shows the five Tennessee counties where residents of each selected home county hold the most primary jobs. People can select a county and year to view employment destinations and hover over the bars for specific job counts. Data come from Census OnTheMap for 2013, 2018 and 2023. Jobs outside Tennessee are excluded.
############################################################
# THE MIDDLE TENNESSEE COMMUTE
# PHASE 1: DATA COLLECTION
############################################################
############################################################
# STEP 1: Load Packages
############################################################
if (!require("tidycensus")) install.packages("tidycensus")
if (!require("tidyverse")) install.packages("tidyverse")
if (!require("kableExtra")) install.packages("kableExtra")
library(tidycensus)
library(tidyverse)
library(kableExtra)
############################################################
# STEP 2: Select Counties, Years, and ACS Variables
############################################################
# Five Middle Tennessee counties
my_counties <- c(
"Rutherford",
"Davidson",
"Williamson",
"Wilson",
"Montgomery"
)
# ACS five-year estimates ending in these years
my_years <- c(2013, 2018, 2023)
# Census variables for population, age, commuting,
# and working from home
my_variables <- c(
Population = "B01003_001",
Median_Age = "B01002_001",
# Total workers and working from home
Total_Workers = "B08301_001",
Work_From_Home = "B08301_021",
# Total workers who did not work from home
Total_Commuters = "B08303_001",
# Commute times under 30 minutes
Commute_Under_5 = "B08303_002",
Commute_5_9 = "B08303_003",
Commute_10_14 = "B08303_004",
Commute_15_19 = "B08303_005",
Commute_20_24 = "B08303_006",
Commute_25_29 = "B08303_007",
# Commute times 30 minutes or longer
Commute_30_34 = "B08303_008",
Commute_35_39 = "B08303_009",
Commute_40_44 = "B08303_010",
Commute_45_59 = "B08303_011",
Commute_60_89 = "B08303_012",
Commute_90_Plus = "B08303_013"
)
############################################################
# STEP 3: Download ACS Five-Year Estimates
############################################################
mydata <- purrr::map_dfr(
my_years,
function(my_year) {
get_acs(
geography = "county",
state = "TN",
year = my_year,
survey = "acs5",
variables = my_variables,
output = "wide"
) |>
mutate(Year = my_year)
}
)
############################################################
# STEP 4: Keep Five Middle Tennessee Counties
############################################################
mydata <- mydata |>
mutate(
County = str_remove(NAME, " County, Tennessee")
) |>
filter(County %in% my_counties)
############################################################
# STEP 5: Organize Dataset
############################################################
mydata <- mydata |>
select(
County,
Year,
GEOID,
everything(),
-NAME
) |>
arrange(County, Year)
############################################################
# STEP 6: Inspect Dataset
############################################################
# View variable names and types
glimpse(mydata)
# Display all county-year records
print(mydata, n = 15)
# Confirm five counties across three years
stopifnot(nrow(mydata) == 15)
# Check for missing values
colSums(is.na(mydata))
############################################################
# STEP 7: Display Results as a Table
############################################################
ResultsTable <- mydata |>
select(
County,
Year,
Population = PopulationE,
Median_Age = Median_AgeE,
Total_Workers = Total_WorkersE,
Work_From_Home = Work_From_HomeE,
Total_Commuters = Total_CommutersE
) |>
mutate(Year = as.character(Year)) |>
kbl(
col.names = c(
"County",
"Year",
"Population",
"Median Age",
"Total Workers",
"Work From Home",
"Total Commuters"
),
format.args = list(big.mark = ","),
caption = "Middle Tennessee Population and Commuting"
) |>
kable_styling(
bootstrap_options = c("striped", "hover"),
full_width = FALSE
)
ResultsTable
############################################################
# STEP 8: Save Dataset as CSV
############################################################
write_csv(
mydata,
"Middle_Tennessee_Commute_Data.csv"
)
############################################################
# STEP 9: Check Variables for Codebook
############################################################
glimpse(mydata)
names(mydata)
colSums(is.na(mydata))
############################################################
# STEP 10: Create Interactive Population Growth Graph
############################################################
# Install plotly if needed
if (!require("plotly")) install.packages("plotly")
library(plotly)
# Prepare population data
population_graph <- mydata %>%
select(County, Year, Population = PopulationE) %>%
arrange(County, Year)
# Create graph
population_plot <- ggplot(
population_graph,
aes(
x = Year,
y = Population,
color = County,
group = County,
text = paste0(
"County: ", County,
"<br>Year: ", Year,
"<br>Population: ", scales::comma(Population)
)
)
) +
geom_line(linewidth = 1.2) +
geom_point(size = 3) +
scale_x_continuous(breaks = c(2013, 2018, 2023)) +
scale_y_continuous(labels = scales::comma) +
labs(
title = "Population Growth in Middle Tennessee",
subtitle = "Five counties, 2013–2023",
x = "Year",
y = "Population",
color = "County",
caption = "Source: U.S. Census Bureau, ACS 5-Year Estimates"
) +
theme_minimal(base_size = 13)
# Make graph interactive
population_interactive <- ggplotly(
population_plot,
tooltip = "text"
)
# Display graph
population_interactive
############################################################
# STEP 11: Create Interactive Commute Time Graph
############################################################
# Calculate commuters traveling 30 minutes or longer
commute_graph <- mydata %>%
mutate(
Long_Commuters = Commute_30_34E +
Commute_35_39E +
Commute_40_44E +
Commute_45_59E +
Commute_60_89E +
Commute_90_PlusE,
Long_Commute_Percent = round(
Long_Commuters / Total_CommutersE * 100, 1
)
) %>%
select(
County,
Year,
Total_CommutersE,
Long_Commuters,
Long_Commute_Percent
)
# Create graph
commute_plot <- ggplot(
commute_graph,
aes(
x = Year,
y = Long_Commute_Percent,
color = County,
group = County,
text = paste0(
"County: ", County,
"<br>Year: ", Year,
"<br>30+ Minute Commuters: ",
scales::comma(Long_Commuters),
"<br>Percentage: ", Long_Commute_Percent, "%"
)
)
) +
geom_line(linewidth = 1.2) +
geom_point(size = 3) +
scale_x_continuous(breaks = c(2013, 2018, 2023)) +
scale_y_continuous(labels = function(x) paste0(x, "%")) +
labs(
title = "Commuters Traveling 30 Minutes or Longer",
subtitle = "Five Middle Tennessee counties, 2013–2023",
x = "Year",
y = "Percentage of Commuters",
color = "County",
caption = "Source: U.S. Census Bureau, ACS 5-Year Estimates"
) +
theme_minimal(base_size = 13)
# Make graph interactive
commute_interactive <- ggplotly(
commute_plot,
tooltip = "text"
)
# Display graph
commute_interactive# The Middle Tennessee Commute
# Part 2: Census OnTheMap / LODES Data
# Tennessee Employment Destinations: 2013, 2018, 2023
# Step 1: Load packages
library(tidyverse)
# Step 2: Define our five counties
county_lookup <- tibble(
County_FIPS = c(
"47037", "47125", "47149", "47187", "47189"
),
County = c(
"Davidson", "Montgomery", "Rutherford",
"Williamson", "Wilson"
)
)
# Step 3: Define our years
my_years <- c(2013, 2018, 2023)
# Step 4: Create a function to download employment data
get_jobs <- function(year) {
url <- paste0(
"https://lehd.ces.census.gov/data/lodes/LODES8/",
"tn/od/tn_od_main_JT01_", year, ".csv.gz"
)
jobs <- read_csv(
url,
col_types = cols(
w_geocode = col_character(),
h_geocode = col_character(),
S000 = col_double(),
.default = col_skip()
),
show_col_types = FALSE
)
jobs %>%
transmute(
Year = year,
Home_County_FIPS = substr(h_geocode, 1, 5),
Work_County_FIPS = substr(w_geocode, 1, 5),
Primary_Jobs = S000
) %>%
filter(
Home_County_FIPS %in% county_lookup$County_FIPS
) %>%
group_by(
Year, Home_County_FIPS, Work_County_FIPS
) %>%
summarise(
Primary_Jobs = sum(Primary_Jobs, na.rm = TRUE),
.groups = "drop"
)
}
# Step 5: Download and combine all three years
county_jobs <- map_dfr(
my_years,
get_jobs
)
# Step 6: Add readable home county names
county_jobs <- county_jobs %>%
left_join(
county_lookup,
by = c("Home_County_FIPS" = "County_FIPS")
) %>%
rename(Home_County = County)
# Step 7: Classify where residents work
county_jobs <- county_jobs %>%
mutate(
Work_Location = if_else(
Home_County_FIPS == Work_County_FIPS,
"Inside home county",
"Another Tennessee county"
)
)
# Step 8: Summarize jobs by work location
commute_summary <- county_jobs %>%
group_by(Year, Home_County, Work_Location) %>%
summarise(
Primary_Jobs = sum(Primary_Jobs),
.groups = "drop"
) %>%
group_by(Year, Home_County) %>%
mutate(
Total_Jobs = sum(Primary_Jobs),
Percentage = round(
Primary_Jobs / Total_Jobs * 100, 1
)
) %>%
ungroup()
# Step 9: Create employment destination dataset
destination_summary <- county_jobs %>%
select(
Year,
Home_County,
Home_County_FIPS,
Work_County_FIPS,
Work_Location,
Primary_Jobs
) %>%
arrange(
Year,
Home_County,
desc(Primary_Jobs)
)
# Step 10: Display results
print(commute_summary, n = 30)
print(destination_summary, n = 30)
# Step 11: Check dataset dimensions
dim(commute_summary)
dim(destination_summary)
# Step 12: Save CSV files
write_csv(
commute_summary,
"Middle_Tennessee_Commute_Summary.csv"
)
write_csv(
destination_summary,
"Middle_Tennessee_Job_Destinations.csv"
)
# Step 13: View datasets and check Rutherford County
#View(commute_summary)
#View(destination_summary)
commute_summary %>%
filter(Home_County == "Rutherford") %>%
arrange(Year, Work_Location)
# Step 14: Add actual Tennessee workplace county names
tn_names <- tigris::fips_codes %>%
filter(state == "TN") %>%
transmute(
Work_County_FIPS = paste0(state_code, county_code),
Work_County = county
)
destination_named <- destination_summary %>%
left_join(
tn_names,
by = "Work_County_FIPS"
) %>%
select(
Year,
Home_County,
Work_County,
Primary_Jobs
) %>%
arrange(
Year,
Home_County,
desc(Primary_Jobs)
)
#View(destination_named)
# Step 15: Save the dataset with county names
write_csv(
destination_named,
"Middle_Tennessee_Job_Destinations_Named.csv"
)
############################################################
# Step 16: Create Interactive Employment Location Graph
############################################################
# Install and load plotly
if (!require("plotly")) install.packages("plotly")
library(plotly)
# Prepare employment location data
employment_graph <- commute_summary %>%
mutate(
Year = factor(Year, levels = c(2013, 2018, 2023)),
Work_Location = factor(
Work_Location,
levels = c(
"Inside home county",
"Another Tennessee county"
)
)
)
# Create stacked bar chart
employment_plot <- ggplot(
employment_graph,
aes(
x = Year,
y = Percentage,
fill = Work_Location,
text = paste0(
"Home County: ", Home_County,
"<br>Year: ", Year,
"<br>Work Location: ", Work_Location,
"<br>Primary Jobs: ",
scales::comma(Primary_Jobs),
"<br>Percentage: ", Percentage, "%"
)
)
) +
geom_col(width = 0.7) +
facet_wrap(~ Home_County, ncol = 2) +
scale_y_continuous(
limits = c(0, 100),
labels = function(x) paste0(x, "%")
) +
scale_fill_manual(
values = c(
"Inside home county" = "#2878B5",
"Another Tennessee county" = "#F28E6B"
)
) +
labs(
title = "Where Middle Tennessee Residents Work",
subtitle = "Share of Tennessee-based primary jobs, 2013–2023",
x = "Year",
y = "Percentage of Primary Jobs",
fill = "Work Location",
caption = paste(
"Source: U.S. Census Bureau, Census OnTheMap.",
"Out-of-state workplaces excluded."
)
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(size = 16),
legend.position = "bottom"
)
# Make graph interactive
employment_interactive <- ggplotly(
employment_plot,
tooltip = "text"
)
# Display graph
employment_interactive
############################################################
# STEP 17: Interactive Job Destinations by County and Year
############################################################
library(tidyverse)
library(plotly)
# Prepare top five job destinations for each county and year
destination_graph <- destination_named %>%
group_by(Home_County, Year) %>%
slice_max(
order_by = Primary_Jobs,
n = 5,
with_ties = FALSE
) %>%
ungroup()
# Set county colors
county_colors <- c(
"Davidson" = "#F8766D",
"Montgomery" = "#A3A500",
"Rutherford" = "#00BF7D",
"Williamson" = "#00B0F6",
"Wilson" = "#E76BF3"
)
# Define county and year combinations
county_years <- expand.grid(
Year = c(2013, 2018, 2023),
County = names(county_colors),
KEEP.OUT.ATTRS = FALSE,
stringsAsFactors = FALSE
) %>%
arrange(match(County, names(county_colors)), Year)
# Create one interactive graph
fig <- plot_ly()
# Add one trace for each county and year
for (i in seq_len(nrow(county_years))) {
county <- county_years$County[i]
yr <- county_years$Year[i]
d <- destination_graph %>%
filter(Home_County == county, Year == yr) %>%
arrange(Primary_Jobs)
fig <- fig %>%
add_bars(
x = d$Primary_Jobs,
y = d$Work_County,
orientation = "h",
name = paste(county, yr),
marker = list(color = county_colors[[county]]),
# Show details ONLY when hovering
hovertext = paste0(
"Home County: ", county,
"<br>Year: ", yr,
"<br>Workplace County: ", d$Work_County,
"<br>Primary Jobs: ",
scales::comma(d$Primary_Jobs)
),
hoverinfo = "text",
# No text inside the bars
visible = (county == "Davidson" && yr == 2023),
showlegend = FALSE
)
}
# Create dropdown buttons
buttons <- lapply(seq_len(nrow(county_years)), function(i) {
county <- county_years$County[i]
yr <- county_years$Year[i]
d <- destination_graph %>%
filter(Home_County == county, Year == yr) %>%
arrange(Primary_Jobs)
visible_traces <- rep(FALSE, nrow(county_years))
visible_traces[i] <- TRUE
list(
method = "update",
label = paste(county, yr),
args = list(
list(visible = visible_traces),
list(
title = list(
text = paste0(
"Top Job Destinations: ",
county, " County (", yr, ")"
),
x = 0.05
),
yaxis = list(
title = "Workplace County",
categoryorder = "array",
categoryarray = d$Work_County,
automargin = TRUE
),
xaxis = list(
title = "Number of Primary Jobs",
tickformat = ",",
rangemode = "tozero",
autorange = TRUE
)
)
)
)
})
# Set initial Davidson County 2023 labels
initial_data <- destination_graph %>%
filter(Home_County == "Davidson", Year == 2023) %>%
arrange(Primary_Jobs)
# Format chart and add dropdown
fig <- fig %>%
layout(
title = list(
text = "Top Job Destinations: Davidson County (2023)",
x = 0.05
),
xaxis = list(
title = "Number of Primary Jobs",
tickformat = ",",
rangemode = "tozero"
),
yaxis = list(
title = "Workplace County",
categoryorder = "array",
categoryarray = initial_data$Work_County,
automargin = TRUE
),
margin = list(
l = 180,
r = 40,
t = 155,
b = 80
),
updatemenus = list(
list(
type = "dropdown",
direction = "down",
x = 0,
y = 1.17,
xanchor = "left",
yanchor = "top",
buttons = buttons
)
),
annotations = list(
list(
text = paste(
"Source: U.S. Census Bureau, Census OnTheMap.",
"Tennessee workplaces only."
),
x = 0,
y = -0.2,
xref = "paper",
yref = "paper",
showarrow = FALSE,
xanchor = "left",
font = list(size = 11)
)
)
)
# Display interactive graph
fig