Week 5 Lab

Code:

# ----------------------------------------------------------
# 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        <- "Studio"       # Which numeric column to shade by: "Studio","BR1","BR2","BR3","BR4"
PaletteName    <- "Reds"    # 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"
)
# ==========================================================

# 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))
Week 5 Lab

Riley Marshall

2026-02-19

Studio Rent in Rutherford County Reaches $1500 on Average.

Rent Categories Across Rutherford County

Code:
