Midterm

Most zip codes in Nashville area are unaffordable

Though rent prices through Nashville-area zip codes vary widely, most zip codes in the area are unaffordable if one follows the recommended 30% rule.

The map below shows the range of rents of two-bedroom apartments in the Nashville area, with the darkest shades containing the greatest rent costs. The highest costs are mostly concentrated in the Brentwood, Franklin, and Spring Hill areas, though there are other spots throughout the map with higher rents.

The first table labeled “Data” breaks down on a table what information is available on the map, including the hourly wage needed to follow the 30% rule in the area. The “affordability” status is based on whether the average Nashville area wage of $30.92 would be sufficient to live in that zip code.

The second table provides information of how many affordable and unaffordable properties there are, including the rents from the two-bedroom rentals.

Though areas farther away from Nashville center tend to be more affordable, it is generally unaffordable to live in the Nashville area with the average hourly wage while following the longstanding 30% rule.

---

Rent in Nashville area

Data
ZIP	Studio	BR1	BR2	BR3	BR4	Rentals	Rentals_MOE	Households	Households_MOE	Pay	Affordability
38401	1150	1170	1320	1660	2020	7942	602	26524	686	27.50	Affordable
37160	1150	1170	1320	1660	2020	4933	518	14238	493	27.50	Affordable
37080	1150	1170	1320	1660	2020	357	158	3056	394	27.50	Affordable
37025	1150	1170	1320	1660	2020	210	102	2607	337	27.50	Affordable
37180	1150	1170	1320	1660	2020	100	83	1308	189	27.50	Affordable
37149	1150	1180	1320	1660	2020	81	69	937	198	27.50	Affordable
37118	1150	1170	1320	1660	2020	55	59	424	155	27.50	Affordable
37020	1150	1230	1360	1810	2130	93	55	1998	265	28.33	Affordable
38476	1180	1220	1390	1770	2210	40	47	324	165	28.96	Affordable
37207	1260	1320	1450	1850	2260	8000	960	18067	971	30.21	Affordable
37015	1270	1330	1460	1870	2280	1708	379	7571	497	30.42	Affordable
37130	1280	1340	1470	1880	2290	11852	804	23624	927	30.62	Affordable
37132	1280	1340	1470	1880	2290	0	14	0	14	30.62	Affordable
37189	1290	1350	1480	1890	2310	348	184	1505	345	30.83	Affordable
37143	1300	1360	1490	1900	2320	145	88	1614	207	31.04	Unaffordable
37085	1320	1380	1520	1940	2360	113	86	1992	302	31.67	Unaffordable
37127	1360	1420	1560	1990	2430	1650	330	7056	523	32.50	Unaffordable
37210	1380	1440	1580	2020	2460	5901	656	8464	598	32.92	Unaffordable
37218	1380	1440	1580	2020	2460	2170	456	6227	516	32.92	Unaffordable
37060	1370	1460	1600	2070	2500	113	61	1079	158	33.33	Unaffordable
37115	1410	1480	1620	2070	2520	10961	681	19328	811	33.75	Unaffordable
37072	1420	1490	1630	2080	2540	4626	519	13778	696	33.96	Unaffordable
37167	1430	1500	1640	2100	2560	8823	720	23225	773	34.17	Unaffordable
37090	1430	1490	1640	2100	2550	2072	421	7916	497	34.17	Unaffordable
37062	1470	1530	1690	2130	2620	1070	270	5025	406	35.21	Unaffordable
37138	1510	1580	1730	2210	2700	2211	398	9708	458	36.04	Unaffordable
37228	1510	1580	1730	2210	2700	1791	352	1812	339	36.04	Unaffordable
37232	1540	1610	1770	2260	2760	0	14	0	14	36.88	Unaffordable
37238	1540	1610	1770	2260	2760	0	14	0	14	36.88	Unaffordable
37211	1550	1620	1780	2280	2770	16612	983	32716	1101	37.08	Unaffordable
37076	1550	1620	1780	2280	2770	8609	730	17897	865	37.08	Unaffordable
37217	1550	1620	1780	2280	2770	7861	688	13411	666	37.08	Unaffordable
37128	1570	1640	1800	2300	2800	10523	1007	28968	1212	37.50	Unaffordable
37129	1570	1640	1800	2300	2800	8241	990	23583	1187	37.50	Unaffordable
37216	1580	1650	1810	2310	2820	2719	337	9123	621	37.71	Unaffordable
37212	1590	1660	1820	2330	2840	4022	498	6822	580	37.92	Unaffordable
37213	1590	1670	1830	2340	2850	0	14	0	14	38.12	Unaffordable
37206	1600	1680	1840	2350	2870	6507	563	13079	662	38.33	Unaffordable
37013	1630	1710	1870	2390	2910	18517	1276	40353	1310	38.96	Unaffordable
37208	1640	1720	1880	2400	2930	6572	600	9805	624	39.17	Unaffordable
37046	1600	1680	1880	2420	2870	313	185	2589	292	39.17	Unaffordable
37153	1670	1750	1920	2450	2990	281	175	1982	326	40.00	Unaffordable
37209	1700	1780	1950	2490	3040	10641	772	20049	901	40.62	Unaffordable
37203	1730	1820	1990	2540	3100	11852	1016	14683	899	41.46	Unaffordable
37086	1730	1820	1990	2540	3100	3434	488	12887	545	41.46	Unaffordable
37214	1740	1820	2000	2560	3120	5541	609	14795	682	41.67	Unaffordable
37174	1760	1810	2050	2610	3070	5061	597	19512	852	42.71	Unaffordable
37064	1870	1960	2150	2750	3350	5589	656	24359	803	44.79	Unaffordable
37037	1900	1990	2180	2790	3400	395	186	3128	372	45.42	Unaffordable
37221	1920	2010	2200	2810	3430	5827	632	19935	848	45.83	Unaffordable
37122	1920	2010	2200	2810	3430	5052	585	24785	680	45.83	Unaffordable
37215	1920	2010	2200	2810	3430	2505	497	10341	666	45.83	Unaffordable
37205	1940	2030	2230	2850	3470	3784	611	11753	620	46.46	Unaffordable
37067	1960	2050	2250	2880	3510	6479	641	13405	867	46.88	Unaffordable
37014	1960	2060	2250	2880	3510	20	33	1250	403	46.88	Unaffordable
37204	1990	2080	2280	2910	3550	3200	349	7322	518	47.50	Unaffordable
37201	2060	2150	2360	3020	3680	516	168	799	224	49.17	Unaffordable
37027	2130	2230	2440	3120	3800	4030	564	22535	840	50.83	Unaffordable
37219	2130	2230	2440	3120	3800	1363	332	1704	361	50.83	Unaffordable
37179	2130	2230	2440	3120	3800	788	211	5918	546	50.83	Unaffordable
37220	2150	2230	2470	3120	3840	193	98	2213	256	51.46	Unaffordable
37069	2260	2370	2600	3320	4050	917	217	7125	412	54.17	Unaffordable
37135	2260	2370	2600	3320	4050	577	189	7827	611	54.17	Unaffordable

ZIP Code Affordability
Affordability	Count	Minimum	Average	Maximum
Affordable	14	1320	1380	1480
Unaffordable	49	1490	1951	2600

---

Code:

# ----------------------------------------------------------
# Step 1: Install & load required packages
# ----------------------------------------------------------
if (!require("tidyverse"))
  install.packages("tidyverse")
if (!require("gt"))
  install.packages("gt")
if (!require("leaflet"))
  install.packages("leaflet")
if (!require("leafpop"))
  install.packages("leafpop")
if (!require("sf"))
  install.packages("sf")
if (!require("RColorBrewer"))
  install.packages("RColorBrewer")
if (!require("classInt"))
  install.packages("classInt")
if (!require("scales"))
  install.packages("scales")
if (!require("htmlwidgets"))
  install.packages("htmlwidgets")
if (!require("tidycensus"))
  install.packages("tidycensus")

library(tidyverse)
library(gt)
library(sf)
library(leaflet)
library(leafpop)
library(RColorBrewer)
library(classInt)
library(scales)
library(htmlwidgets)
library(tidycensus)

# ----------------------------------------------------------
# Step 2: Nashville-Area ZIP Codes
# ----------------------------------------------------------
ZIPList <- c(
  "37135",
  "37215",
  "37064",
  "37060",
  "37014",
  "37122",
  "37027",
  "37046",
  "37221",
  "37153",
  "37210",
  "37202",
  "37024",
  "37218",
  "37062",
  "37179",
  "37025",
  "37206",
  "37065",
  "37214",
  "37067",
  "37246",
  "37068",
  "37167",
  "37069",
  "37189",
  "37070",
  "37204",
  "37072",
  "37208",
  "37076",
  "37212",
  "37080",
  "37216",
  "37085",
  "37020",
  "37086",
  "38476",
  "37089",
  "37160",
  "37090",
  "37174",
  "37115",
  "37180",
  "37116",
  "37201",
  "37118",
  "37203",
  "37015",
  "37205",
  "37127",
  "37207",
  "37128",
  "37209",
  "37129",
  "37211",
  "37130",
  "37213",
  "37220",
  "37037",
  "37222",
  "37217",
  "37228",
  "37219",
  "37232",
  "37013",
  "37131",
  "37224",
  "37132",
  "37229",
  "37133",
  "37236",
  "37238",
  "37240",
  "37243",
  "37138",
  "38401",
  "37143",
  "37011",
  "37149"
)

