PR: GDALG (#9)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gdalvector
 Title: Modern GDAL Vector Data Workflows
-Version: 0.0.3
+Version: 0.0.4
 Authors@R: 
     person("Jimmy", "Briggs", , "jimmy.briggs@jimbrig.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-7489-8787"))

R/gdal_gdalg.R

@@ -6,11 +6,54 @@
 #
 #  ------------------------------------------------------------------------
 
-# read write ------------------------------------------------------------------------------------------------------
 
-gdalg_read <- function(path, ...) {}
+# read ------------------------------------------------------------------------------------------------------------
 
-gdalg_write <- function(x, path, ...) {}
+gdalg_read <- function(path, ...) {
+  check_file(path, ext = "json")
+  validate_gdalg_file(path)
+  as_gdalg(read_json_file(path), .path = path)
+}
+
+
+# write -----------------------------------------------------------------------------------------------------------
+
+gdalg_write <- function(x, path, ..., overwrite = FALSE) {
+  check_gdalg(x)
+  command_line <- x$command_line
+  command_line_parsed <- gdalg_parse_command_line(command_line)
+  if (command_line_parsed[[1]] == "gdal") {
+    command_line_parsed <- command_line_parsed[-1]
+  }
+  alg_cmd <- paste(command_line_parsed[[1]], command_line_parsed[[2]], sep = " ")
+  alg_args <- c(
+    command_line_parsed[-c(1, 2)],
+    "!", "write", "--output", path, "--output-format", "GDALG",
+    if (overwrite) "--overwrite" else NULL
+  )
+  res <- rlang::try_fetch({
+    gdalg_alg <- gdalraster::gdal_alg(cmd = alg_cmd, alg_args, parse = FALSE)
+    gdalg_alg$run()
+  }, error = function(e) {
+    FALSE
+  }, finally = {
+    gdalg_alg$close()
+    gdalg_alg$release()
+  })
+  if (res && file.exists(path)) {
+    cli::cli_alert_success("GDALG written to {.file {path}}")
+    return(invisible(path))
+  }
+  FALSE
+}
+
+
+# parse -----------------------------------------------------------------------------------------------------------
+
+gdalg_parse_command_line <- function(command_line) {
+  tokens <- strsplit(command_line, "(?<!\\\\)\\s+(?=(?:[^\"]*\"[^\"]*\")*[^\"]*$)", perl = TRUE)[[1]]
+  gsub("^\"|\"$", "", tokens)
+}
 
 
 # coercion --------------------------------------------------------------------------------------------------------
@@ -61,9 +104,16 @@ as_gdalg.character <- function(x, ..., call = rlang::caller_env()) {
 }
 
 #' @export
-as_gdalg.list <- function(x, ..., call = rlang::caller_env()) {
-  # check_names(x, required = c("command_line", "gdal_version"))
-  # TODO
+as_gdalg.list <- function(x, ..., .path = NULL, call = rlang::caller_env()) {
+  check_names(x, required = c("type", "command_line", "gdal_version"))
+  type <- purrr::pluck(x, "type", .default = NA_character_)
+  if (!identical(type, "gdal_streamed_alg")) {
+    gdal_abort_check("Provided list must have {.field type} field equal to {.field \"gdal_streamed_alg\"}.", call = call)
+  }
+  cmd <- purrr::pluck(x, "command_line", .default = NULL)
+  ver <- purrr::pluck(x, "gdal_version", .default = gdal_version_num())
+  rel_paths <- purrr::pluck(x, "relative_paths_relative_to_this_file", .default = NULL)
+  new_gdalg(command_line = cmd, gdal_version = ver, relative_paths = rel_paths, .path = .path)
 }
 
 #' @export
@@ -75,18 +125,38 @@ as_gdalg.json <- function(x, ..., call = rlang::caller_env()) {
 # constructor -----------------------------------------------------------------------------------------------------
 
 new_gdalg <- function(command_line, relative_paths = TRUE, gdal_version = gdal_version_num(), .path = NULL) {
+
+  gdalg <- list(
+    type = "gdal_streamed_alg",
+    command_line = command_line,
+    gdal_version = as.character(gdal_version),
+    relative_paths_relative_to_this_file = relative_paths
+  ) |>
+    purrr::compact()
+
   structure(
-    list(
-      type = "gdal_streamed_alg",
-      command_line = command_line,
-      gdal_version = as.character(gdal_version),
-      relative_paths_relative_to_this_file = relative_paths
-    ),
+    gdalg,
     path = .path,
     class = c("gdalg", "list")
   )
 }
 
+
+# validate --------------------------------------------------------------------------------------------------------
+
+validate_gdalg_file <- function(x, schema = pkg_sys_schemas("gdalg.schema.json"), ..., call = rlang::caller_env()) {
+  res <- validate_json_schema(x, schema = schema, ..., call = call)
+  if (res) {
+    gdal_inform(c("v" = "Provided GDALG is valid against the GDALG schema"))
+    return(res)
+  }
+  attr(res, "errors")
+}
+
+validate_gdalg <- function(x, schema = pkg_sys_schemas("gdalg.schema.json"), ..., call = rlang::caller_env()) {
+  check_gdalg(x)
+}
+
 # format and print ------------------------------------------------------------------------------------------------
 
 #' @export
@@ -107,7 +177,4 @@ print.gdalg <- function(x, ...) {
   invisible(x)
 }
 
-gdalg_parse_command_line <- function(command_line) {
-  tokens <- strsplit(command_line, "(?<!\\\\)\\s+(?=(?:[^\"]*\"[^\"]*\")*[^\"]*$)", perl = TRUE)[[1]]
-  gsub("^\"|\"$", "", tokens)
-}
+

R/utils_checks.R

@@ -292,6 +292,15 @@ check_named2 <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_env
   invisible(x)
 }
 
+check_names <- function(x, required, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
+  check_named(x, arg = arg, call = call)
+  missing_names <- setdiff(required, names(x))
+  if (length(missing_names) > 0) {
+    check_abort("{.arg {arg}} is missing required names: {.field {missing_names}}.", call = call)
+  }
+  invisible(x)
+}
+
 # gdal ------------------------------------------------------------------------------------------------------------
 
 check_gdal_vector <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
@@ -345,6 +354,11 @@ check_open_opts <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_
   invisible(x)
 }
 
+check_gdalg <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
+  check_inherits(x, "gdalg", arg = arg, call = call)
+  invisible(x)
+}
+
 # assert a (non-NULL) option value is one of the driver's advertised values. the
 # allowed set is sourced from driver metadata by the caller (e.g. via
 # `gdal_driver_get_open_opts_values()`); an `NA`/empty set means unconstrained.
@@ -440,7 +454,20 @@ check_file <- function(x, ext = NULL, arg = rlang::caller_arg(x), call = rlang::
   }
   ext <- tolower(ext)
   ext <- gsub("*", "", ext, fixed = TRUE)
-  ext <- gsub(".", "", ext, fixed = TRUE)
+  # ext <- gsub(".", "", ext, fixed = TRUE)
+  ext <- gsub("^\\.", "", ext)
+  # ext_parts <- strsplit(ext, ".", fixed = TRUE)[[1]]
+  # if (length(ext_parts) > 1L) {
+  #   # for each ext_part, check, in order, it against the initial path, then the extension of the initial path sans ext, ...
+  #   for (i in seq_along(ext_parts)) {
+  #     ext_part <- ext_parts[i]
+  #     if (tolower(tools::file_ext(x)) == ext_part) {
+  #       return(invisible(x))
+  #     }
+  #     x <- sub(paste0("\\.", tools::file_ext(x), "$"), "", x)
+  #   }
+  # }
+
   if (length(ext) > 1L) {
     if (!any(tools::file_ext(x) %in% ext)) {
       check_abort("{.arg {arg}} must have one of the following extensions: {.field {ext}}.", call = call)
@@ -662,7 +689,7 @@ check_json_file <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_
 }
 
 check_json_schema_file <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
-  check_file(x, ext = "schema.json", arg = arg, call = call)
+  check_file(x, ext = "json", arg = arg, call = call)
   check_json_file(x, arg = arg, call = call)
   invisible(x)
 }
@@ -722,3 +749,23 @@ check_available_ram <- function(x, arg = rlang::caller_arg(x), call = rlang::cal
   }
   invisible(x)
 }
+
+# spatial ---------------------------------------------------------------------------------------------------------
+
+check_crs <- function(x, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
+  check_inherits_any(x, c("crs", "crs_wkt", "crs_proj"), arg = arg, call = call)
+  invisible(x)
+}
+
+check_crs_epsg <- function(x, expected_epsg, arg = rlang::caller_arg(x), call = rlang::caller_env()) {
+  check_crs(x, arg = arg, call = call)
+  epsg <- sf::st_crs(x)$epsg
+  if (is.na(epsg) || epsg != expected_epsg) {
+    check_abort(
+      "Provided {.arg {arg}} CRS {.field {epsg}} does not match expected {.field {expected_epsg}}",
+      call = call
+    )
+  }
+  invisible(x)
+}
+

dev/R/utils_json.R → R/utils_json.R

@@ -6,6 +6,9 @@
 #
 #  ------------------------------------------------------------------------
 
+
+# read ------------------------------------------------------------------------------------------------------------
+
 read_json <- function(x, ...) {
   UseMethod("read_json")
 }
@@ -19,3 +22,8 @@ read_json.character <- function(x, ...) {
   }
   gdal_abort_check(msg = "Provided {.arg x} is not a valid JSON file path or string", call = rlang::caller_env())
 }
+
+
+# write -----------------------------------------------------------------------------------------------------------
+
+

R/utils_validation.R

@@ -8,6 +8,23 @@
 
 # schema validation -----------------------------------------------------------------------------------------------
 
+#' Validate JSON Schema
+#'
+#' @description
+#' Validates a JSON string or file against a provided JSON schema.
+#'
+#' @param x A JSON string, file path, or list to validate.
+#' @param schema A JSON schema string or file path to validate against.
+#' @inheritParams jsonvalidate::json_validate
+#' @inheritDotParams jsonvalidate::json_validate
+#'
+#' @returns
+#' Logical indicating whether the JSON is valid against the schema.
+#'
+#' @export
+#'
+#' @importFrom jsonvalidate json_validate
+#' @importFrom yyjsonr write_json_str read_json_file
 validate_json_schema <- function(x, schema, engine = "ajv", verbose = TRUE, ..., call = rlang::caller_env()) {
   if (!is_valid_json_str(x) && is_valid_json_file(x)) {
     x <- yyjsonr::read_json_file(x, opts = JSON_READ_OPTS) |> yyjsonr::write_json_str(opts = JSON_WRITE_OPTS)
@@ -18,3 +35,12 @@ validate_json_schema <- function(x, schema, engine = "ajv", verbose = TRUE, ...,
   check_json_schema_file(schema, call = call)
   jsonvalidate::json_validate(json = x, schema = schema, verbose = verbose, engine = engine, ...)
 }
+
+# TODO
+validate_xml_schema <- function(x, schema, ..., call = rlang::caller_env()) {
+  check_xml(x, call = call)
+  check_xml_schema_file(schema, call = call)
+  xml2::xml_validate(x, schema, ...)
+}
+
+

dev/docs/design-vector-introspection-and-fid.md

@@ -0,0 +1,94 @@
+# Design note: vector introspection layer & FID handling
+
+Status: **design decision / captured for later** (not implemented). The full system is too large to
+tackle at once; this records the direction and the hard-won FID nuances so they don't have to be
+re-derived.
+
+## Intent of the `gdal_vector_*()` family
+
+These functions are an **introspection layer**. Their job is to surface every relevant fact about a
+data source/layer *once, up front* so that downstream **declarative specs** can be crafted from facts
+rather than rediscovered by trial and error:
+
+- field selection / renames
+- field type pinning (casts)
+- CRS alignment
+- ignored fields
+- filtering (attribute / spatial / empty-geometry)
+- custom SQL (dialect-aware)
+- GDAL `vector pipeline` steps
+
+The goal is to **avoid circular rabbit holes** (the FID saga below being the canonical example).
+
+## Proposed shape (deferred)
+
+A single **layer profile** snapshot, gathered in one open, consumed by pure spec-builder functions
+(no re-introspection):
+
+- **Source**: driver/format, dsn, layer, capabilities (`$testCapability()` — random read, fast feature
+  count, fast spatial filter, ignore-fields, Arrow stream, etc.).
+- **Fields**: name, OGR type + subtype, width/precision, nullable, unique, default, domain.
+- **Geometry**: column name, geom type, CRS (WKT / authority / EPSG, lon-lat flag).
+- **FID**: `getFIDColumn()`, named-vs-implicit, the carry SQL, and how to query it (see below).
+- **Read-path defaults**: `$fetch()` omits FID; `$getArrowStream()` includes it by default.
+
+A type map (`ogr_type` -> `sql_type` / `arrow_type` / `r_type`) drives casts/pins. (An earlier
+`gdal_vector_schema_spec` engine did some of this; it was removed and would be rebuilt on top of a
+solid profile rather than on assumptions.)
+
+## FID nuances (researched against GDAL docs)
+
+### OGR model
+
+- The FID is a special 64-bit feature property, **not** an attribute field.
+- `OGRLayer::GetFIDColumn()` returns the name of the backing column used as the FID, or `""` if the
+  FID is implicit (no backing column). GDAL never fabricates a *named* FID on read.
+- Therefore `nzchar(GetFIDColumn())` is the discriminator:
+  - **non-empty** -> a real, named source column is used as the FID (e.g. GeoPackage PK `fid`/`lrid`,
+    OpenFileGDB `OBJECTID`). OGR **always drops it from `getFieldNames()`** because it is consumed as
+    the FID, so it is *not directly queryable* as a regular field.
+  - **`""`** -> implicit/synthetic FID (Shapefile record number, GeoJSON sequential id, FlatGeobuf
+    feature id, FID-less Parquet).
+- `%in% getFieldNames()` is **not** a useful test — a named FID is always absent from the field list
+  (this was the original bug in `gdal_vector_layer_fid_col()`).
+- What OGR cannot tell you: the column's deeper semantics (physical SQL type, auto-increment surrogate
+  like `fid` vs meaningful key like `lrid`). That requires source-specific inspection
+  (e.g. `PRAGMA table_info(<layer>)` for a GeoPackage).
+
+### Per-format
+
+| Format            | `GetFIDColumn()`                | Notes |
+| ----------------- | ------------------------------- | ----- |
+| GeoPackage        | the `INTEGER PRIMARY KEY` (default `fid`, `FID=` open option) | real column, consumed as FID; for views, alias the PK to `OGC_FID` |
+| (Geo)Parquet/Arrow| `""` unless written with `FID=` | no FID column created unless requested; Arrow schema default name `OGC_FID` |
+| FlatGeobuf        | `""`                            | per-feature id round-trips, but no named column |
+| Shapefile         | `""`                            | implicit 0-based record number; `-preserve_fid` uses that, not `OBJECTID` |
+| GeoJSON           | `""`                            | FID from feature-level `id`, else `id`/`ID` attribute |
+| OpenFileGDB       | `OBJECTID`                      | named FID column |
+
+### Per-dialect querying
+
+- **OGR SQL**: reference the FID as `FID`. `SELECT *` excludes it -> `SELECT FID, *`.
+- **SQLite**: reference it as `rowid` (since GDAL 3.8 the named FID column also works). `SELECT *`
+  excludes it -> `SELECT rowid, *` / `SELECT rowid AS fid, *`. For SQLite-backed sources
+  (GPKG/SpatiaLite) the SQLite dialect is the native engine.
+- To **carry the FID value through as a regular attribute**, rename it so OGR doesn't re-consume it as
+  the FID: `CAST(rowid AS INTEGER) AS source_fid` (SQLite) or `SELECT FID AS source_fid, *` (OGR SQL).
+  For GPKG views, alias the PK to `OGC_FID`.
+- `-preserve_fid` only preserves the FID *as the FID* (and only when the source reports a non-empty
+  FID column name); it does not turn it into an attribute.
+
+### GDALVector read-path asymmetry (`?gdalraster::GDALVector`)
+
+- **`$fetch(n)`** (incl. `n = -1`): data frame has only attribute + geometry fields. The FID is **not**
+  included by default; expose it via a custom SQL layer or by selecting the FID special field.
+- **`$getArrowStream()`**: governed by `$arrowStreamOptions`, where **`INCLUDE_FID=YES/NO` defaults to
+  `YES`** -> the FID column **is** included by default (`FID=name` sets the column name, defaulting to
+  `GetFIDColumn()`).
+- Net: `fetch()` omits the FID by default; the Arrow stream includes it by default.
+
+## Current state
+
+- `gdal_vector_layer_fid_col()` returns `getFIDColumn()` and emits a suppressible, case-specific
+  `gdal_inform` (named -> "consumed/not queryable, rename to carry"; implicit -> "use `FID`/`rowid`").
+- Everything above is otherwise **deferred** pending a holistic introspection/spec design.

inst/extdata/gdalg/tl_2025_us_county.gdalg.json

@@ -0,0 +1,5 @@
+{
+  "type":"gdal_streamed_alg",
+  "command_line":"gdal vector pipeline read --open-option ENCODING=UTF-8 --open-option ADJUST_GEOM_TYPE=FIRST_SHAPE --open-option AUTO_REPACK=YES --open-option DBF_EOF_CHAR=YES --input \/vsizip\/\/vsicurl\/https:\/\/www2.census.gov\/geo\/tiger\/TIGER2025\/COUNTY\/tl_2025_us_county.zip\/tl_2025_us_county.shp --input-layer tl_2025_us_county ! filter --where \"STATEFP NOT IN ('02','15','60','66','69','72','74','78')\" ! sql --sql \"SELECT GEOID AS geoid, STATEFP AS state_fips, COUNTYFP AS county_fips, NAME AS county_name, ALAND AS area_land_m2, AWATER AS area_water_m2 FROM \\\"tl_2025_us_county\\\"\" ! make-valid ! set-geom-type --multi --skip ! reproject --output-crs EPSG:4326 ! sort --method hilbert",
+  "gdal_version":"3130000"
+}

inst/extdata/gdalg/tl_2025_us_state.gdalg.json

@@ -0,0 +1,5 @@
+{
+  "type":"gdal_streamed_alg",
+  "command_line":"gdal vector pipeline read --open-option ENCODING=UTF-8 --open-option ADJUST_GEOM_TYPE=FIRST_SHAPE --open-option AUTO_REPACK=YES --open-option DBF_EOF_CHAR=YES --input \/vsizip\/\/vsicurl\/https:\/\/www2.census.gov\/geo\/tiger\/TIGER2025\/STATE\/tl_2025_us_state.zip\/tl_2025_us_state.shp --input-layer tl_2025_us_state ! filter --where \"STATEFP NOT IN ('02','15','60','66','69','72','74','78')\" ! sql --sql \"SELECT GEOID AS geoid, STATEFP AS state_fips, STUSPS AS state_abbr, NAME AS state_name, ALAND AS area_land_m2, AWATER AS area_water_m2 FROM \\\"tl_2025_us_state\\\"\" ! make-valid ! set-geom-type --multi --skip ! reproject --output-crs EPSG:4326 ! sort --method hilbert",
+  "gdal_version":"3130000"
+}