library(rjson) library(shiny) library(bslib) library(leaflet) library(sf) library(htmltools) library(dplyr) library(purrr) # Json of Crime Reports crime_json <- fromJSON(file="data.json") get_bezirk_by_stadtteil <- function(name) { parents <- names(crime_json)[sapply(crime_json, function(item) name %in% names(item))] if (length(parents) == 0) return(NULL) parents } map_data_to_table <- function(bezirk, stadtteil, year) { year <- as.character(trimws(year)) map_df(names(crime_json[[bezirk]][[stadtteil]]), function(crime) { row <- crime_json[[bezirk]][[stadtteil]][[crime]][[year]] tibble( Name = crime, `Erfasste Fälle` = as.integer(row[["Erfasste Fälle"]]), `Aufgeklärte Fälle` = as.integer(row[["Aufgeklärte Fälle"]]), `Aufklärung relativ` = row[["Aufklärung relativ"]] ) }) } #GeoJson for Bezirke geo_bezirke <- st_read("geobezirke-parsed.json") geo_bezirke <- st_transform(geo_bezirke, crs = 4326) geo_bezirke$leaflet_id <- paste("bez_", geo_bezirke$bezirk, sep="") #GeoJson for Stadtteile geo_stadtteile <- st_read("geostadtteile-parsed.json") geo_stadtteile <- st_transform(geo_stadtteile, crs = 4326) geo_stadtteile$leaflet_id <- paste("std_", geo_stadtteile$stadtteil, sep="") bezirke <- sort(names(crime_json)) #User interface definitions ui <- function() { page_fillable( page_sidebar( layout_columns( leafletOutput("hhmap"), card( textOutput("txt_map_selection_bezirk"), textOutput("txt_map_selection_stadtteil"), "2024", tableOutput("tbl_2024"), #"2023", #tableOutput("tbl_2023"), ), col_widths = c(7, 5), ), sidebar = sidebar( radioButtons( inputId = "rd_maptype", label = "Kartentyp", choices = c("Bezirke", "Stadtteile"), selected = "Bezirke" ), selectInput( inputId = "drp_bezirk", label = "Bezirk", choices = bezirke ), selectInput( inputId = "drp_stadtteil", label = "Stadtteil", choices = NULL, ), ), ), ) } currently_selected_bezirk <- "" currently_selected_stadtteil <- "" get_map_layer_prefix <- function(text){ return(substring(text, 0, 4)) } get_map_layer_name <- function(text) { return(substring(text, 5)) } update_selection_text <- function(output) { output$txt_map_selection_bezirk <- renderText({ paste("Bezirk:", currently_selected_bezirk) }) output$txt_map_selection_stadtteil <- renderText({ paste("Stadtteil:", currently_selected_stadtteil) }) } update_selection_table <- function(output) { output$tbl_2024 <- renderTable( map_data_to_table( bezirk = currently_selected_bezirk, stadtteil = currently_selected_stadtteil, year = "2024" ), striped = TRUE ) # output$tbl_2023 <- renderTable( # map_data_to_table( # bezirk = currently_selected_bezirk, # stadtteil = currently_selected_stadtteil, # year = "2023" # ), # striped = TRUE # ) } #Server handling user input and processing of data server <- function(input, output, session){ observeEvent(input$drp_bezirk, { sel_bezirk <- input$drp_bezirk if (sel_bezirk != "") { sel_stadtteile <- names(crime_json[[sel_bezirk]]) selected_stadtteil <- paste("Bezirk", sel_bezirk) updateSelectInput( session, inputId = "drp_stadtteil", choices = sort(sel_stadtteile), selected = selected_stadtteil, ) currently_selected_bezirk <<- sel_bezirk currently_selected_stadtteil <<- selected_stadtteil update_selection_text(output) update_selection_table(output) } }) observeEvent(input$drp_stadtteil, { sel_stadtteil <- input$drp_stadtteil if (sel_stadtteil != "") { currently_selected_stadtteil <<- sel_stadtteil update_selection_text(output) update_selection_table(output) } }) observeEvent(input$rd_maptype, { maptype <- input$rd_maptype mapproxy <- leafletProxy("hhmap") if (maptype == "Bezirke"){ hideGroup(mapproxy, "layer_stadtteile") showGroup(mapproxy, "layer_bezirke") } else { hideGroup(mapproxy, "layer_bezirke") showGroup(mapproxy, "layer_stadtteile") } }) observeEvent(input$hhmap_shape_click, { click_event <- input$hhmap_shape_click # Check if an ID was returned (meaning a polygon was clicked) if (!is.null(click_event$id)) { # The ID of the clicked polygon clicked_polygon_id <- click_event$id prefix <- get_map_layer_prefix(clicked_polygon_id) rest_of_name <- get_map_layer_name(clicked_polygon_id) if (prefix == "bez_") { currently_selected_bezirk <<- rest_of_name currently_selected_stadtteil <<- paste("Bezirk", rest_of_name) } if(prefix == "std_") { currently_selected_bezirk <<- get_bezirk_by_stadtteil(rest_of_name) currently_selected_stadtteil <<- rest_of_name } update_selection_text(output) update_selection_table(output) } }) output$hhmap <- renderLeaflet({ leaflet() %>% addProviderTiles(providers$CartoDB.Positron) %>% addPolygons( data = geo_bezirke, layerId = ~leaflet_id, group = "layer_bezirke", color = "#7bb5ab", fillColor = "#bdf0e7", weight = 1, fillOpacity = 0.4, # Polygon fill transparency highlightOptions = highlightOptions( color = "#103b57", weight = 4, bringToFront = TRUE ), ) %>% addPolygons( data = geo_stadtteile, group = "layer_stadtteile", layerId = ~leaflet_id, color = "#7bb5ab", fillColor = "#bdf0e7", options = pathOptions(pane = "overlayPane"), # Use a leaflet option to ensure it's hidden weight = 1, fillOpacity = 0.4, # Polygon fill transparency highlightOptions = highlightOptions( color = "#103b57", weight = 4, bringToFront = TRUE ), ) %>% setView( lng = 9.98716634776887, lat = 53.5488439196432, zoom = 11 ) }) update_selection_text(output) } options(shiny.host = '0.0.0.0') options(shiny.port = 8888) shinyApp(ui = ui, server = server)