diff --git a/R/create_geo_output.R b/R/create_geo_output.R index d0d3447..c742b28 100644 --- a/R/create_geo_output.R +++ b/R/create_geo_output.R @@ -8,7 +8,7 @@ #' @param gpkg_file The name of the .gpkg-file. For example `baupub.gpkg`. #' @param sf_liegenschaften A shapefile containing the Liegenschaften-data #' geometry and metadata. -#' +#' #' @return Writes data to a GeoPackage file. Returns nothing. #' #' @export @@ -47,8 +47,6 @@ create_gpkg <- function(gpkg_file, df_bp, sf_liegenschaften) { } } - - #' Prepare Building Permit Data for Export as Spatial Features #' #' Converts building permit data into a spatial format with Swiss coordinate @@ -80,22 +78,20 @@ add_spatial_information <- function(df_bp, sf_liegenschaften) { return(sf_bp_geo) } - - #' Calculate Share of Non-Georeferenced Building Permits #' -#' Computes the percentage of building permit applications within a given date -#' range that do not contain valid geometries. This is useful for assessing -#' the completeness of spatial information in the dataset. +#' Computes the percentage of building permit applications within a given date +#' range that do not contain valid geometries. This is useful for assessing +#' the completeness of spatial information in the dataset. #' -#' @param sf_bp_geo An `sf` object containing building permit applications, +#' @param sf_bp_geo An `sf` object containing building permit applications, #' including a geometry column and a `publicationDate` attribute. -#' @param start_date A character string in the format "yyyy-mm-dd" specifying +#' @param start_date A character string in the format "yyyy-mm-dd" specifying #' the first day to include in the calculation. -#' @param end_date A character string in the format "yyyy-mm-dd" specifying +#' @param end_date A character string in the format "yyyy-mm-dd" specifying #' the last day to include in the calculation. #' -#' @return A numeric value representing the percentage of permits without valid +#' @return A numeric value representing the percentage of permits without valid #' geometries, rounded to two decimal places. #' #' @@ -104,19 +100,17 @@ add_spatial_information <- function(df_bp, sf_liegenschaften) { #' calc_geo_availability(sf_bp_geo, start_date = "2025-01-01", end_date = "2025-07-15") #' } calc_geo_availability <- function(sf_bp_geo, start_date, end_date) { - - sf_bp_geo <- sf_bp_geo |> - dplyr::mutate(publicationDate = as.Date(publicationDate)) |> - dplyr::filter(publicationDate >= as.Date(start_date) & - publicationDate <= as.Date(end_date)) - + + sf_bp_geo <- sf_bp_geo |> + dplyr::mutate(publicationDate = as.Date(publicationDate)) |> + dplyr::filter(publicationDate >= as.Date(start_date) & + publicationDate <= as.Date(end_date)) + share <- sum(!sf::st_is_empty(sf_bp_geo)) / nrow(sf_bp_geo) share <- round(share * 100, 2) return(share) - } - - +} #' Create an Interactive Leaflet Map of Building Permits #' @@ -132,7 +126,7 @@ calc_geo_availability <- function(sf_bp_geo, start_date, end_date) { #' @param start_date A character date in the format "yyyy-mm-dd" representing the #' first day for which data should be included. #' first day for which data should be included. -#' @param end_date A character date in the format "yyyy-mm-dd" representing the +#' @param end_date A character date in the format "yyyy-mm-dd" representing the #' the last day for which data should be included. #' @return A Leaflet map widget displaying the building permit polygons and #' associated information. @@ -143,34 +137,33 @@ calc_geo_availability <- function(sf_bp_geo, start_date, end_date) { #' \dontrun{ #' # creating a map of the last 20 days #' create_map(sf_bp_geo) -#' +#' #' # customize period of retrieval -#' sf_bp_geo |> +#' sf_bp_geo |> #' create_map(start_date = "20205-01-01", end_date = "2025-07-15") #' } -create_map <- function(sf_bp_geo, - start_date = as.character(Sys.Date()-20), +create_map <- function(sf_bp_geo, + start_date = as.character(Sys.Date() - 20), end_date = as.character(Sys.Date())) { - # Warnings if (start_date < "2025-01-01") { cli::cli_warn("There are no geo-referenced building permit applications before 2025-01-01.") } - sf_bp_geo <- sf_bp_geo |> + sf_bp_geo <- sf_bp_geo |> dplyr::filter(publicationDate >= start_date & publicationDate <= end_date) - + if (nrow(sf_bp_geo) == 0) { cli::cli_abort("There are no building permit application for this period.") } - + # find polygons that overlap (indexes of polygons) intersected_poly <- sf_bp_geo |> sf::st_intersects() # isolate the overlapping polygons that do not have the same index - # --> making sure publication 1 is not categorized as "overlapping with + # --> making sure publication 1 is not categorized as "overlapping with # publication 1" intersected_poly <- purrr::map(seq_along(intersected_poly), ~ { intersected_poly[[.x]][intersected_poly[[.x]] != .x] @@ -180,27 +173,27 @@ create_map <- function(sf_bp_geo, publicationNumber_intersected_poly <- purrr::map(intersected_poly, ~ { sf_bp_geo$publicationNumber[.x] }) - + # isolte url of overlapping polygons url_intersected_poly <- purrr::map(intersected_poly, ~ { sf_bp_geo$url[.x] }) - + # create hyperlinks url_intersected_poly_merged <- purrr::map2_chr(publicationNumber_intersected_poly, url_intersected_poly, ~ { paste("", .x, "", collapse = "
") }) - - url_intersected_poly_merged <- ifelse(url_intersected_poly_merged == " ", - "-", - url_intersected_poly_merged + + url_intersected_poly_merged <- ifelse(url_intersected_poly_merged == " ", + "-", + url_intersected_poly_merged ) - + # define enriched input for leaflet map sf_bp_geo_wgs84 <- sf_bp_geo |> sf::st_transform(crs = 4326) |> dplyr::mutate(popup_text = paste0( - " Meldungsnummer: ", publicationNumber, "", + " Meldungsnummer: ", publicationNumber, "", "
", "Publikationsdatum: ", publicationDate, "
", @@ -212,85 +205,91 @@ create_map <- function(sf_bp_geo, "
", url_intersected_poly_merged )) - + # calculate share of liegenschaften that could not be linked to a polygon - available_share <- calc_geo_availability(sf_bp_geo, start_date, end_date) |> - as.character() |> gsub(pattern = "\\.", replacement = ",") - observed_period <- paste0(format(as.Date(start_date), "%d.%m.%Y"), - " - " , - format(as.Date(end_date), "%d.%m.%Y")) - + available_share <- calc_geo_availability(sf_bp_geo, start_date, end_date) |> + as.character() |> + gsub(pattern = "\\.", replacement = ",") + observed_period <- paste0( + format(as.Date(start_date), "%d.%m.%Y"), + " - ", + format(as.Date(end_date), "%d.%m.%Y") + ) + # Define HTML for the infobox info.box <- htmltools::HTML(paste0( htmltools::HTML( '