get_map_layer_prefix <- function(text){ return(substring(text, 0, 4)) } get_map_layer_name <- function(text) { return(substring(text, 5)) } #Server handling user input and processing of data server <- function(input, output, session) { currently_selected_bezirk <- reactiveVal("") currently_selected_stadtteil <- reactiveVal("") currently_selected_maptype <- reactiveVal("Bezirke") currently_selected_heatmap_crime <- reactiveVal("Allgemeine Verstöße gem. § 29 BtMG -Konsumentendelikte-") currently_compared_location <- reactiveVal(c("")) currently_compared_crimes <- reactiveVal(c("")) currently_compared_year <- reactiveVal(c("2024", "2023")) # 1. Aktualisieren der Auswahlmöglichkeiten mit den extrahierten Schlüsselnamen updateSelectizeInput( session = session, inputId = "search", choices = auswahlmöglichkeiten, selected = "" ) observeEvent(input$search, { req(input$search) currently_selected_bezirk(get_bezirk_by_stadtteil(input$search)) currently_selected_stadtteil(input$search) }) observeEvent(input$heatmap, { currently_selected_heatmap_crime(input$heatmap) }) observeEvent(input$rd_maptype, { currently_selected_maptype(input$rd_maptype) }) observeEvent(input$vergleichs_jahr, { currently_compared_year(input$vergleichs_jahr) }) observe({ maptype <- currently_selected_maptype() heatmap <- currently_selected_heatmap_crime() mapproxy <- leafletProxy("hhmap") clearGroup(mapproxy, "selected") clearGroup(mapproxy, "layer_heatmap") # Entfernt eine eventuell existierende Legende vom vorherigen Durchlauf removeControl(mapproxy, "heatmap_legend") if (heatmap != "") { hideGroup(mapproxy, "layer_bezirke") hideGroup(mapproxy, "layer_stadtteile") #---Create heatmap---- heatmap_polygons <- if(maptype == "Bezirke") { geo_bezirke %>% mutate(bezirke_join = paste("Bezirk", bezirk)) %>% left_join(get_intensity_df(crime_json, heatmap), by = c("bezirke_join" = "stadtteil")) } else { geo_stadtteile %>% left_join(get_intensity_df(crime_json, heatmap), by = "stadtteil") } pal <- colorNumeric( palette = "YlOrRd", domain = heatmap_polygons$intensity, na.color = "transparent", alpha = 1 ) addPolygons(mapproxy, data = heatmap_polygons, layerId = paste("heat_", heatmap_polygons$leaflet_id, sep = ""), group = "layer_heatmap", label = get_map_layer_name(heatmap_polygons$leaflet_id), color = "#003063", fillColor = ~pal(heatmap_polygons$intensity), weight = 3, fillOpacity = 0.8, highlightOptions = highlightOptions( weight = 6, bringToFront = TRUE ), ) pal_legend <- colorNumeric( palette = "YlOrRd", domain = heatmap_polygons$intensity )# Legende hinzufügen addLegend(mapproxy, pal = pal_legend, opacity = 0.8, values = heatmap_polygons$intensity, title = paste("Fallzahlen:", heatmap), position = "bottomright", layerId = "heatmap_legend" # Wichtig zum gezielten Entfernen ) #--------------------- } else { 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)) { if(click_event$group == "selected") { # Clicked on an already selected area of the map therefore we unselect. currently_selected_bezirk("") currently_selected_stadtteil("") leafletProxy("hhmap") %>% clearGroup("selected") return() } # The ID of the clicked polygon clicked_polygon_id <- click_event$id clicked_polygon_id <- sub("^heat_", "", clicked_polygon_id) prefix <- get_map_layer_prefix(clicked_polygon_id) rest_of_name <- get_map_layer_name(clicked_polygon_id) selected_polygon_data <- NULL if (prefix == "bez_") { currently_selected_bezirk(rest_of_name) currently_selected_stadtteil(paste("Bezirk", rest_of_name)) selected_polygon_data <- geo_bezirke[geo_bezirke[["leaflet_id"]] == clicked_polygon_id,] } if(prefix == "std_") { currently_selected_bezirk(get_bezirk_by_stadtteil(rest_of_name)) currently_selected_stadtteil(rest_of_name) selected_polygon_data <- geo_stadtteile[geo_stadtteile[["leaflet_id"]] == clicked_polygon_id,] } req(selected_polygon_data) #neues Polygon über die anderen legen, wenn ein bezirk angeklickt wurde leafletProxy("hhmap") %>% clearGroup("selected") %>% addPolygons( data = selected_polygon_data, layerId = id, label = selected_polygon_data$bezirk, color = "#003063", fillOpacity = 0.2, weight = 4, group = "selected" ) } }) output$hhmap <- renderLeaflet({ leaflet() %>% addProviderTiles(providers$CartoDB.Positron) %>% addPolygons( data = geo_bezirke, layerId = ~leaflet_id, group = "layer_bezirke", label = get_map_layer_name(geo_bezirke$leaflet_id), color = "#003063", fillOpacity = 0.2, # Polygon fill transparency highlightOptions = highlightOptions( fillOpacity = 0.4, color = "#003063", weight = 4, bringToFront = TRUE ), ) %>% addPolygons( data = geo_stadtteile, group = "layer_stadtteile", label = get_map_layer_name(geo_stadtteile$leaflet_id), layerId = ~leaflet_id, color = "#003063", options = pathOptions(pane = "overlayPane"), # Use a leaflet option to ensure it's hidden weight = 3, fillOpacity = 0.2, # Polygon fill transparency highlightOptions = highlightOptions( fillOpacity = 0.4, color = "#003063", weight = 4, bringToFront = TRUE ), ) %>% setView( lng = 9.98716634776887, lat = 53.5488439196432, zoom = 11 ) }) output$txt_map_selection_bezirk <- renderUI({ bez <- currently_selected_bezirk() req(bez) # tags$h5( # style = "margin-top: 10px; margin-bottom: 2px; font-weight: 400;", # tags$strong("Bezirk:"), # tags$span(bez, style = "font-weight: 400;") # ) div(# Überschrift einfügen style = "margin-top: 5px; margin-bottom: 0px; display: flex; align-items: center; gap: 8px;", # Ganz wenig Abstand zum nächsten Element tags$span("Bezirk:", style = "font-weight: 700; font-size: 0.95rem;"), tags$span(bez, style = "font-weight: 400; font-size: 0.95rem;") ) }) output$txt_map_selection_stadtteil <- renderUI({ sdt <- currently_selected_stadtteil() req(sdt) # tags$h5( # style = "margin-top: 0px; margin-bottom: 20px; font-weight: 400;", # tags$strong("Stadtteil:"), # tags$span(sdt, style = "font-weight: 400;") # ) div( style = "margin-top: 2px; margin-bottom: 15px; display: flex; align-items: center; gap: 8px;", tags$span("Stadtteil:", style = "font-weight: 700; font-size: 0.95rem;"), tags$span(sdt, style = "font-weight: 400; font-size: 0.95rem;") ) }) output$grph_top3 <- renderPlotly({ data_tibble <- map_data_to_top3_plot( bezirk = currently_selected_bezirk(), stadtteil = currently_selected_stadtteil(), year = "2024" ) req(nrow(data_tibble) > 0) plot_ly( data = data_tibble, x = ~factor( str_wrap(Name, width = 15), levels = str_wrap(Name[order(-Erfasst)], width = 15) ), y = ~Erfasst, name = "Top 3", text = format(data_tibble$Erfasst, big.mark = ".", decimal.mark = ","), textposition = "outside", type = "bar", marker = list( color = c("#b8ecff", "#d5f4ff", "#e6f9ff") ) ) %>% layout( xaxis = list( title = "

