People that live in Rutherford county and are looking for an affordable place to live may be looking places they didn’t expect to, according to numbers from the Federal Department of Housing and Urban Development.
Numbers show that area codes surrounding MTSU tend to have lower rent prices compered to those on the west and south sides of town. The only exception for a high rent price on the west side of town is 37167 decreasing by over $500 compared to its neighboring ZIP codes, 37086 and 37129. 37118 has the lowest rent price for a one bedroom apartment and is fairly close to campus.
# ----------------------------------------------------------
# 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") # for Jenks breaks
if (!require("scales"))
install.packages("scales") # for comma formatting
if (!require("htmlwidgets"))
install.packages("htmlwidgets") # optional, for saving
library(tidyverse)
library(gt)
library(sf)
library(leaflet)
library(leafpop)
library(RColorBrewer)
library(classInt)
library(scales)
library(htmlwidgets) # optional (duplicate safe to keep)
# ----------------------------------------------------------
# Load the FMR dataset
# ----------------------------------------------------------
FMR_RuCo <- read_csv("https://raw.githubusercontent.com/drkblake/Data/refs/heads/main/FMR_RuCo.csv")
# ----------------------------------------------------------
# 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")
# ----------------------------------------------------------
# Load ZCTA shapefile into R
# ----------------------------------------------------------
ZCTAMap <- read_sf("cb_2020_us_zcta520_500k.shp")
# ----------------------------------------------------------
# Prepare ZIP column for joining
# ----------------------------------------------------------
FMR_RuCo$ZIP <- as.character(FMR_RuCo$ZIP)
# ----------------------------------------------------------
# Join the FMR data to the ZCTA polygons
# ----------------------------------------------------------
FMR_RuCo_Map <- left_join(FMR_RuCo, ZCTAMap, by = c("ZIP" = "ZCTA5CE20"))
# ----------------------------------------------------------
# Drop unneeded Census columns
# ----------------------------------------------------------
FMR_RuCo_Map <- FMR_RuCo_Map %>%
select(-c(AFFGEOID20, GEOID20, NAME20, LSAD20, ALAND20, AWATER20))
# ----------------------------------------------------------
# Convert to sf object and reproject to WGS84 (EPSG:4326)
# ----------------------------------------------------------
FMR_RuCo_Map <- st_as_sf(FMR_RuCo_Map)
if (!is.na(sf::st_crs(FMR_RuCo_Map))) {
FMR_RuCo_Map <- st_transform(FMR_RuCo_Map, 4326)
}
# ==========================================================
# SINGLE CONTROL POINTS (edit these lines)
# ==========================================================
ShadeBy <- "BR1" # Which numeric column to shade by: "Studio","BR1","BR2","BR3","BR4"
PaletteName <- "Greys" # Any sequential/diverging RColorBrewer palette (e.g., "Blues","OrRd","PuBuGn","GnBu")
legend_classes <- 5 # 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"
)
# ==========================================================
# 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 (!is.null(friendly_names[[ShadeBy]])) {
friendly_names[[ShadeBy]]
} else {
ShadeBy
}
# ----------------------------------------------------------
# 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 {
colorRampPalette(base)(k)
}
}
# ----------------------------------------------------------
# Jenks breaks + robust fallback (prevents non-unique breaks)
# ----------------------------------------------------------
vals <- FMR_RuCo_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_RuCo_Map[[ShadeBy]],
bins = breaks,
na.color = "#cccccc",
right = FALSE
)
# ----------------------------------------------------------
# Precompute FillColor (avoid hard-coding a field name in leaflet)
# ----------------------------------------------------------
FMR_RuCo_Map$FillColor <- pal_bin(FMR_RuCo_Map[[ShadeBy]])
# Build a clean hover label with comma formatting (no dollar signs)
FMR_RuCo_Map$HoverLabel <- sprintf(
"ZIP %s: %s = %s",
FMR_RuCo_Map$ZIP,
legend_title,
ifelse(is.na(FMR_RuCo_Map[[ShadeBy]]), "NA", scales::comma(FMR_RuCo_Map[[ShadeBy]]))
)
# ----------------------------------------------------------
# Popup table with comma formatting (no dollar signs)
# Create a formatted copy for display; keep numerics unchanged in FMR_RuCo_Map
# ----------------------------------------------------------
popup_data <- FMR_RuCo_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))
)
# 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_keys <- intersect(names(popup_labels), names(popup_data)) # columns available to show
popup_display <- popup_data %>%
st_drop_geometry() %>% # ensure a plain data.frame for the popup
select(all_of(popup_keys))
# Use the user-specified labels as the actual column names for display
colnames(popup_display) <- unname(popup_labels[popup_keys])
# ----------------------------------------------------------
# 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_RuCo_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_RuCo_Map[[ShadeBy]],
title = legend_title,
opacity = 0.7,
labFormat = labelFormat(
big.mark = ",",
digits = 0,
between = " – "
)
) %>%
# Layer control to switch basemaps and toggle overlay
addLayersControl(
baseGroups = c(
"Streets (CartoDB Positron)",
"Streets (Esri World Street Map)",
"Satellite (Esri World Imagery)"
),
overlayGroups = c("FMR by ZIP"),
options = layersControlOptions(collapsed = FALSE)
)
# Note: No extra call to set a different basemap—CartoDB.Positron is first and will be default
# ----------------------------------------------------------
# Display the map
# ----------------------------------------------------------
Rent_Category_Map
# ----------------------------------------------------------
# (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))
# ==========================================================
ShadeBy <- "BR1" # Which numeric column to shade by: "Studio","BR1","BR2","BR3","BR4"
PaletteName <- "Blues" # Any sequential/diverging RColorBrewer palette (e.g., "Blues","OrRd","PuBuGn","GnBu")
legend_classes <- 6 # 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"
)
# ==========================================================