# ----------------------------------------------------------
# Step 3: Download HUD SAFMR Excel file
# ----------------------------------------------------------
download.file(
  "https://www.huduser.gov/portal/datasets/fmr/fmr2026/fy2026_safmrs.xlsx",
  "rent.xlsx",
  mode = "wb"
)

# ----------------------------------------------------------
# Step 4: Read Excel data
# ----------------------------------------------------------
FMR_Area <- readxl::read_xlsx(path = "rent.xlsx",
                              .name_repair = "universal")

# ----------------------------------------------------------
# Step 5: Filter FMR data for "ZIPList" ZIP codes,
# select and rename columns,
# and remove duplicates
# ----------------------------------------------------------
FMR_Area <- FMR_Area %>%
  transmute(
    ZIP    = ZIP.Code,
    Studio = SAFMR.0BR,
    BR1    = SAFMR.1BR,
    BR2    = SAFMR.2BR,
    BR3    = SAFMR.3BR,
    BR4    = SAFMR.4BR
  ) %>%
  filter(ZIP %in% ZIPList) %>%
  distinct()

# ----------------------------------------------------------
# Step 6: Download and unzip the ZCTA shapefile
# ----------------------------------------------------------
download.file(
  "https://www2.census.gov/geo/tiger/GENZ2020/shp/cb_2020_us_zcta520_500k.zip",
  "ZCTAs2020.zip",
  mode = "wb"
)
unzip("ZCTAs2020.zip")

# ----------------------------------------------------------
# Step 7: Load ZCTA shapefile into R
# ----------------------------------------------------------
ZCTAMap <- read_sf("cb_2020_us_zcta520_500k.shp")

# ----------------------------------------------------------
# Step 8: Prepare ZIP column for joining
# ----------------------------------------------------------
FMR_Area$ZIP <- as.character(FMR_Area$ZIP)

# ----------------------------------------------------------
# Step 9: Join the FMR data to the ZCTA polygons
# ----------------------------------------------------------
FMR_Area_Map <- left_join(FMR_Area, ZCTAMap, by = c("ZIP" = "ZCTA5CE20"))

# ----------------------------------------------------------
# Step 10: Drop unneeded Census columns
# ----------------------------------------------------------
FMR_Area_Map <- FMR_Area_Map %>%
  select(-c(AFFGEOID20, GEOID20, NAME20, LSAD20, ALAND20, AWATER20))

# ----------------------------------------------------------
# Step 11: Convert to sf object and reproject to WGS84 (EPSG:4326),
#          then filter to valid geometries (fix for hover/popup)
# ----------------------------------------------------------
FMR_Area_Map <- st_as_sf(FMR_Area_Map)
if (!is.na(sf::st_crs(FMR_Area_Map))) {
  FMR_Area_Map <- st_transform(FMR_Area_Map, 4326)
}

# >>> Fix: keep only rows with valid geometry so popups/labels match features <<<
FMR_Area_Map <- FMR_Area_Map %>%
  dplyr::filter(!sf::st_is_empty(geometry) & !is.na(sf::st_geometry_type(geometry)))

