shiny-app/IT Shiny App.R

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)