add derive_grid() to generate grids from INSPIRE IDs (#3)

DESCRIPTION

@@ -1,9 +1,12 @@
 Package: gridmaker
 Title: Create INSPIRE-compliant grids with IDs
 Version: 0.1.0
-Authors@R: 
+Authors@R: c(
     person("Egor", "Kotov", , "kotov.egor@gmail.com", role = c("aut", "cre", "cph"),
-           comment = c(ORCID = "0000-0001-6690-5345"))
+           comment = c(ORCID = "0000-0001-6690-5345")),
+    person("Jonas", "Lieth", , "jslth@outlook.com", role = "ctb",
+           comment = c(ORCID = "0000-0002-3451-3176"))
+           )
 Description: Creates GISCO compatible and INSPIRE-compliant grids with IDs
     that look like 'CRS3035RES1000mN3497000E4448000' or '1kmN3497E4447'.
     Input can be 'sf', 'sfc' objects or bounding boxes. Output can be 'sf'

NAMESPACE

@@ -1,3 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export(create_grid)
+export(derive_grid)
+export(inspire_convert)
+export(inspire_extract)
+export(inspire_generate)

R/as_grid.R

@@ -0,0 +1,108 @@
+as_grid <- function(
+    coords,
+    cellsize,
+    crs,
+    output_type = "sf_polygons",
+    point_type = "centroid",
+    clipping_target = NULL
+) {
+  out_obj <- switch(
+    output_type,
+    sf_polygons = as_grid_polygons(
+      coords,
+      cellsize = cellsize,
+      crs = crs,
+      clipping_target = clipping_target
+    ),
+    sf_points = as_grid_points(
+      coords,
+      cellsize = cellsize,
+      crs = crs,
+      point_type = point_type
+    ),
+    dataframe = as_grid_coordinates(coords, cellsize = cellsize)
+  )
+
+  if (!is.null(clipping_target) && !identical(output_type, "sf_polygons")) {
+    # For filtering, we always use centroids as the representative point
+    points_for_filter <- sf::st_as_sf(
+      data.frame(
+        x = coords$X_LLC + (cellsize / 2),
+        y = coords$Y_LLC + (cellsize / 2)
+      ),
+      coords = c("x", "y"),
+      crs = crs
+    )
+    keep_indices <- sf::st_intersects(
+      points_for_filter,
+      clipping_target,
+      sparse = FALSE
+    )
+    out_obj <- out_obj[keep_indices[, 1], ]
+  }
+
+  out_obj
+}
+
+
+
+as_grid_polygons <- function(coords, cellsize, crs, clipping_target = NULL) {
+  n_polygons <- nrow(coords)
+  x_llc_rep <- rep(coords$X_LLC, each = 5)
+  y_llc_rep <- rep(coords$Y_LLC, each = 5)
+  x_coords_poly <- x_llc_rep + c(0, cellsize, cellsize, 0, 0)
+  y_coords_poly <- y_llc_rep + c(0, 0, cellsize, cellsize, 0)
+
+  df_vertices <- data.frame(
+    id = rep(seq_len(n_polygons), each = 5),
+    x = x_coords_poly,
+    y = y_coords_poly
+  )
+  grid_geoms <- sfheaders::sf_polygon(
+    obj = df_vertices,
+    x = "x",
+    y = "y",
+    polygon_id = "id"
+  )
+  grid_sf <- sf::st_sf(geometry = grid_geoms, crs = crs)
+  grid_sf$X_LLC <- coords$X_LLC
+  grid_sf$Y_LLC <- coords$Y_LLC
+
+  if (!is.null(clipping_target)) {
+    intersects_list <- sf::st_intersects(grid_sf, clipping_target)
+    keep_indices <- lengths(intersects_list) > 0
+    grid_sf <- grid_sf[keep_indices, ]
+  }
+
+  grid_sf
+}
+
+
+as_grid_points <- function(
+    coords,
+    cellsize,
+    crs,
+    point_type = "centroid"
+) {
+  coords_to_use <- if (point_type == "centroid") {
+    list(
+      x = coords$X_LLC + (cellsize / 2),
+      y = coords$Y_LLC + (cellsize / 2),
+      names = c("X_centroid", "Y_centroid")
+    )
+  } else {
+    # llc
+    list(x = coords$X_LLC, y = coords$Y_LLC, names = c("X_LLC", "Y_LLC"))
+  }
+  points_df <- data.frame(x = coords_to_use$x, y = coords_to_use$y)
+  out_obj <- sf::st_as_sf(points_df, coords = c("x", "y"), crs = crs)
+  # Re-attach all original attributes for consistency
+  cbind(out_obj, coords)
+}
+
+
+as_grid_coordinates <- function(coords, cellsize) {
+  coords$X_centroid <- coords$X_LLC + (cellsize / 2)
+  coords$Y_centroid <- coords$Y_LLC + (cellsize / 2)
+  coords
+}