# (Optional) See which ZIPs didn't have polygons
# missing_zips <- setdiff(ZIPList, ZCTAMap$ZCTA5CE20)
# if (length(missing_zips)) {
#   message("ZIPs without ZCTA polygons (not mapped): ", paste(missing_zips, collapse = ", "))
# }

# ----------------------------------------------------------
# Step 12: Fetch ACS data 
# ----------------------------------------------------------

census_api_key("e96c46601fca77f6f3fcb0f72b673a75aed0ff2a") # <- Add your API key

Census_Data <- get_acs(
  geography = "zcta",
  variables = c(
    Rentals = "DP04_0047",
    Households = "DP04_0045"
  ),
  year = 2024,
  survey = "acs5",
  output = "wide",
  geometry = FALSE
)

Census_Data <- Census_Data %>%
  transmute(
    ZIP = GEOID,
    
    Rentals = RentalsE,
    Rentals_MOE = RentalsM,
    
    Households = HouseholdsE,
    Households_MOE = HouseholdsM,
    
  )

# ----------------------------------------------------------
# Step 13: Filter ACS data for "ZIPList" ZIP codes 
# ----------------------------------------------------------
Census_Data <- Census_Data %>%
  filter(ZIP %in% ZIPList)

# Left-join ACS counts & MOEs into the map data by ZIP
FMR_Area_Map <- FMR_Area_Map %>%
  left_join(Census_Data, by = "ZIP")

# ==========================================================
# Step 14: EDIT MAP CONTROL POINTS AS NEEDED
# ==========================================================
ShadeBy        <- "BR2"    # Which numeric column to shade by: "Studio","BR1","BR2","BR3","BR4"
PaletteName    <- "Greens"  # Any sequential/diverging RColorBrewer palette (e.g., "Blues","OrRd","PuBuGn","GnBu")
legend_classes <- 7        # Number of legend classes/bins (typical: 4–7)

# Customizable popup labels:
# Keys MUST match columns we will pass (ZIP and the *_fmt columns created below).
# Values are the human-friendly headers shown in the popup. Reorder to change popup order.
popup_labels <- c(
  ZIP               = "ZIP",
  Studio_fmt        = "Studio",
  BR1_fmt           = "1-Bed",
  BR2_fmt           = "2-Bed",
  BR3_fmt           = "3-Bed",
  BR4_fmt           = "4-Bed",
  # --- NEW FIELDS (comma-formatted strings defined below) ---
  Rentals_fmt        = "Renter-occupied units",
  Rentals_MOE_fmt    = "Renter MOE (±)",
  Households_fmt     = "Occupied housing units",
  Households_MOE_fmt = "Occupied MOE (±)"
)
# ==========================================================

# Friendly labels for legend title (optional)
friendly_names <- c(
  Studio = "Studio",
  BR1    = "1-Bed",
  BR2    = "2-Bed",
  BR3    = "3-Bed",
  BR4    = "4-Bed"
)

# Legend title shows ONLY the selected ShadeBy field (friendly name if available)
legend_title <- if (ShadeBy %in% names(friendly_names)) {
  friendly_names[[ShadeBy]]
} else {
  ShadeBy
}

# ----------------------------------------------------------
# Step 15: Helper: Build a Brewer palette safely for a requested size
#  - Uses up to the palette's native max colors
#  - Interpolates if you ask for more than the palette provides
# ----------------------------------------------------------
build_brewer_colors <- function(name, k) {
  info <- RColorBrewer::brewer.pal.info
  if (!name %in% rownames(info)) {
    stop(sprintf("Palette '%s' not found in RColorBrewer.", name))
  }
  max_n <- info[name, "maxcolors"]
  base  <- RColorBrewer::brewer.pal(min(max_n, max(3, k)), name)
  if (k <= length(base)) {
    base[seq_len(k)]
  } else {
    grDevices::colorRampPalette(base)(k)
  }
}

# ----------------------------------------------------------
# Step 16: Jenks breaks + robust fallback (prevents non-unique breaks)
# ----------------------------------------------------------
vals <- FMR_Area_Map[[ShadeBy]]
vals <- vals[!is.na(vals)]

# 1) Try Jenks
ci <- classInt::classIntervals(vals, n = legend_classes, style = "jenks")
breaks <- sort(unique(ci$brks))

# 2) If Jenks couldn't produce enough unique breaks, fall back to quantiles, then pretty
if (length(breaks) < 3) {
  qbreaks <- quantile(
    vals,
    probs = seq(0, 1, length.out = legend_classes + 1),
    na.rm = TRUE,
    type = 7
  )
  qbreaks <- sort(unique(as.numeric(qbreaks)))
  if (length(qbreaks) >= 3) {
    breaks <- qbreaks
  } else {
    pbreaks <- pretty(range(vals, na.rm = TRUE), n = legend_classes)
    pbreaks <- sort(unique(as.numeric(pbreaks)))
    if (length(pbreaks) >= 3) {
      breaks <- pbreaks
    } else {
      # As a last resort, ensure at least two unique break points around a single value
      rng <- range(vals, na.rm = TRUE)
      if (rng[1] == rng[2]) {
        b0  <- rng[1]
        eps <- if (abs(b0) < 1) 1e-9 else abs(b0) * 1e-9
        breaks <- c(b0 - eps, b0 + eps)
      } else {
        breaks <- rng
      }
    }
  }
}

# 3) Final guard: ensure strictly increasing, unique breaks (and at least two)
breaks <- sort(unique(breaks))
if (length(breaks) < 2) {
  b0  <- vals[1]
  eps <- if (abs(b0) < 1) 1e-9 else abs(b0) * 1e-9
  breaks <- c(b0 - eps, b0 + eps)
}

# Palette length must match # of bins (breaks - 1)
n_bins <- max(1, length(breaks) - 1)
pal_colors <- build_brewer_colors(PaletteName, n_bins)

pal_bin <- colorBin(
  palette  = pal_colors,
  domain   = FMR_Area_Map[[ShadeBy]],
  bins     = breaks,
  na.color = "#cccccc",
  right    = FALSE
)

# ----------------------------------------------------------
# Step 17: Precompute FillColor (avoid hard-coding a field name in leaflet)
# ----------------------------------------------------------
FMR_Area_Map$FillColor <- pal_bin(FMR_Area_Map[[ShadeBy]])

# Build a clean hover label with comma formatting (no dollar signs)
FMR_Area_Map$HoverLabel <- sprintf(
  "ZIP %s: %s = %s",
  FMR_Area_Map$ZIP,
  legend_title,
  ifelse(is.na(FMR_Area_Map[[ShadeBy]]), "NA", scales::comma(FMR_Area_Map[[ShadeBy]]))
)

# ----------------------------------------------------------
# Step 18: Popup table with comma formatting (no dollar signs)
# Create a formatted copy for display; keep numerics unchanged in FMR_Area_Map
# ----------------------------------------------------------
popup_data <- FMR_Area_Map %>%
  mutate(
    Studio_fmt = ifelse(is.na(Studio), NA, scales::comma(Studio)),
    BR1_fmt    = ifelse(is.na(BR1), NA, scales::comma(BR1)),
    BR2_fmt    = ifelse(is.na(BR2), NA, scales::comma(BR2)),
    BR3_fmt    = ifelse(is.na(BR3), NA, scales::comma(BR3)),
    BR4_fmt    = ifelse(is.na(BR4), NA, scales::comma(BR4)),
    # --- NEW: formatted ACS fields for the popup ---
    Rentals_fmt         = ifelse(is.na(Rentals), NA, scales::comma(Rentals)),
    Rentals_MOE_fmt     = ifelse(is.na(Rentals_MOE), NA, scales::comma(Rentals_MOE)),
    Households_fmt      = ifelse(is.na(Households), NA, scales::comma(Households)),
    Households_MOE_fmt  = ifelse(is.na(Households_MOE), NA, scales::comma(Households_MOE))
  )

# Build the popup data with user-defined labels as actual column names.
# IMPORTANT: We pass THIS object to popupTable and use its own colnames in zcol.
popup_labels <- popup_labels  # keep as defined above
popup_keys <- intersect(names(popup_labels), names(popup_data))   # columns available to show
popup_display <- popup_data %>%
  sf::st_drop_geometry() %>%
  select(all_of(popup_keys))
colnames(popup_display) <- unname(popup_labels[popup_keys])

# ----------------------------------------------------------
# Step 19: Build the Leaflet interactive map with base layer options
#   - Default: CartoDB.Positron (your original)
#   - Options: Esri.WorldStreetMap and Esri.WorldImagery
# ----------------------------------------------------------
Rent_Category_Map <- leaflet(FMR_Area_Map, options = leafletOptions(preferCanvas = TRUE)) %>%
  # Default/base layer (original view)
  addProviderTiles(providers$CartoDB.Positron, group = "Streets (CartoDB Positron)") %>%
  # Additional selectable base layers
  addProviderTiles(providers$Esri.WorldStreetMap, group = "Streets (Esri World Street Map)") %>%
  addProviderTiles(providers$Esri.WorldImagery,   group = "Satellite (Esri World Imagery)") %>%
  
  # Your data layer (overlay group)
  addPolygons(
    fillColor   = ~ FillColor,
    color       = "#444444",
    weight      = 1,
    opacity     = 1,
    fillOpacity = 0.7,
    label = ~ HoverLabel,
    labelOptions = labelOptions(
      style = list("font-weight" = "bold"),
      textsize = "12px",
      direction = "auto"
    ),
    popup = leafpop::popupTable(
      popup_display,
      feature.id = FALSE,
      row.numbers = FALSE,
      zcol = colnames(popup_display)
    ),
    highlight = highlightOptions(
      weight = 2,
      color = "#000000",
      fillOpacity = 0.8,
      bringToFront = TRUE
    ),
    group = "FMR by ZIP"
  ) %>%
  
  # Legend
  addLegend(
    position = "bottomright",
    pal = pal_bin,
    values = FMR_Area_Map[[ShadeBy]],
    title = legend_title,
    opacity = 0.7,
    labFormat = labelFormat(
      big.mark = ",",
      digits = 0,
      between = " – "
    )
  ) %>%
  
  # Layer control to switch basemaps ONLY (overlay toggle removed)
  addLayersControl(
    baseGroups = c(
      "Streets (CartoDB Positron)",
      "Streets (Esri World Street Map)",
      "Satellite (Esri World Imagery)"
    ),
    options = layersControlOptions(collapsed = FALSE)
  )
# Note: No overlayGroups parameter, so "FMR by ZIP" can't be toggled off.

# ----------------------------------------------------------
# Step 20: Display the map
# ----------------------------------------------------------
Rent_Category_Map

# ----------------------------------------------------------
# Step 21: (Optional) Save the map as an HTML file
# ----------------------------------------------------------
outfile <- paste0("FMR_",
                  ShadeBy,
                  "_",
                  PaletteName,
                  "_",
                  legend_classes,
                  "Classes.html")
htmlwidgets::saveWidget(widget = Rent_Category_Map,
                        file = outfile,
                        selfcontained = TRUE)
message("Saved map to: ", normalizePath(outfile))

# ----------------------------------------------------------
# Step 22: Downshifting map file to a data file &
# showing contents as a table with Pay and Affordability
# ----------------------------------------------------------

Data_From_Map <- st_drop_geometry(FMR_Area_Map) %>% 
  select(-c(FillColor, HoverLabel)) %>%
  
mutate(

  # Required hourly wage (rounded to hundredths)
  Pay = round(BR2 / 0.30 / 160, 2),
  
  # Affordability classification
  Affordability = case_when(
    Pay <= 30.92 ~ "Affordable",
    Pay > 30.92 ~ "Unaffordable",
    TRUE ~ NA_character_
  )
) %>%
  
  # ------------------------------------------------------


# Sort ZIP codes from lowest to highest Pay
# ------------------------------------------------------
arrange(Pay, desc(Rentals))

#__________________________________
#Data from map table
#__________________________________

Data_From_Map_Table <- gt(Data_From_Map) %>%
  tab_header(title = "Data") %>%
  cols_align(align = "left")

Data_From_Map_Table
#__________________________________
#Summary Table
#__________________________________
Summary_BR2 <- Data_From_Map %>% 
  group_by(Affordability) %>% 
  summarize(Count = n(),
            Minimum = min(BR2),
            Average = round(mean(BR2), 0),
            Maximum = max(BR2))

Summary_Table <- gt(Summary_BR2) %>%
  tab_header(title = "ZIP Code Affordability") %>%
  cols_align(align = "left")

Summary_Table