') else "",
paste(sections, collapse = ""),
'',
''
)
writeLines(html, con = file, useBytes = TRUE)
}
# Store a lightweight static spatial map inside downloadable HTML report cards.
# The PNG is embedded as a base64 data URI, so the report remains self-contained.
report_card_map_uri <- function(writer) {
map_file <- tempfile(fileext = ".png")
on.exit(unlink(map_file), add = TRUE)
map_ok <- tryCatch(writer(map_file), error = function(e) FALSE)
if (!isTRUE(map_ok) || !file.exists(map_file) ||
!is.finite(file.info(map_file)$size) || file.info(map_file)$size <= 0 ||
!requireNamespace("base64enc", quietly = TRUE)) {
return(NULL)
}
paste0("data:image/png;base64,", base64enc::base64encode(map_file))
}
report_card_map_section <- function(map_uri, alt = "Static spatial context map") {
map_html <- if (!is.null(map_uri)) {
paste0(
''
)
} else {
'
Static report map unavailable.
'
}
paste0(
'
Spatial context
',
'
Static map of the isochrone area(s) used for this report card. The map is embedded in this HTML file so the spatial context is retained with the report.
',
map_html,
''
)
}
write_report_isochrone_map <- function(
file,
iso_list,
labels = NULL,
colors = NULL,
map_title = "Isochrone spatial context"
) {
if (inherits(iso_list, "sf")) {
iso_list <- lapply(seq_len(nrow(iso_list)), function(i) iso_list[i, , drop = FALSE])
}
if (!is.list(iso_list)) iso_list <- list(iso_list)
iso_list <- Filter(
function(x) !is.null(x) && inherits(x, "sf") && nrow(x) > 0,
iso_list
)
if (length(iso_list) == 0) return(FALSE)
iso_list <- lapply(iso_list, function(x) {
suppressWarnings(sf::st_transform(sf::st_make_valid(x), 3857))
})
n_iso <- length(iso_list)
if (is.null(labels) || length(labels) != n_iso) {
labels <- paste0("Isochrone ", seq_len(n_iso))
}
if (is.null(colors) || length(colors) != n_iso) {
colors <- rep("#2f6fb0", n_iso)
}
colors <- as.character(colors)
colors[is.na(colors) | !nzchar(colors)] <- "#2f6fb0"
focus_geom <- do.call(c, lapply(iso_list, sf::st_geometry))
bb <- sf::st_bbox(focus_geom)
dx <- as.numeric(bb[["xmax"]] - bb[["xmin"]])
dy <- as.numeric(bb[["ymax"]] - bb[["ymin"]])
pad_x <- max(dx * 0.18, 400)
pad_y <- max(dy * 0.18, 400)
map_bb <- sf::st_bbox(c(
xmin = bb[["xmin"]] - pad_x,
ymin = bb[["ymin"]] - pad_y,
xmax = bb[["xmax"]] + pad_x,
ymax = bb[["ymax"]] + pad_y
), crs = sf::st_crs(3857))
local_cbg <- NULL
if (exists("cbg_vect_sf", inherits = TRUE)) {
local_cbg <- tryCatch({
cbg <- get("cbg_vect_sf", inherits = TRUE)
suppressWarnings(sf::st_crop(sf::st_transform(cbg, 3857), map_bb))
}, error = function(e) NULL)
}
grDevices::png(file, width = 1500, height = 920, res = 170, bg = "white")
on.exit(grDevices::dev.off(), add = TRUE)
graphics::par(mar = c(0.4, 0.4, 1.4, 0.4), xaxs = "i", yaxs = "i")
graphics::plot(
sf::st_geometry(iso_list[[1]]),
col = NA,
border = NA,
xlim = c(map_bb[["xmin"]], map_bb[["xmax"]]),
ylim = c(map_bb[["ymin"]], map_bb[["ymax"]]),
axes = FALSE,
asp = 1
)
if (!is.null(local_cbg) && nrow(local_cbg) > 0) {
graphics::plot(
sf::st_geometry(local_cbg),
add = TRUE,
col = "#f6f7f6",
border = "#d8ddda",
lwd = 0.5
)
}
for (i in seq_len(n_iso)) {
graphics::plot(
sf::st_geometry(iso_list[[i]]),
add = TRUE,
col = grDevices::adjustcolor(colors[[i]], alpha.f = 0.20),
border = colors[[i]],
lwd = 2.2
)
}
label_points <- lapply(iso_list, function(x) {
suppressWarnings(sf::st_point_on_surface(sf::st_union(sf::st_geometry(x))))
})
label_xy <- do.call(rbind, lapply(label_points, sf::st_coordinates))
if (!is.null(label_xy) && nrow(label_xy) == n_iso) {
graphics::points(
label_xy[, 1], label_xy[, 2],
pch = 21, bg = "white", col = colors,
cex = 1.3, lwd = 1.8
)
graphics::text(
label_xy[, 1], label_xy[, 2],
labels = seq_len(n_iso),
cex = 0.72, font = 2, col = colors
)
}
graphics::legend(
"bottomleft",
legend = paste0(seq_len(n_iso), ". ", labels),
fill = grDevices::adjustcolor(colors, alpha.f = 0.20),
border = colors,
bg = grDevices::adjustcolor("white", alpha.f = 0.92),
cex = 0.72,
bty = "o"
)
graphics::mtext(map_title, side = 3, line = 0.2, cex = 0.82, font = 2, col = "#294337")
TRUE
}
# ---------------------------------------------------------------------------
# DuckDB connection
# ---------------------------------------------------------------------------
con <- dbConnect(duckdb::duckdb(), dbdir = ":memory:")
dbExecute(con, "INSTALL spatial; LOAD spatial;")
dbExecute(con, "INSTALL httpfs; LOAD httpfs;")
gbif_tab <- tbl(con, glue("read_parquet('{gbif_parquet}')"))
onStop(function() {
try(dbDisconnect(con, shutdown = TRUE), silent = TRUE)
})
chosen_point <- reactiveVal(NULL)
corridor_reference_point <- reactiveVal(NULL)
proposed_greenspace <- reactiveVal(NULL)
greenspace_draw_active <- reactiveVal(FALSE)
# ---------------------------------------------------------------------------
# Legacy CBG contextual distributions
# ---------------------------------------------------------------------------
# Retained because corridor-planning thresholds still use greenspace_cover.
# These CBG distributions are NOT used for the same-mode × same-time
# isochrone percentile scores or the new isochrone-benchmarked BAI.
city_benchmarks <- local({
bench_cache <- file.path(cache_dir, "city_benchmarks.rds")
if (file.exists(bench_cache)) {
message("Loading city_benchmarks from cache...")
return(readRDS(bench_cache))
}
message("Computing legacy citywide contextual distributions for corridor thresholds (first run only)...")
cbg_bench <- cbg_vect_sf |>
st_transform(3857) |>
mutate(area_km2 = as.numeric(st_area(geometry)) / 1e6) |>
st_transform(4326)
transit_density_bench <- rep(0, nrow(cbg_bench))
if (!is.null(gtfs_stops_sf)) {
stop_join <- tryCatch(
st_join(gtfs_stops_sf, cbg_bench[, c("GEOID")], left = FALSE),
error = function(e) NULL
)
if (!is.null(stop_join) && nrow(stop_join) > 0) {
transit_density_bench <- stop_join |>
st_drop_geometry() |>
count(GEOID, name = "n_stops") |>
right_join(
cbg_bench |> st_drop_geometry() |> select(GEOID, area_km2),
by = "GEOID"
) |>
mutate(
n_stops = replace_na(n_stops, 0),
transit_density = ifelse(area_km2 > 0, n_stops / area_km2, 0)
) |>
pull(transit_density)
}
}
sampling_density_bench <- cbg_bench |>
st_drop_geometry() |>
mutate(
obs = ifelse(is.na(n_observations), 0, n_observations),
sampling_density = ifelse(area_km2 > 0, obs / area_km2, 0)
) |>
pull(sampling_density)
biodiversity_bench <- cbg_bench |>
st_drop_geometry() |>
mutate(unique_species = replace_na(unique_species, 0)) |>
pull(unique_species)
ndvi_bench <- cbg_bench |>
st_drop_geometry() |>
mutate(ndvi_ref = dplyr::coalesce(ndvi_mean, ndvi_sentinel)) |>
pull(ndvi_ref)
ej_bench <- if (!is.null(sf_ej_sf) && "score" %in% names(sf_ej_sf)) {
sf_ej_sf |> st_drop_geometry() |> pull(score) |> na.omit()
} else {
numeric(0)
}
# Greenspace coverage (%) per CBG, read from the precomputed coverage table
# (code/prep/build_cbg_greenspace_coverage.R) -- the same source the socio
# summary uses -- instead of recomputing the CBG x greenspace intersection.
# gs_pct = 100 * greenspace_m2 / cbg_area_m2 reproduces the old value exactly.
greenspace_cover_bench <- tryCatch({
cov_path <- hf_or_local("cbg_greenspace_coverage.csv")
readr::read_csv(cov_path, col_types = readr::cols(GEOID = readr::col_character()),
show_col_types = FALSE) |>
# NA (not 0) for zero-area CBGs so the is.finite() filter below drops them,
# matching the old inline computation exactly.
mutate(gs_pct = ifelse(cbg_area_m2 > 0, 100 * greenspace_m2 / cbg_area_m2, NA_real_)) |>
pull(gs_pct)
}, error = function(e) {
warning("Greenspace coverage benchmark failed: ", e$message)
numeric(0)
})
# Unique Muni routes accessible per CBG (for route-access axis)
route_access_bench <- if (!is.null(gtfs_routes_sf)) {
message("Computing per-CBG unique route counts for BAI benchmark...")
tryCatch({
route_join <- st_join(
gtfs_routes_sf[, "route_id"],
cbg_bench[, "GEOID"],
left = FALSE
)
route_join |>
st_drop_geometry() |>
group_by(GEOID) |>
summarise(n_routes = n_distinct(route_id), .groups = "drop") |>
right_join(
cbg_bench |> st_drop_geometry() |> select(GEOID),
by = "GEOID"
) |>
mutate(n_routes = replace_na(n_routes, 0L)) |>
pull(n_routes)
}, error = function(e) {
warning("Route access benchmark failed: ", e$message)
numeric(0)
})
} else {
numeric(0)
}
bench <- list(
transit_density = transit_density_bench[is.finite(transit_density_bench)],
biodiversity = biodiversity_bench[is.finite(biodiversity_bench)],
sampling = sampling_density_bench[is.finite(sampling_density_bench)],
ndvi = ndvi_bench[is.finite(ndvi_bench)],
ej = ej_bench[is.finite(ej_bench)],
route_access = route_access_bench[is.finite(route_access_bench)],
greenspace_cover = greenspace_cover_bench[is.finite(greenspace_cover_bench)]
)
if (!dir.exists(cache_dir)) dir.create(cache_dir, recursive = TRUE)
saveRDS(bench, bench_cache)
message("City benchmarks saved to cache.")
bench
})
# ---------------------------------------------------------------------------
# Logos
# ---------------------------------------------------------------------------
output$combine_logo <- renderImage({
list(
src = file.path("www", "Combined_logos.png"),
width = "50%",
height = "auto",
alt = "UC Berkeley ESPM · California Academy of Sciences · Reimagining San Francisco"
)
}, deleteFile = FALSE)
# ---------------------------------------------------------------------------
# Base map
# ---------------------------------------------------------------------------
output$isoMap <- renderLeaflet({
pal_cbg <- colorNumeric("YlOrRd", cbg_vect_sf$medincE)
pal_rich <- colorNumeric("YlOrRd", domain = cbg_vect_sf$unique_species)
# GBIF effort is extremely right-skewed: across SF block groups the median is
# 72 records, the maximum 740,656, and the top 1% of block groups hold 68% of
# every record in the city. On a linear ramp that paints Golden Gate Park dark
# and the entire rest of the city white, which is exactly the inequality the
# map is supposed to let you SEE rather than hide. Log-spaced bins in real
# units keep the legend readable without a transformed axis to explain.
avail_bins <- c(0, 1, 10, 50, 200, 1000, 5000, 50000, Inf)
pal_data <- colorBin("Blues", domain = cbg_vect_sf$n_observations,
bins = avail_bins, na.color = "transparent")
hotspot_sf <- safe_biodiv_hotspots()
coldspot_sf <- safe_biodiv_coldspots()
m <- leaflet() |>
addTiles(group = "Street Map (Default)") |>
addProviderTiles(providers$Esri.NatGeoWorldMap, group = "National Geographic") |>
addProviderTiles(providers$CartoDB.Positron, group = "CartoDB.Positron") |>
addProviderTiles(providers$Esri.WorldImagery, group = "Satellite (ESRI)") |>
addPolygons(
data = cbg_vect_sf, group = "Income",
fillColor = ~pal_cbg(medincE), fillOpacity = 0.6,
color = "white", weight = 1, label = ~GEOID
) |>
addPolygons(
data = osm_greenspace, group = "Existing SF Greenspace",
fillColor = "#81c784", fillOpacity = 0.26,
color = "#2e7d32", weight = 1.2, label = ~name
) |>
addPolygons(
data = cbg_vect_sf, group = "Species Richness",
fillColor = ~pal_rich(unique_species), fillOpacity = 0.6,
color = "white", weight = 1, label = ~unique_species
) |>
addPolygons(
data = cbg_vect_sf, group = "Data Availability",
fillColor = ~pal_data(n_observations), fillOpacity = 0.75,
color = "white", weight = 1,
label = ~sprintf("%s GBIF records", format(n_observations, big.mark = ","))
) |>
addLegend(
position = "bottomleft", pal = pal_data,
values = cbg_vect_sf$n_observations,
title = "GBIF records per block group",
labFormat = labelFormat(big.mark = ","),
group = "Data Availability"
)
if (FALSE && !is.null(hotspot_sf)) {
m <- m |>
addPolygons(
data = hotspot_sf,
group = "Hotspots (KnowBR)",
fillColor = "firebrick", fillOpacity = 0.2,
color = "firebrick", weight = 2
)
}
if (FALSE && !is.null(coldspot_sf)) {
m <- m |>
addPolygons(
data = coldspot_sf,
group = "Coldspots (KnowBR)",
fillColor = "navy", fillOpacity = 0.2,
color = "navy", weight = 2
)
}
rsf_proj_sf <- choose_existing_sf_object(c("rsf_projects", "rsf_project_areas", "rsf_polygons", "rsf_programs"))
if (!is.null(rsf_proj_sf)) {
m <- m |>
addPolygons(
data = rsf_proj_sf,
group = "RSF Program Projects",
fillColor = "purple",
fillOpacity = 0.3,
color = "purple",
weight = 1,
label = ~if (exists("prj_name")) ~prj_name else "RSF Project",
highlightOptions = highlightOptions(
weight = 5,
color = "blue",
fillOpacity = 0.5,
bringToFront = TRUE
),
labelOptions = labelOptions(
style = list("font-weight" = "bold", "color" = "blue"),
textsize = "12px",
direction = "auto",
noHide = FALSE
)
)
}
if (FALSE && exists("greenspace_dist_raster")) {
greenspace_vals_clean <- values(greenspace_dist_raster) |>
as.vector() |>
(\(x) x[is.finite(x)])()
if (length(greenspace_vals_clean) > 0) {
upper_limit <- quantile(greenspace_vals_clean, 0.998, na.rm = TRUE)
pal_greenspace_dist <- colorNumeric(
palette = rev(brewer.pal(9, "YlGnBu")),
domain = c(0, upper_limit),
na.color = "transparent"
)
m <- m |>
addRasterImage(
x = greenspace_dist_raster,
colors = pal_greenspace_dist,
opacity = 0.65,
project = TRUE,
group = "Greenspace Distance"
) |>
addLegend(
position = "bottomleft",
pal = pal_greenspace_dist,
values = c(0, upper_limit),
title = "Distance to Greenspace (m)",
group = "Greenspace Distance"
)
}
}
if (FALSE && exists("rsfprogram_dist_raster")) {
rsf_vals_clean <- values(rsfprogram_dist_raster) |>
as.vector() |>
(\(x) x[is.finite(x)])()
if (length(rsf_vals_clean) > 0) {
upper_rsf <- quantile(rsf_vals_clean, 0.998, na.rm = TRUE)
pal_rsf_dist <- colorNumeric(
palette = rev(brewer.pal(9, "Purples")),
domain = c(0, upper_rsf),
na.color = "transparent"
)
m <- m |>
addRasterImage(
x = rsfprogram_dist_raster,
colors = pal_rsf_dist,
opacity = 0.65,
project = TRUE,
group = "RSF Program Distance"
) |>
addLegend(
position = "bottomright",
pal = pal_rsf_dist,
values = c(0, upper_rsf),
title = "Distance to RSF program (m)",
group = "RSF Program Distance"
)
}
}
if (!is.null(gtfs_routes_sf)) {
m <- m |>
addPolylines(
data = gtfs_routes_sf,
group = "Transit Routes",
color = ~route_color_hex,
weight = 2,
opacity = 0.8,
label = ~paste0(route_short_name, ": ", route_long_name)
)
}
# if (!is.null(gtfs_stops_sf)) {
# m <- m |>
# addCircleMarkers(
# data = gtfs_stops_sf,
# group = "Transit Stops",
# radius = 4,
# color = "#005B95", fillColor = "#005B95",
# fillOpacity = 0.7, stroke = FALSE,
# label = ~stop_name
# )
# }
# Inserted this to make reactive to URL:
if (!is.null(gtfs_stops_sf)) {
stops_for_map <- gtfs_stops_sf
if (!"stop_url" %in% names(stops_for_map)) {
stops_for_map$stop_url <- NA_character_
}
if (!"mean_headway_min" %in% names(stops_for_map)) {
stops_for_map$mean_headway_min <- NA_real_
}
if (!"n_departures_peak" %in% names(stops_for_map)) {
stops_for_map$n_departures_peak <- NA_real_
}
stops_for_map$popup_html <- paste0(
"", stops_for_map$stop_name, "",
" Stop ID: ", stops_for_map$stop_id,
ifelse(
!is.na(stops_for_map$mean_headway_min),
paste0(" Mean headway (AM): ", round(stops_for_map$mean_headway_min, 1), " min"),
""
),
ifelse(
!is.na(stops_for_map$n_departures_peak),
paste0(" Departures (7–9am): ", stops_for_map$n_departures_peak),
""
),
ifelse(
!is.na(stops_for_map$stop_url) & stops_for_map$stop_url != "",
paste0(" Open stop page"),
""
)
)
m <- m |>
addCircleMarkers(
data = stops_for_map,
group = "Transit Stops",
radius = 4,
color = "#005B95",
fillColor = "#005B95",
fillOpacity = 0.7,
stroke = FALSE,
label = ~stop_name,
popup = ~popup_html
)
}
if (!is.null(cenv_sf)) {
pal_cenv <- colorNumeric("YlOrBr", domain = cenv_sf$CIscore, na.color = "transparent")
m <- m |>
addPolygons(
data = cenv_sf,
group = "CalEnviroScreen (CI Score)",
fillColor = ~pal_cenv(CIscore),
fillOpacity = 0.65,
color = "white",
weight = 0.5,
label = ~paste0("CI Score: ", round(CIscore, 1))
)
}
if (!is.null(ces5_sf)) {
# The published CalEnviroScreen map colours TRACTS BY PERCENTILE, not by
# raw score, in ten classes on OEHHA's yellow-to-dark-red ramp. Colouring
# by raw CIscore instead compresses most of the city into one shade, the
# same mistake the Data Availability layer used to make.
CES_DECILES <- c("#FFFFCC", "#FFEDA0", "#FED976", "#FEB24C", "#FD8D3C",
"#FC4E2A", "#E31A1C", "#BD0026", "#980043", "#800026")
ces_pal <- colorBin(CES_DECILES, domain = c(0, 100), bins = seq(0, 100, 10),
na.color = "transparent")
m <- m |>
addPolygons(
data = ces5_sf, group = "CalEnviroScreen 5.0",
fillColor = ~ces_pal(CIscore_Pctl), fillOpacity = 0.7,
color = "white", weight = 0.5,
label = ~sprintf("Tract %s - CES 5.0 score %.1f (%.0fth percentile statewide)",
tract, CIscore, CIscore_Pctl)
) |>
addLegend(
position = "bottomright", pal = ces_pal, values = c(0, 100),
title = "CalEnviroScreen 5.0 percentile (statewide)",
labFormat = labelFormat(suffix = "%"),
group = "CalEnviroScreen 5.0"
)
}
if (!is.null(sf_ej_sf)) {
m <- m |>
addPolygons(
data = sf_ej_sf,
group = "SF EJ Communities",
fillColor = ~symbol_hex,
fillOpacity = 0.7,
color = "white",
weight = 0.5,
label = ~paste0(ej_label, ifelse(is.na(score), "", paste0(" (score: ", score, ")")))
)
}
m |>
setView(lng = -122.4194, lat = 37.7749, zoom = 12) |>
addLayersControl(
baseGroups = c("Street Map (Default)", "National Geographic", "CartoDB.Positron", "Satellite (ESRI)"),
overlayGroups = c(
"Income", "Existing SF Greenspace", "RSF Program Projects",
"Species Richness", "Data Availability",
"CalEnviroScreen 5.0", "CalEnviroScreen (CI Score)", "SF EJ Communities",
"Transit Routes", "Transit Stops",
"Isochrones", "Transit Isochrones", "Muni Stops Reached", "NDVI Raster"
),
options = layersControlOptions(collapsed = TRUE)
) |>
hideGroup("Income") |>
hideGroup("RSF Program Projects") |>
hideGroup("Species Richness") |>
hideGroup("Data Availability") |>
hideGroup("CalEnviroScreen 5.0") |>
hideGroup("CalEnviroScreen (CI Score)") |>
hideGroup("SF EJ Communities") |>
hideGroup("Transit Routes") |>
hideGroup("Transit Stops")
})
# A separate, simplified map for intervention planning. Keeping drawing and
# scenario layers off the Isochrone Explorer prevents the two workflows from
# competing for controls, map clicks, and visual attention.
output$corridorMap <- renderLeaflet({
m <- leaflet() |>
addMapPane("corridorBasePane", zIndex = 360) |>
addMapPane("corridorIsochronePane", zIndex = 385) |>
addMapPane("corridorProposalPane", zIndex = 430) |>
addTiles(group = "Street Map") |>
addProviderTiles(providers$Esri.NatGeoWorldMap, group = "National Geographic") |>
addProviderTiles(providers$CartoDB.Positron, group = "CartoDB.Positron") |>
addProviderTiles(providers$Esri.WorldImagery, group = "Satellite (ESRI)") |>
addPolygons(
data = osm_greenspace,
group = "Existing SF Greenspace",
fillColor = "#81c784",
fillOpacity = 0.28,
color = "#2e7d32",
weight = 1.2,
label = ~ifelse(is.na(name) | name == "", "Unnamed mapped greenspace", name),
options = pathOptions(pane = "corridorBasePane")
)
if (!is.null(sf_ej_sf) && inherits(sf_ej_sf, "sf") && nrow(sf_ej_sf) > 0) {
m <- m |>
addPolygons(
data = sf_ej_sf,
group = "SF EJ Communities",
fillColor = ~symbol_hex,
fillOpacity = 0.40,
color = "#8e44ad",
weight = 1,
label = ~paste0(ej_label, ifelse(is.na(score), "", paste0(" (score: ", score, ")"))),
options = pathOptions(pane = "corridorBasePane")
)
}
m |>
setView(lng = -122.4194, lat = 37.7749, zoom = 12) |>
addScaleBar(
position = "bottomright",
options = scaleBarOptions(metric = TRUE, imperial = FALSE, maxWidth = 140)
) |>
addDrawToolbar(
targetGroup = "Your Drawn Route or Shape",
position = "topleft",
polylineOptions = drawPolylineOptions(
shapeOptions = drawShapeOptions(
color = "#1565c0",
weight = 5,
opacity = 0.95
)
),
polygonOptions = drawPolygonOptions(
showArea = TRUE,
metric = TRUE,
shapeOptions = drawShapeOptions(
color = "#1565c0",
weight = 3,
fillColor = "#90caf9",
fillOpacity = 0.40
)
),
circleOptions = FALSE,
rectangleOptions = FALSE,
markerOptions = FALSE,
circleMarkerOptions = FALSE,
editOptions = editToolbarOptions(
edit = TRUE,
remove = TRUE,
selectedPathOptions = selectedPathOptions(maintainColor = TRUE)
)
) |>
addLayersControl(
baseGroups = c("Street Map", "National Geographic", "CartoDB.Positron", "Satellite (ESRI)"),
overlayGroups = c(
"Existing SF Greenspace", "SF EJ Communities", "Explorer Location",
"Active Analysis Isochrone",
"Your Drawn Route or Shape", "Your Proposed Habitat Area",
"Existing Greenspaces Reached", "Measured Connection Gaps",
"Population Estimate Area (Optional)"
),
options = layersControlOptions(collapsed = TRUE)
) |>
addControl(
html = paste0(
'
',
'
How to read this scenario
',
'
Existing greenspace Mapped parks and green areas already present
',
'
Active analysis isochrone The only reachable area used for baseline-vs-proposal greenspace and BAI
',
'
Your proposed intervention For a line, the blue area reflects the selected total width; zoom in to inspect it
',
'
Greenspaces reached Existing patches within the selected rule
',
'
Population-estimate area Optional; hidden until enabled
',
'
Measured ecological gap
',
'
'
),
position = "bottomleft",
className = "corridor-map-key"
) |>
hideGroup("SF EJ Communities")
})
# Transfer the selected Explorer location and generated isochrones into the
# dedicated corridor workflow. All generated isochrones remain available in
# the selector, but exactly ONE isochrone is active at a time. No averaging
# across transport modes or travel times is used for corridor BAI comparisons.
corridor_isochrone_catalog <- function(iso_data) {
if (is.null(iso_data) || !inherits(iso_data, "sf") || nrow(iso_data) == 0) {
return(NULL)
}
out <- iso_data
mode_chr <- as.character(out$mode)
mode_label <- vapply(mode_chr, pretty_mode, character(1))
time_num <- suppressWarnings(as.numeric(out$time))
time_label <- ifelse(is.finite(time_num), paste0(format(time_num, trim = TRUE), " min"), "time unavailable")
raw_key <- paste0(mode_chr, "__", ifelse(is.finite(time_num), time_num, "NA"))
out$.corridor_iso_key <- make.unique(raw_key, sep = "__")
out$.corridor_iso_label <- paste0(mode_label, " — ", time_label)
out
}
# Default analysis context: Walking at the shortest available travel time.
# If Walking was not generated, use the shortest available isochrone overall.
corridor_default_iso_index <- function(iso_data) {
if (is.null(iso_data) || nrow(iso_data) == 0) return(NA_integer_)
mode_chr <- tolower(as.character(iso_data$mode))
time_num <- suppressWarnings(as.numeric(iso_data$time))
time_rank <- ifelse(is.finite(time_num), time_num, Inf)
walking_idx <- which(mode_chr == "walking")
if (length(walking_idx) > 0) {
return(walking_idx[[which.min(time_rank[walking_idx])]])
}
if (any(is.finite(time_num))) return(which.min(time_rank))
1L
}
corridor_active_iso_info <- reactive({
iso_data <- corridor_isochrone_catalog(isochrones_data())
if (is.null(iso_data) || nrow(iso_data) == 0) return(NULL)
selected_key <- input$corridor_active_isochrone
idx <- match(selected_key, iso_data$.corridor_iso_key)
if (length(idx) == 0 || is.na(idx)) idx <- corridor_default_iso_index(iso_data)
list(
index = idx,
key = iso_data$.corridor_iso_key[[idx]],
label = iso_data$.corridor_iso_label[[idx]],
data = iso_data[idx, , drop = FALSE],
all = iso_data
)
})
output$corridorIsochroneSelectorUI <- renderUI({
iso_data <- corridor_isochrone_catalog(isochrones_data())
if (is.null(iso_data) || nrow(iso_data) == 0) {
return(tags$div(
style = "font-size:12px; color:#777; margin:7px 0;",
icon("info-circle"),
" No generated Explorer isochrones are currently available. Generate them in the Explorer, then return here."
))
}
choices <- iso_data$.corridor_iso_key
names(choices) <- iso_data$.corridor_iso_label
selected <- isolate(input$corridor_active_isochrone)
if (is.null(selected) || !(selected %in% choices)) {
selected <- choices[[corridor_default_iso_index(iso_data)]]
}
tagList(
selectInput(
"corridor_active_isochrone",
"Active analysis isochrone:",
choices = choices,
selected = selected,
selectize = FALSE
),
tags$div(
style = "background:#e3f2fd; border-left:4px solid #1976d2; padding:8px 9px; margin:0 0 7px 0; font-size:12px;",
tags$b("Used for: "),
"greenspace cover and BAI baseline-versus-proposal results. This is the only isochrone used for those calculations.",
tags$br(),
tags$b("Not used for: "),
"habitat connectivity or population estimates; those are calculated independently of the active isochrone."
),
tags$div(
style = "font-size:12px; color:#2e7d32; margin:-2px 0 7px 0;",
icon("check-circle"), " ",
"Default = Walking at the shortest generated travel time. You can select a different single mode × time above."
)
)
})
draw_explorer_isochrones_on_corridor <- function(
fit = FALSE,
active_key = NULL,
iso_data = NULL
) {
proxy <- leafletProxy("corridorMap") |>
clearGroup("Active Analysis Isochrone")
if (is.null(iso_data) || !inherits(iso_data, "sf") || nrow(iso_data) == 0) {
return(invisible(NULL))
}
iso_display <- corridor_isochrone_catalog(iso_data)
iso_display <- tryCatch(
st_transform(st_make_valid(iso_display), 4326),
error = function(e) NULL
)
if (is.null(iso_display) || nrow(iso_display) == 0) return(invisible(NULL))
active_idx <- match(active_key, iso_display$.corridor_iso_key)
if (length(active_idx) == 0 || is.na(active_idx)) {
active_idx <- corridor_default_iso_index(iso_display)
}
poly_i <- iso_display[active_idx, , drop = FALSE]
mode_i <- as.character(poly_i$mode[[1]])
time_i <- suppressWarnings(as.numeric(poly_i$time[[1]]))
mode_label <- pretty_mode(mode_i)
is_transit <- identical(mode_i, "transit")
is_walk_transit <- identical(mode_i, "walk_transit")
dash_style <- if (is_transit) "6,4" else if (is_walk_transit) "4,4" else NULL
proxy <- proxy |>
addPolygons(
data = poly_i,
group = "Active Analysis Isochrone",
color = "#3949ab",
weight = 4,
opacity = 1,
dashArray = dash_style,
fillColor = "#9fa8da",
fillOpacity = 0.18,
label = paste0(
"ACTIVE ANALYSIS ISOCHRONE — ",
mode_label,
if (is.finite(time_i)) paste0(" — ", time_i, " min") else ""
),
popup = paste0(
"Active analysis isochrone ",
mode_label,
if (is.finite(time_i)) paste0(" — ", time_i, " min") else "",
" This is the only Explorer isochrone used for baseline-versus-proposal greenspace and BAI. No averaging across isochrones is performed."
),
options = pathOptions(pane = "corridorIsochronePane")
)
if (isTRUE(fit)) {
bb <- tryCatch(
st_bbox(st_union(st_geometry(poly_i))),
error = function(e) NULL
)
if (!is.null(bb) && all(is.finite(as.numeric(bb)))) {
leafletProxy("corridorMap") |>
fitBounds(
lng1 = unname(bb[["xmin"]]),
lat1 = unname(bb[["ymin"]]),
lng2 = unname(bb[["xmax"]]),
lat2 = unname(bb[["ymax"]])
)
}
}
invisible(NULL)
}
focus_corridor_on_reference <- function(
pt,
zoom = 15,
active_key = NULL,
iso_data = NULL
) {
if (is.null(pt) || length(pt) < 2) return(invisible(NULL))
leafletProxy("corridorMap") |>
clearGroup("Explorer Location") |>
addCircleMarkers(
lng = unname(pt[["lon"]]),
lat = unname(pt[["lat"]]),
radius = 7,
color = "#212121",
fillColor = "#ffffff",
fillOpacity = 1,
weight = 2,
group = "Explorer Location",
label = "Location transferred from Isochrone Explorer"
)
has_iso <- !is.null(iso_data) && inherits(iso_data, "sf") && nrow(iso_data) > 0
draw_explorer_isochrones_on_corridor(
fit = has_iso,
active_key = active_key,
iso_data = iso_data
)
if (!has_iso) {
leafletProxy("corridorMap") |>
flyTo(
lng = unname(pt[["lon"]]),
lat = unname(pt[["lat"]]),
zoom = zoom
)
}
invisible(NULL)
}
transfer_explorer_location <- function() {
pt <- chosen_point()
if (is.null(pt)) {
showNotification(
"Select a location in the Isochrone Explorer first.",
type = "warning"
)
return(invisible(NULL))
}
corridor_reference_point(pt)
updateTabItems(session, "tabs", selected = "corridor")
iso_data <- isochrones_data()
if (is.null(iso_data) || !inherits(iso_data, "sf") || nrow(iso_data) == 0) {
showNotification(
"The location was transferred. Generate isochrones in the Explorer to display reachable areas here.",
type = "message",
duration = 6
)
}
# Capture reactive values before entering onFlushed(). The callback itself
# must not read input$... or reactive expressions directly.
iso_snapshot <- iso_data
active_snapshot <- input$corridor_active_isochrone
session$onFlushed(function() {
focus_corridor_on_reference(
pt,
active_key = active_snapshot,
iso_data = iso_snapshot
)
}, once = TRUE)
invisible(NULL)
}
observeEvent(input$evaluate_green_intervention, {
transfer_explorer_location()
})
observeEvent(input$use_explorer_location, {
transfer_explorer_location()
})
observeEvent(input$return_to_isochrone, {
updateTabItems(session, "tabs", selected = "isochrone")
})
# Keep the corridor map synchronized with exactly one active isochrone when
# the selector changes or Explorer isochrones are regenerated/cleared.
observe({
active_key <- input$corridor_active_isochrone
iso_snapshot <- isochrones_data()
session$onFlushed(function() {
draw_explorer_isochrones_on_corridor(
fit = FALSE,
active_key = active_key,
iso_data = iso_snapshot
)
}, once = TRUE)
})
observeEvent(input$tabs, {
if (identical(input$tabs, "corridor")) {
pt <- corridor_reference_point()
active_key <- input$corridor_active_isochrone
iso_snapshot <- isochrones_data()
if (!is.null(pt)) {
session$onFlushed(function() {
focus_corridor_on_reference(
pt,
active_key = active_key,
iso_data = iso_snapshot
)
}, once = TRUE)
} else {
session$onFlushed(function() {
draw_explorer_isochrones_on_corridor(
fit = FALSE,
active_key = active_key,
iso_data = iso_snapshot
)
}, once = TRUE)
}
}
}, ignoreInit = TRUE)
corridor_drawing_mode <- reactive({
proposal <- proposed_greenspace()
if (is.null(proposal) || nrow(proposal) == 0) return("none")
types <- as.character(st_geometry_type(st_zm(proposal, drop = TRUE, what = "ZM")))
has_line <- any(types %in% c("LINESTRING", "MULTILINESTRING"))
has_polygon <- any(types %in% c("POLYGON", "MULTIPOLYGON"))
if (has_line && has_polygon) return("mixed")
if (has_line) return("line")
if (has_polygon) return("polygon")
"other"
})
output$corridorWidthPreviewUI <- renderUI({
width_m <- suppressWarnings(as.numeric(input$corridor_width_m))
if (!is.finite(width_m) || width_m <= 0) width_m <- 10
half_width <- width_m / 2
mode <- corridor_drawing_mode()
# A deliberately exaggerated cross-section makes the selected width legible
# even when the map is zoomed out. It is explanatory, not map-scale.
preview_px <- round(34 + 166 * (width_m - 2) / 38)
preview_px <- max(34, min(200, preview_px))
mode_note <- switch(
mode,
line = tags$div(
style = "margin-top:6px; color:#0d47a1;",
icon("check-circle"),
" A line is currently drawn, so this width is being used."
),
polygon = tags$div(
style = "margin-top:6px; color:#8a6d3b;",
icon("info-circle"),
" A polygon is currently drawn. The width setting does not change polygons."
),
mixed = tags$div(
style = "margin-top:6px; color:#8a6d3b;",
icon("info-circle"),
" The width is applied only to the line portion; polygon portions keep their drawn shape."
),
tags$div(
style = "margin-top:6px; color:#666;",
"Draw a line to apply this width, or draw a polygon to define area directly."
)
)
area_note <- NULL
if (mode %in% c("line", "mixed")) {
proposal <- proposed_greenspace()
proposal_3857 <- tryCatch(
proposal |> st_transform(3857) |> st_zm(drop = TRUE, what = "ZM"),
error = function(e) NULL
)
if (!is.null(proposal_3857) && nrow(proposal_3857) > 0) {
types <- as.character(st_geometry_type(proposal_3857))
line_idx <- types %in% c("LINESTRING", "MULTILINESTRING")
if (any(line_idx)) {
route_length_m <- sum(as.numeric(st_length(st_geometry(proposal_3857[line_idx, , drop = FALSE]))), na.rm = TRUE)
estimated_line_area_ha <- route_length_m * width_m / 10000
if (is.finite(route_length_m) && route_length_m > 0) {
area_note <- tags$div(
style = "margin-top:6px; font-size:12px; color:#444;",
paste0(
"Current line length: ", scales::comma(round(route_length_m)),
" m. Approximate planted area from the line: ",
round(estimated_line_area_ha, 2), " ha before overlap corrections."
)
)
}
}
}
}
tags$div(
style = "background:#eef6fb; border:1px solid #b8d8ef; border-left:4px solid #1976d2; padding:8px 9px; margin:6px 0 4px 0;",
tags$div(
style = "font-size:12px; color:#333; margin-bottom:5px;",
tags$b(paste0(width_m, " m total planted width")),
paste0(" = ", half_width, " m on each side of the line")
),
tags$div(
style = "height:30px; display:flex; justify-content:center; align-items:center; position:relative;",
tags$div(
style = paste0(
"width:", preview_px, "px; height:22px; background:#42a5f5; border:2px solid #0d47a1; position:relative;"
),
tags$div(style = "position:absolute; left:50%; top:-4px; bottom:-4px; border-left:2px dashed #263238;")
)
),
tags$div(
style = "display:flex; justify-content:space-between; font-size:11px; color:#555; max-width:220px; margin:0 auto;",
tags$span(paste0(half_width, " m")),
tags$span("drawn centerline"),
tags$span(paste0(half_width, " m"))
),
tags$small(
style = "display:block; margin-top:5px; color:#666;",
"The cross-section is enlarged for explanation. Use the zoom button to inspect the actual map footprint."
),
mode_note,
area_note
)
})
output$corridorLocationStatus <- renderUI({
pt <- corridor_reference_point()
if (is.null(pt)) {
return(tags$div(
style = "background:#f7f9fb; border-left:4px solid #9e9e9e; padding:8px 10px; margin-bottom:10px;",
tags$b("No Explorer location transferred."),
tags$br(),
tags$small("You can still draw anywhere in San Francisco, or return to the Explorer and select a location first.")
))
}
tags$div(
style = "background:#f5f5f5; border-left:4px solid #212121; padding:8px 10px; margin-bottom:10px;",
tags$b("Explorer location carried into this tab"),
tags$br(),
tags$small(
paste0(
"Longitude ", round(unname(pt[["lon"]]), 5),
"; latitude ", round(unname(pt[["lat"]]), 5),
". The black-and-white point is a reference location only."
)
)
)
})
# ---------------------------------------------------------------------------
# Proposed greenspace drawing scenario
# ---------------------------------------------------------------------------
observeEvent(input$corridorMap_draw_start, {
greenspace_draw_active(TRUE)
})
observeEvent(input$corridorMap_draw_stop, {
greenspace_draw_active(FALSE)
})
observeEvent(input$corridorMap_draw_editstart, {
greenspace_draw_active(TRUE)
})
observeEvent(input$corridorMap_draw_editstop, {
greenspace_draw_active(FALSE)
})
observeEvent(input$corridorMap_draw_all_features, {
proposed_greenspace(
tryCatch(
draw_features_to_sf(input$corridorMap_draw_all_features),
error = function(e) {
showNotification(
paste("Could not read the proposed habitat drawing:", e$message),
type = "error"
)
NULL
}
)
)
}, ignoreNULL = FALSE)
observeEvent(input$clear_proposed_greenspace, {
proposed_greenspace(NULL)
leafletProxy("corridorMap") |>
clearGroup("Your Drawn Route or Shape") |>
clearGroup("Your Proposed Habitat Area") |>
clearGroup("Existing Greenspaces Reached") |>
clearGroup("Measured Connection Gaps") |>
clearGroup("Population Estimate Area (Optional)")
})
# Convert all user drawings to habitat area in EPSG:3857. Polygon drawings are
# used directly; line drawings are buffered by half the selected full corridor
# width on each side. Geometry is unioned without carrying Leaflet attributes.
proposed_habitat_3857 <- reactive({
proposal <- proposed_greenspace()
if (is.null(proposal) || nrow(proposal) == 0) return(NULL)
proposal_3857 <- proposal |>
st_transform(3857) |>
st_zm(drop = TRUE, what = "ZM") |>
st_make_valid()
geom_type <- as.character(st_geometry_type(proposal_3857))
polygon_idx <- geom_type %in% c("POLYGON", "MULTIPOLYGON")
line_idx <- geom_type %in% c("LINESTRING", "MULTILINESTRING")
parts <- list()
if (any(polygon_idx)) {
parts[[length(parts) + 1]] <- st_geometry(proposal_3857[polygon_idx, , drop = FALSE])
}
if (any(line_idx)) {
corridor_width <- suppressWarnings(as.numeric(input$corridor_width_m))
if (!is.finite(corridor_width) || corridor_width <= 0) corridor_width <- 10
parts[[length(parts) + 1]] <- st_buffer(
st_geometry(proposal_3857[line_idx, , drop = FALSE]),
dist = corridor_width / 2,
endCapStyle = "ROUND",
joinStyle = "ROUND"
)
}
if (length(parts) == 0) return(NULL)
combined <- do.call(c, parts)
proposal_union <- suppressWarnings(st_union(combined))
out <- st_sf(geometry = proposal_union, crs = 3857) |> st_make_valid()
out <- out[!st_is_empty(out), , drop = FALSE]
if (nrow(out) == 0) NULL else out
})
# Remove portions of a proposal that already overlap mapped OSM greenspace.
# This prevents double-counting when a user draws over an existing park.
net_proposed_greenspace_3857 <- reactive({
proposal_sf <- proposed_habitat_3857()
if (is.null(proposal_sf) || nrow(proposal_sf) == 0) return(NULL)
if (is.null(osm_greenspace_3857) || nrow(osm_greenspace_3857) == 0) {
return(proposal_sf)
}
hits <- st_intersects(proposal_sf, osm_greenspace_3857, sparse = TRUE)[[1]]
if (length(hits) == 0) return(proposal_sf)
existing_local <- st_union(st_geometry(osm_greenspace_3857[hits, , drop = FALSE]))
net_geometry <- tryCatch(
suppressWarnings(st_difference(st_geometry(proposal_sf), existing_local)),
error = function(e) st_geometry(proposal_sf)
)
out <- st_sf(geometry = net_geometry, crs = 3857) |> st_make_valid()
out <- out[!st_is_empty(out), , drop = FALSE]
if (nrow(out) == 0) NULL else out
})
# Generic structural connectivity around the proposed intervention. Existing
# OSM greenspace polygons are treated as habitat patches. The complete SF-wide
# layer is searched, but only patches near the proposal are returned and drawn.
# A user-selected gap threshold is a structural planning proxy rather than a
# species-specific functional-connectivity model.
corridor_connectivity <- reactive({
proposal_area <- proposed_habitat_3857()
proposal_features <- proposed_greenspace()
if (is.null(proposal_area) || nrow(proposal_area) == 0 ||
is.null(osm_greenspace_3857) || nrow(osm_greenspace_3857) == 0) {
return(list(
available = FALSE,
message = "Draw a corridor line or habitat polygon to estimate connectivity."
))
}
gap_m <- suppressWarnings(as.numeric(input$connectivity_gap_m))
if (!is.finite(gap_m) || gap_m < 0) gap_m <- 100
existing_geom <- st_geometry(osm_greenspace_3857) |> st_make_valid()
raw_names <- if ("name" %in% names(osm_greenspace_3857)) {
as.character(osm_greenspace_3857$name)
} else {
rep(NA_character_, length(existing_geom))
}
raw_names[is.na(raw_names) | trimws(raw_names) == ""] <- NA_character_
patches <- st_sf(
patch_id = seq_along(existing_geom),
patch_name = raw_names,
geometry = existing_geom,
crs = 3857
)
patches$patch_area_ha <- as.numeric(st_area(patches)) / 10000
nearby_idx <- which(
lengths(st_is_within_distance(patches, proposal_area, dist = gap_m)) > 0
)
feature_types <- if (is.null(proposal_features)) {
character(0)
} else {
as.character(st_geometry_type(proposal_features))
}
line_idx <- feature_types %in% c("LINESTRING", "MULTILINESTRING")
poly_idx <- feature_types %in% c("POLYGON", "MULTIPOLYGON")
corridor_length_m <- 0
if (any(line_idx)) {
corridor_length_m <- sum(
as.numeric(st_length(st_transform(proposal_features[line_idx, , drop = FALSE], 3857))),
na.rm = TRUE
)
}
novel <- net_proposed_greenspace_3857()
novel_ha <- if (is.null(novel) || nrow(novel) == 0) {
0
} else {
sum(as.numeric(st_area(novel)), na.rm = TRUE) / 10000
}
if (length(nearby_idx) == 0) {
nearest_idx <- tryCatch(st_nearest_feature(proposal_area, patches), error = function(e) integer(0))
nearest_patch_m <- if (length(nearest_idx) > 0 && is.finite(nearest_idx[[1]])) {
tryCatch(
as.numeric(st_distance(proposal_area, patches[nearest_idx[[1]], , drop = FALSE], by_element = TRUE)),
error = function(e) NA_real_
)
} else {
NA_real_
}
return(list(
available = TRUE,
classification = "Isolated intervention",
gap_m = gap_m,
linked_patches = 0,
overlapping_patches = 0,
baseline_components = 0,
scenario_components = 1,
components_reduced = 0,
nearest_patch_m = nearest_patch_m,
maximum_linked_gap_m = NA_real_,
existing_linked_area_ha = 0,
novel_area_ha = novel_ha,
scenario_connected_area_ha = novel_ha,
corridor_length_m = corridor_length_m,
drawn_patch_count = sum(poly_idx),
linked_sf = patches[0, , drop = FALSE],
links_sf = st_sf(
display_id = character(0),
distance_m = numeric(0),
geometry = st_sfc(crs = 3857)
)
))
}
linked <- patches[nearby_idx, , drop = FALSE]
proposal_union <- st_union(st_geometry(proposal_area))
prop_dist <- vapply(
seq_len(nrow(linked)),
function(i) {
as.numeric(st_distance(st_geometry(linked)[i], proposal_union))[[1]]
},
numeric(1)
)
nearest_patch_m <- min(prop_dist, na.rm = TRUE)
overlapping_patches <- sum(prop_dist <= 0.01, na.rm = TRUE)
# Identify baseline network components among the affected existing patches.
adjacency <- st_is_within_distance(linked, linked, dist = gap_m)
n <- nrow(linked)
visited <- rep(FALSE, n)
component_id <- integer(n)
baseline_components <- 0L
for (i in seq_len(n)) {
if (visited[i]) next
baseline_components <- baseline_components + 1L
queue <- i
visited[i] <- TRUE
component_id[i] <- baseline_components
while (length(queue) > 0) {
current <- queue[[1]]
queue <- queue[-1]
neighbors <- setdiff(adjacency[[current]], current)
new_nodes <- neighbors[!visited[neighbors]]
if (length(new_nodes) > 0) {
visited[new_nodes] <- TRUE
component_id[new_nodes] <- baseline_components
queue <- c(queue, new_nodes)
}
}
}
linked$baseline_component <- component_id
linked$distance_to_proposal_m <- prop_dist
linked$relationship <- ifelse(
prop_dist <= 0.01,
"Direct overlap / expansion",
paste0(round(prop_dist), " m gap")
)
linked$display_id <- paste0("P", seq_len(nrow(linked)))
linked$display_name <- ifelse(
is.na(linked$patch_name),
paste0("Unnamed mapped greenspace ", linked$display_id),
linked$patch_name
)
# Draw a dashed nearest-distance segment from the proposal to every affected
# patch. These segments make the selected connection threshold visible.
link_geoms <- lapply(seq_len(nrow(linked)), function(i) {
tryCatch(
st_nearest_points(proposal_union, st_geometry(linked)[i])[[1]],
error = function(e) st_geometrycollection()
)
})
links_sf <- st_sf(
display_id = linked$display_id,
patch_name = linked$display_name,
distance_m = linked$distance_to_proposal_m,
geometry = st_sfc(link_geoms, crs = 3857)
)
links_sf <- links_sf[!st_is_empty(links_sf), , drop = FALSE]
linked_area_ha <- as.numeric(st_area(st_union(st_geometry(linked)))) / 10000
maximum_linked_gap_m <- max(prop_dist, na.rm = TRUE)
classification <- dplyr::case_when(
nrow(linked) >= 2 && baseline_components >= 2 ~ "Bridge",
nrow(linked) >= 2 && baseline_components == 1 ~ "Network reinforcement",
nrow(linked) == 1 && overlapping_patches >= 1 ~ "Patch expansion",
nrow(linked) >= 1 ~ "Stepping-stone",
TRUE ~ "Isolated intervention"
)
list(
available = TRUE,
classification = classification,
gap_m = gap_m,
linked_patches = nrow(linked),
overlapping_patches = overlapping_patches,
baseline_components = baseline_components,
scenario_components = 1L,
components_reduced = max(0L, baseline_components - 1L),
nearest_patch_m = nearest_patch_m,
maximum_linked_gap_m = maximum_linked_gap_m,
existing_linked_area_ha = linked_area_ha,
novel_area_ha = novel_ha,
scenario_connected_area_ha = linked_area_ha + novel_ha,
corridor_length_m = corridor_length_m,
drawn_patch_count = sum(poly_idx),
linked_sf = linked,
links_sf = links_sf
)
})
# Display the full buffered intervention footprint so line width is visible.
observe({
footprint <- proposed_habitat_3857()
proxy <- leafletProxy("corridorMap") |> clearGroup("Your Proposed Habitat Area")
if (!is.null(footprint) && nrow(footprint) > 0) {
width_m <- suppressWarnings(as.numeric(input$corridor_width_m))
if (!is.finite(width_m) || width_m <= 0) width_m <- 10
mode <- corridor_drawing_mode()
gross_area_ha <- sum(as.numeric(st_area(footprint)), na.rm = TRUE) / 10000
width_text <- if (mode %in% c("line", "mixed")) {
paste0("Assumed total line width: ", width_m, " m")
} else {
"Polygon area follows the shape you drew; line width is not applied"
}
footprint_map <- st_transform(footprint, 4326)
footprint_map$popup_html <- paste0(
"Your proposed habitat area",
" ", width_text,
" Modeled footprint area: ", round(gross_area_ha, 2), " ha",
" Zoom in to distinguish narrow width choices."
)
proxy |> addPolygons(
data = footprint_map,
group = "Your Proposed Habitat Area",
color = "#0d47a1", weight = 4,
fillColor = "#42a5f5", fillOpacity = 0.42,
label = if (mode %in% c("line", "mixed")) {
paste0("Proposed habitat: ", width_m, " m total width")
} else {
"Your proposed habitat polygon"
},
popup = ~popup_html,
options = pathOptions(pane = "corridorProposalPane")
)
}
})
# Highlight the specific existing greenspaces affected by the proposal and
# draw the threshold links used by the connectivity calculation.
observe({
connectivity <- corridor_connectivity()
proxy <- leafletProxy("corridorMap") |>
clearGroup("Existing Greenspaces Reached") |>
clearGroup("Measured Connection Gaps")
if (is.null(connectivity) || !isTRUE(connectivity$available) ||
is.null(connectivity$linked_sf) || nrow(connectivity$linked_sf) == 0) {
return(invisible(NULL))
}
linked_map <- st_transform(connectivity$linked_sf, 4326)
linked_map$popup_html <- paste0(
"", linked_map$display_id, ": ", linked_map$display_name, "",
" Relationship: ", linked_map$relationship,
" Existing area: ", round(linked_map$patch_area_ha, 2), " ha",
" Baseline network: ", linked_map$baseline_component
)
proxy <- proxy |>
addPolygons(
data = linked_map,
group = "Existing Greenspaces Reached",
color = "#e65100",
weight = 4,
fillColor = "#ffb74d",
fillOpacity = 0.48,
label = ~paste0(display_id, ": ", display_name),
popup = ~popup_html,
highlightOptions = highlightOptions(
weight = 6,
color = "#bf360c",
fillOpacity = 0.58,
bringToFront = TRUE
)
)
label_points <- suppressWarnings(st_point_on_surface(linked_map))
proxy <- proxy |>
addLabelOnlyMarkers(
data = label_points,
group = "Existing Greenspaces Reached",
label = ~display_id,
labelOptions = labelOptions(
noHide = TRUE,
direction = "center",
textOnly = TRUE,
style = list(
"font-weight" = "bold",
"font-size" = "12px",
"color" = "#7f2704",
"background" = "rgba(255,255,255,0.88)",
"border" = "1px solid #e65100",
"padding" = "1px 4px"
)
)
)
if (!is.null(connectivity$links_sf) && nrow(connectivity$links_sf) > 0) {
links_map <- st_transform(connectivity$links_sf, 4326)
proxy <- proxy |>
addPolylines(
data = links_map,
group = "Measured Connection Gaps",
color = "#ef6c00",
weight = 3,
opacity = 0.9,
dashArray = "6,7",
label = ~paste0(
display_id,
ifelse(distance_m <= 0.01, ": direct overlap", paste0(": ", round(distance_m), " m gap"))
)
)
}
})
# At city scale, a 2--40 m buffer can be only a few screen pixels wide.
# This action centers the map on the middle of a drawn line at street scale so
# the selected total planted width can be inspected directly.
observeEvent(input$inspect_corridor_width, {
proposal <- proposed_greenspace()
if (is.null(proposal) || nrow(proposal) == 0) {
showNotification("Draw a line first, then use this button to inspect its planted width.", type = "warning")
return(invisible(NULL))
}
proposal_3857 <- tryCatch(
proposal |> st_transform(3857) |> st_zm(drop = TRUE, what = "ZM"),
error = function(e) NULL
)
if (is.null(proposal_3857) || nrow(proposal_3857) == 0) return(invisible(NULL))
types <- as.character(st_geometry_type(proposal_3857))
line_idx <- types %in% c("LINESTRING", "MULTILINESTRING")
if (!any(line_idx)) {
showNotification(
"The width control applies only to line drawings. Your polygon already defines its own area.",
type = "message"
)
return(invisible(NULL))
}
line_geom <- suppressWarnings(st_union(st_geometry(proposal_3857[line_idx, , drop = FALSE])))
inspect_point <- tryCatch(
st_line_sample(line_geom, sample = 0.5),
error = function(e) st_centroid(line_geom)
)
if (length(inspect_point) == 0 || all(st_is_empty(inspect_point))) {
inspect_point <- st_centroid(line_geom)
}
inspect_sf <- st_sf(geometry = inspect_point, crs = 3857) |> st_transform(4326)
coords <- st_coordinates(inspect_sf)
if (nrow(coords) == 0) return(invisible(NULL))
width_m <- suppressWarnings(as.numeric(input$corridor_width_m))
if (!is.finite(width_m) || width_m <= 0) width_m <- 10
leafletProxy("corridorMap") |>
showGroup("Your Drawn Route or Shape") |>
showGroup("Your Proposed Habitat Area") |>
setView(lng = coords[1, "X"], lat = coords[1, "Y"], zoom = 19)
showNotification(
paste0(
"Street-scale view: the blue footprint is ", width_m,
" m wide in total (", width_m / 2, " m on each side)."
),
type = "message",
duration = 5
)
invisible(NULL)
})
# One stakeholder-facing action produces a clean corridor view and zooms to
# the proposal plus the existing patches it affects.
observeEvent(input$show_corridor_result, {
footprint <- proposed_habitat_3857()
connectivity <- corridor_connectivity()
if (is.null(footprint) || nrow(footprint) == 0) {
showNotification("Draw a corridor line or habitat polygon first.", type = "warning")
return()
}
proxy <- leafletProxy("corridorMap") |>
showGroup("Existing SF Greenspace") |>
showGroup("Your Drawn Route or Shape") |>
showGroup("Your Proposed Habitat Area") |>
showGroup("Existing Greenspaces Reached") |>
showGroup("Measured Connection Gaps")
focus_parts <- list(st_geometry(footprint))
if (!is.null(connectivity$linked_sf) && nrow(connectivity$linked_sf) > 0) {
focus_parts[[length(focus_parts) + 1]] <- st_geometry(connectivity$linked_sf)
}
focus_geom <- do.call(c, focus_parts)
focus_sf <- st_sf(geometry = focus_geom, crs = 3857) |> st_transform(4326)
bb <- st_bbox(focus_sf)
pad_x <- max((bb[["xmax"]] - bb[["xmin"]]) * 0.15, 0.002)
pad_y <- max((bb[["ymax"]] - bb[["ymin"]]) * 0.15, 0.002)
proxy |> fitBounds(
lng1 = bb[["xmin"]] - pad_x,
lat1 = bb[["ymin"]] - pad_y,
lng2 = bb[["xmax"]] + pad_x,
lat2 = bb[["ymax"]] + pad_y
)
})
# Straight-line walking catchment around the novel proposed greenspace. This is
# intentionally labelled as an approximation: it uses the app's existing
# 80 m/min walking assumption rather than a routed pedestrian network.
scenario_beneficiary_catchment_3857 <- reactive({
proposal_net <- net_proposed_greenspace_3857()
if (is.null(proposal_net) || nrow(proposal_net) == 0) return(NULL)
walk_min <- suppressWarnings(as.numeric(input$beneficiary_walk_min))
if (!is.finite(walk_min) || walk_min <= 0) return(NULL)
catchment_geom <- st_geometry(proposal_net) |>
st_union() |>
st_buffer(dist = walk_min * walk_speed_m_per_min) |>
st_make_valid()
out <- st_sf(
walk_minutes = walk_min,
geometry = catchment_geom,
crs = 3857
)
out <- out[!st_is_empty(out), , drop = FALSE]
if (nrow(out) == 0) NULL else out
})
# Area-weighted beneficiary estimates. Population is apportioned by the share
# of each census block group covered by the catchment, which assumes residents
# are uniformly distributed within each block group. EJ beneficiaries are the
# portion of that population also falling inside the SF EJ-community polygons.
scenario_beneficiaries <- reactive({
catchment <- scenario_beneficiary_catchment_3857()
if (is.null(catchment) || nrow(catchment) == 0) {
proposal <- proposed_greenspace()
msg <- if (!is.null(proposal) && nrow(proposal) > 0) {
"No novel proposed area remains after overlap with existing OSM greenspace is removed."
} else {
"Draw proposed greenspace to estimate beneficiaries."
}
return(list(available = FALSE, message = msg))
}
required_cbg_cols <- c("GEOID", "popE", "medincE")
if (!inherits(cbg_vect_sf, "sf") || !all(required_cbg_cols %in% names(cbg_vect_sf))) {
return(list(
available = FALSE,
message = "Beneficiary estimates require GEOID, popE, and medincE in cbg_vect_sf."
))
}
cbg_3857 <- cbg_vect_sf |>
dplyr::select(dplyr::all_of(required_cbg_cols)) |>
st_transform(3857) |>
st_make_valid() |>
mutate(cbg_area_m2 = as.numeric(st_area(geometry)))
catchment_geom <- st_geometry(catchment)
cbg_inter <- tryCatch(
suppressWarnings(st_intersection(cbg_3857, catchment_geom)),
error = function(e) NULL
)
if (is.null(cbg_inter) || nrow(cbg_inter) == 0) {
return(list(
available = TRUE,
walk_minutes = catchment$walk_minutes[[1]],
walk_distance_m = catchment$walk_minutes[[1]] * walk_speed_m_per_min,
catchment_area_km2 = as.numeric(st_area(catchment_geom)) / 1e6,
total_population = 0,
ej_population = 0,
ej_share = NA_real_,
ej_vulnerability_threshold = NA_real_,
ej_vulnerability_percentile = 75,
low_access_population = 0,
low_access_threshold = median(city_benchmarks$greenspace_cover, na.rm = TRUE),
weighted_income = NA_real_,
mean_ej_score = NA_real_,
n_cbgs = 0
))
}
cbg_inter <- cbg_inter |>
mutate(
inter_area_m2 = as.numeric(st_area(geometry)),
area_fraction = pmin(1, pmax(0, inter_area_m2 / cbg_area_m2)),
served_population = pmax(0, as.numeric(popE)) * area_fraction
)
# Attach existing CBG greenspace cover so beneficiaries in relatively
# low-greenspace areas can be reported. The threshold is the citywide median.
low_access_threshold <- median(city_benchmarks$greenspace_cover, na.rm = TRUE)
if (exists("cbg_greenspace_coverage") &&
!is.null(cbg_greenspace_coverage) &&
all(c("GEOID", "greenspace_m2", "cbg_area_m2") %in% names(cbg_greenspace_coverage))) {
gs_lookup <- cbg_greenspace_coverage |>
transmute(
GEOID = as.character(GEOID),
existing_greenspace_pct = ifelse(
cbg_area_m2 > 0,
100 * greenspace_m2 / cbg_area_m2,
NA_real_
)
)
cbg_inter <- cbg_inter |>
mutate(GEOID = as.character(GEOID)) |>
left_join(gs_lookup, by = "GEOID")
} else {
cbg_inter$existing_greenspace_pct <- NA_real_
}
total_population <- sum(cbg_inter$served_population, na.rm = TRUE)
weighted_income <- if (total_population > 0) {
sum(cbg_inter$medincE * cbg_inter$served_population, na.rm = TRUE) /
sum(cbg_inter$served_population[is.finite(cbg_inter$medincE)], na.rm = TRUE)
} else {
NA_real_
}
if (!is.finite(weighted_income)) weighted_income <- NA_real_
low_access_population <- if (is.finite(low_access_threshold)) {
sum(
cbg_inter$served_population[
is.finite(cbg_inter$existing_greenspace_pct) &
cbg_inter$existing_greenspace_pct < low_access_threshold
],
na.rm = TRUE
)
} else {
NA_real_
}
ej_population <- 0
mean_ej_score <- NA_real_
ej_vulnerability_threshold <- NA_real_
ej_vulnerability_percentile <- 75
if (!is.null(sf_ej_sf) && inherits(sf_ej_sf, "sf") && nrow(sf_ej_sf) > 0) {
ej_all_3857 <- sf_ej_sf |>
st_transform(3857) |>
st_make_valid()
if ("score" %in% names(ej_all_3857)) {
city_ej_scores <- suppressWarnings(as.numeric(ej_all_3857$score))
city_ej_scores <- city_ej_scores[is.finite(city_ej_scores)]
if (length(city_ej_scores) > 0) {
ej_vulnerability_threshold <- as.numeric(
stats::quantile(
city_ej_scores,
probs = 0.75,
na.rm = TRUE,
names = FALSE,
type = 7
)
)
}
ej_vulnerable_3857 <- ej_all_3857 |>
dplyr::filter(
is.finite(score),
score > 0,
is.finite(ej_vulnerability_threshold),
score >= ej_vulnerability_threshold
)
} else {
ej_vulnerable_3857 <- ej_all_3857[0, , drop = FALSE]
}
vulnerable_union <- if (nrow(ej_vulnerable_3857) > 0) {
st_union(st_geometry(ej_vulnerable_3857))
} else {
st_sfc(crs = 3857)
}
vulnerable_catchment <- tryCatch(
suppressWarnings(st_intersection(catchment_geom, vulnerable_union)),
error = function(e) st_sfc(crs = 3857)
)
if (length(vulnerable_catchment) > 0 &&
!all(st_is_empty(vulnerable_catchment))) {
ej_cbg_inter <- tryCatch(
suppressWarnings(st_intersection(cbg_3857, vulnerable_catchment)),
error = function(e) NULL
)
if (!is.null(ej_cbg_inter) && nrow(ej_cbg_inter) > 0) {
ej_cbg_inter <- ej_cbg_inter |>
mutate(
inter_area_m2 = as.numeric(st_area(geometry)),
area_fraction = pmin(1, pmax(0, inter_area_m2 / cbg_area_m2)),
served_population = pmax(0, as.numeric(popE)) * area_fraction
)
ej_population <- sum(ej_cbg_inter$served_population, na.rm = TRUE)
}
}
if ("score" %in% names(ej_all_3857)) {
ej_score_inter <- tryCatch(
suppressWarnings(st_intersection(ej_all_3857[, "score"], catchment_geom)),
error = function(e) NULL
)
if (!is.null(ej_score_inter) && nrow(ej_score_inter) > 0) {
ej_score_inter$area_m2 <- as.numeric(st_area(ej_score_inter))
valid <- is.finite(ej_score_inter$score) & ej_score_inter$area_m2 > 0
if (any(valid)) {
mean_ej_score <- weighted.mean(
ej_score_inter$score[valid],
ej_score_inter$area_m2[valid],
na.rm = TRUE
)
}
}
}
}
list(
available = TRUE,
walk_minutes = catchment$walk_minutes[[1]],
walk_distance_m = catchment$walk_minutes[[1]] * walk_speed_m_per_min,
catchment_area_km2 = as.numeric(st_area(catchment_geom)) / 1e6,
total_population = total_population,
ej_population = min(ej_population, total_population),
ej_share = if (total_population > 0) 100 * min(ej_population, total_population) / total_population else NA_real_,
ej_vulnerability_threshold = ej_vulnerability_threshold,
ej_vulnerability_percentile = ej_vulnerability_percentile,
low_access_population = low_access_population,
low_access_threshold = low_access_threshold,
weighted_income = weighted_income,
mean_ej_score = mean_ej_score,
n_cbgs = dplyr::n_distinct(cbg_inter$GEOID)
)
})
# Draw the beneficiary catchment as a separate, toggleable map layer.
observe({
catchment <- scenario_beneficiary_catchment_3857()
proxy <- leafletProxy("corridorMap") |>
clearGroup("Population Estimate Area (Optional)")
if (isTRUE(input$show_beneficiary_catchment) &&
!is.null(catchment) && nrow(catchment) > 0) {
catchment_4326 <- st_transform(catchment, 4326)
proxy |>
addPolygons(
data = catchment_4326,
group = "Population Estimate Area (Optional)",
color = "#6a1b9a",
weight = 2,
dashArray = "6, 4",
fillColor = "#ce93d8",
fillOpacity = 0.14,
label = paste0(
catchment$walk_minutes[[1]],
"-minute population-estimate area (approximate)"
)
)
}
})
# ---------------------------------------------------------------------------
# Location selection
# ---------------------------------------------------------------------------
observeEvent(input$isoMap_click, {
req(input$location_choice == "map_click")
req(!isTRUE(greenspace_draw_active()))
click <- input$isoMap_click
if (!is.null(click)) {
chosen_point(c(lon = click$lng, lat = click$lat))
leafletProxy("isoMap") |>
clearGroup("selected_point") |>
addCircleMarkers(
lng = click$lng, lat = click$lat,
radius = 6, color = "firebrick",
group = "selected_point", label = "Map Click Location"
)
}
})
observeEvent(input$geocoder, {
req(input$location_choice == "address")
geocode_result <- input$geocoder
if (!is.null(geocode_result)) {
xy <- geocoder_as_xy(geocode_result)
chosen_point(c(lon = xy[1], lat = xy[2]))
leafletProxy("isoMap") |>
clearGroup("selected_point") |>
addCircleMarkers(
lng = xy[1], lat = xy[2],
radius = 6, color = "navy",
group = "selected_point", label = "Geocoded Address"
) |>
flyTo(lng = xy[1], lat = xy[2], zoom = 13)
}
})
observeEvent(input$clear_map, {
chosen_point(NULL)
iso_store$data <- NULL
leafletProxy("isoMap") |>
removeControl("ndvi_legend") |>
clearGroup("selected_point") |>
clearGroup("Isochrones") |>
clearGroup("Transit Isochrones") |>
clearGroup("Muni Stops Reached") |>
clearGroup("NDVI Raster")
})
# ---------------------------------------------------------------------------
# Isochrone generation
# ---------------------------------------------------------------------------
# iso_store holds the computed sf; only written inside observeEvent(input$generate_iso).
# Nothing can write to it except the button press, so map clicks cannot trigger
# Mapbox calls regardless of what other reactives read isochrones_data().
iso_store <- reactiveValues(data = NULL)
isochrones_data <- reactive({ iso_store$data })
# Flag for the conditionalPanel that reveals the spider plot once isochrones
# exist. suspendWhenHidden = FALSE so the condition is evaluated while the box
# is still hidden.
output$iso_ready <- reactive({
d <- isochrones_data()
!is.null(d) && nrow(d) > 0
})
outputOptions(output, "iso_ready", suspendWhenHidden = FALSE)
output$proposal_ready <- reactive({
d <- proposed_greenspace()
!is.null(d) && nrow(d) > 0
})
outputOptions(output, "proposal_ready", suspendWhenHidden = FALSE)
# build_isochrones() lives in the sourced helper and its signature is shared
# with the comparer tab, so the wait toggle is passed as an option rather than
# threaded through as another argument.
observeEvent(input$transit_charge_wait, {
options(bas.transit_charge_wait = isTRUE(input$transit_charge_wait))
}, ignoreNULL = FALSE)
observeEvent(input$generate_iso, {
options(bas.transit_charge_wait = isTRUE(input$transit_charge_wait))
pt <- chosen_point()
if (is.null(pt)) return()
if (length(input$transport_modes) == 0) return()
if (length(input$iso_times) == 0) return()
# A time budget with no precomputed reference still produces a valid
# isochrone and valid raw metrics, but add_reference_bai() has nothing to
# rank it against, so the Biodiversity Access Index comes back NA. Say so
# rather than showing a blank index.
no_ref <- setdiff(as.numeric(input$iso_times), REFERENCE_TIMES)
if (length(no_ref)) {
showNotification(
HTML(paste0("", paste(no_ref, collapse = ", "), "-minute isochrones have no ",
"citywide reference yet. The map and the raw metrics are correct; the ",
"Biodiversity Access Index needs same-mode, same-time percentiles and will ",
"be blank for ", ifelse(length(no_ref) > 1, "those budgets", "that budget"),
" until code/prep/extend_reference.R is run.")),
type = "warning", duration = 12)
}
leafletProxy("isoMap") |>
removeControl("ndvi_legend") |>
clearGroup("Isochrones") |>
clearGroup("Transit Isochrones") |>
clearGroup("Muni Stops Reached") |>
clearGroup("NDVI Raster")
# All isochrone construction lives in build_isochrones() (code/iso_metrics_AUDITED.R)
# so the comparer tab builds isochrones the exact same way.
iso_store$data <- build_isochrones(
point = pt,
modes = input$transport_modes,
times = input$iso_times,
transit_hour = input$transit_hour,
walk_to_stop_min = input$walk_to_stop_min,
walk_from_stop_min = input$walk_from_stop_min,
transit_departure_window_min = input$transit_departure_window_min
)
})
# ---------------------------------------------------------------------------
# Render isochrones and NDVI
# ---------------------------------------------------------------------------
observeEvent(isochrones_data(), {
iso_data <- isochrones_data()
req(iso_data)
leafletProxy("isoMap") |>
removeControl("ndvi_legend") |>
clearGroup("Isochrones") |>
clearGroup("Transit Isochrones") |>
clearGroup("Muni Stops Reached") |>
clearGroup("NDVI Raster")
standard_like_modes <- c("driving", "walking", "cycling", "driving-traffic", "walk_transit")
standard_iso <- iso_data[iso_data$mode %in% standard_like_modes, ]
if (nrow(standard_iso) > 0) {
for (i in seq_len(nrow(standard_iso))) {
poly_i <- standard_iso[i, ]
mode_i <- as.character(poly_i$mode[[1]])
time_i <- as.numeric(poly_i$time[[1]])
mode_label <- pretty_mode(mode_i)
is_walk_transit <- identical(mode_i, "walk_transit")
line_weight <- if (is_walk_transit) 3 else 2
dash_style <- if (is_walk_transit) "5, 5" else NULL
fill_alpha <- if (is_walk_transit) 0.28 else 0.35
color_i <- unname(mode_palette[mode_label])
if (is.na(color_i) || length(color_i) == 0) color_i <- "#666666"
popup_i <- if (is_walk_transit) {
paste0(
"Walk + Transit — ", time_i, " min",
" First-mile walk: up to ", input$walk_to_stop_min, " min",
" Transit: uses remaining budget after first-mile access",
" Departure flexibility window: ", input$transit_departure_window_min, " min",
" Last-mile walk: up to ", input$walk_from_stop_min, " min",
" Built from reachable transit stops plus walking-network access."
)
} else {
paste0("", mode_label, " — ", time_i, " min")
}
leafletProxy("isoMap") |>
addPolygons(
data = poly_i,
group = "Isochrones",
color = color_i,
weight = line_weight,
dashArray = dash_style,
fillOpacity = fill_alpha,
label = paste0(mode_label, " — ", time_i, " mins"),
popup = popup_i
)
}
}
transit_iso <- iso_data[iso_data$mode == "transit", ]
if (nrow(transit_iso) > 0 && !is.null(gtfs_stops_sf)) {
for (i in seq_len(nrow(transit_iso))) {
poly_i <- transit_iso[i, ]
time_i <- as.numeric(poly_i$time[[1]])
# keep the stops themselves, not just the count: they are drawn below so
# the user can see WHERE the isochrone lets them get off and walk out.
stops_in <- tryCatch(suppressWarnings(st_intersection(gtfs_stops_sf, poly_i)),
error = function(e) NULL)
n_stops_in <- if (is.null(stops_in)) 0 else nrow(stops_in)
area_km2 <- round(as.numeric(st_area(st_transform(poly_i, 3857))) / 1e6, 2)
t_score <- if (area_km2 > 0) round(n_stops_in / area_km2, 2) else NA_real_
iso_wkt_t <- st_as_text(st_geometry(poly_i)[[1]])
gbif_t <- tryCatch({
gbif_tab |>
filter(sql(glue("ST_Intersects(ST_GeomFromText(geom_wkt), ST_GeomFromText('{iso_wkt_t}'))"))) |>
summarise(n_records = n(), n_species = n_distinct(species)) |>
collect()
}, error = function(e) NULL)
n_gbif_rec <- if (!is.null(gbif_t) && nrow(gbif_t) > 0) gbif_t$n_records[[1]] else 0L
n_gbif_sp <- if (!is.null(gbif_t) && nrow(gbif_t) > 0) gbif_t$n_species[[1]] else 0L
popup_html <- paste0(
"Transit Isochrone — ", time_i, " min",
" Transit Access Score: ", t_score, " stops/km²",
" Muni stops within: ", n_stops_in,
" Area: ", area_km2, " km²",
" GBIF records within: ", n_gbif_rec,
" Unique species: ", n_gbif_sp
)
leafletProxy("isoMap") |>
addPolygons(
data = poly_i,
group = "Transit Isochrones",
color = mode_palette[["Transit"]],
weight = 2,
dashArray = "6, 4",
fillOpacity = 0.22,
label = paste0("Transit ", time_i, " min"),
popup = popup_html
)
# Draw the reachable stops only for the LARGEST budget, which is a
# superset of the smaller ones - drawing them per budget would stack
# several markers on the same stop.
if (!is.null(stops_in) && nrow(stops_in) > 0 &&
isTRUE(time_i == max(as.numeric(transit_iso$time), na.rm = TRUE))) {
leafletProxy("isoMap") |>
addCircleMarkers(
data = stops_in,
group = "Muni Stops Reached",
radius = 3.5, weight = 1,
color = "#20456e", fillColor = "#4a90d9", fillOpacity = 0.9,
label = ~paste0(stop_name, " (", stop_id, ")"),
popup = ~paste0("", stop_name, " Stop ID: ", stop_id,
" Reachable within ", time_i,
" min, including the walk at each end.")
)
}
}
}
if (exists("ndvi")) {
iso_union <- st_union(iso_data)
iso_union_vect <- vect(iso_union)
ndvi_crop <- terra::crop(ndvi, iso_union_vect)
ndvi_mask <- terra::mask(ndvi_crop, iso_union_vect)
ndvi_vals <- values(ndvi_mask)
ndvi_vals <- ndvi_vals[!is.na(ndvi_vals)]
if (length(ndvi_vals) > 0) {
ndvi_pal <- colorNumeric("YlGn", domain = range(ndvi_vals, na.rm = TRUE), na.color = "transparent")
leafletProxy("isoMap") |>
addRasterImage(x = ndvi_mask, colors = ndvi_pal, opacity = 0.7, project = TRUE, group = "NDVI Raster") |>
addLegend(
position = "bottomright", pal = ndvi_pal, values = ndvi_vals, title = "NDVI",
layerId = "ndvi_legend"
)
}
}
})
# ---------------------------------------------------------------------------
# Per-isochrone summaries
# ---------------------------------------------------------------------------
base_socio_data <- reactive({
iso_data <- isochrones_data()
if (is.null(iso_data) || nrow(iso_data) == 0) return(data.frame())
# compute_iso_metrics() preserves one row per generated isochrone. Immediately
# score EACH row independently against the matching precomputed mode × time
# distribution. No union/mean across generated isochrones enters percentile
# calculation.
raw_metrics <- quiet_sf_overlay(
compute_iso_metrics(iso_data, isolate(chosen_point()), gbif_tab)
)
score_iso_metrics_against_reference(raw_metrics)
})
# Apply the planning scenario to each isochrone. The drawn area modifies only
# Greenspace_percent; all observed biodiversity, transit, NDVI and equity values
# remain unchanged. Each scenario row is then re-ranked against the SAME mode ×
# time precomputed reference and its own per-isochrone composite is updated.
socio_data <- reactive({
base <- base_socio_data()
if (is.null(base) || nrow(base) == 0) return(base)
base$Baseline_Greenspace_percent <- base$Greenspace_percent
base$Added_Greenspace_m2 <- 0
base$Added_Greenspace_percent <- 0
proposal_net <- net_proposed_greenspace_3857()
if (is.null(proposal_net) || nrow(proposal_net) == 0) return(base)
# compute_iso_metrics() returns a non-spatial data.frame. Use the original
# isochrone sf object for geometry and keep the metrics table separate.
iso_sf <- isochrones_data()
if (is.null(iso_sf) || !inherits(iso_sf, "sf") || nrow(iso_sf) == 0) {
return(base)
}
# compute_iso_metrics() is expected to preserve one row per isochrone in the
# same order. Fail safely rather than calling an sf method on the metrics table.
if (nrow(iso_sf) != nrow(base)) {
warning(
"Proposed-greenspace scenario skipped: metric rows (", nrow(base),
") do not match isochrone rows (", nrow(iso_sf), ")."
)
return(base)
}
# Greenspace is now a 100 m grid-supported metric in BOTH the live app and
# Step 5. Therefore the scenario must modify the same support: the union of
# grid cells whose centroids fall within each individual isochrone.
if (!("MetricSupportArea_km2" %in% names(base))) {
warning("Scenario skipped: MetricSupportArea_km2 is missing from harmonized metrics.")
return(base)
}
support_area_m2 <- as.numeric(base$MetricSupportArea_km2) * 1e6
proposal_geometry <- st_geometry(proposal_net)
added_m2 <- vapply(seq_len(nrow(iso_sf)), function(i) {
support_geom_i <- tryCatch(
iso_metric_support_geometry(iso_sf[i, , drop = FALSE]),
error = function(e) st_sfc(crs = 3857)
)
if (length(support_geom_i) == 0) return(0)
proposal_geometry_i <- tryCatch(
st_transform(st_sf(geometry = proposal_geometry), st_crs(support_geom_i)) |> st_geometry(),
error = function(e) st_sfc(crs = st_crs(support_geom_i))
)
intersection_i <- tryCatch(
suppressWarnings(st_intersection(support_geom_i, proposal_geometry_i)),
error = function(e) st_sfc(crs = st_crs(support_geom_i))
)
if (length(intersection_i) == 0) return(0)
sum(as.numeric(st_area(intersection_i)), na.rm = TRUE)
}, numeric(1))
added_pct <- ifelse(
is.finite(support_area_m2) & support_area_m2 > 0,
100 * added_m2 / support_area_m2,
NA_real_
)
base$Added_Greenspace_m2 <- added_m2
base$Added_Greenspace_percent <- added_pct
base$Greenspace_percent <- ifelse(
is.na(base$Baseline_Greenspace_percent),
NA_real_,
pmin(100, base$Baseline_Greenspace_percent + added_pct)
)
# compute_iso_metrics() stores several summary values as custom attributes.
# Reattach non-percentile attributes, then RE-SCORE each scenario isochrone
# independently so a changed greenspace value receives a new percentile
# against its own matching mode × time reference distribution.
for (nm in c(
"closest_greenspace", "closest_greenspace_dist_m",
"closest_rsf_program", "closest_rsf_program_dist_m"
)) {
attr(base, nm) <- attr(base_socio_data(), nm)
}
score_iso_metrics_against_reference(base)
})
# ---------------------------------------------------------------------------
# Biodiversity Access Index — same-mode × same-time isochrone benchmarks
# ---------------------------------------------------------------------------
baseline_biodiversity_access_index <- reactive({
base <- base_socio_data()
if (is.null(base) || nrow(base) == 0) return(base)
add_reference_bai(base)
})
biodiversity_access_index <- reactive({
scenario <- socio_data()
if (is.null(scenario) || nrow(scenario) == 0) return(scenario)
add_reference_bai(scenario)
})
# Corridor access comparisons use exactly one active Explorer isochrone.
# NEVER average different modes or travel times for the corridor scenario.
# The selected row alone enters the baseline-versus-proposal BAI calculation.
corridor_selected_isochrone_metrics <- reactive({
info <- corridor_active_iso_info()
if (is.null(info)) return(NULL)
idx <- info$index
base_raw <- base_socio_data()
scenario_raw <- socio_data()
base_bai <- baseline_biodiversity_access_index()
scenario_bai <- biodiversity_access_index()
objects <- list(base_raw, scenario_raw, base_bai, scenario_bai)
if (any(vapply(objects, function(x) is.null(x) || nrow(x) < idx, logical(1)))) {
return(NULL)
}
list(
index = idx,
key = info$key,
label = info$label,
baseline_raw = base_raw[idx, , drop = FALSE],
scenario_raw = scenario_raw[idx, , drop = FALSE],
baseline_bai = base_bai[idx, , drop = FALSE],
scenario_bai = scenario_bai[idx, , drop = FALSE]
)
})
greenspace_scenario_comparison <- reactive({
selected <- corridor_selected_isochrone_metrics()
proposal <- proposed_greenspace()
if (is.null(proposal) || nrow(proposal) == 0 || is.null(selected)) {
return(NULL)
}
baseline <- selected$baseline_bai
scenario <- selected$scenario_bai
axis_cols <- c(
"Mobility_Access_std", "Route_Access_std",
"Biodiversity_Potential_std", "Observation_Intensity_std",
"Environmental_Quality_std", "Greenspace_Cover_std",
"Equity_Context_std"
)
if (!all(c(axis_cols, "BAI") %in% names(baseline)) ||
!all(c(axis_cols, "BAI") %in% names(scenario))) {
return(NULL)
}
list(
baseline = baseline,
scenario = scenario,
baseline_raw = selected$baseline_raw,
scenario_raw = selected$scenario_raw,
axis_cols = axis_cols,
index = selected$index,
label = selected$label
)
})
output$corridorImpactSummary <- renderUI({
comparison <- greenspace_scenario_comparison()
connectivity <- corridor_connectivity()
if (is.null(comparison)) return(NULL)
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
x <- x[is.finite(x)]
if (length(x) == 0) NA_real_ else x[[1]]
}
base_bai <- 100 * safe_num(comparison$baseline$BAI)
scenario_bai <- 100 * safe_num(comparison$scenario$BAI)
delta_bai <- scenario_bai - base_bai
base_bai_pctile <- safe_num(comparison$baseline$pctile_BAI)
scenario_bai_pctile <- safe_num(comparison$scenario$pctile_BAI)
delta_bai_pctile <- scenario_bai_pctile - base_bai_pctile
base_gs_pctile <- 100 * safe_num(comparison$baseline$Greenspace_Cover_std)
scenario_gs_pctile <- 100 * safe_num(comparison$scenario$Greenspace_Cover_std)
delta_gs_pctile <- scenario_gs_pctile - base_gs_pctile
base_gs_raw <- safe_num(comparison$baseline_raw$Greenspace_percent)
scenario_gs_raw <- safe_num(comparison$scenario_raw$Greenspace_percent)
delta_gs_raw <- scenario_gs_raw - base_gs_raw
# Identify which validated BAI axes actually changed in this modeled scenario.
bai_axis_cols <- c(
"Mobility_Access_std",
"Route_Access_std",
"Biodiversity_Potential_std",
"Observation_Intensity_std",
"Environmental_Quality_std",
"Greenspace_Cover_std",
"Equity_Context_std"
)
axis_delta <- vapply(bai_axis_cols, function(nm) {
if (!(nm %in% names(comparison$baseline)) ||
!(nm %in% names(comparison$scenario))) return(NA_real_)
100 * (
safe_num(comparison$scenario[[nm]]) -
safe_num(comparison$baseline[[nm]])
)
}, numeric(1))
changed_axes <- names(axis_delta)[is.finite(axis_delta) & abs(axis_delta) >= 0.1]
greenspace_only <- identical(changed_axes, "Greenspace_Cover_std")
impact_banner <- if (greenspace_only) {
tags$div(
style = paste0(
"background:#e8f5e9; border-left:5px solid #2f7d4b; ",
"border-radius:7px; padding:9px 12px; margin:8px 0 10px 0;"
),
tags$b("Modeled BAI gain is driven by greenspace cover only. "),
"The other six validated BAI dimensions are held constant in this scenario."
)
} else if (length(changed_axes) > 0) {
tags$div(
style = paste0(
"background:#eef6f1; border-left:5px solid #5d8d70; ",
"border-radius:7px; padding:9px 12px; margin:8px 0 10px 0;"
),
tags$b("Modeled BAI change is concentrated in: "),
paste(changed_axes, collapse = ", "),
"."
)
} else {
tags$div(
style = paste0(
"background:#f4f4f4; border-left:5px solid #888; ",
"border-radius:7px; padding:9px 12px; margin:8px 0 10px 0;"
),
tags$b("No validated BAI dimension changed under the current scenario settings.")
)
}
fmt_arrow <- function(a, b, suffix = "", digits = 1) {
if (!is.finite(a) || !is.finite(b)) return("N/A")
paste0(round(a, digits), suffix, " → ", round(b, digits), suffix)
}
fmt_delta <- function(x, suffix = "", digits = 1) {
if (!is.finite(x)) return("N/A")
paste0(if (x >= 0) "+" else "", round(x, digits), suffix)
}
connectivity_value <- "Unavailable"
connectivity_detail <- "Structural connectivity could not be evaluated."
connectivity_subdetail <- NULL
if (!is.null(connectivity) && isTRUE(connectivity$available)) {
connectivity_value <- connectivity$classification
if (identical(connectivity$classification, "Network reinforcement") &&
is.finite(connectivity$baseline_components) &&
is.finite(connectivity$scenario_components)) {
connectivity_detail <- paste0(
"The habitat network remains ",
connectivity$baseline_components, " → ", connectivity$scenario_components,
"; the proposal reinforces habitat around ",
connectivity$linked_patches, " reached greenspaces."
)
} else {
connectivity_detail <- paste0(
connectivity$baseline_components, " → ", connectivity$scenario_components,
" habitat networks; ", connectivity$linked_patches, " greenspaces reached."
)
}
connectivity_subdetail <- paste0(
"Separate structural-connectivity result — not included as a BAI axis."
)
}
connectivity_sentence <- if (!is.null(connectivity) && isTRUE(connectivity$available)) {
dplyr::case_when(
identical(connectivity$classification, "Network reinforcement") ~
paste0(
"It reinforces an existing habitat network rather than joining separate networks under the ",
connectivity$gap_m, " m connection rule."
),
identical(connectivity$classification, "Bridge") ~
paste0(
"It joins previously separate habitat networks under the ",
connectivity$gap_m, " m connection rule."
),
identical(connectivity$classification, "Patch expansion") ~
"It expands an existing mapped habitat patch rather than creating a new network connection.",
identical(connectivity$classification, "Stepping-stone") ~
"It adds a potential stepping stone but does not join separate habitat networks.",
TRUE ~
"It remains structurally isolated from mapped greenspaces under the selected connection rule."
)
} else {
"Structural connectivity is unavailable for the current proposal."
}
stakeholder_summary <- if (
is.finite(base_gs_raw) && is.finite(scenario_gs_raw) &&
is.finite(base_gs_pctile) && is.finite(scenario_gs_pctile) &&
is.finite(base_bai) && is.finite(scenario_bai)
) {
paste0(
"This intervention increases accessible greenspace from ",
round(base_gs_raw, 1), "% to ", round(scenario_gs_raw, 1),
"%, moving the greenspace benchmark from ",
round(base_gs_pctile, 1), " to ", round(scenario_gs_pctile, 1),
" percentile points and the composite BAI from ",
round(base_bai, 1), " to ", round(scenario_bai, 1), "/100. ",
connectivity_sentence
)
} else {
paste0("The modeled intervention changes accessible greenspace and the selected-isochrone BAI. ", connectivity_sentence)
}
tags$div(
style = "background:#f7fbf8; border:1px solid #cfe2d6; border-radius:10px; padding:12px 12px 10px 12px; margin-bottom:10px;",
tags$div(
style = "display:flex; justify-content:space-between; align-items:flex-start; gap:10px; flex-wrap:wrap;",
tags$div(
tags$div(
style = "font-size:19px; font-weight:700; color:#28543b;",
"Conservation action impact dashboard"
),
tags$small(
"Two different outcomes are shown together: validated BAI change and structural connectivity."
)
),
tags$span(
style = "background:#e8f5e9; border:1px solid #c6dfca; border-radius:999px; padding:5px 10px; font-weight:700; color:#2f6b45;",
comparison$label
)
),
tags$div(
style = "background:#ffffff; border-left:5px solid #2f855a; border-radius:8px; padding:10px 12px; margin:9px 0;",
tags$b("Stakeholder summary: "),
stakeholder_summary
),
impact_banner,
tags$div(
style = "display:grid; grid-template-columns:3fr 2fr; gap:10px; margin-bottom:9px;",
tags$div(
style = "background:white; border:1px solid #cfe2d6; border-radius:9px; padding:10px;",
tags$div(
style = "font-size:12px; text-transform:uppercase; letter-spacing:.04em; color:#557064; font-weight:700;",
"BAI IMPACT — validated 7-axis accessibility index"
),
tags$div(
style = "display:grid; grid-template-columns:repeat(4,minmax(0,1fr)); gap:8px; margin-top:7px;",
tags$div(
style = "background:#f8fbf9; border:1px solid #e0ebe4; border-radius:8px; padding:9px;",
tags$small(tags$b("Composite BAI")),
tags$div(style = "font-size:21px; font-weight:700;", fmt_arrow(base_bai, scenario_bai)),
tags$small(
style = if (is.finite(delta_bai) && delta_bai > 0) "color:#2f7d4b; font-weight:700;" else "color:#66766e;",
paste0("Change: ", fmt_delta(delta_bai))
)
),
tags$div(
style = "background:#f3f7fb; border:1px solid #d9e4ef; border-radius:8px; padding:9px;",
tags$small(tags$b("BAI citywide percentile")),
tags$div(style = "font-size:21px; font-weight:700;", fmt_arrow(base_bai_pctile, scenario_bai_pctile)),
tags$small(
style = if (is.finite(delta_bai_pctile) && delta_bai_pctile > 0) "color:#2f7d4b; font-weight:700;" else "color:#66766e;",
paste0("Change: ", fmt_delta(delta_bai_pctile, " pp"))
)
),
tags$div(
style = "background:#f8fbf9; border:1px solid #e0ebe4; border-radius:8px; padding:9px;",
tags$small(tags$b("Greenspace percentile")),
tags$div(style = "font-size:21px; font-weight:700;", fmt_arrow(base_gs_pctile, scenario_gs_pctile)),
tags$small(
style = if (is.finite(delta_gs_pctile) && delta_gs_pctile > 0) "color:#2f7d4b; font-weight:700;" else "color:#66766e;",
paste0("Change: ", fmt_delta(delta_gs_pctile, " pp"))
)
),
tags$div(
style = "background:#f8fbf9; border:1px solid #e0ebe4; border-radius:8px; padding:9px;",
tags$small(tags$b("Greenspace cover (raw)")),
tags$div(style = "font-size:21px; font-weight:700;", fmt_arrow(base_gs_raw, scenario_gs_raw, "%")),
tags$small(
style = if (is.finite(delta_gs_raw) && delta_gs_raw > 0) "color:#2f7d4b; font-weight:700;" else "color:#66766e;",
paste0("Change: ", fmt_delta(delta_gs_raw, " pp"))
)
)
)
),
tags$div(
style = "background:#fffaf0; border:1px solid #ecd8aa; border-radius:9px; padding:10px;",
tags$div(
style = "font-size:12px; text-transform:uppercase; letter-spacing:.04em; color:#7a622b; font-weight:700;",
"CONNECTIVITY OUTCOME — separate structural metric"
),
tags$div(
style = "font-size:23px; line-height:1.1; font-weight:800; color:#5f4a19; margin-top:8px;",
connectivity_value
),
tags$div(
style = "font-size:13px; line-height:1.35; margin-top:6px; color:#4f493c;",
connectivity_detail
),
if (!is.null(connectivity_subdetail)) {
tags$small(
style = "display:block; margin-top:7px; color:#766b55;",
connectivity_subdetail
)
}
)
)
)
})
output$corridorBaiComparisonNote <- renderUI({
info <- corridor_active_iso_info()
if (is.null(info)) {
return(tags$p("Choose an Explorer isochrone to compare baseline and proposal conditions."))
}
tags$p(
tags$b("How to read this scenario: "), info$label, " is the only active access area. ",
"The proposal changes greenspace cover inside that same isochrone and re-ranks it against the same citywide mode × time reference. ",
"Observed species richness, NDVI, transit access, route access, sampling density, and equity context are held constant. ",
"Therefore any outward movement in the radar identifies the modeled access-score effect of the planned greenspace action rather than a prediction of future biodiversity."
)
})
# ---------------------------------------------------------------------------
# HTML report cards
# ---------------------------------------------------------------------------
output$download_explorer_report <- downloadHandler(
filename = function() paste0("sf_biodiversity_access_explorer_", format(Sys.Date(), "%Y%m%d"), ".html"),
contentType = "text/html",
content = function(file) {
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) stop("Generate isochrones before downloading this report card.")
colnum <- function(nm, mult = 1) {
if (!(nm %in% names(df))) return(rep(NA_real_, nrow(df)))
suppressWarnings(as.numeric(df[[nm]])) * mult
}
report_df <- data.frame(
Isochrone = vapply(seq_len(nrow(df)), function(i) iso_metric_row_label(df, i), character(1)),
`Transit raw (stops/km²)` = round(colnum("Transit_Access_Score"), 2),
`Transit percentile` = round(colnum("pctile_Transit_Access_Score"), 1),
`Muni routes raw` = round(colnum("Unique_Muni_Routes")),
`Muni route percentile` = round(colnum("pctile_Unique_Muni_Routes"), 1),
`Total species raw` = round(colnum("GBIF_Species")),
`Species percentile` = round(colnum("pctile_GBIF_Species"), 1),
`Sampling density raw` = round(colnum("SamplingDensity_km2"), 1),
`Sampling-density percentile` = round(colnum("pctile_SamplingDensity_km2"), 1),
`Mean NDVI raw` = round(colnum("MeanNDVI"), 3),
`NDVI percentile` = round(colnum("pctile_MeanNDVI"), 1),
`Greenspace cover raw (%)` = round(colnum("Greenspace_percent"), 1),
`Greenspace percentile` = round(colnum("pctile_Greenspace_percent"), 1),
`SF EJ score raw` = round(colnum("SF_EJ_Score"), 1),
`Favorable equity percentile` = round(colnum("pctile_SF_EJ_Score"), 1),
`BAI score (/100)` = round(colnum("BAI", 100), 1),
`BAI citywide percentile` = round(colnum("pctile_BAI"), 1),
`GBIF records` = round(colnum("GBIF_Records")),
check.names = FALSE
)
map_iso <- isochrones_data()
map_labels <- if (!is.null(map_iso) && nrow(map_iso) > 0) {
vapply(seq_len(nrow(map_iso)), function(i) {
paste0(pretty_mode(as.character(map_iso$mode[[i]])), " ", as.numeric(map_iso$time[[i]]), " min")
}, character(1))
} else character(0)
map_colors <- if (!is.null(map_iso) && nrow(map_iso) > 0) {
vapply(seq_len(nrow(map_iso)), function(i) {
clr <- unname(mode_palette[pretty_mode(as.character(map_iso$mode[[i]]))])
if (length(clr) == 0 || is.na(clr) || !nzchar(clr)) "#666666" else clr
}, character(1))
} else character(0)
map_uri <- if (!is.null(map_iso) && nrow(map_iso) > 0) {
report_card_map_uri(function(path) {
write_report_isochrone_map(
path,
map_iso,
labels = map_labels,
colors = map_colors,
map_title = "Isochrone Explorer — spatial context"
)
})
} else NULL
write_report_card(
file,
"Isochrone Explorer — Biodiversity Access Report Card",
"Citywide same-mode × same-time benchmarking",
sections = paste0(
report_card_map_section(map_uri, "Map of Isochrone Explorer analysis areas"),
'
Results
',
'
Every BAI dimension is shown as a raw value paired with its citywide percentile. BAI score /100 is the seven-axis mean; BAI citywide percentile is a separate rank of that composite score against complete same-mode × same-time reference BAIs.
',
report_card_table(report_df),
''
)
)
}
)
output$download_comparer_report <- downloadHandler(
filename = function() paste0("sf_biodiversity_access_comparison_", format(Sys.Date(), "%Y%m%d"), ".html"),
contentType = "text/html",
content = function(file) {
res <- cmp_results()
if (is.null(res)) stop("Run the Point A vs Point B comparison first.")
side_row <- function(side, side_name) {
if (is.null(side) || is.null(side$metrics) || nrow(side$metrics) == 0) {
return(data.frame(Point = side_name, Location = "Unavailable", check.names = FALSE))
}
m <- side$metrics
b <- side$bai
gm <- function(nm) if (nm %in% names(m)) suppressWarnings(as.numeric(m[[nm]][[1]])) else NA_real_
gb <- function(nm) if (!is.null(b) && nm %in% names(b)) suppressWarnings(as.numeric(b[[nm]][[1]])) else NA_real_
data.frame(
Point = side_name,
Location = if (!is.null(side$label)) side$label else iso_metric_row_label(m, 1),
`Transit raw (stops/km²)` = round(gm("Transit_Access_Score"), 2),
`Transit percentile` = round(gm("pctile_Transit_Access_Score"), 1),
`Muni routes raw` = round(gm("Unique_Muni_Routes")),
`Muni route percentile` = round(gm("pctile_Unique_Muni_Routes"), 1),
`Total species raw` = round(gm("GBIF_Species")),
`Species percentile` = round(gm("pctile_GBIF_Species"), 1),
`Sampling density raw` = round(gm("SamplingDensity_km2"), 1),
`Sampling-density percentile` = round(gm("pctile_SamplingDensity_km2"), 1),
`Mean NDVI raw` = round(gm("MeanNDVI"), 3),
`NDVI percentile` = round(gm("pctile_MeanNDVI"), 1),
`Greenspace raw (%)` = round(gm("Greenspace_percent"), 1),
`Greenspace percentile` = round(gm("pctile_Greenspace_percent"), 1),
`SF EJ raw` = round(gm("SF_EJ_Score"), 1),
`Favorable equity percentile` = round(gm("pctile_SF_EJ_Score"), 1),
`BAI score (/100)` = round(100 * gb("BAI"), 1),
`BAI citywide percentile` = round(gb("pctile_BAI"), 1),
check.names = FALSE
)
}
report_df <- dplyr::bind_rows(side_row(res$a, "Point A"), side_row(res$b, "Point B"))
map_iso <- list()
map_labels <- character()
map_colors <- character()
if (!is.null(res$a) && !is.null(res$a$iso) && nrow(res$a$iso) > 0) {
map_iso[[length(map_iso) + 1L]] <- res$a$iso
map_labels <- c(map_labels, paste0("Point A — ", res$a$label))
map_colors <- c(map_colors, cmp_color_a)
}
if (!is.null(res$b) && !is.null(res$b$iso) && nrow(res$b$iso) > 0) {
map_iso[[length(map_iso) + 1L]] <- res$b$iso
map_labels <- c(map_labels, paste0("Point B — ", res$b$label))
map_colors <- c(map_colors, cmp_color_b)
}
map_uri <- if (length(map_iso) > 0) {
report_card_map_uri(function(path) {
write_report_isochrone_map(
path,
map_iso,
labels = map_labels,
colors = map_colors,
map_title = "Isochrone Comparer — spatial context"
)
})
} else NULL
write_report_card(
file,
"Isochrone Comparer — Report Card",
"Point A and Point B are benchmarked independently",
sections = paste0(
report_card_map_section(map_uri, "Map of Point A and Point B isochrone analysis areas"),
'
Comparison
',
'
Each point uses its own matching SF transportation-mode × travel-time reference. Raw values and percentiles remain paired, and the two BAI quantities are reported separately.
This screen does not calculate green-gentrification or displacement risk. A descriptive overlap between greenspace need and EJ burden is a reason to consider community governance and anti-displacement safeguards, not evidence that greening will cause displacement.
',
'
A defensible displacement-risk screen would require housing tenure, rent burden, eviction/displacement events, housing-cost trends, affordable-housing protection, and related housing-market indicators.
',
''
),
caution = "Do not interpret this context screen as evidence that a proposed greening action will cause displacement."
)
}
)
# ---------------------------------------------------------------------------
# Green Investment & Displacement Context
# ---------------------------------------------------------------------------
output$displacementContextSummary <- renderUI({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) {
return(tags$div(
style = "color:#66766e;",
"Generate one or more isochrones in the Explorer to populate this context screen."
))
}
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
if (length(x) == 0 || !is.finite(x[[1]])) NA_real_ else x[[1]]
}
cards <- lapply(seq_len(nrow(df)), function(i) {
gs_raw <- if ("Greenspace_percent" %in% names(df)) safe_num(df$Greenspace_percent[[i]]) else NA_real_
gs_pct <- if ("pctile_Greenspace_percent" %in% names(df)) safe_num(df$pctile_Greenspace_percent[[i]]) else NA_real_
equity_pct <- if ("pctile_SF_EJ_Score" %in% names(df)) safe_num(df$pctile_SF_EJ_Score[[i]]) else NA_real_
ej_raw <- if ("SF_EJ_Score" %in% names(df)) safe_num(df$SF_EJ_Score[[i]]) else NA_real_
income <- if ("MedianIncome" %in% names(df)) safe_num(df$MedianIncome[[i]]) else NA_real_
bai <- if ("BAI" %in% names(df)) 100 * safe_num(df$BAI[[i]]) else NA_real_
bai_pct <- if ("pctile_BAI" %in% names(df)) safe_num(df$pctile_BAI[[i]]) else NA_real_
greenspace_gap <- if (is.finite(gs_pct)) 100 - gs_pct else NA_real_
ej_burden_context <- if (is.finite(equity_pct)) 100 - equity_pct else NA_real_
planning_context <- if (!is.finite(greenspace_gap) || !is.finite(ej_burden_context)) {
"Insufficient comparable percentile information for a descriptive planning context."
} else if (greenspace_gap >= 50 && ej_burden_context >= 50) {
"Greening opportunity overlaps with greater EJ burden context. Consider community-led planning and explicit anti-displacement safeguards alongside ecological investment."
} else if (greenspace_gap >= 50) {
"Larger relative greenspace-access gap, but lower EJ burden context on this screen. Greening need is visible; displacement vulnerability is not estimated."
} else if (ej_burden_context >= 50) {
"Greater EJ burden context despite comparatively stronger greenspace access. Equity considerations remain important, but this is not a displacement-risk classification."
} else {
"Neither the relative greenspace-access gap nor EJ burden context falls in the upper half of these descriptive citywide scales."
}
tags$div(
style = paste0(
"border:1px solid #dbe8e1; border-radius:9px; padding:10px 12px; ",
"margin-bottom:9px; background:white;"
),
tags$div(
style = "font-size:15px; font-weight:700; color:#294337; margin-bottom:7px;",
iso_metric_row_label(df, i)
),
tags$div(
style = "display:grid; grid-template-columns:repeat(5,minmax(0,1fr)); gap:8px;",
tags$div(
style = paste0("border-top:4px solid ", BAI_GROUP_COLORS[["green_environment"]], "; padding-top:5px;"),
tags$small(tags$b("Greenspace cover")),
tags$div(style = "font-size:19px; font-weight:700;", if (is.finite(gs_raw)) paste0(round(gs_raw, 1), "%") else "N/A"),
tags$small("Citywide rank: ", format_pct(gs_pct))
),
tags$div(
style = paste0("border-top:4px solid ", BAI_GROUP_COLORS[["equity"]], "; padding-top:5px;"),
tags$small(tags$b("SF EJ context")),
tags$div(style = "font-size:19px; font-weight:700;", if (is.finite(ej_raw)) round(ej_raw, 1) else "N/A"),
tags$small("Favorable citywide rank: ", format_pct(equity_pct))
),
tags$div(
tags$small(tags$b("Median-income context")),
tags$div(
style = "font-size:19px; font-weight:700;",
if (is.finite(income)) scales::dollar(income, accuracy = 1) else "N/A"
),
tags$small("Context only; not a vulnerability score")
),
tags$div(
tags$small(tags$b("BAI score")),
tags$div(style = "font-size:19px; font-weight:700;", if (is.finite(bai)) paste0(round(bai, 1), "/100") else "N/A"),
tags$small("Seven-axis mean")
),
tags$div(
tags$small(tags$b("BAI citywide rank")),
tags$div(style = "font-size:19px; font-weight:700;", format_pct(bai_pct)),
tags$small("Same mode × same travel time")
)
),
tags$div(
style = paste0(
"background:#fff7e8; border-left:4px solid #d6a542; ",
"border-radius:6px; padding:7px 9px; margin-top:8px; font-size:12px;"
),
tags$b("Planning interpretation — descriptive, not a risk classification: "),
planning_context
),
tags$div(
style = paste0(
"background:#f7f7f7; border-left:4px solid #888; border-radius:6px; ",
"padding:7px 9px; margin-top:6px; font-size:12px;"
),
tags$b("Displacement-risk estimate: not calculated. "),
"Housing tenure, rent burden, eviction, housing-cost trend, and affordable-housing data are not currently included."
)
)
})
tags$div(cards)
})
output$displacementContextPlot <- renderPlot({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0 ||
!("pctile_Greenspace_percent" %in% names(df)) ||
!("pctile_SF_EJ_Score" %in% names(df))) {
plot.new()
title("Generate supported isochrones to view the context plot.")
return(invisible(NULL))
}
plot_df <- data.frame(
label = vapply(
seq_len(nrow(df)),
function(i) iso_metric_row_label(df, i),
character(1)
),
greenspace_gap = 100 - suppressWarnings(as.numeric(df$pctile_Greenspace_percent)),
ej_burden_context = 100 - suppressWarnings(as.numeric(df$pctile_SF_EJ_Score)),
stringsAsFactors = FALSE
)
plot_df <- plot_df[
is.finite(plot_df$greenspace_gap) &
is.finite(plot_df$ej_burden_context),
,
drop = FALSE
]
if (nrow(plot_df) == 0) {
plot.new()
title("No comparable same-mode × same-time context values are available.")
return(invisible(NULL))
}
ggplot2::ggplot(
plot_df,
ggplot2::aes(
x = greenspace_gap,
y = ej_burden_context,
label = label
)
) +
ggplot2::annotate(
"rect",
xmin = 50, xmax = 100,
ymin = 50, ymax = 100,
fill = "#fff4d6",
alpha = 0.45
) +
ggplot2::geom_vline(
xintercept = 50,
linetype = "dashed",
color = "#9aa7a0"
) +
ggplot2::geom_hline(
yintercept = 50,
linetype = "dashed",
color = "#9aa7a0"
) +
ggplot2::geom_point(
size = 4.2,
shape = 21,
fill = "#5d8d70",
color = "#294337",
stroke = 1.1
) +
ggplot2::geom_text(
nudge_y = 3.2,
size = 4,
fontface = "bold",
check_overlap = TRUE
) +
ggplot2::annotate(
"text",
x = 75,
y = 96,
label = "High greening opportunity\\n+ greater EJ burden context",
fontface = "bold",
size = 4.2,
color = "#795b16"
) +
ggplot2::scale_x_continuous(
limits = c(0, 100),
breaks = c(0, 25, 50, 75, 100)
) +
ggplot2::scale_y_continuous(
limits = c(0, 100),
breaks = c(0, 25, 50, 75, 100)
) +
ggplot2::labs(
x = "Relative greenspace-access gap\\n100 − greenspace-cover percentile",
y = "EJ burden context\\n100 − favorable equity-context percentile",
title = "Equity-Sensitive Greening Context",
subtitle = paste0(
"Upper-right highlights overlap between a larger greenspace-access gap ",
"and greater EJ burden context. It is not a displacement-risk classification."
),
caption = paste0(
"Each point is one independently scored isochrone. ",
"The 50/50 guide lines are descriptive only."
)
) +
ggplot2::theme_minimal(base_size = 13) +
ggplot2::theme(
panel.grid.minor = ggplot2::element_blank(),
panel.grid.major = ggplot2::element_line(color = "#e1e9e4"),
plot.title = ggplot2::element_text(
face = "bold",
color = "#294337",
size = 16
),
axis.title = ggplot2::element_text(face = "bold"),
plot.subtitle = ggplot2::element_text(color = "#596861"),
plot.caption = ggplot2::element_text(
hjust = 0,
color = "#66766e"
)
)
})
output$ngoReportingSummary <- renderUI({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) {
return(tags$p(
"Generate an isochrone to create reporting-ready citywide benchmark language."
))
}
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
if (length(x) == 0 || !is.finite(x[[1]])) NA_real_ else x[[1]]
}
rows <- lapply(seq_len(nrow(df)), function(i) {
species_raw <- if ("GBIF_Species" %in% names(df)) safe_num(df$GBIF_Species[[i]]) else NA_real_
species_pct <- if ("pctile_GBIF_Species" %in% names(df)) safe_num(df$pctile_GBIF_Species[[i]]) else NA_real_
greenspace_raw <- if ("Greenspace_percent" %in% names(df)) safe_num(df$Greenspace_percent[[i]]) else NA_real_
greenspace_pct <- if ("pctile_Greenspace_percent" %in% names(df)) safe_num(df$pctile_Greenspace_percent[[i]]) else NA_real_
equity_raw <- if ("SF_EJ_Score" %in% names(df)) safe_num(df$SF_EJ_Score[[i]]) else NA_real_
equity_pct <- if ("pctile_SF_EJ_Score" %in% names(df)) safe_num(df$pctile_SF_EJ_Score[[i]]) else NA_real_
bai <- if ("BAI" %in% names(df)) 100 * safe_num(df$BAI[[i]]) else NA_real_
bai_pct <- if ("pctile_BAI" %in% names(df)) safe_num(df$pctile_BAI[[i]]) else NA_real_
sentence_parts <- c(
paste0(iso_metric_row_label(df, i), ":"),
if (is.finite(species_raw) && is.finite(species_pct)) {
paste0(
scales::comma(round(species_raw)),
" accessible unique GBIF species (", format_pct(species_pct), ")"
)
} else NULL,
if (is.finite(greenspace_raw) && is.finite(greenspace_pct)) {
paste0(
round(greenspace_raw, 1),
"% greenspace cover (", format_pct(greenspace_pct), ")"
)
} else NULL,
if (is.finite(bai)) {
paste0(
"BAI score ", round(bai, 1), "/100",
if (is.finite(bai_pct)) paste0(" with a citywide BAI rank of ", format_pct(bai_pct)) else ""
)
} else NULL,
if (is.finite(equity_raw) && is.finite(equity_pct)) {
paste0(
"SF EJ raw score ", round(equity_raw, 1),
" with a favorable equity-context rank of ", format_pct(equity_pct),
" (higher rank = lower EJ burden)"
)
} else NULL
)
tags$div(
style = paste0(
"background:#f3f8f5; border-left:4px solid #5d8d70; ",
"border-radius:7px; padding:9px 11px; margin-bottom:8px;"
),
paste0(paste(sentence_parts, collapse = "; "), ".")
)
})
tags$div(
rows,
tags$small(
style = "display:block; color:#66766e; margin-top:7px;",
"Recommended wording attributes each benchmark to the specific isochrone/site and matching transportation scenario—not to the NGO as an organization. BAI score and BAI citywide percentile are reported separately."
)
)
})
# ---------------------------------------------------------------------------
# Summary outputs
# ---------------------------------------------------------------------------
output$dataTable <- renderDT({
df <- base_socio_data()
if (nrow(df) == 0) return(DT::datatable(data.frame(Message = "No isochrones generated yet.")))
out <- df |>
mutate(
MedianIncome = ifelse(is.na(MedianIncome), NA, dollar(MedianIncome)),
MeanNDVI = round(MeanNDVI, 3)
)
DT::datatable(
out,
options = list(pageLength = 10, autoWidth = TRUE, scrollX = TRUE),
rownames = FALSE
)
})
output$bioScoreBox <- renderUI({
df <- base_socio_data()
if (is.null(df) || nrow(df) == 0) return(NULL)
fmt_count <- function(x) {
x <- suppressWarnings(as.numeric(x))
if (length(x) == 0 || !is.finite(x)) return("N/A")
scales::comma(round(x))
}
# One independently benchmarked result per generated isochrone. Never show a
# percentile for the union/mean of multiple mode × time polygons.
cards <- lapply(seq_len(nrow(df)), function(i) {
total_raw <- if ("GBIF_Species" %in% names(df)) df$GBIF_Species[[i]] else NA_real_
bird_raw <- if ("Bird_Species" %in% names(df)) df$Bird_Species[[i]] else NA_real_
mammal_raw <- if ("Mammal_Species" %in% names(df)) df$Mammal_Species[[i]] else NA_real_
plant_raw <- if ("Plant_Species" %in% names(df)) df$Plant_Species[[i]] else NA_real_
total_pct <- if ("pctile_GBIF_Species" %in% names(df)) df$pctile_GBIF_Species[[i]] else NA_real_
bird_pct <- if ("pctile_Bird_Species" %in% names(df)) df$pctile_Bird_Species[[i]] else NA_real_
mammal_pct <- if ("pctile_Mammal_Species" %in% names(df)) df$pctile_Mammal_Species[[i]] else NA_real_
plant_pct <- if ("pctile_Plant_Species" %in% names(df)) df$pctile_Plant_Species[[i]] else NA_real_
# % native among plant species with an iNaturalist establishment status
# (native/endemic vs introduced); status-unknown species are excluded.
plant_native <- if ("Plant_Native_Species" %in% names(df)) df$Plant_Native_Species[[i]] else NA_real_
plant_intro <- if ("Plant_Introduced_Species" %in% names(df)) df$Plant_Introduced_Species[[i]] else NA_real_
plant_known <- plant_native + plant_intro
n_ref <- if ("nref_GBIF_Species" %in% names(df)) df$nref_GBIF_Species[[i]] else NA_integer_
tags$div(
style = "padding:10px 0 12px 0; border-bottom:1px solid #e6e6e6;",
tags$b(iso_metric_row_label(df, i)),
tags$div(
style = "display:flex; gap:12px; align-items:flex-end; flex-wrap:wrap; margin-top:5px;",
tags$div(
tags$div(
style = "font-size:25px; line-height:1.05; font-weight:700; color:#28543b;",
paste0(fmt_count(total_raw), " species")
),
tags$small("Total unique GBIF species in this isochrone")
),
tags$div(
style = "padding-left:12px; border-left:3px solid #b9dfc8;",
tags$div(
style = "font-size:20px; line-height:1.05; font-weight:700;",
format_pct(total_pct)
),
tags$small("Citywide rank for the same mode × time")
)
),
tags$div(
style = "display:grid; grid-template-columns:repeat(3,minmax(0,1fr)); gap:6px; margin-top:9px;",
tags$div(
style = "background:#f6faf7; border:1px solid #e0ebe4; border-radius:6px; padding:6px 8px;",
tags$b("Birds"), tags$br(),
tags$small(paste0(fmt_count(bird_raw), " species · ", format_pct(bird_pct)))
),
tags$div(
style = "background:#f6faf7; border:1px solid #e0ebe4; border-radius:6px; padding:6px 8px;",
tags$b("Mammals"), tags$br(),
tags$small(paste0(fmt_count(mammal_raw), " species · ", format_pct(mammal_pct)))
),
tags$div(
style = "background:#f6faf7; border:1px solid #e0ebe4; border-radius:6px; padding:6px 8px;",
tags$b("Plants"), tags$br(),
tags$small(paste0(fmt_count(plant_raw), " species · ", format_pct(plant_pct))),
if (is.finite(plant_known) && plant_known > 0) {
tags$small(
style = "display:block;",
title = paste0(
"Of ", fmt_count(plant_known), " plant species with an iNaturalist establishment status, ",
fmt_count(plant_native), " are native or endemic. ",
fmt_count(plant_raw - plant_known), " species without a status are excluded."
),
paste0(round(100 * plant_native / plant_known), "% native")
)
}
)
),
if (is.finite(total_pct)) {
tags$div(
style = paste0(
"background:#f0f7f3; border-left:4px solid #5d8d70; ",
"border-radius:6px; padding:7px 9px; margin-top:8px; font-size:12px;"
),
tags$b("Reporting sentence: "),
paste0(
iso_metric_row_label(df, i),
" ranks at the ",
format_pct(total_pct),
" for accessible total species richness among comparable SF origins with the same mode and travel time."
)
)
},
if (is.finite(n_ref)) {
tags$small(
style = "display:block; color:#66766e; margin-top:6px;",
paste0("Percentile reference uses ", scales::comma(n_ref), " finite comparable SF origins.")
)
}
)
})
wellPanel(
tags$div(
style = "max-height:390px; overflow-y:auto;",
cards
),
tags$small(
style = "display:block; color:#666; margin-top:7px;",
"Raw species counts and citywide percentiles are shown separately. Each result is compared only with precomputed SF origins having the same transportation mode and travel time. Isochrones are never pooled."
)
)
})
output$transitScoreBox <- renderUI({
df <- base_socio_data()
if (is.null(df) || nrow(df) == 0) return(NULL)
cards <- lapply(seq_len(nrow(df)), function(i) {
raw <- if ("Transit_Access_Score" %in% names(df)) {
suppressWarnings(as.numeric(df$Transit_Access_Score[[i]]))
} else NA_real_
pct <- if ("pctile_Transit_Access_Score" %in% names(df)) {
suppressWarnings(as.numeric(df$pctile_Transit_Access_Score[[i]]))
} else NA_real_
n_ref <- if ("nref_Transit_Access_Score" %in% names(df)) df$nref_Transit_Access_Score[[i]] else NA_integer_
tags$div(
style = "padding:8px 0; border-bottom:1px solid #e6e6e6;",
tags$b(iso_metric_row_label(df, i)),
tags$div(
style = "font-size:21px; line-height:1.15; margin-top:2px;",
if (is.finite(raw)) paste0(round(raw, 2), " stops/km²") else "N/A"
),
tags$small(
"Citywide isochrone percentile: ", format_pct(pct),
if (is.finite(n_ref)) paste0(" · n=", scales::comma(n_ref)) else ""
)
)
})
wellPanel(
tags$div(style = "max-height:310px; overflow-y:auto;", cards),
tags$small(
style = "display:block; color:#666; margin-top:7px;",
"Raw transit values are retained. A percentile is shown only when a comparable same-mode × same-time precomputed reference exists."
)
)
})
output$dataCoverageBox <- renderUI({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) return(NULL)
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
if (length(x) == 0 || !is.finite(x[[1]])) NA_real_ else x[[1]]
}
cards <- lapply(seq_len(nrow(df)), function(i) {
records <- if ("GBIF_Records" %in% names(df)) safe_num(df$GBIF_Records[[i]]) else NA_real_
density <- if ("SamplingDensity_km2" %in% names(df)) safe_num(df$SamplingDensity_km2[[i]]) else NA_real_
pct <- if ("pctile_SamplingDensity_km2" %in% names(df)) safe_num(df$pctile_SamplingDensity_km2[[i]]) else NA_real_
n_ref <- if ("nref_SamplingDensity_km2" %in% names(df)) safe_num(df$nref_SamplingDensity_km2[[i]]) else NA_real_
interpretation <- if (!is.finite(pct)) {
"No comparable observation-density benchmark is available."
} else if (pct >= 75) {
"Relatively well sampled compared with matched SF isochrones."
} else if (pct >= 25) {
"Mid-range sampling intensity compared with matched SF isochrones."
} else {
"Relatively lightly sampled compared with matched SF isochrones."
}
tags$div(
style = paste0(
"border-left:5px solid ", BAI_GROUP_COLORS[["biodiversity"]],
"; background:#fffaf3; border-radius:8px; padding:9px 11px; ",
"margin-bottom:8px;"
),
tags$b(iso_metric_row_label(df, i)),
tags$div(
style = "display:grid; grid-template-columns:repeat(3,minmax(0,1fr)); gap:8px; margin-top:7px;",
tags$div(
tags$small(tags$b("GBIF records")),
tags$div(
style = "font-size:20px; font-weight:700;",
if (is.finite(records)) scales::comma(round(records)) else "N/A"
)
),
tags$div(
tags$small(tags$b("Sampling density")),
tags$div(
style = "font-size:20px; font-weight:700;",
if (is.finite(density)) paste0(round(density, 1), " records/km²") else "N/A"
)
),
tags$div(
tags$small(tags$b("Citywide sampling-density rank")),
tags$div(
style = "font-size:20px; font-weight:700;",
format_pct(pct)
),
if (is.finite(n_ref)) tags$small(paste0("n=", scales::comma(round(n_ref)))) else NULL
)
),
tags$div(
style = "margin-top:7px; font-size:12px; color:#5d5245;",
tags$b("Interpretation: "),
interpretation
)
)
})
tagList(
cards,
tags$small(
style = "display:block; color:#66766e; margin-top:5px;",
"This is an observation-coverage indicator, not statistical confidence and not proof that true species richness is completely sampled. The descriptive low/mid/high wording is based on the matched sampling-density percentile."
)
)
})
output$baiDimensionDetailsBox <- renderUI({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) return(NULL)
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
if (length(x) == 0 || !is.finite(x[[1]])) NA_real_ else x[[1]]
}
spec <- list(
list(group = "ACCESS", color = BAI_GROUP_COLORS[["access"]],
label = "Transit access", raw = "Transit_Access_Score",
pct = "pctile_Transit_Access_Score", nref = "nref_Transit_Access_Score",
fmt = function(x) if (is.finite(x)) paste0(round(x, 2), " stops/km²") else "N/A"),
list(group = "ACCESS", color = BAI_GROUP_COLORS[["access"]],
label = "Muni route access", raw = "Unique_Muni_Routes",
pct = "pctile_Unique_Muni_Routes", nref = "nref_Unique_Muni_Routes",
fmt = function(x) if (is.finite(x)) paste0(round(x), " routes") else "N/A"),
list(group = "BIODIVERSITY EVIDENCE", color = BAI_GROUP_COLORS[["biodiversity"]],
label = "Total species richness", raw = "GBIF_Species",
pct = "pctile_GBIF_Species", nref = "nref_GBIF_Species",
fmt = function(x) if (is.finite(x)) paste0(scales::comma(round(x)), " species") else "N/A"),
list(group = "BIODIVERSITY EVIDENCE", color = BAI_GROUP_COLORS[["biodiversity"]],
label = "GBIF sampling density", raw = "SamplingDensity_km2",
pct = "pctile_SamplingDensity_km2", nref = "nref_SamplingDensity_km2",
fmt = function(x) if (is.finite(x)) paste0(round(x, 1), " records/km²") else "N/A"),
list(group = "GREEN ENVIRONMENT", color = BAI_GROUP_COLORS[["green_environment"]],
label = "Vegetation NDVI", raw = "MeanNDVI",
pct = "pctile_MeanNDVI", nref = "nref_MeanNDVI",
fmt = function(x) if (is.finite(x)) format(round(x, 3), nsmall = 3) else "N/A"),
list(group = "GREEN ENVIRONMENT", color = BAI_GROUP_COLORS[["green_environment"]],
label = "Greenspace cover", raw = "Greenspace_percent",
pct = "pctile_Greenspace_percent", nref = "nref_Greenspace_percent",
fmt = function(x) if (is.finite(x)) paste0(round(x, 1), "%") else "N/A"),
list(group = "EQUITY CONTEXT", color = BAI_GROUP_COLORS[["equity"]],
label = "SF EJ context", raw = "SF_EJ_Score",
pct = "pctile_SF_EJ_Score", nref = "nref_SF_EJ_Score",
fmt = function(x) if (is.finite(x)) paste0("raw score ", round(x, 1)) else "N/A")
)
iso_sections <- lapply(seq_len(nrow(df)), function(i) {
metric_cards <- lapply(spec, function(s) {
raw <- if (s$raw %in% names(df)) safe_num(df[[s$raw]][[i]]) else NA_real_
pct <- if (s$pct %in% names(df)) safe_num(df[[s$pct]][[i]]) else NA_real_
nref <- if (s$nref %in% names(df)) safe_num(df[[s$nref]][[i]]) else NA_real_
tags$div(
style = paste0(
"border-top:4px solid ", s$color,
"; background:white; border-radius:8px; padding:8px 9px; ",
"border-left:1px solid #e0e6e2; border-right:1px solid #e0e6e2; ",
"border-bottom:1px solid #e0e6e2;"
),
tags$div(
style = paste0("font-size:11px; font-weight:800; color:", s$color, "; letter-spacing:.03em;"),
s$group
),
tags$b(s$label),
tags$div(
style = "font-size:18px; font-weight:700; margin-top:3px;",
s$fmt(raw)
),
tags$small(
"Citywide rank: ", format_pct(pct),
if (is.finite(nref)) paste0(" · n=", scales::comma(round(nref))) else ""
),
if (identical(s$raw, "SF_EJ_Score")) {
tags$small(
style = "display:block; color:#6b5a78; margin-top:2px;",
"Percentile is inverted once: higher rank = lower EJ burden."
)
} else NULL
)
})
tags$div(
style = "margin-bottom:14px;",
tags$div(
style = "font-size:16px; font-weight:700; margin-bottom:7px; color:#294337;",
iso_metric_row_label(df, i)
),
tags$div(
style = "display:grid; grid-template-columns:repeat(4,minmax(0,1fr)); gap:8px;",
metric_cards
)
)
})
tagList(
iso_sections,
tags$small(
style = "display:block; color:#66766e;",
"Every raw value is paired with its independently calculated citywide percentile from the same transportation mode × travel-time reference."
)
)
})
output$biodiversityAccessIndexBox <- renderUI({
df <- baseline_biodiversity_access_index()
if (is.null(df) || nrow(df) == 0) return(NULL)
cards <- lapply(seq_len(nrow(df)), function(i) {
bai <- if ("BAI" %in% names(df)) suppressWarnings(as.numeric(df$BAI[[i]])) else NA_real_
bai_pct <- if ("pctile_BAI" %in% names(df)) suppressWarnings(as.numeric(df$pctile_BAI[[i]])) else NA_real_
n_bai_ref <- if ("nref_BAI" %in% names(df)) suppressWarnings(as.numeric(df$nref_BAI[[i]])) else NA_real_
n_comp <- if ("BAI_n_components" %in% names(df)) df$BAI_n_components[[i]] else NA_integer_
tags$div(
style = "padding:9px 0; border-bottom:1px solid #e6e6e6;",
tags$b(iso_metric_row_label(df, i)),
tags$div(
style = "display:grid; grid-template-columns:1fr 1fr; gap:9px; margin-top:5px;",
tags$div(
style = "background:#fff9ee; border-radius:7px; padding:7px 9px;",
tags$small(tags$b("BAI score")),
tags$div(
style = "font-size:24px; line-height:1.15; font-weight:700;",
if (is.finite(bai)) paste0(round(100 * bai, 1), "/100") else "N/A"
),
tags$small("Mean of the seven percentile-standardized dimensions")
),
tags$div(
style = "background:#f3f7fb; border-radius:7px; padding:7px 9px;",
tags$small(tags$b("BAI citywide rank")),
tags$div(
style = "font-size:21px; line-height:1.15; font-weight:700;",
format_pct(bai_pct)
),
tags$small(
if (is.finite(n_bai_ref)) {
paste0("Compared with ", scales::comma(round(n_bai_ref)), " complete seven-axis reference isochrones")
} else {
"No complete matching BAI reference distribution"
}
)
)
),
tags$small(
style = "display:block; margin-top:6px;",
if (is.finite(n_comp)) {
paste0(n_comp, " of 7 same-mode × same-time percentile dimensions available")
} else {
"No comparable precomputed reference dimensions"
}
)
)
})
wellPanel(
tags$div(style = "max-height:380px; overflow-y:auto;", cards),
tags$small(
style = "display:block; color:#666; margin-top:7px;",
"BAI score and BAI percentile are different quantities. The score is the seven-axis mean; the citywide rank compares that score with complete seven-axis BAIs from the exact same mode × travel-time reference. Each user isochrone is ranked independently."
)
)
})
output$greenspaceScenarioSummary <- renderUI({
proposal <- proposed_greenspace()
if (is.null(proposal) || nrow(proposal) == 0) {
return(tags$small(
style = "color:#666;",
"No proposed habitat or corridor drawn."
))
}
safe_num <- function(x) {
x <- suppressWarnings(as.numeric(x))
x <- x[is.finite(x)]
if (length(x) == 0) NA_real_ else x[[1]]
}
gross_m2 <- tryCatch({
footprint <- proposed_habitat_3857()
if (is.null(footprint) || nrow(footprint) == 0) NA_real_ else
sum(as.numeric(st_area(footprint)), na.rm = TRUE)
}, error = function(e) NA_real_)
proposal_net <- net_proposed_greenspace_3857()
net_m2 <- if (is.null(proposal_net) || nrow(proposal_net) == 0) {
0
} else {
sum(as.numeric(st_area(proposal_net)), na.rm = TRUE)
}
selected_metrics <- corridor_selected_isochrone_metrics()
cover_line <- NULL
bai_line <- NULL
if (!is.null(selected_metrics)) {
base_cover <- safe_num(selected_metrics$baseline_raw$Greenspace_percent)
scenario_cover <- safe_num(selected_metrics$scenario_raw$Greenspace_percent)
base_cover_pct <- safe_num(selected_metrics$baseline_bai$pctile_Greenspace_percent)
scenario_cover_pct <- safe_num(selected_metrics$scenario_bai$pctile_Greenspace_percent)
if (is.finite(base_cover) && is.finite(scenario_cover)) {
cover_line <- tags$p(
style = "margin:4px 0 0 0;",
tags$b(paste0(selected_metrics$label, " greenspace cover: ")),
paste0(
round(base_cover, 1), "% (", format_pct(base_cover_pct), ") → ",
round(scenario_cover, 1), "% (", format_pct(scenario_cover_pct), ")"
)
)
}
base_bai_value <- 100 * safe_num(selected_metrics$baseline_bai$BAI)
scenario_bai_value <- 100 * safe_num(selected_metrics$scenario_bai$BAI)
base_bai_pct <- safe_num(selected_metrics$baseline_bai$pctile_BAI)
scenario_bai_pct <- safe_num(selected_metrics$scenario_bai$pctile_BAI)
if (is.finite(base_bai_value) && is.finite(scenario_bai_value)) {
bai_line <- tags$p(
style = "margin:2px 0 0 0;",
tags$b("Selected-isochrone BAI: "),
paste0(
round(base_bai_value, 1), "/100 (", format_pct(base_bai_pct), ") → ",
round(scenario_bai_value, 1), "/100 (", format_pct(scenario_bai_pct), ")"
)
)
}
}
tagList(
tags$p(
style = "margin:6px 0 0 0;",
tags$b("Your proposed habitat area: "),
if (is.finite(gross_m2)) paste0(round(gross_m2 / 10000, 2), " ha") else "N/A"
),
tags$p(
style = "margin:2px 0 0 0;",
tags$b("New area not already mapped as greenspace: "),
paste0(round(net_m2 / 10000, 2), " ha")
),
tags$small(
style = "display:block; color:#555; margin:4px 0 6px 0;",
"The blue area is what the app treats as the intervention. A drawn line is widened using the selected corridor planting width; a drawn polygon is used directly."
),
cover_line,
bai_line,
tags$small(
style = "color:#666;",
"Scenario changes greenspace cover and BAI only; it does not predict future NDVI or biodiversity."
)
)
})
output$corridorConnectivitySummary <- renderUI({
c <- corridor_connectivity()
if (is.null(c) || !isTRUE(c$available)) {
return(tags$small(
style = "color:#666;",
if (!is.null(c$message)) c$message else "Connectivity estimate unavailable."
))
}
fmt_num <- function(x, digits = 0) {
if (is.null(x) || !is.finite(x)) "N/A" else scales::comma(round(x, digits))
}
fmt_ha <- function(x) {
if (is.null(x) || !is.finite(x)) "N/A" else paste0(round(x, 2), " ha")
}
interpretation <- dplyr::case_when(
c$classification == "Bridge" ~ paste0(
"This proposal brings ", c$linked_patches,
" existing mapped greenspaces from ", c$baseline_components,
" separate baseline networks into one potential corridor network."
),
c$classification == "Network reinforcement" ~ paste0(
"This proposal adds habitat around ", c$linked_patches,
" existing patches that are already structurally connected under the selected threshold."
),
c$classification == "Patch expansion" ~
"This proposal directly overlaps and enlarges one existing mapped greenspace.",
c$classification == "Stepping-stone" ~
"This proposal creates a potential stepping stone near an existing mapped greenspace, but it does not join separate baseline networks.",
TRUE ~ paste0(
"No existing mapped greenspace lies within the selected ", c$gap_m,
" m connection threshold. The intervention is currently classified as isolated."
)
)
tagList(
tags$div(
style = "background:#e3f2fd; border-left:5px solid #1976d2; padding:12px 14px; margin-bottom:12px;",
tags$h3(style = "margin:0 0 4px 0;", c$classification),
tags$p(style = "margin:0; font-size:15px;", interpretation)
),
fluidRow(
column(
6,
wellPanel(
tags$h3(style = "margin-top:0;", fmt_num(c$linked_patches)),
tags$b("Existing greenspaces reached"),
tags$br(),
tags$small("Orange and numbered P1, P2, … on the map")
)
),
column(
6,
wellPanel(
tags$h3(style = "margin-top:0;", paste0(c$baseline_components, " → ", c$scenario_components)),
tags$b("Habitat networks: baseline → scenario"),
tags$br(),
tags$small(paste0("Using a ", c$gap_m, " m connection rule"))
)
),
column(
6,
wellPanel(
tags$h3(style = "margin-top:0;", fmt_ha(c$scenario_connected_area_ha)),
tags$b("Potential connected habitat area"),
tags$br(),
tags$small(paste0(fmt_ha(c$existing_linked_area_ha), " existing + ", fmt_ha(c$novel_area_ha), " novel"))
)
),
column(
6,
wellPanel(
tags$h3(
style = "margin-top:0;",
if (is.finite(c$maximum_linked_gap_m)) paste0(fmt_num(c$maximum_linked_gap_m), " m") else "N/A"
),
tags$b("Largest proposal-to-patch gap"),
tags$br(),
tags$small("Dashed orange lines show these measured gaps")
)
)
),
if (is.finite(c$corridor_length_m) && c$corridor_length_m > 0) {
tags$p(
style = "margin:8px 0 0 0; color:#555;",
paste0(
"Drawn corridor length: ", fmt_num(c$corridor_length_m),
" m; planted width: ", input$corridor_width_m, " m."
)
)
},
tags$small(
style = "color:#666; display:block; margin-top:6px;",
paste0(
"Coverage note: the analysis searches all ",
scales::comma(osm_greenspace_feature_count),
" mapped OSM greenspace polygons loaded for San Francisco, but OSM may not represent every real or ecologically suitable habitat. This result describes structural proximity only; it does not model vegetation quality, roads, mortality risk, or species-specific movement."
)
)
)
})
output$linkedHabitatTable <- renderDT({
c <- corridor_connectivity()
if (is.null(c) || !isTRUE(c$available) ||
is.null(c$linked_sf) || nrow(c$linked_sf) == 0) {
return(DT::datatable(
data.frame(Message = "No existing mapped greenspace is affected under the selected connection rule."),
rownames = FALSE,
options = list(dom = "t")
))
}
linked_table <- c$linked_sf |>
st_drop_geometry() |>
transmute(
ID = display_id,
`Existing greenspace` = display_name,
Relationship = relationship,
`Distance to proposal (m)` = round(distance_to_proposal_m),
`Existing area (ha)` = round(patch_area_ha, 2),
`Baseline network` = baseline_component
)
DT::datatable(
linked_table,
rownames = FALSE,
escape = TRUE,
options = list(
pageLength = 7,
lengthChange = FALSE,
searching = FALSE,
info = FALSE,
scrollX = TRUE,
autoWidth = TRUE
)
)
})
# ---------------------------------------------------------------------------
# Corridor scenario exports
# ---------------------------------------------------------------------------
corridor_scenario_name <- reactive({
raw_name <- input$corridor_scenario_name
nm <- if (is.null(raw_name)) "" else trimws(as.character(raw_name))
if (!nzchar(nm)) "Green corridor scenario" else nm
})
safe_export_stem <- function(x) {
x <- iconv(x, to = "ASCII//TRANSLIT", sub = "")
x <- tolower(gsub("[^A-Za-z0-9]+", "_", x))
x <- gsub("^_+|_+$", "", x)
if (!nzchar(x)) "green_corridor_scenario" else substr(x, 1, 80)
}
# Build a mixed-geometry GeoJSON package containing the analyzed intervention,
# novel habitat, reached existing greenspaces, measured gap lines, the optional
# population-estimate area, and the transferred Explorer location when present.
scenario_export_sf <- reactive({
footprint <- proposed_habitat_3857()
if (is.null(footprint) || nrow(footprint) == 0) return(NULL)
scenario_name <- corridor_scenario_name()
generated_at <- format(Sys.time(), "%Y-%m-%d %H:%M:%S %Z")
gap_rule <- suppressWarnings(as.numeric(input$connectivity_gap_m))
width_m <- suppressWarnings(as.numeric(input$corridor_width_m))
connectivity <- corridor_connectivity()
beneficiaries <- scenario_beneficiaries()
active_iso_info <- corridor_active_iso_info()
active_iso_label <- if (is.null(active_iso_info)) NA_character_ else active_iso_info$label
connectivity_class <- if (!is.null(connectivity) && isTRUE(connectivity$available)) connectivity$classification else NA_character_
baseline_network_count <- if (!is.null(connectivity) && isTRUE(connectivity$available)) connectivity$baseline_components else NA_integer_
scenario_network_count <- if (!is.null(connectivity) && isTRUE(connectivity$available)) connectivity$scenario_components else NA_integer_
linked_patch_count <- if (!is.null(connectivity) && isTRUE(connectivity$available)) connectivity$linked_patches else NA_integer_
potential_population <- if (!is.null(beneficiaries) && isTRUE(beneficiaries$available)) beneficiaries$total_population else NA_real_
ej_population <- if (!is.null(beneficiaries) && isTRUE(beneficiaries$available)) beneficiaries$ej_population else NA_real_
make_layer <- function(x, feature_type, feature_id = NULL,
feature_name = NULL, relationship = NULL,
distance_m = NULL, baseline_network = NULL,
walk_minutes = NULL) {
if (is.null(x) || !inherits(x, "sf") || nrow(x) == 0) return(NULL)
x <- tryCatch(
st_zm(x, drop = TRUE, what = "ZM"),
error = function(e) x
)
x <- suppressWarnings(st_transform(x, 4326))
n <- nrow(x)
recycle <- function(value, default = NA) {
if (is.null(value)) return(rep(default, n))
rep(value, length.out = n)
}
st_sf(
scenario_name = rep(scenario_name, n),
feature_type = rep(feature_type, n),
feature_id = as.character(recycle(feature_id, NA_character_)),
feature_name = as.character(recycle(feature_name, NA_character_)),
relationship = as.character(recycle(relationship, NA_character_)),
distance_m = suppressWarnings(as.numeric(recycle(distance_m, NA_real_))),
baseline_network = suppressWarnings(as.integer(recycle(baseline_network, NA_integer_))),
connection_rule_m = rep(gap_rule, n),
selected_explorer_isochrone = rep(active_iso_label, n),
assumed_planted_width_m = rep(width_m, n),
population_walk_minutes = suppressWarnings(as.numeric(recycle(walk_minutes, NA_real_))),
connectivity_classification = rep(connectivity_class, n),
baseline_network_count = rep(baseline_network_count, n),
scenario_network_count = rep(scenario_network_count, n),
linked_patch_count = rep(linked_patch_count, n),
potentially_reached_population = rep(potential_population, n),
ej_population = rep(ej_population, n),
generated_at = rep(generated_at, n),
geometry = st_geometry(x),
crs = 4326
)
}
layers <- list(
make_layer(
footprint,
feature_type = "proposed_habitat_area",
feature_id = "proposal",
feature_name = scenario_name,
relationship = "Analyzed footprint"
)
)
novel <- net_proposed_greenspace_3857()
if (!is.null(novel) && nrow(novel) > 0) {
layers[[length(layers) + 1]] <- make_layer(
novel,
feature_type = "novel_habitat_area",
feature_id = "novel_area",
feature_name = paste0(scenario_name, " — area not already mapped as greenspace"),
relationship = "Excludes overlap with existing mapped OSM greenspace"
)
}
if (!is.null(connectivity) && isTRUE(connectivity$available)) {
linked <- connectivity$linked_sf
if (!is.null(linked) && nrow(linked) > 0) {
layers[[length(layers) + 1]] <- make_layer(
linked,
feature_type = "existing_greenspace_reached",
feature_id = linked$display_id,
feature_name = linked$display_name,
relationship = linked$relationship,
distance_m = linked$distance_to_proposal_m,
baseline_network = linked$baseline_component
)
}
links <- connectivity$links_sf
if (!is.null(links) && nrow(links) > 0) {
layers[[length(layers) + 1]] <- make_layer(
links,
feature_type = "measured_connection_gap",
feature_id = links$display_id,
feature_name = links$patch_name,
relationship = ifelse(
links$distance_m <= 0.01,
"Direct overlap",
paste0(round(links$distance_m), " m measured gap")
),
distance_m = links$distance_m
)
}
}
if (isTRUE(input$show_beneficiary_catchment)) {
catchment <- scenario_beneficiary_catchment_3857()
if (!is.null(catchment) && nrow(catchment) > 0) {
layers[[length(layers) + 1]] <- make_layer(
catchment,
feature_type = "population_estimate_area",
feature_id = "population_area",
feature_name = paste0(catchment$walk_minutes[[1]], "-minute approximate population-estimate area"),
relationship = "Straight-line proximity screen; not a routed walkshed",
walk_minutes = catchment$walk_minutes
)
}
}
ref_pt <- corridor_reference_point()
if (!is.null(ref_pt) && length(ref_pt) >= 2) {
ref_sf <- st_as_sf(
data.frame(
lon = unname(ref_pt[["lon"]]),
lat = unname(ref_pt[["lat"]])
),
coords = c("lon", "lat"),
crs = 4326
)
layers[[length(layers) + 1]] <- make_layer(
ref_sf,
feature_type = "explorer_reference_location",
feature_id = "explorer_location",
feature_name = "Location transferred from Isochrone Explorer",
relationship = "Context point only"
)
}
layers <- Filter(function(x) !is.null(x) && nrow(x) > 0, layers)
if (length(layers) == 0) return(NULL)
do.call(rbind, layers)
})
html_value <- function(x) {
htmltools::htmlEscape(as.character(x), attribute = FALSE)
}
report_metric <- function(label, value, detail = NULL) {
paste0(
'
', html_value(label), '
',
'
', html_value(value), '
',
if (!is.null(detail) && nzchar(detail)) paste0('