R/backend_future.R

@@ -79,7 +79,7 @@ run_parallel_future <- function(grid_extent, cellsize_m, crs, dot_args) {
     .f = ~ {
       args_for_tile <- c(list(grid_extent = .x), all_args)
       args_for_tile$clip_to_input <- FALSE
-      chunk <- do.call(gridmaker:::create_grid_internal, args_for_tile)
+      chunk <- do.call(create_grid_internal, args_for_tile)
       if (nrow(chunk) > 0 && !is.null(clipping_target)) {
         intersects_indices <- sf::st_intersects(chunk, clipping_target)
         chunk <- chunk[lengths(intersects_indices) > 0, ]

R/backend_mirai.R

@@ -85,15 +85,16 @@ run_parallel_mirai <- function(grid_extent, cellsize_m, crs, dot_args) {
     function(tile_bbox) {
       args_for_tile <- c(list(grid_extent = tile_bbox), all_args)
       args_for_tile$clip_to_input <- FALSE
-      chunk <- do.call(gridmaker:::create_grid_internal, args_for_tile)
+      chunk <- do.call(create_grid_internal, args_for_tile)
       if (nrow(chunk) > 0 && !is.null(clipping_target)) {
         intersects_indices <- sf::st_intersects(chunk, clipping_target)
         chunk <- chunk[lengths(intersects_indices) > 0, ]
       }
       if (nrow(chunk) == 0) NULL else chunk
     },
     all_args = all_args,
-    clipping_target = clipping_target
+    clipping_target = clipping_target,
+    create_grid_internal = create_grid_internal
   )
 
   grid_chunks <- purrr::map(tile_bboxes, parallel_worker, .progress = !quiet)

R/backend_sequential.R

@@ -185,77 +185,14 @@ create_grid_internal <- function(
   }
 
   # --- 7. HANDLE OUTPUT TYPE ---
-  if (output_type == "sf_polygons") {
-    # --- 7a. SF POLYGON OUTPUT ---
-    n_polygons <- nrow(grid_df)
-    x_llc_rep <- rep(grid_df$X_LLC, each = 5)
-    y_llc_rep <- rep(grid_df$Y_LLC, each = 5)
-    x_coords_poly <- x_llc_rep + c(0, cellsize_m, cellsize_m, 0, 0)
-    y_coords_poly <- y_llc_rep + c(0, 0, cellsize_m, cellsize_m, 0)
-
-    df_vertices <- data.frame(
-      id = rep(seq_len(n_polygons), each = 5),
-      x = x_coords_poly,
-      y = y_coords_poly
-    )
-    grid_geoms <- sfheaders::sf_polygon(
-      obj = df_vertices,
-      x = "x",
-      y = "y",
-      polygon_id = "id"
-    )
-    grid_sf <- sf::st_sf(geometry = grid_geoms, crs = grid_crs)
-    grid_sf$X_LLC <- grid_df$X_LLC
-    grid_sf$Y_LLC <- grid_df$Y_LLC
-
-    if (!is.null(clipping_target)) {
-      intersects_list <- sf::st_intersects(grid_sf, clipping_target)
-      keep_indices <- lengths(intersects_list) > 0
-      grid_sf <- grid_sf[keep_indices, ]
-    }
-    out_obj <- grid_sf
-  } else {
-    # --- 7b. SF POINTS OR DATAFRAME OUTPUT ---
-    if (output_type == "sf_points") {
-      coords_to_use <- if (point_type == "centroid") {
-        list(
-          x = grid_df$X_LLC + (cellsize_m / 2),
-          y = grid_df$Y_LLC + (cellsize_m / 2),
-          names = c("X_centroid", "Y_centroid")
-        )
-      } else {
-        # llc
-        list(x = grid_df$X_LLC, y = grid_df$Y_LLC, names = c("X_LLC", "Y_LLC"))
-      }
-      points_df <- data.frame(x = coords_to_use$x, y = coords_to_use$y)
-      out_obj <- sf::st_as_sf(points_df, coords = c("x", "y"), crs = grid_crs)
-      # Re-attach all original attributes for consistency
-      out_obj <- cbind(out_obj, grid_df)
-    } else {
-      # dataframe
-      grid_df$X_centroid <- grid_df$X_LLC + (cellsize_m / 2)
-      grid_df$Y_centroid <- grid_df$Y_LLC + (cellsize_m / 2)
-      out_obj <- grid_df
-    }
-
-    if (!is.null(clipping_target)) {
-      # For filtering, we always use centroids as the representative point
-      points_for_filter <- sf::st_as_sf(
-        data.frame(
-          x = grid_df$X_LLC + (cellsize_m / 2),
-          y = grid_df$Y_LLC + (cellsize_m / 2)
-        ),
-        coords = c("x", "y"),
-        crs = grid_crs
-      )
-      keep_indices <- sf::st_intersects(
-        points_for_filter,
-        clipping_target,
-        sparse = FALSE
-      )
-      out_obj <- out_obj[keep_indices[, 1], ]
-    }
-  }
+  out_obj <- as_grid(
+    grid_df,
+    cellsize = cellsize_m,
+    crs = grid_crs,
+    output_type = output_type,
+    point_type = point_type,
+    clipping_target = clipping_target
+  )
 
   # --- 8. ADD ID & CLEAN UP COLUMNS ---
   if (nrow(out_obj) == 0) {
@@ -309,3 +246,4 @@ create_grid_internal <- function(
 
   return(out_obj)
 }
+

R/derive_grid.R

@@ -0,0 +1,49 @@
+#' Convert INSPIRE IDs into a spatial grid
+#'
+#' @description{
+#' This function takes a vector of INSPIRE-compliant IDs and derives a
+#' regular spatial grid from it. For generating a spatial grid from a spatial
+#' extent, see \code{\link{create_grid}}.}
+#' @param ids A vector containing character strings of INSPIRE-compliant IDs.
+#'   Can be either short or long INSPIRE IDs.
+#' @param point_type A character string, used only when `output_type = "sf_points"`.
+#'   Determines the location of the points: `"centroid"` for the center
+#'   of the cell, or `"llc"` (default) for the lower-left corner.
+#'
+#' @inherit create_grid
+#'
+#' @export
+#'
+#' @examples
+#' library(sf)
+#'
+#' inspire <- c(
+#'   "CRS3035RES100000mN26E43", "CRS3035RES100000mN26E44",
+#'   "CRS3035RES100000mN27E41", "CRS3035RES100000mN27E42",
+#'   "CRS3035RES100000mN27E43", "CRS3035RES100000mN27E44"
+#' )
+#'
+#' grid <- derive_grid(inspire)
+#' plot(grid$geometry)
+derive_grid <- function(
+    ids,
+    point_type = c("llc", "centroid"),
+    output_type = c("sf_polygons", "sf_points", "dataframe"),
+    include_llc = TRUE,
+    parallel = FALSE,
+    quiet = FALSE
+) {
+  if (!isFALSE(parallel)) {
+    warning("Parallel processing is not yet supported for `derive_grid()`.")
+  }
+
+  if (!is.logical(quiet) || length(quiet) != 1) {
+    stop(
+      "'quiet' must be a single logical value (TRUE or FALSE).",
+      call. = FALSE
+    )
+  }
+
+  backend_args <- list(point_type = point_type, output_type = output_type)
+  do.call(derive_grid_internal, c(list(ids = ids), backend_args))
+}

R/derive_grid_sequential.R

@@ -0,0 +1,59 @@
+derive_grid_internal <- function(
+  ids,
+  point_type = c("llc", "centroid"),
+  output_type = c("sf_polygons", "sf_points", "dataframe"),
+  quiet = FALSE
+) {
+  output_type <- match.arg(output_type)
+  point_type <- match.arg(point_type)
+
+  if (!requireNamespace("sf", quietly = TRUE)) {
+    stop("The 'sf' package is required. Please install it.", call. = FALSE)
+  }
+
+  if (
+    output_type == "sf_polygons" &&
+      !requireNamespace("sfheaders", quietly = TRUE)
+  ) {
+    stop(
+      "Package 'sfheaders' is required for 'sf' output. Please install it.",
+      call. = FALSE
+    )
+  }
+
+  grid_df <- inspire_extract(ids, as_sf = FALSE)
+  names(grid_df) <- c("crs", "cellsize", "Y_LLC", "X_LLC")
+
+  if (length(unique(grid_df$crs)) > 1) {
+    stop(
+      "Invalid CRS: Multiple coordinate reference systems found. Please ensure that all INSPIRE IDs have the same CRS.",
+      call. = FALSE
+    )
+  }
+
+  if (length(unique(grid_df$cellsize)) > 1) {
+    stop(
+      "Invalid cell size: Multiple different cell sizes found. Please ensure that all INSPIRE IDs refer to the same cell size.",
+      call. = FALSE
+    )
+  }
+
+  grid_crs <- sf::st_crs(grid_df$crs[[1]])
+  if (is.na(grid_crs) || sf::st_is_longlat(grid_crs)) {
+    stop(
+      "Invalid CRS: The coordinate reference system must be a projected system (e.g., EPSG:3035) and not a geographic one (like WGS84, EPSG:4326).",
+      call. = FALSE
+    )
+  }
+
+  out_obj <- as_grid(
+    grid_df,
+    cellsize = grid_df$cellsize[[1]],
+    crs = grid_crs,
+    output_type = output_type,
+    point_type = point_type
+  )
+
+  out_obj$id <- ids
+  out_obj
+}