R/list_codes.R

In DEplotting: Visualization Tools for German Regional Data

#' Look Up Administrative Codes (AGS) for German Regions
#'
#' Displays an interactive table for identifying official administrative codes (AGS) of municipalities (Gemeinden), districts (Kreise), and federal states (Länder) in Germany. The function loads and processes shapefiles for a given year, merges them across administrative levels, and presents a searchable datatable with names and AGS codes for each region.
#' 
#' @param year Integer. Year of the geodata (must be between 1998 and 2022).
#'
#' @return A \code{DT::datatable} object showing merged geospatial metadata with municipality, district, and state names and their respective AGS codes.
#' 
#' @export
#' 
#' @importFrom DT datatable
#' @importFrom dplyr select rename mutate filter distinct inner_join all_of
#' @importFrom magrittr %>%
#' @importFrom rlang sym
#' @importFrom sf st_read st_drop_geometry
#' 
#' @encoding UTF-8
#'
#' @examples
#' \donttest{
#' list_codes(year = 2022)
#' }
list_codes <- function(year) {
  
  # Validate year input
  if (year < 1998) {
    stop("Data is available only from 1998.")
  }
  
  #! NOTE: Code structure may need to be maintained annually.
  ##  attribute name based on the year
  attribute <- if (year >= 1998 & year <= 2002) {
    "SHN"
  } else if (year >= 2003 & year <= 2012) {
    "AGS"
  } else if (year >= 2013 & year <= 2022) {
    "AGS_0"
  } else {
    stop("Data is available only from 1998 to 2022.")
  }
  
  # Check if shapefiles for the given year exist
  geo_dir <- file.path(tools::R_user_dir("DEplotting", "data"), paste0("vg250_", year))
  if (!dir.exists(geo_dir) || length(list.files(geo_dir, recursive = TRUE)) == 0) {
    stop(paste0(
      "Geodata for year ", year, " not found. ",
      "Please run download_geo(", year, ", ", year, ") to download it, ",
      "or run download_geo() to check if there are other missing years in your Geodata folder."
    ))
  }
  
  # Load GEODATA Shapefiles
  get_shapefile_path <- function(year, layer) {
    # Base directory inside the package's extdata
    base_dir <- file.path(tools::R_user_dir("DEplotting", "data"), paste0("vg250_", year))
    
    #! NOTE: Code structure may need to be maintained annually.
    # Determine directory structure based on year
    dir_part <- if (year >= 2019) {
      file.path("vg250_12-31.gk3.shape.ebenen", "vg250_ebenen_1231")
    } else if (year >= 2015 && year <= 2018) {
      file.path(paste0("vg250_", year, "-12-31.gk3.shape.ebenen"), "vg250_ebenen")
    } else if (year >= 2012 && year <= 2014) {
      file.path("vg250_3112.gk3.shape.ebenen", "vg250_ebenen")
    } else if (year >= 1998 && year <= 2011) {
      file.path(paste0("vg250_", year, "-12-31.gk3.shape.ebenen"),
                paste0("vg250_ebenen-historisch/de", substr(as.character(year), 3, 4), "12"))
    } else {
      stop("Unsupported year: ", year)
    }
    
    #! NOTE: Code structure may need to be maintained annually.
    # Determine filename based on year and layer
    if (year >= 2013) {
      prefix <- "VG250_"
      suffix <- layer
    } else if (year == 2012) {
      prefix <- "vg250_"
      suffix <- switch(layer,
                       "LAN" = "bld",
                       "KRS" = "krs",
                       "GEM" = "gem",
                       stop("Invalid layer for 2012")
      )
    } else if (year >= 2003 && year <= 2011) {
      prefix <- "vg250_"
      suffix <- switch(layer,
                       "LAN" = "bld",
                       tolower(layer)
      )
    } else if (year >= 1998 && year <= 2002) {
      prefix <- "vg250"
      suffix <- switch(layer,
                       "LAN" = "lnd",
                       tolower(layer)
      )
    }
    
    filename <- paste0(prefix, suffix, ".shp")
    
    # Return the full path
    return(file.path(base_dir, dir_part, filename))
  }
  
  # Load shapefiles using the generalized function
  load_shapefile <- function(year, layer) {
    path <- get_shapefile_path(year, layer)
    st_read(path, quiet = TRUE)
  }
  
  # Usage
  vg250_lan <- load_shapefile(year, "LAN")
  vg250_krs <- load_shapefile(year, "KRS")
  vg250_gem <- load_shapefile(year, "GEM")
  
  
  ### Process shapefiles based on the year
  process_vg_data <- function(data, attribute, year) {
    
    selected_columns <- c("GEN", attribute)
    #### Add GF and BSG if they exist in the data
    if ("GF" %in% names(data)) {
      selected_columns <- c(selected_columns, "GF")
    }
    if ("BSG" %in% names(data)) {
      selected_columns <- c(selected_columns, "BSG")
    }
    
    processed_data <- data %>%
      dplyr::select(all_of(selected_columns)) %>%
      dplyr::rename(Name = GEN, AGS = !!rlang::sym(attribute))
    
    #! NOTE: Code structure may need to be maintained annually.
    #### Apply year-specific filters
    if (year >= 1998 & year <= 2002) {
      processed_data <- processed_data %>%
        dplyr::mutate(AGS = paste0(substr(AGS, 1, 5), substr(AGS, 8, 10)))
    } else {
      if ("GF" %in% names(processed_data)) {
        processed_data <- processed_data %>%
          dplyr::filter(GF == 4)
      }
      if ("BSG" %in% names(processed_data)) {
        processed_data <- processed_data %>%
          dplyr::filter(BSG == 1)
      }
    }
    
    #### Remove duplicates based on AGS only, keep first occurrence
    processed_data <- processed_data %>%
      dplyr::distinct(AGS, .keep_all = TRUE)
    
    return(processed_data)
  }
  
  vg250_krs <- process_vg_data(vg250_krs, attribute, year)
  vg250_lan <- process_vg_data(vg250_lan, attribute, year)
  vg250_gem <- process_vg_data(vg250_gem, attribute, year)
  
  # Prepare the data for merging
  vg250_gem <- vg250_gem %>%
    mutate(AGS_Kreis = paste0(substr(AGS, 1, nchar(AGS) - 3), "000")) %>%
    st_drop_geometry() %>%
    inner_join(
      vg250_krs %>%
        mutate(AGS_Kreis = substr(AGS, 1, 8)) %>%
        st_drop_geometry() %>%
        select(AGS_Kreis, Name_Kreis = Name),
      by = "AGS_Kreis"
    )  %>%
    mutate(AGS_Land = paste0(substr(AGS, 1, nchar(AGS) - 6), "000000")) %>%
    st_drop_geometry() %>%
    inner_join(
      vg250_lan %>%
        mutate(AGS_Land = substr(AGS, 1, 8)) %>%
        st_drop_geometry() %>%
        select(AGS_Land, Name_Land = Name),
      by = "AGS_Land"
    )
  
  vg250_gem <- vg250_gem %>%
    rename(
      Name_Gemeinde = Name,
      MAP_AGS_Gemeinde = AGS,
      MAP_AGS_Kreis = AGS_Kreis,
      MAP_AGS_Land = AGS_Land
    )
  
  # Example: Reordering columns in data_Gem
  vg250_gem <- vg250_gem %>%
    select(
      Name_Gemeinde,          # First column
      MAP_AGS_Gemeinde,                # Second column
      Name_Kreis,             # Third column
      MAP_AGS_Kreis,              # Fourth column
      Name_Land,              # Fifth column
      MAP_AGS_Land                # Sixth column
    )
  
  
  # Display the data in an interactive table
  DT::datatable(vg250_gem)
}