345 lines
11 KiB
R
345 lines
11 KiB
R
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 = "<br><br><b>Straftat<b>",
|
|
tickangle = 0,
|
|
ticklabeloverflow = "allow"
|
|
),
|
|
yaxis = list(
|
|
title = "<b>Anzahl erfasster Fälle<b>"
|
|
),
|
|
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 = "<b>Anzahl erfasster Fälle<b>"
|
|
),
|
|
yaxis = list(
|
|
title = "<b>Straftat<b>",
|
|
tickangle = "-90"
|
|
),
|
|
legend = list(
|
|
orientation = "h",
|
|
x = 0.5,
|
|
itemwidth = 40,
|
|
xanchor = "center",
|
|
yanchor = "top",
|
|
valign = "top"
|
|
)
|
|
) %>%
|
|
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
|
|
})
|
|
|
|
} |