Skip to content

Instantly share code, notes, and snippets.

@szechno

szechno/Filtering Spatial Data by Leaflet bbox_v0.23_mapgl_variant.R

Created February 20, 2026 20:55
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save szechno/a46ff8b60252eeb5aaf4bc95810f4f4e to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save szechno/a46ff8b60252eeb5aaf4bc95810f4f4e to your computer and use it in GitHub Desktop.
Download ZIP
Raw
Filtering Spatial Data by Leaflet bbox_v0.23_mapgl_variant.R
library(shiny)
library(shinyWidgets)
library(bslib)
library(mapgl)
library(sf)
library(stringr)
library(dplyr)
library(DBI)
library(RSQLite)
library(callr)
# library(bsicons) ## https://icons.getbootstrap.com
# !! need to include attribution: <a href="https://www.flaticon.com/free-icons/adress" title="adress icons">Adress icons created by Boris farias - Flaticon</a>
# West_Sussex_TSS_2025
# https://mackaszechno.shinyapps.io/West_Sussex_TSS_maplibre_2025/
# West_Sussex_TSS_maplibre_2025
# variables ----
## geodata ----
geodata <- "./shapefile/west sussex_tss_review_20250714a_esuid.gpkg"
# IMPORTANT 2 RECORDS SET TO tss I AND C FOR TESTING... CHANGE BACK AS REQUIRED
map_start <- c(-0.404549247616387, 50.9365654134795)
initial_zoom <- 10
dft_color <- c("coral", "#DC143C", "darkred")
cj_color <- c("#bc9958")
bus_color <- c("#658e3b")
train_color <- c("#6b717a", "#707f94")
school_color <- c("#e2e218")
emergency_color <- c("#5959f9")
medical_color <- c("#78c5d3")
retail_color <- c("#825e76")
commerce_color <- c("#826a5e")
leisure_color <- c("#bed378")
grid_color <- c("#75b7a0")
border_color <- c("#758cb7")
NH_color <- c("pink")
esusline_color <- c("#c997b8")
lookup_class <- tibble(
column = rep("CLASS", 7),
classification = c("A", "B", "C", "D", "P", "Q", ""),
colours = c("#22A884", "#2A788E", "#414487", "#440154", "#7AD151", "#f06060", "#ff02ff"),
lwd = c( 5, 4, 3, 2, 1, 1, 1)
)
lookup_tss <- tibble(
column = rep("TSS", 5),
classification = c("C", "D", "H", "I", ""),
colours = c("#1f78b4", "#33a02c", "#e31a1c", "#ff7f00", "#f0f0f0"),
lwd = rep(3, 5)
)
# https://mastering-shiny.org/action-transfer.html#downloading-reports
# to work on shinyapps.io
## report_path ----
report_path <- tempfile(fileext = ".Rmd")
file.copy("./rmd/test__wscc_tss_review_v6a1_tss.Rmd",
report_path,
overwrite = TRUE)
## set colour squares for layer sidecard ----
dft_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
dft_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
dft_color[2],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
dft_color[3],";\"></div>"))
cj_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
cj_color[1],";\"></div>"))
transport_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
bus_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
train_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
train_color[2],";\"></div>"))
school_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
school_color[1],";\"></div>"))
emergency_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
emergency_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
medical_color[1],";\"></div>"))
landuse_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
retail_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
commerce_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
leisure_color[1],";\"></div>"))
boundary_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
grid_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
border_color[1],";\"></div>",
"<div style=\"width: 10px; height: 10px; background-color: ",
NH_color[1],";\"></div>"))
esusline_icons <- span(HTML("<div style=\"width: 10px; height: 10px; background-color: ",
esusline_color[1],";\"></div>"))
#  preload functions ----
load_data <- function(layer, bb = NULL, query = NA){
# https://r-spatial.github.io/sf/reference/st_read.html
if(is.null(bb)){
st_read(geodata,
layer = layer,
quiet = TRUE) |> st_transform(crs = 4326)
} else {
bb <- st_bbox(c(xmin = bb$xmin,
xmax = bb$xmax,
ymax = bb$ymax,
ymin = bb$ymin),
crs = st_crs(4326)) |>
st_transform(crs = 27700)
st_read(geodata,
layer = layer,
wkt_filter = st_as_text(
# st_as_sfc(bb |> st_transform(crs = 27700))
st_as_sfc(bb)
),
query = query,
quiet = TRUE) |> st_transform(crs = 4326)
}
}
# https://mastering-shiny.org/action-transfer.html#downloading-reports
get_params <- function(type = "TSS",
year = "2025",
filename = "unknown.html"){
has_old_tss <- FALSE
old_tss <- NULL
# version <- type # version6 single-layer version" type = TSS or LR?
page_description <- paste0(year, " ", type, " Review") #"2025 TSS Review"
page_council <- "West Sussex County Council"
page_council_image <- "https://github.com/szechno/wscc_shinyapp/blob/main/wscc.png?raw=true"
page_image_styling <- "width: 100px; height: 100px; float: left;"
# page_image_styling <- "width: 475px; height: 96.3px; float: left;"
# data_path <- paste0(home, stringr::str_sub(geodata, start = 3L, end = -1L))
checklist <- "TSS Checklist"
border <- "TSS Boundary"
has_old_tss <- FALSE
old_tss <- ""
report_type <- type
# input_file <- "https://github.com/szechno/wscc_shinyapp/blob/main/test__wscc_tss_review_v6a_tss.Rmd?raw=true"
# output_file <- paste0(home, type, "_review_", version, "_",
# Sys.Date(), "_",
# str_replace_all(format(Sys.time(), "%X"), ":", ""),
# ".html") #Sys.time
params_list <- list(version = type,
page_description = page_description,
page_council = page_council,
page_council_image = page_council_image,
page_image_styling = page_image_styling,
checklist = load_data(layer = checklist) |> filter(TSS %in% c("D", "I", "C", "H")), # remove when sufficient space or perform calcs shiny side
border = load_data(layer = border)
)
if(type == "TSS"){
params_list <- c(params_list,
list(
has_old_tss = has_old_tss,
old_tss = old_tss))
}
return(params_list)
}
render_report <- function(input, output, params) {
rmarkdown::render(input,
output_file = output,
params = params,
envir = new.env(parent = globalenv())
)
}
add_polygons <- function(m,
data,
group,
...){
m |> add_fill_layer(
source = data,
id = group,
...
)
}
add_lines <- function(m,
data,
group,
...){
m |> add_line_layer(
source = data,
id = group,
...
)
}
add_points <- function(m,
data,
group,
...){
m |> add_circle_layer(
source = data,
id = group,
...
)
}
convert_true_false <- function(x){
if(x){
x <- 1
} else {
x <- 0
}
}
## reuseable control function ----
# https://mastering-shiny.org/scaling-functions.html
# ... maybe need a list where multiple checkboxes???
# create_accordion_panel <- function(title, chkbox_id, layer_name, val = TRUE){
# accordion_panel(
# title,
# checkboxInput(chkbox_id, layer_name, value = val),
# )
# }
# ui -----
ui <-
page_sidebar(
tags$head(
tags$link(
rel="shortcut icon",
href="https://github.com/szechno/wscc_shinyapp/blob/main/favicon.ico?raw=true"
)
),
theme = bs_theme(bootswatch = "simplex",
"bslib_spacer" = "0.1rem",
# fg = "rgb(158, 79, 79)",
# fg = "#555555",
# bg = "white",
primary = "#555566",
base_font = font_google("Inter"),
code_font = font_google("JetBrains Mono")),
# theme = "main1_v6a.css",
title = "West Sussex TSS Shiny prototype 2025",
window_title = "West Sussex TSS 2025",
##  main sidebar ----
sidebar = sidebar(
position = "left",
title = "Layers and options",
# bg = "white",
open = TRUE,
# gap = 0,
# padding = 0, # use elsewhere in menu
accordion(
open = FALSE,
accordion_panel(
title = "map options",
radioGroupButtons(
"toggle_roads", "Toggle roads", choices = c("All roads", "TSS potential", "TSS actual"),
size = "sm"
),
# "colours"
sliderInput("map_refresh", "Map refresh rate (ms)", min = 100, max = 3000,
step = 50, value = 100),
### select basemaps ----
selectInput("basemap",
"Change basemap",
choices = c("voyager", "positron", "dark-matter",
"voyager-no-labels", "positron-no-labels",
"dark-matter-no-labels",
"liberty", "osm-bright", "fiord"),
selected = "voyager")
),
accordion_panel(
title = "layers",
radioGroupButtons(
"toggle_layers", "Toggle all layers", c("Custom", "On", "Off"),
size = "sm"
),
p(HTML("If road network is not selectable, toggle TSS Checklist OFF and ON."),
style = "font-size:0.7em;"),
## layers accordion ----
accordion_panel(
"TSS Checklist",
checkboxInput("chkbox_TSSChecklist", "TSS Checklist", value = TRUE)
),
accordion_panel(
"DfT Counts",
icon = dft_icons,
checkboxInput("chkbox_DfTCounts", "DfT Counts", value = TRUE)
),
accordion_panel(
"Critical junctions",
icon = cj_icons,
checkboxInput("chkbox_GEOCJ_TrafficSignals", "GEO CJ Traffic Signals", value = FALSE),
checkboxInput("chkbox_GEOCJ_Roundabouts", "GEO CJ Roundabouts", value = FALSE)
),
accordion_panel(
"Transport",
icon = transport_icons,
checkboxInput("chkbox_OpenBusBusStops", "OpenBus Bus Stops", value = FALSE),
checkboxInput("chkbox_OpenBusroutes", "OpenBus routes", value = FALSE),
checkboxInput("chkbox_GEOTransport_Bus_Stations", "GEO Transport Bus Stations", value = FALSE),
checkboxInput("chkbox_GEOTransport_Train_Stations", "GEO Transport Train Stations", value = FALSE),
checkboxInput("chkbox_ORRTransport_Train_Station_Passengers", "ORR Transport Train Station Passengers", value = FALSE)
),
accordion_panel(
"Education",
icon = school_icons,
checkboxInput("chkbox_GEOEducation", "GEO Education", value = TRUE),
checkboxInput("chkbox_MHCLGEducation_Capacity", "MHCLG Education_Capacity", value = FALSE)
),
accordion_panel(
"Emergency",
icon = emergency_icons,
checkboxInput("chkbox_GEOMedical", "GEO Medical", value = FALSE),
checkboxInput("chkbox_GEOBlueLights", "GEO Blue Lights", value = FALSE),
),
accordion_panel(
"Land use",
icon = landuse_icons,
checkboxInput("chkbox_GEORetail", "GEO Retail", value = FALSE),
checkboxInput("chkbox_GEOCommercialIndustrial", "GEO Commercial-Industrial", value = TRUE),
checkboxInput("chkbox_GEOLeisure", "GEO Leisure", value = FALSE)
),
accordion_panel(
"Boundary",
icon = boundary_icons,
checkboxInput("chkbox_InspectionGrid", "Inspection Grid", value = FALSE),
checkboxInput("chkbox_TSSBoundary", "TSS Boundary", value = TRUE),
checkboxInput("chkbox_NationalHighwaysboundary", "National Highways boundary", value = FALSE)
)
),
## downloads accordion ----
accordion_panel(
title = "downloads",
"Download TSS Checklist",
actionButton("download_geopackage", "GPKG", disabled = TRUE),
actionButton("download_shapefile", "SHP", disabled = TRUE),
actionButton("download_csv", "CSV", disabled = TRUE),
"Create ASD file",
actionButton("geoplace_csv", "ASD update", disabled = TRUE),
"Create TSS polygon",
downloadButton("geoplace_poly", "Geoplace")
),
## reports accordion ----
accordion_panel(
title = "reports",
"Create TSS report",
downloadButton("report_tss", "TSS"),
"Create LR report",
downloadButton("report_lr", "LR")
)
)
),
#  map card ----
card(
full_screen = TRUE,
card_header("The map"),
layout_sidebar(
fillable = TRUE, # need to include this if dealing with plotly or leaflet
#  map sidebar ----
sidebar = sidebar(
title = "Edit USRN/ESUID",
id = "edit_usrn",
open = FALSE,
p(HTML("Choose between:<br />1. editing this ESUID [ESUID] <b>or</b> <br />2. all ESUIDs ",
"associated with this USRN with the same class [USRN class] <b>or</b> <br />3. all ESUIDs ",
"associated with this USRN regardless of class [USRN all]."),
style = "font-size:0.6em;"),
radioGroupButtons(
"toggle_usrn_esuid", "Toggle ESUID/USRN", choices = c("ESUID", "USRN class", "USRN all"),
size = "sm"
),
"USRN",
verbatimTextOutput("usrn_edit", placeholder = TRUE),
"ESUIDs",
verbatimTextOutput("esuid_edit", placeholder = TRUE),
"Street",
verbatimTextOutput("street_edit", placeholder = TRUE),
"CLASS",
verbatimTextOutput("class_edit", placeholder = TRUE),
selectInput("tss_edit", "TSS", c("D", "I", "C", "H", "")),
p(HTML("Use backspace to remove from TSS."),
style = "font-size:0.7em;"),
"LR", checkboxInput("lr_edit", "", FALSE),
"Traffic_flow", checkboxInput("traffic_flow_edit", "", FALSE),
"HGVs", checkboxInput("hgvs_edit", "", FALSE),
"Buses", checkboxInput("buses_edit", "", FALSE),
"Peds", checkboxInput("peds_edit", "", FALSE),
"Carriageway", checkboxInput("carriageway_edit", "", FALSE),
"CJ", checkboxInput("cj_edit", "", FALSE),
"Medical", checkboxInput("medical_edit", "", FALSE),
"Educational", checkboxInput("educational_edit", "", FALSE),
"Retail", checkboxInput("retail_edit", "", FALSE),
"Commercial", checkboxInput("commercial_edit", "", FALSE),
"Recreational", checkboxInput("recreational_edit", "", FALSE),
"Transport", checkboxInput("transport_edit", "", FALSE),
"Emergency", checkboxInput("emergency_edit", "", FALSE),
"AM_peak", checkboxInput("am_peak_edit", "", FALSE),
"PM_peak", checkboxInput("pm_peak_edit", "", FALSE),
"Inter_peak", checkboxInput("inter_peak_edit", "", FALSE),
"Off_peak", checkboxInput("off_peak_edit", "", FALSE),
"Inc_sats", checkboxInput("inc_sats_edit", "", FALSE),
"Sat_rec", checkboxInput("sat_rec_edit", "", FALSE),
"All_year", checkboxInput("all_year_edit", "", FALSE),
"Term_time", checkboxInput("term_time_edit", "", FALSE),
"Key_shopping", checkboxInput("key_shopping_edit", "", FALSE),
"Notes",
verbatimTextOutput("notes_edit", placeholder = TRUE),
textInput("notes_edit_plus", "Additional Notes"),
actionButton("add_notes", "Add Note", disabled = FALSE),
"Length (m)",
verbatimTextOutput("length_edit", placeholder = TRUE),
# "Save changes to record",
# actionButton("save_changes", "Save"),
# "Discard changes to record",
# actionButton("discard_changes", "Discard"),
"Save changes to file",
actionButton("commit_changes", "Commit", disabled = FALSE)
),
maplibreOutput("map", height = "800px")
)
),
#  info card ----
card(verbatimTextOutput("info")),
#  datatable card ----
card(
card_header("The data table")
)
)
# server ----
server <- function(input, output, session) {
# bs_themer()
#  selected/clicked esuid we call `v` ----
## values set observeEvent(input$map_shape_click...)
## ensuring that we only store the clicked ESUID in `v`
v <- reactiveValues()
map_refresh_rate <- reactive(input$map_refresh)
#  server-side functions ----
create_reactive_data <- function(checkbox, layer_name, max_zoom = initial_zoom){
if(checkbox){
print(paste("checkbox is", checkbox))
if(is.null(bboxed())){
return(NULL)
} else if(input$map_zoom <= max_zoom){
return(NULL)
} else {
road <- load_data(layer_name, bb = bboxed())
if(layer_name == "DfT Counts"){
road <- road |> mutate(hourly = trunc(all_motor_vehicles / 24))
} else {
road
}
}
}
}
create_observation <- function(checkbox,
layer_name,
reactive_data,
map = "map",
...){
m <- maplibre_proxy(map) |> clear_layer(layer_name)
if(checkbox & !is.null(reactive_data) && nrow(reactive_data) > 0){
m <- maplibre_proxy(map) #|> showGroup(layer_name)
# determine type of layer to add
# 0 for points,
# 1 for lines,
# 2 for surfaces, and,
# if NA_if_empty is TRUE, NA for empty geometries
if(st_dimension(reactive_data[1, ]) == 0){
add_points(m, data = reactive_data, group = layer_name, ...)
} else if(st_dimension(reactive_data[1, ]) == 1){
add_lines(m, data = reactive_data, group = layer_name, ...)
} else if(st_dimension(reactive_data[1, ]) == 2){
add_polygons(m, data = reactive_data, group = layer_name, ...)
}
if(layer_name != "tss_data"){
move_layer(m, layer_id = layer_name, before_id = "tss_data")
} else {
m
}
}
}
#  reactive data ----
### reactive mousemove ----
hov_reac <- reactive({
input$map_bbox
})
hov_reac_d <- debounce(hov_reac, map_refresh_rate)
### reactive bbox ----
bboxed <- reactiveVal()
# see observeEvent(hov_reac_d())
### commercial_data ----
commercial_data <- reactive({
create_reactive_data(input$chkbox_GEOCommercialIndustrial, "GEO Commercial-Industrial")
})
### dftcounts_data ----
dftcounts_data <- reactive({
d <- create_reactive_data(input$chkbox_DfTCounts, "DfT Counts")
})
### trafficsignals_data ----
trafficsignals_data <- reactive({
create_reactive_data(input$chkbox_GEOCJ_TrafficSignals, "GEO CJ_Traffic Signals")
})
### roundabouts_data ----
roundabouts_data <- reactive({
create_reactive_data(input$chkbox_GEOCJ_Roundabouts, "GEO CJ_Roundabouts")
})
### openbusstops_data ----
openbusstops_data <- reactive({
create_reactive_data(input$chkbox_OpenBusBusStops, "OpenBus Bus Stops")
})
### openbusroutes_data ----
openbusroutes_data <- reactive({
create_reactive_data(input$chkbox_OpenBusroutes, "OpenBus routes")
})
### busstations_data ----
busstations_data <- reactive({
create_reactive_data(input$chkbox_GEOTransport_Bus_Stations, "GEO Transport_Bus_Stations")
})
### trainstations_data ----
trainstations_data <- reactive({
create_reactive_data(input$chkbox_GEOTransport_Train_Stations, "GEO Transport_Train_Stations")
})
### trainpassengers_data ----
trainpassengers_data <- reactive({
create_reactive_data(input$chkbox_ORRTransport_Train_Station_Passengers, "ORR Transport_Train_Station_Passengers")
})
### education_data ----
education_data <- reactive({
create_reactive_data(input$chkbox_GEOEducation, "GEO Education")
})
### schoolcapacity_data ----
schoolcapacity_data <- reactive({
create_reactive_data(input$chkbox_MHCLGEducation_Capacity, "MHCLG Education_Capacity")
})
### medical_data ----
medical_data <- reactive({
create_reactive_data(input$chkbox_GEOMedical, "GEO Medical")
})
### bluelights_data ----
bluelights_data <- reactive({
create_reactive_data(input$chkbox_GEOBlueLights, "GEO Blue Lights")
})
### retail_data ----
retail_data <- reactive({
create_reactive_data(input$chkbox_GEORetail, "GEO Retail")
})
### commercial_data ----
commercial_data <- reactive({
create_reactive_data(input$chkbox_GEOCommercialIndustrial, "GEO Commercial-Industrial")
})
### leisure_data ----
leisure_data <- reactive({
create_reactive_data(input$chkbox_GEOLeisure, "GEO Leisure")
})
### inspectiongrid_data ----
inspectiongrid_data <- reactive({
create_reactive_data(input$chkbox_InspectionGrid, "Inspection Grid")
})
### tssboundary_data ----
tssboundary_data <- reactive({
create_reactive_data(input$chkbox_TSSBoundary, "TSS Boundary")
})
### nationalhighways_data ----
nationalhighways_data <- reactive({
create_reactive_data(input$chkbox_NationalHighwaysboundary, "National Highways boundary")
})
### tss_data ----
tss_data <- reactive({
if(input$chkbox_TSSChecklist){
if(is.null(bboxed())){
return(NULL)
} else if(input$toggle_roads == "All roads"){
if(input$map_zoom >= 14){
road <- load_data(
"TSS Checklist",
bb = bboxed()
)
} else if(input$map_zoom >= 13){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE CLASS IN ('A', 'B', 'C', 'D')"
)
)
} else if(input$map_zoom >= 12){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE CLASS IN ('A', 'B', 'C')"
)
)
} else if(input$map_zoom >= 11){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE CLASS IN ('A', 'B')"
)
)
} else if(input$map_zoom < 11){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE CLASS LIKE 'A'"
)
)
}
} else if(input$toggle_roads == "TSS potential"){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE TSS IN ('D', 'I', 'C', 'H')"
)
)
} else if(input$toggle_roads == "TSS actual"){
road <- load_data(
"TSS Checklist",
bb = bboxed(),
query = sprintf(
"SELECT * FROM \"TSS Checklist\" WHERE TSS IN ('D', 'I', 'C')"
)
)
}
# # testing
# road <- load_data(
# "TSS Checklist",
# bb = bboxed())
}
})
#  Initialize map ----
output$map <- renderMaplibre({
maplibre(
# style = carto_style("positron")
style = carto_style("voyager")
# style = carto_style(input$basemap)
) |>
fly_to(center = map_start, zoom = initial_zoom)
})
#  observe reactive data ----
### observe toggle all layers on ----
observe({
if(input$toggle_layers == "Custom"){
updateCheckboxInput(session, "chkbox_TSSChecklist", value = TRUE)
updateCheckboxInput(session, "chkbox_DfTCounts", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOCJ_TrafficSignals", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOCJ_Roundabouts", value = FALSE)
updateCheckboxInput(session, "chkbox_OpenBusBusStops", value = FALSE)
updateCheckboxInput(session, "chkbox_OpenBusroutes", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOTransport_Bus_Stations", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOTransport_Train_Stations", value = FALSE)
updateCheckboxInput(session, "chkbox_ORRTransport_Train_Station_Passengers", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOEducation", value = TRUE)
updateCheckboxInput(session, "chkbox_MHCLGEducation_Capacity", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOMedical", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOBlueLights", value = FALSE)
updateCheckboxInput(session, "chkbox_GEORetail", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOCommercialIndustrial", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOLeisure", value = FALSE)
updateCheckboxInput(session, "chkbox_InspectionGrid", value = FALSE)
updateCheckboxInput(session, "chkbox_TSSBoundary", value = FALSE)
updateCheckboxInput(session, "chkbox_NationalHighwaysboundary", value = FALSE)
} else if(input$toggle_layers == "On"){
# updateCheckboxInput(session, "chkbox_TSSChecklist", value = TRUE)
updateCheckboxInput(session, "chkbox_TSSChecklist", value = TRUE)
updateCheckboxInput(session, "chkbox_DfTCounts", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOCJ_TrafficSignals", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOCJ_Roundabouts", value = TRUE)
updateCheckboxInput(session, "chkbox_OpenBusBusStops", value = TRUE)
updateCheckboxInput(session, "chkbox_OpenBusroutes", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOTransport_Bus_Stations", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOTransport_Train_Stations", value = TRUE)
updateCheckboxInput(session, "chkbox_ORRTransport_Train_Station_Passengers", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOEducation", value = TRUE)
updateCheckboxInput(session, "chkbox_MHCLGEducation_Capacity", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOMedical", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOBlueLights", value = TRUE)
updateCheckboxInput(session, "chkbox_GEORetail", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOCommercialIndustrial", value = TRUE)
updateCheckboxInput(session, "chkbox_GEOLeisure", value = TRUE)
updateCheckboxInput(session, "chkbox_InspectionGrid", value = TRUE)
updateCheckboxInput(session, "chkbox_TSSBoundary", value = TRUE)
updateCheckboxInput(session, "chkbox_NationalHighwaysboundary", value = TRUE)
} else if(input$toggle_layers == "Off"){
# updateCheckboxInput(session, "chkbox_TSSChecklist", value = FALSE)
updateCheckboxInput(session, "chkbox_TSSChecklist", value = FALSE)
updateCheckboxInput(session, "chkbox_DfTCounts", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOCJ_TrafficSignals", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOCJ_Roundabouts", value = FALSE)
updateCheckboxInput(session, "chkbox_OpenBusBusStops", value = FALSE)
updateCheckboxInput(session, "chkbox_OpenBusroutes", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOTransport_Bus_Stations", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOTransport_Train_Stations", value = FALSE)
updateCheckboxInput(session, "chkbox_ORRTransport_Train_Station_Passengers", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOEducation", value = FALSE)
updateCheckboxInput(session, "chkbox_MHCLGEducation_Capacity", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOMedical", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOBlueLights", value = FALSE)
updateCheckboxInput(session, "chkbox_GEORetail", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOCommercialIndustrial", value = FALSE)
updateCheckboxInput(session, "chkbox_GEOLeisure", value = FALSE)
updateCheckboxInput(session, "chkbox_InspectionGrid", value = FALSE)
updateCheckboxInput(session, "chkbox_TSSBoundary", value = FALSE)
updateCheckboxInput(session, "chkbox_NationalHighwaysboundary", value = FALSE)
}
})
### observe dftcounts_data ----
observe({
create_observation(checkbox = input$chkbox_DfTCounts,
layer_name = "dftcounts_data",
reactive_data = dftcounts_data(),
# circle_color = interpolate(
# column = "all_motor_vehicles",
# type = "linear",
# values = c(0, 500, 1000, 5000, 20000, 50000, 100000),
# stops = c("#22A884", "#2A788E", "#414487", "#440154", "#7AD151", "#f06060", "#FDE725")
# ),
# circle_color = dft_color,
circle_color = interpolate(
column = "hourly",
values = c(0, 500, 1000),
stops = c(dft_color[[1]], dft_color[[2]], dft_color[[3]])
),
circle_radius = interpolate(
column = "all_motor_vehicles",
type = "linear",
values = c(0, 1000, 5000, 15000, 30000, 50000, 70000, 100000),
stops = c(1, 2, 4, 7, 9, 10, 12, 14)
),
tooltip = concat("Annual Daily Traffic Flow",
"<br /><big><b>",
number_format("all_motor_vehicles"),
"</b></big><br />(",
get_column("hourly"),
" vehicles ph)")
)
})
#
### observe trafficsignals_data ----
observe({
create_observation(checkbox = input$chkbox_GEOCJ_TrafficSignals,
layer_name = "trafficsignals_data",
reactive_data = trafficsignals_data(),
circle_color = cj_color[1],
circle_stroke_color = "black",
circle_stroke_width = 1,
circle_opacity = 1,
tooltip = concat("Traffic signals ",
"<br />",
get_column("highway"),
"<br />",
get_column("traffic_signals")
)
)
})
### observe roundabouts_data ----
observe({
create_observation(checkbox = input$chkbox_GEOCJ_Roundabouts,
layer_name = "roundabouts_data",
reactive_data = roundabouts_data(),
tooltip = concat("Roundabout ",
"<br />",
get_column("name"),
"<br />",
get_column("junction")),
line_color = cj_color[1],
line_width = 2
)
})
### observe openbusstops_data ----
# observe({
# create_observation(checkbox = input$chkbox_OpenBusBusStops,
# layer_name = "openbusstops_data",
# reactive_data = openbusstops_data(),
# tooltip = concat("Bus stop (8+ buses ph)",
# "<br />",
# get_column("stop_name")),
# circle_color = bus_color[1],
# circle_radius = 6,
# circle_opacity = 0.8
# )
# })
observe({
m <- maplibre_proxy("map") |> clear_layer("openbusstops_data")
if(input$chkbox_OpenBusBusStops & !is.null(openbusstops_data()) &&
nrow(openbusstops_data()) > 0){
# m |> add_image("busstop", url = "https://github.com/szechno/wscc_shinyapp/blob/main/busstop.png?raw=true")|>
# https://www.base64-image.de/ convert png to base64....
m |> add_image("busstop", url = "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAKUAAACrCAYAAAAHIVyqAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsAAAA7AAWrWiQkAAAAZdEVYdFNvZnR3YXJlAHd3dy5pbmtzY2FwZS5vcmeb7jwaAAABh2lUWHRYTUw6Y29tLmFkb2JlLnhtcAAAAAAAPD94cGFja2V0IGJlZ2luPSfvu78nIGlkPSdXNU0wTXBDZWhpSHpyZVN6TlRjemtjOWQnPz4NCjx4OnhtcG1ldGEgeG1sbnM6eD0iYWRvYmU6bnM6bWV0YS8iPjxyZGY6UkRGIHhtbG5zOnJkZj0iaHR0cDovL3d3dy53My5vcmcvMTk5OS8wMi8yMi1yZGYtc3ludGF4LW5zIyI+PHJkZjpEZXNjcmlwdGlvbiByZGY6YWJvdXQ9InV1aWQ6ZmFmNWJkZDUtYmEzZC0xMWRhLWFkMzEtZDMzZDc1MTgyZjFiIiB4bWxuczp0aWZmPSJodHRwOi8vbnMuYWRvYmUuY29tL3RpZmYvMS4wLyI+PHRpZmY6T3JpZW50YXRpb24+MTwvdGlmZjpPcmllbnRhdGlvbj48L3JkZjpEZXNjcmlwdGlvbj48L3JkZjpSREY+PC94OnhtcG1ldGE+DQo8P3hwYWNrZXQgZW5kPSd3Jz8+LJSYCwAACiZJREFUeF7t3XmsXGUdxvHvC7UClaWylKUWTQxqASO21ehJlAQLQhEhoiyWxBiOIVhED1FiAOOCsohH9qAvIgZkMQIuIcEAJaCvEUJq4h9sikhLQdm3Flna1z96aoZf7+2dmbPMe+99Pskkw/ObuZee+9wzZ+6cBURERGSScTYYoZnAfOAdwFxgJ2AWMAPY1j5YankJeANYAzwFrAZWAvcDr9kHd22UpdwZWAzsD2TAXnmZzbAPku74IrwBPAj8GbgDuK0qbae6LuXWwDHAscD+eZltaR8g6fBFWFeV8xrgOuAV+5g2dFXK2cApwAl5me1oh5I+X4SngcuAHwHP23mT2i7lDOBk4LS8zGbboUw+vgjPAmcCFwLr7LwJbZbyfcAv8jJbZAcy+fki3A18AXjAzupqq5RLgGvyMtvODmTq8EVYAxwH3GRndbTxRuNrwJV5mW1lBzK1LDho3swVf1j1WeAF4G47H1bTa8pleZldZEOZ2nwRIrAMuNTOhrGFDWo4tNr4lWkmLzMHXAQcbGfDaGpN+U5ghd5hT2++CM8AH6w+HRpaU2vKi1VIqf4GXfvVsok15SF5md1sQ5m+fBEOBm6xeb+aWFOeZgOZ9mp1ou6aclFeZvfYUMQXYRFwr837UXdN+XkbiFSOtUG/6pZyiQ1EKofZoF91Xr73zMvsXzYU2cgXYR6wyuYTqbOmfL8NRIx9bdCPOqWcbwMRY28b9KNOKXeygYgxVEfqlFK7pclEtrdBP+qUchsbiBizbNCPOqUUaYVKKclRKSU5KqUkR6WU5KiUkhyVUpJTZ4eMq/IyW2rD8fgiPGezSWj7vMyG+kX2RVhfHYo6qQ1y2IsvwtXVceEDGWoBD2lOjHH2ZL4Ns8dLj1X26022GzDH/qPa0GUpRfqiUkpyVEpJjkopyVEpJTkqpSRHpZTkqJSSHJVSkjNeKfcAvgUsB+4DHh7jdrh9kohx+Bi9ebjq1O3AGcDu9kljffZ9EnBOXmZb20EdvggzY4wjv5pVHc65R/My29Pm/fBFeDTGONRzU+Gcm5mXWaM/Q1+EtcA3gEs2ZnZNeWpeZhc2XUiR8eRltk1eZhcDX9+Y9ZZyfnV9FJFROAvYB1PKU3RtRBmV6pKIJ2NKeUDPfZFROABTyl177ouMwu6YUuqlW0ZtBmO8+xYZOZVSkqNSSnJUSkmOSinJUSklOSqlJEellOSolJIclVKSo1JKclRKSY5KKclRKSU5KqUkR6WU5KiUkhyVUpKjUkpyVEpJjkopyVEpJTkqpSRHpZTkqJSSHJVSkqNSSnJUSkmOSinJUSklOSqlJKe3lC/33BcZhRcxpXyg577IKDyAKeV1PfdFRuF6TCkv80V4qOe/RTrji/Ag8BNMKf8LfMoXYVVPJtI6X4SVwGFVBzd59/0QsNAX4QpfhNfNTKRRvgiv+yJcDiysugfjXJtxox2AjwK7AVvaIfDFvMw+bMPx6NqM0+/ajL4IdwNX2BxYBzwBBOAFO9xcKSdyVV5mS204Hl+E9wBv2HySuSsvsz1s2A9fhNXAx2w+yczIy+xBG47HF+Fq4DibT6SzUsr0M2wp7TalyMiplJIclVKSo1JKclRKSY5KKclRKSU5KqUkR6WU5KiUkhyVUpKjUkpyVEpJjkopyVEpJTkj35/SF2E9sBJ4HFgL7ALMzcvs7fax0jxfhGeA1cCTwDbAHsC8vMzqdANq7E9Z5xvXKqUvwr3AZcDNMcYnemfOuS2ABcARwIl5me3QO5d6fBGeAy4FbgJWxBjX986dc7sBhwIn5GW2oHc2iElTSl+EJ4ETgRvtwhiLc25H4NvAsiZ+e6czX4QIXAB8N8b4rJ1b1crhSOCSvMx2tvOJDFvKTrcpfRFWAAtjjL/up5AAMcZnYownAcf6Irxi59IfX4S1wNExxq/2U0g2LPv1McZfVUe4/tXO29JZKX0R/gl8Msa40s76EWO8FlhabYPKAKpltjTGeL2d9SPG+Ciw2Bfh73bWhk5K6YvwKnBIjPFJOxtEjPEG4Cyby4S+F2O80YaDiDE+DXzaF6HvQ2yH1UkpgQtijE2dQOv71RkVpA++CI8B59p8GDHG+4CLbN601ktZnWmjkYXChgWzFvixzWVcP4wxrrFhDWe3ffaU1ksJ3FGt+pt0Y/VOUjajWka1XratGONTwJ02b1IXpVxug7qqDe9/2Fw28VCMsY0TljX+M+3VRSkfs0FD2vq6U0kbhaTtZd9FKTc5gVFD+vpb2zTX1rJ/zgZN6qKUu9igIbvaQDbR1rKfY4MmdVHKtk5/19bXnUraWkZtfV3oqJQH26Au59wH8jKba3N5s7zM5jnn9rV5A5bYoEldlHKhc+7dNqzpczaQcR1lgzqcc3sB+9m8Sa2Xstqz50ybD8s5tzvwFZvLuE52zjW5/f2DtvfWar2UlaOccwfZcFDVrlTn52X2NjuTseVltm1Tn4A555YAn7F50zopZfWbdb1zbm87G9AZeZnppXtAeZkd45w73eaDcM7tA1zb9lqSrkrJhgWzA3CXc+4TdjYR59wM59w51c6+MoS8zM50zv3UOfcWO5uIc+7jwO15mW1nZ23orJRsWDA7Arc4586t9iifkHPuI8CdeZmd2sVv6VSWl9mXgOXOub6u6uGc28k5d15VyFb/Ntmrzg95qMMhNvJFeL667NnvgXs27mvpnHsrMA9YDByRl9li+1ypp9pR49bqGJ1bgVUxxlfZsPznAB+qjtE5Oi+z7e3z+zXs4RAjK6VV7Ty6Ji+z2XYm7asOJpuVl9lMOxvWpC+lTD3DlrLTbUqRfqiUkhyVUpKjUkpyVEpJjkopyVEpJTkqpSRHpZTkqJSSHJVSklPns+9ZwHgf3l+Xl9mBNuxCdbq6vnbNmiL2y8vsdht2xRfh+M2cGuY1YODzGNVZU66pDkof69bqCZAmsG6M/5+pfHvJLoCOba4HAxeSmqUUaYVKKclRKSU5KqUkR6WU5KiUkhyVUpKjUkpyVEpJjkopyVEpJTkqpSSnrVK2fv2+zRjl9x6FUf97X7VBXW2V8k0Xle/YahtMcaNc1rSxvNsq5d9s0KFRfu9ReMoX4XEbdqE6KVlTF4L9v7ZK+VtfhHU27Mh4O5xOVRH4jQ07chvwog3raquU/wautGHbfBGWA/fYfBo4r7qmetfOtkET2iolwOm+CJ1t7/givDyNrxrxCHCWDdvki/Bz4I82b0KdY3T6sag6NfG2dtCk6vrTRwK/s7NpxAG/zMvsGDtomi/CXcCBbbzzpoNSAswHbsjL7L120IRqI/8o4E92Ng1tAXwH+GZeZlvaYRN8ES4HlrVVSDoqJdVRj8cDX87LbL4dDsMX4RHgZ8D5wx6gNIXNB04HDsvLbJYdDqraXr2tukjXX+y8aV2Vste7qoW2CzDo5TPWA/+pLkB/vx3KJrYCFgBzgWFOqL+m+jvkvcDLdigiIiIiIiJ9+h8ZyfwnvuiPpwAAAABJRU5ErkJggg==") |>
add_symbol_layer(
id = "openbusstops_data",
source = openbusstops_data(),
icon_image = "busstop",
icon_allow_overlap = TRUE,
icon_size = 0.1,
icon_opacity = 1,
# icon_color = bus_color,
tooltip = concat("Bus stop (8+ buses ph)",
"<br />",
get_column("stop_name"),
"<br />",
get_column("Total_ph"), " bus ph")
)
}
})
### observe openbusroutes_data ----
observe({
create_observation(checkbox = input$chkbox_OpenBusroutes,
layer_name = "openbusroutes_data",
reactive_data = openbusroutes_data(),
tooltip = concat("Bus route ",
"<br />",
get_column("shape_id")),
line_color = bus_color[1],
line_width = 3,
line_dasharray = c(5, 5),
)
})
### observe busstations_data ----
observe({
create_observation(checkbox = input$chkbox_GEOTransport_Bus_Stations,
layer_name = "busstations_data",
reactive_data = busstations_data(),
tooltip = concat("Bus station ",
get_column("name"),
"<br />",
get_column("amenity")),
fill_color = bus_color[1],
fill_opacity = 0.8
)
})
### observe trainstations_data ----
observe({
create_observation(checkbox = input$chkbox_GEOTransport_Train_Stations,
layer_name = "trainstations_data",
reactive_data = trainstations_data(),
tooltip = concat("Train station",
"<br />",
get_column("name")),
fill_color = train_color[[2]],
fill_outline_color = "black"
)
})
### observe trainpassengers_data ----
observe({
create_observation(checkbox = input$chkbox_ORRTransport_Train_Station_Passengers,
layer_name = "trainpassengers_data",
reactive_data = trainpassengers_data(),
tooltip = concat("Train Station annual passengers",
"<br />",
number_format("Annual_passengers")
),
circle_color = train_color[[1]],
circle_stroke_color = "white",
circle_stroke_width = 1,
circle_radius = interpolate(
column = "Annual_passengers",
type = "linear",
values = c(0, 5000, 50000, 100000, 300000, 500000, 1000000, 2000000),
stops = c(1, 2, 4, 7, 9, 10, 12, 14)
),
# circle_radius = 8
)
})
### observe education_data ----
observe({
create_observation(checkbox = input$chkbox_GEOEducation,
layer_name = "education_data",
reactive_data = education_data(),
fill_color = school_color[1],
fill_opacity = 0.5,
fill_outline_color = "purple",
# stroke = FALSE,
tooltip = concat("Education",
"<br />",
get_column("name"),
"<br />",
get_column("amenity")),
# highlightOptions = highlightOptions(
# fill_opacity = 0.7,
# fill_color = "#C4B454"
# )
)
})
### observe schoolcapacity_data ----
observe({
create_observation(checkbox = input$chkbox_MHCLGEducation_Capacity,
layer_name = "schoolcapacity_data",
reactive_data = schoolcapacity_data(),
# # tooltip = ~paste(name, school.capacity),
# radius = ~school.capacity/50,
# stroke = FALSE,
# color = "grey",
# fill_opacity = 0.8,
tooltip = concat(get_column("name"),
"<br />",
get_column("school.capacity")
),
circle_color = school_color[1],
circle_stroke_color = "white",
circle_stroke_width = 2,
circle_radius = interpolate(
column = "school.capacity",
type = "linear",
values = c(0, 50, 500, 1000, 1500, 2000, 2500, 5000),
stops = c(1, 2, 4, 7, 9, 10, 12, 14)
),
)
})
### observe medical_data ----
observe({
create_observation(checkbox = input$chkbox_GEOMedical,
layer_name = "medical_data",
reactive_data = medical_data(),
fill_color = medical_color[1],
fill_opacity = 0.5,
fill_outline_color = "navy",
# stroke = FALSE,
tooltip = concat("Medical",
"<br />",
get_column("name"),
"<br />",
get_column("amenity"),
"<br />",
"Emergency",
get_column("emergency"))
)
})
### observe bluelights_data ----
observe({
create_observation(checkbox = input$chkbox_GEOBlueLights,
layer_name = "bluelights_data",
reactive_data = bluelights_data(),
fill_color = emergency_color[1],
fill_opacity = 0.5,
fill_outline_color = "navy",
# stroke = FALSE,
tooltip = concat("Blue lights",
"<br />",
get_column("name"),
"<br />",
get_column("amenity"),
"<br />",
get_column("emergency"))
)
})
### observe retail_data ----
observe({
create_observation(checkbox = input$chkbox_GEORetail,
layer_name = "retail_data",
reactive_data = retail_data(),
fill_color = retail_color[1],
fill_opacity = 0.5,
fill_outline_color = "navy",
# stroke = FALSE,
tooltip = concat("Retail",
"<br />",
get_column("name"),
"<br />",
get_column("amenity"),
"<br />",
get_column("landuse"))
)
})
### observe commercial_data ----
observe({
create_observation(checkbox = input$chkbox_GEOCommercialIndustrial,
layer_name = "commercial_data",
reactive_data = commercial_data(),
# fill_color = "orange",
# fill_opacity = 0.5,
# stroke = FALSE,
# tooltip = ~name,
# highlightOptions = highlightOptions(
# fill_opacity = 0.7,
# fill_color = "#FF5F1F"
fill_color = commerce_color[1],
fill_opacity = 0.5,
fill_outline_color = "navy",
tooltip = concat("Commercial-Industrial",
"<br />",
get_column("name"),
"<br />",
get_column("amenity"))
)
})
### observe leisure_data ----
observe({
create_observation(checkbox = input$chkbox_GEOLeisure,
layer_name = "leisure_data",
reactive_data = leisure_data(),
fill_color = leisure_color[1],
fill_opacity = 0.8,
fill_outline_color = "darkgreen",
tooltip = concat("Leisure",
"<br />",
get_column("name"),
"<br />",
get_column("landuse"))
)
})
### observe inspectiongrid_data ----
observe({
create_observation(checkbox = input$chkbox_InspectionGrid,
layer_name = "inspection_grid",
reactive_data = inspectiongrid_data(),
# fill_color = "transparent",
# color = "#696969",
# weight = 1,
# stroke = TRUE,
# fill = FALSE,
# tooltip = ~id,
# labelOptions = labelOptions(noHide = TRUE,
# textOnly = TRUE,
# direction = 'center',
# permanent = TRUE,
# opacity = 1,
# style = list(
# color = "#696969")
# ),
# options = pathOptions(interactive = FALSE))
fill_color = "transparent",
fill_antialias = TRUE,
fill_opacity = 1,
fill_outline_color = grid_color[1])
})
### observe tssboundary_data ----
observe({
create_observation(checkbox = input$chkbox_TSSBoundary,
layer_name = "tssboundary_data",
reactive_data = tssboundary_data(),
fill_color = "transparent",
fill_outline_color = border_color
)
})
### observe nationalhighways_data ----
observe({
create_observation(checkbox = input$chkbox_NationalHighwaysboundary,
layer_name = "nationalhighways_data",
reactive_data = nationalhighways_data(),
# stroke = FALSE,
# color = "pink",
# fill_opacity = 0.8,
# tooltip = "National Highways land"
fill_color = NH_color,
fill_opacity = 0.5,
fill_outline_color = "pink",
tooltip = concat("NH boundary",
"<br />",
get_column("category"))
)
})
### observe tss_data ----
# NOTE: THIS OBSERVE ALWAYS GOES LAST AS EASIEST WAY TO KEEP LAYER ON TOP
observe({
# https://rstudio.github.io/leaflet/articles/shiny.html
m <- maplibre_proxy("map") |> clear_layer("tss_data")
if (input$chkbox_TSSChecklist & !is.null(tss_data()) && nrow(tss_data()) > 0){
if(input$toggle_roads == "All roads"){
set <- tss_data()$CLASS |> unique() |> sort()
set <- lookup_class |> filter(classification %in% set)
set$title <- "Class of road"
} else {
set <- tss_data()$TSS |> unique() |> sort()
set <- lookup_tss |> filter(classification %in% set)
set$title <- "TSS of road"
}
# pal <- list(
# values = set$classification,
# lwd = set$lwd,
# colors = set$colours,
# default = "pink",
# col = set$column[[1]])
m <- m |> add_line_layer(
source = tss_data(),
line_opacity = 0.5,
line_cap = "round",
line_width = match_expr(column = set$column[[1]],
values = set$classification,
stops = set$lwd,
default = 3),
line_color = match_expr(
column = set$column[[1]],
values = set$classification,
stops = set$colours,
default = "pink"
),
tooltip = "Street",
hover_options = list(
line_color = "gold",
line_opacity = 1,
line_width = 5
),
id = "tss_data"
)
m |> clear_controls()
m |>
add_legend(position = "top-left",
legend_title = set$title[[1]],
# colors = pal,
colors = set$colours,
values = set$classification,
patch_shape = "square",
type = "categorical",
style = list(
background_color = "#f0f0f0",
shadow = TRUE,
shadow_color = "white",
shadow_size = 8
)
)
}
})
#  observe events ----
### update basemap selected ----
observeEvent(input$basemap, {
# set_style(mapbox_style("dark"), config = list(showLabels = FALSE), diff = TRUE)
# https://codepen.io/g2g/pen/rNRJBZg <--- more free styles
basemap <- isolate(input$basemap)
m <- maplibre_proxy("map", session)
if(basemap == "liberty"){
m <- m |>
set_style(
style = "https://tiles.openfreemap.org/styles/liberty")
} else if(basemap == "osm-bright"){
m <- m |>
set_style(
style =
# "https://raw.githubusercontent.com/go2garret/maps/main/src/assets/json/openStreetMap.json")
"https://tiles.openfreemap.org/styles/bright")
} else if(basemap == "fiord"){
m <- m |>
set_style(
style =
# "https://raw.githubusercontent.com/go2garret/maps/main/src/assets/json/arcgis_hybrid.json")
"https://tiles.openfreemap.org/styles/fiord")
} else {
m <- m |> set_style(carto_style(basemap))
}
})
### hov_reac_d ----
observeEvent(hov_reac_d(), {
if (!is.null(hov_reac_d())){
bboxed(hov_reac_d())
}
})
### add_notes clicked ----
observeEvent(input$add_notes, {
print(paste("v is...", v$ESUID, " - ", v$Notes))
# get new input
text <- str_squish(input$notes_edit_plus) |> str_to_title()
# # check if existing notes is blank
if(is.null(v$Notes) | v$Notes == ""){
# print("Existing note is an empty string or null")
spacer <- ""
} else {
spacer <- " "
}
# if new note isn't blank
if(is.null(text) | text == ""){
print("New text is empty or null")
} else {
if(str_detect(text, ";$")){
v$Notes <- paste0(str_squish(v$Notes), spacer, text)
} else {
v$Notes <- paste0(str_squish(v$Notes), spacer, text, ";")
}
# update notes
output$notes_edit <- renderText(v$Notes, quoted = FALSE)
# blanbk off additional notes
updateTextInput(session,"notes_edit_plus", value="")
}
# confirm added
print(paste("new v$Notes is", v$Notes))
})
### commit_changes clicked ----
observeEvent(input$commit_changes, {
# check if anything clicked first
# need to update v based on input$lr_edit
#print(convert_true_false(v$LR))
if(length(reactiveValuesToList(v)) == 0){
showNotification(type = "warning",
closeButton = TRUE,
paste("Nothing selected. Click a road to edit.")
)
} else {
# if clicked *temporarily* check if notes blank to test logic
if(is.null(v$ESUID) | v$ESUID == ""){
showNotification(type = "warning",
closeButton = TRUE,
paste("ESUID is empty.")
)
} else {
# do some committing
conn = dbConnect(RSQLite::SQLite(), geodata)
# # disable triggers that work on geometries
triggers = dbGetQuery(conn, "SELECT name FROM sqlite_master WHERE type = 'trigger';")
if(nrow(triggers) != 0){
for (trigger_name in triggers$name) {
dbExecute(conn, paste0("DROP TRIGGER IF EXISTS '", trigger_name, "';"))
}
}
# check tables
## dbListTables(conn)
# check the table structure
## dbGetQuery(conn, "PRAGMA table_info(\"TSS Checklist\");")
# change just this ESUID
if(input$toggle_usrn_esuid == "ESUID"){
where_clause <- paste0("WHERE ESUID = '", v$ESUID, "';")
# change this USRN regardless of class
} else if(input$toggle_usrn_esuid == "USRN all"){
where_clause <- paste0("WHERE USRN = '", v$USRN, "';")
# change this USRN with the same class
} else if(input$toggle_usrn_esuid == "USRN class"){
where_clause <- paste0("WHERE USRN = '", v$USRN, "' AND CLASS = '", v$CLASS, "';")
} else {
return(NULL)
}
# ask_confirmation(inputId = "bob",
# type = "question",
# btn_labels = c("Confirm", "Cancel"))
# if(isTRUE(input$bob)){
# print("bob is NULL")
# } else if(!isTRUE(input$bob)){
# print("bob is TRUE")
# }
dbExecute(conn,
paste0("UPDATE \"TSS Checklist\" SET ",
# field2=value2,
# field3=value3
"TSS = '", input$tss_edit, "', ",
"LR = ", convert_true_false(input$lr_edit), ", ",
"Traffic_flow = ", convert_true_false(input$traffic_flow_edit), ", ",
"HGVs = ", convert_true_false(input$hgvs_edit), ", ",
"Buses = ", convert_true_false(input$buses_edit), ", ",
"Peds = ", convert_true_false(input$peds_edit), ", ",
"Carriageway = ", convert_true_false(input$carriageway_edit), ", ",
"CJ = ", convert_true_false(input$cj_edit), ", ",
"Medical = ", convert_true_false(input$medical_edit), ", ",
"Educational = ", convert_true_false(input$educational_edit), ", ",
"Retail = ", convert_true_false(input$retail_edit), ", ",
"Commercial = ", convert_true_false(input$commercial_edit), ", ",
"Recreational = ", convert_true_false(input$recreational_edit), ", ",
"Transport = ", convert_true_false(input$transport_edit), ", ",
"Emergency = ", convert_true_false(input$emergency_edit), ", ",
"AM_peak = ", convert_true_false(input$am_peak_edit), ", ",
"PM_peak = ", convert_true_false(input$pm_peak_edit), ", ",
"Inter_peak = ", convert_true_false(input$inter_peak_edit), ", ",
"Off_peak = ", convert_true_false(input$off_peak_edit), ", ",
"Inc_sats = ", convert_true_false(input$inc_sats_edit), ", ",
"Sat_rec = ", convert_true_false(input$sat_rec_edit), ", ",
"All_year = ", convert_true_false(input$all_year_edit), ", ",
"Term_time = ", convert_true_false(input$term_time_edit), ", ",
"Key_shopping = ", convert_true_false(input$key_shopping_edit), ", ",
"Notes = '", v$Notes, "' ",
where_clause)
# "WHERE ESUID = '", v$ESUID, "';")
)
dbDisconnect(conn)
showNotification(type = "message",
closeButton = FALSE,
paste("Committed changes. Move map to reload data.")
)
}
}
})
### map_shape_click clicked ----
observeEvent(input$map_feature_click, {
# p <- input$map_shape_click
# if(p$group == "tss_data"){
if(input$map_feature_click$layer == "tss_data"){
# print(p$id) # layerId ... which is now "esuid"
# data <- tss_data() |> filter(ESUID == p$id) |> st_drop_geometry()
data <- input$map_feature_click$properties
#### fill out edit_usrn boxes ----
output$usrn_edit <-renderText(data$USRN, quoted = FALSE)
output$esuid_edit <-renderText(data$ESUID, quoted = FALSE)
output$street_edit <-renderText(data$Street, quoted = FALSE)
output$class_edit <-renderText(data$CLASS, quoted = FALSE)
updateSelectInput(inputId = "tss_edit", selected = data$TSS)
updateCheckboxInput(inputId = "lr_edit", value = data$LR)
updateCheckboxInput(inputId = "traffic_flow_edit", value = data$Traffic_flow)
updateCheckboxInput(inputId = "hgvs_edit", value = data$HGVs)
updateCheckboxInput(inputId = "buses_edit", value = data$Buses)
updateCheckboxInput(inputId = "peds_edit", value = data$Peds)
updateCheckboxInput(inputId = "carriageway_edit", value = data$Carriageway)
updateCheckboxInput(inputId = "cj_edit", value = data$CJ)
updateCheckboxInput(inputId = "medical_edit", value = data$Medical)
updateCheckboxInput(inputId = "educational_edit", value = data$Educational)
updateCheckboxInput(inputId = "retail_edit", value = data$Retail)
updateCheckboxInput(inputId = "commercial_edit", value = data$Commercial)
updateCheckboxInput(inputId = "recreational_edit", value = data$Recreational)
updateCheckboxInput(inputId = "transport_edit", value = data$Transport)
updateCheckboxInput(inputId = "emergency_edit", value = data$Emergency)
updateCheckboxInput(inputId = "am_peak_edit", value = data$AM_peak)
updateCheckboxInput(inputId = "pm_peak_edit", value = data$PM_peak)
updateCheckboxInput(inputId = "inter_peak_edit", value = data$Inter_peak)
updateCheckboxInput(inputId = "off_peak_edit", value = data$Off_peak)
updateCheckboxInput(inputId = "inc_sats_edit", value = data$Inc_sats)
updateCheckboxInput(inputId = "sat_rec_edit", value = data$Sat_rec)
updateCheckboxInput(inputId = "all_year_edit", value = data$All_year)
updateCheckboxInput(inputId = "term_time_edit", value = data$Term_time)
updateCheckboxInput(inputId = "key_shopping_edit", value = data$Key_shopping)
output$notes_edit <-renderText(data$Notes, quoted = FALSE)
output$length_edit <-renderText(data$length, quoted = FALSE)
v$USRN = data$USRN
v$ESUID = data$ESUID
v$Street = data$Street
v$CLASS = data$CLASS
# v$TSS = data$TSS
# v$LR = data$LR
# v$Traffic_flow = data$Traffic_flow
# v$HGVs = data$HGVs
# v$Buses = data$Buses
# v$Peds = data$Peds
# v$Carriageway = data$Carriageway
# v$CJ = data$CJ
# v$Medical = data$Medical
# v$Educational = data$Educational
# v$Retail = data$Retail
# v$Commercial = data$Commercial
# v$Recreational = data$Recreational
# v$Transport = data$Transport
# v$Emergency = data$Emergency
# v$AM_peak = data$AM_peak
# v$PM_peak = data$PM_peak
# v$Inter_peak = data$Inter_peak
# v$Off_peak = data$Off_peak
# v$Inc_sats = data$Inc_sats
# v$Sat_rec = data$Sat_rec
# v$All_year = data$All_year
# v$Term_time = data$Term_time
# v$Key_shopping = data$Key_shopping
v$Notes = data$Notes
v$length = data$length
# print v to console for testing....
print(paste(
names(v),
c(v$USRN, v$ESUID, v$Street, v$CLASS, v$TSS, v$LR,
v$Traffic_flow, v$HGVs, v$Buses, v$Peds, v$Carriageway,
v$CJ, v$Medical, v$Educational, v$Retail, v$Commercial,
v$Recreational, v$Transport, v$Emergency, v$AM_peak,
v$PM_peak, v$Inter_peak, v$Off_peak, v$Inc_sats, v$Sat_rec,
v$All_year, v$Term_time, v$Key_shopping, v$Notes, v$length),
# v,
sep = ": "
)
)
toggle_sidebar("edit_usrn", open = TRUE)#, session = get_current_session())
} else {
toggle_sidebar("edit_usrn", open = FALSE)
}
})
### modal
# observe({
# showModal(
# modalDialog(
# tagList(
# textInput("newfilename", label = "Filename", placeholder = "my_file.txt")
# ),
# title="Create a file",
# footer = tagList(actionButton("confirmSave", "Save"),
# modalButton("Cancel")
# )
# )
# )
# }) |>
# bindEvent(input$report_tss)
#
# observeEvent(input$confirmSave, {
# req(input$newfilename)
# print(paste("File will be saved in:", input$newfilename))
# removeModal()
# })
### report_tss clicked ----
# observeEvent(input$report_tss,{
# run_report(type = "TSS", year = "2025")
# })
### downloadhandler tss ----
# https://mastering-shiny.org/action-transfer.html#downloading-reports
output$report_tss <- downloadHandler(
filename = paste0("tss_review_v6a_output-report_tss_",
Sys.Date(), "_",
str_replace_all(format(Sys.time(), "%X"), ":", ""),
".html"),
content = function(file) {
params <- get_params(type = "TSS", year = "2025", filename = filename())
id <- showNotification(
"Please stand by. This will take a minute: Rendering TSS report...",
duration = NULL,
type = "warning",
closeButton = FALSE
)
on.exit(removeNotification(id), add = TRUE)
callr::r(
render_report,
list(input = report_path,
output = file,
params = params)
)
}
)
### report_lr clicked ----
observeEvent(input$report_lr,{
# TODO need to check if LR selected in data
run_report(type = "LR", year = "2025")
})
##  rendertext ----
output$info <- renderText({
zoomlevel <- input$map_zoom
map_center <- input$map_center
edu_selected <- input$chkbox_GEOEducation
if (!is.null(tss_data())) {
paste0(
"Showing ", nrow(tss_data()),
" features in current view at zoom level ",
zoomlevel,
# ". Education is set to ",
# edu_selected,
". Map center is ", map_center$lng, ", ", map_center$lat, ". bboxed: ",
bboxed()[1], ", ", bboxed()[2], ", ", bboxed()[3], ", ", bboxed()[4]
)
} else {
paste0(
"Zoom level = ", zoomlevel, ". Pan/zoom map to load data. ",
"Zoom in passed level 14 to view entirety of road network. "
)
}
})
#  end of server function ----
}
# run me ----
shinyApp(ui = ui, server = server)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment