Nashville’s Rental Market Leaves Single Parents Struggling for Affordable 2-Bedroom Housing

Single-parent households around Nashville are facing a challenge of finding affordable two-bedroom rentals, as they are becoming scarce, according to recent Fair Market Rent data and the U.S. Bureau of Labor Statistics.

Two-Bedroom Rents in Nashville Area

A typical affordability criterion is that housing costs should not exceed 30% of a household’s income. Recent data from the U.S. Bureau of Labor Statistics reveals that the average hourly wage across all occupations in the Nashville area is $30.92. This means that only about 22% of two-bedroom rentals in the Nashville area are affordable for a single parent, as shown in tables below.

The hourly wage needed to afford rent in this area comfortably ranges from $27.50 to $30.83. As living costs rise and the housing demand escalates, this financial burden threatens the stability of single-parent households across Nashville. Addressing this crisis is essential to ensuring that all families in Nashville have access to safe and affordable housing.

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

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

Census_Data <- Census_Data %>%
  transmute(
    ZIP             = GEOID,
    Rentals         = DP04_0047E,
    Rentals_MOE     = DP04_0047M,
    Households      = DP04_0045E,
    Households_MOE  = DP04_0045M
  )

# ----------------------------------------------------------
# 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    <- "GnBu"  # 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)
  )

# ----------------------------------------------------------
# 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, 
# ,making Pay column, and making Affordabilty column.
# ----------------------------------------------------------
Average_hourly_wage <- 30.92 
  
Data_From_Map <- st_drop_geometry(FMR_Area_Map) %>% 
  select(-c(FillColor,HoverLabel)) %>% 
  mutate(Pay = round((BR2/0.30/160),2)) %>% 
  arrange(Pay) %>% 
  mutate(
    Affordability = case_when(
        Pay > Average_hourly_wage ~ "Unnaffordable",
        Pay == Average_hourly_wage ~ "Affordable",
        Pay < Average_hourly_wage ~ "Affordable",
        .default = "Error" ))

# ----------------------------------------------------------
# Step 23: Displaying Data from Map Table with new columns.
# ----------------------------------------------------------

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

Data_From_Map_Table

# ----------------------------------------------------------
# Step 24: 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 = "Affordability") %>%
  cols_align(align = "left")

Summary_Table