Straftat", tickangle = 0, ticklabeloverflow = "allow" ), yaxis = list( title = "Anzahl erfasster Fälle" ), margin = list(b = 160, r = 60, pad = 5) ) %>% config( staticPlot = TRUE ) }) observeEvent(input$vergleich_location, { currently_compared_location(c(input$vergleich_location)) }) observeEvent(input$vergleich_straftat, { currently_compared_crimes(input$vergleich_straftat) }) output$vergleich_balkendiagramm <- renderPlotly({ data_tibble <- map_data_to_plot( locations = currently_compared_location(), crimes = currently_compared_crimes(), year = currently_compared_year() ) location_totals <- data_tibble %>% group_by(Location) %>% summarise(Total = sum(Erfasst)) %>% arrange(Total) data_tibble <- data_tibble %>% mutate(Location = factor(Location, levels = location_totals$Location)) wide_data <- data_tibble %>% pivot_wider(names_from = Name, values_from = Erfasst, values_fill = 0) first_loc <- levels(data_tibble$Location)[length(levels(data_tibble$Location))] crime_order <- wide_data %>% filter(Location == first_loc) %>% select(-Location) %>% t() %>% as.data.frame() %>% arrange(V1) %>% rownames() wide_data <- wide_data %>% select(Location, all_of(crime_order)) blue_palette <- colorRampPalette(tail(RColorBrewer::brewer.pal(8, "Blues"), 6)) plot <- plot_ly() %>% layout( barmode = 'group', colorway = blue_palette(6), xaxis = list( title = "Anzahl erfasster Fälle" ), yaxis = list( title = "Straftat", tickangle = "-90" ) ) %>% config( staticPlot = TRUE ) for(i in seq_along(crime_order)) { crime <- crime_order[i] plot <- plot %>% add_trace( x = wide_data[[crime]], y = wide_data$Location, name = crime, text = format(wide_data[[crime]], big.mark = ".", decimal.mark = ","), textposition = "outside", type = "bar", orientation = "h", legendrank = length(crime_order) - i ) } plot }) }