Created
February 20, 2026 21:04
-
-
Save szechno/6f6d0ebf5a3ec82c28f83ed29546d398 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # preload functions ---- | |
| # 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() | |
| datav <- list() | |
| map_refresh_rate <- reactive(input$map_refresh) | |
| # server-side functions ---- | |
| create_reactive_data <- function(checkbox, layer_name, max_zoom = initial_zoom){ | |
| if(is.character(checkbox)){ | |
| checkbox <- input[[checkbox]] | |
| } | |
| if(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 | |
| } | |
| } | |
| } | |
| } | |
| # Note: options in layers_ref table applies to circle, line, file (and symbol) | |
| # If a key is found in layers_ref it defaults to NULL | |
| # pass all possible arguments to create observation and manage types in add_* functions | |
| create_observation <- function(checkbox, | |
| layer_name, | |
| reactive_data, | |
| map = "map", | |
| i, | |
| ...){ | |
| ## TODO add if statement for tss_data and openbusstops symbol layers ---- | |
| 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, | |
| tooltip = eval(layers_ref$options[[i]]$tooltip), | |
| circle_color = eval(layers_ref$options[[i]]$circle_color), | |
| circle_radius = eval(layers_ref$options[[i]]$circle_radius), | |
| circle_stroke_color = eval(layers_ref$options[[i]]$circle_stroke_color), | |
| circle_opacity = eval(layers_ref$options[[i]]$circle_opacity), | |
| circle_stroke_width = eval(layers_ref$options[[i]]$`circle_stroke_width`), | |
| # ... | |
| ) | |
| } else if(st_dimension(reactive_data[1, ]) == 1){ | |
| add_lines(m, | |
| data = reactive_data, | |
| group = layer_name, | |
| tooltip = eval(layers_ref$options[[i]]$tooltip), | |
| line_color = eval(layers_ref$options[[i]]$line_color), | |
| line_width = eval(layers_ref$options[[i]]$line_width), | |
| line_dasharray = eval(layers_ref$options[[i]]$line_dasharray) | |
| # ... | |
| ) | |
| } else if(st_dimension(reactive_data[1, ]) == 2){ | |
| add_polygons(m, | |
| data = reactive_data, | |
| group = layer_name, | |
| tooltip = eval(layers_ref$options[[i]]$tooltip), | |
| fill_color = eval(layers_ref$options[[i]]$fill_color), | |
| fill_opacity = eval(layers_ref$options[[i]]$fill_opacity), | |
| fill_outline_color = eval(layers_ref$options[[i]]$fill_outline_color), | |
| fill_antialias = eval(layers_ref$options[[i]]$fill_antialias) | |
| # ... | |
| ) | |
| } | |
| if(layer_name != "tss_data" & input$chkbox_TSSChecklist){ | |
| 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() | |
| # Note: see observeEvent(hov_reac_d()) | |
| ### 2. all data layers except tss_data ---- | |
| # assume #1 is layers_ref$data_name == "tsschecklist_data" | |
| for(i in 1:nrow(layers_ref)){ | |
| if(layers_ref$data_name[[i]] == "tsschecklist_data") next | |
| else | |
| rlang::inject({ | |
| datav[[layers_ref$data_name[[!!i]]]] <- | |
| reactive({ | |
| create_reactive_data(layers_ref$checkbox_name[[!!i]], | |
| layers_ref$layer_name[[!!i]]) | |
| }) | |
| }) | |
| } | |
| ### 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')" | |
| ) | |
| ) | |
| } | |
| } | |
| } | |
| ) | |
| # Initialize map ---- | |
| output$map <- renderMaplibre({ | |
| maplibre( | |
| style = carto_style("voyager") | |
| ) |> | |
| fly_to(center = map_start, zoom = initial_zoom) | |
| }) | |
| # observe reactive data ---- | |
| ## 3. all data observations ---- | |
| # Pass i to create observation to reference layers_ref for options | |
| for(i in 1:nrow(layers_ref)){ | |
| if(layers_ref$data_name[[i]] %in% c("tsschecklist_data", "openbusbusstops_data")) next | |
| else | |
| rlang::inject({ | |
| observe({ | |
| create_observation( | |
| checkbox = input[[ layers_ref$checkbox_name[[!!i]] ]], #input[[string]] | |
| layer_name = layers_ref$layer_name[[!!i]], # string | |
| reactive_data = datav[[ layers_ref$data_name[[!!i]] ]](), | |
| i = !!i | |
| ) | |
| }) | |
| }) | |
| } | |
| # m <- maplibre_proxy("map") |> clear_layer("dft_counts_symbols") |> add_symbol_layer(id = "dft_counts_symbols", | |
| # # source_layer = "dftcounts_data", | |
| # source = "dftcounts_data", | |
| # text_field = number_format("all_motor_vehicles")) | |
| # }) | |
| ### observe openbusstops_data ---- | |
| observe({ | |
| m <- maplibre_proxy("map") |> clear_layer("openbusstops_data") | |
| if(input$chkbox_OpenBusBusStops & !is.null(datav$`openbusbusstops_data`()) && | |
| nrow(datav$`openbusbusstops_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 = datav$`openbusbusstops_data`(), | |
| icon_image = "busstop", | |
| icon_allow_overlap = TRUE, | |
| icon_size = interpolate( | |
| column = "Total_ph", | |
| # type = "linear", | |
| # values = c( 8, 10, 15, 20, 30, 35, 40, 100), | |
| # stops = c(0.05, 0.1, 0.125, 0.155, 0.175, 0.19, 0.2, 0.21) | |
| type = list("exponential", 10), | |
| values = c(1:100), | |
| stops = c(1:100)/200 | |
| ), | |
| 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"), | |
| text_field = get_column("Total_ph"), | |
| text_halo_color = "orange", | |
| text_halo_width = 1, | |
| text_color = "white", | |
| text_offset = c(0, 1), | |
| text_allow_overlap = TRUE, | |
| text_font = list("Noto Sans Regular") # must include for openfreemaps!! | |
| ) | |
| } | |
| }) | |
| ### 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" | |
| } | |
| 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 |> | |
| 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 | |
| ) | |
| ) | |
| } else { | |
| m |> clear_legend() | |
| } | |
| }) | |
| # observe events ---- | |
| observeEvent(input$toggle_layers, { | |
| if(input$toggle_layers == "Default"){ | |
| on_list <- c("chkbox_TSSChecklist", | |
| "chkbox_DfTCounts", | |
| "chkbox_GEOEducation", | |
| "chkbox_OpenBusBusStops") | |
| map(layers_ref$checkbox_name, \(x) updateCheckboxInput( | |
| session, x, | |
| value = if_else(x %in% on_list,TRUE,FALSE) | |
| ) | |
| ) | |
| } else if(input$toggle_layers == "On"){ | |
| map(layers_ref$checkbox_name, \(x) updateCheckboxInput(session, x, value = TRUE)) | |
| } else if(input$toggle_layers == "Off"){ | |
| map(layers_ref$checkbox_name, \(x) updateCheckboxInput(session, x, value = FALSE)) | |
| } | |
| } | |
| ) | |
| ### 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 = openfreemap_style("liberty")) | |
| # 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 == ""){ | |
| 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 | |
| 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$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. " | |
| ) | |
| } | |
| # datav[["tsschecklist_data"]]() |> unlist() | |
| # tss_data() |> unlist() | |
| }) | |
| # 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