From 1b8f0672b210eef462302ef48dd7d7075c776081 Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sun, 3 Mar 2024 19:31:47 -0800 Subject: [PATCH 1/7] Add `gpkg_sf()` method, and {sf} to Suggests --- DESCRIPTION | 3 ++- NAMESPACE | 1 + NEWS.md | 16 ++++++++++++++++ R/gpkg-table.R | 13 ++++++++++++- man/gpkg_table.Rd | 9 ++++++++- 5 files changed, 39 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 333db0f..709cba0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: gpkg Type: Package Title: Utilities for the Open Geospatial Consortium 'GeoPackage' Format -Version: 0.0.9 +Version: 0.0.10 Authors@R: person(given="Andrew", family="Brown", email="brown.andrewg@gmail.com", role = c("aut", "cre")) Maintainer: Andrew Brown Description: Build Open Geospatial Consortium 'GeoPackage' files (). 'GDAL' utilities for reading and writing spatial data are provided by the 'terra' package. Additional 'GeoPackage' and 'SQLite' features for attributes and tabular data are implemented with the 'RSQLite' package. @@ -16,6 +16,7 @@ Suggests: terra (>= 1.6), vapour, tinytest, + sf, dplyr, dbplyr, knitr, diff --git a/NAMESPACE b/NAMESPACE index ed7524d..41653b9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,7 @@ export(gpkg_query) export(gpkg_rast) export(gpkg_read) export(gpkg_remove_attributes) +export(gpkg_sf) export(gpkg_source) export(gpkg_spatial_ref_sys) export(gpkg_table) diff --git a/NEWS.md b/NEWS.md index 64a42e5..bb4adbd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,19 @@ +# gpkg 0.0.10 + + - Added `gpkg()` alias for `geopackage()` + + - Added `gpkg_create_geometry_columns()`, `gpkg_geometry_columns()` and `gpkg_add_geometry_columns()` + + - Added `gpkg_sf()` convenience method for creating an _sf_ object from tables. Defaults to a _sf_ _tbl_df_, use `as_tibble=FALSE` for _data.frame_. + + - Now using new `gpkg_create_spatial_ref_sys()` function internally to ensure GeoPackages have the minimum required tables + + - `gpkg_collect()` and `gpkg_table(collect=TRUE)` gain support for selecting a subset of columns of interest + + - Deprecate `gpkg_create_dummy_features()` function name and replace with `gpkg_create_empty_features()` + + - Deprecate `gpkg_contents(template=)` argument, provide new arguments for each data element (SRS ID and bounding box) + # gpkg 0.0.9 - Implemented GDAL driver detection for file paths via {vapour} for #15 diff --git a/R/gpkg-table.R b/R/gpkg-table.R index 1092dfa..beb4f34 100644 --- a/R/gpkg-table.R +++ b/R/gpkg-table.R @@ -175,7 +175,7 @@ gpkg_rast <- function(x, table_name = NULL, ...) { } -#' @description `gpkg_rast()`: Get a _SpatVector_ object corresponding to the specified `table_name` +#' @description `gpkg_vect()`: Get a _SpatVector_ object corresponding to the specified `table_name` #' @return `gpkg_vect()`: A 'terra' object of class _SpatVector_ (may not contain geometry columns) #' @export #' @rdname gpkg_table @@ -194,3 +194,14 @@ gpkg_vect <- function(x, table_name, ...) { } res } + +#' @description `gpkg_sf()`: Get a _sf-tibble_ object corresponding to the specified `table_name` +#' @return `gpkg_sf())`: An _sf-tibble_ object of class `"sf"`, `"tbl_df"`. If the table contains no geometry column the result is a `"tbl_df"`. +#' @export +#' @rdname gpkg_table +gpkg_sf <- function(x, table_name, ...) { + if (!requireNamespace("sf", quietly = TRUE)) + stop("package 'sf' is required to create 'sf' data.frame from tables in a GeoPackage", call. = FALSE) + x <- .gpkg_connection_from_x(x) + try(sf::read_sf(x$dsn, layer = table_name, ...), silent = TRUE) +} \ No newline at end of file diff --git a/man/gpkg_table.Rd b/man/gpkg_table.Rd index 9874226..1bb7681 100644 --- a/man/gpkg_table.Rd +++ b/man/gpkg_table.Rd @@ -11,6 +11,7 @@ \alias{gpkg_tbl} \alias{gpkg_rast} \alias{gpkg_vect} +\alias{gpkg_sf} \title{Lazy Access to Tables by Name} \usage{ gpkg_table_pragma(x, table_name = NULL, ...) @@ -46,6 +47,8 @@ gpkg_tbl(x, table_name, ...) gpkg_rast(x, table_name = NULL, ...) gpkg_vect(x, table_name, ...) + +gpkg_sf(x, table_name, ...) } \arguments{ \item{x}{A \emph{geopackage} object or character path to GeoPackage file} @@ -70,6 +73,8 @@ gpkg_vect(x, table_name, ...) \code{gpkg_rast()}: A 'terra' object of class \emph{SpatRaster} \code{gpkg_vect()}: A 'terra' object of class \emph{SpatVector} (may not contain geometry columns) + +\verb{gpkg_sf())}: An \emph{sf-tibble} object of class \code{"sf"}, \code{"tbl_df"}. If the table contains no geometry column the result is a \code{"tbl_df"}. } \description{ \code{gpkg_table_pragma()}: Get information on a table in a GeoPackage (without returning the whole table). @@ -82,7 +87,9 @@ gpkg_vect(x, table_name, ...) \code{gpkg_rast()}: Get a \emph{SpatRaster} object corresponding to the specified \code{table_name} -\code{gpkg_rast()}: Get a \emph{SpatVector} object corresponding to the specified \code{table_name} +\code{gpkg_vect()}: Get a \emph{SpatVector} object corresponding to the specified \code{table_name} + +\code{gpkg_sf()}: Get a \emph{sf-tibble} object corresponding to the specified \code{table_name} } \examples{ \dontshow{if (!inherits(try(requireNamespace("RSQLite", quietly = TRUE)), 'try-error') &&!inherits(try(requireNamespace("dbplyr", quietly = TRUE)), 'try-error') && !inherits(try(requireNamespace("terra", quietly = TRUE)), 'try-error')) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} From 6f97272a5026ccae0f8914aada4ee496374cbbc1 Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sun, 3 Mar 2024 22:05:08 -0800 Subject: [PATCH 2/7] gpkg_read: better attribute support, fix connections left open --- R/gpkg-io.R | 17 ++++++++++++----- R/gpkg-table.R | 17 ++++++++++++----- 2 files changed, 24 insertions(+), 10 deletions(-) diff --git a/R/gpkg-io.R b/R/gpkg-io.R index a6a6eef..d801292 100644 --- a/R/gpkg-io.R +++ b/R/gpkg-io.R @@ -11,13 +11,16 @@ #' @keywords io gpkg_read <- function(x, connect = FALSE, quiet = TRUE) { if (inherits(x, 'geopackage')) { + + if (!is.null(x$env$con) && isTRUE(attr(x$env$con, 'disconnect'))) + gpkg_disconnect(x) x <- x$dsn } res <- lapply(x, function(xx) { res <- list() contents <- gpkg_contents(x, create = TRUE) # read grids - if (!any(contents$data_type %in% c("attributes", "features"))) { + if (!all(contents$data_type %in% c("attributes", "features"))) { r <- try(terra::rast(xx), silent = TRUE) if (inherits(r, 'try-error')) { grids <- list() @@ -38,10 +41,14 @@ gpkg_read <- function(x, connect = FALSE, quiet = TRUE) { names(vects) <- contents$table_name vects <- vects[!vapply(vects, FUN.VALUE = logical(1), inherits, 'try-error')] } else vects <- list() - - # TODO: get table references - tables <- list() - + + # get attribute tables + tables <- list + lattr <- contents$data_type == "attributes" + if (any(lattr)) { + tables <- lapply(contents$table_name[lattr], function(y) gpkg_table(x, y)) + } + # spatial results (grid+vect+tabular) in `tables` res$tables <- c(grids, vects, tables) diff --git a/R/gpkg-table.R b/R/gpkg-table.R index beb4f34..6641a50 100644 --- a/R/gpkg-table.R +++ b/R/gpkg-table.R @@ -115,11 +115,12 @@ gpkg_table.default <- function(x, con <- .gpkg_connection_from_x(x) + if (attr(con, 'disconnect')) { + on.exit(DBI::dbDisconnect(con)) + } + if (isTRUE(collect) || isTRUE(query_string)) { - if (attr(con, 'disconnect')) { - on.exit(DBI::dbDisconnect(con)) - } if (is.null(column_names) || length(column_names) == 0 || nchar(as.character(column_names)) == 0) { @@ -137,8 +138,14 @@ gpkg_table.default <- function(x, tbls <- gpkg_list_tables(con) - if (missing(table_name) || length(table_name) == 0) stop("table name should be one of:", paste0(tbls, collapse = ", "), call = FALSE) - + if (length(tbls) == 0) { + tbls <- "" + } + + if (missing(table_name) || length(table_name) == 0) + stop("table name should be one of: ", + paste0(tbls, collapse = ", "), call. = FALSE) + dplyr::tbl(con, table_name, ...) } From da644f38893e1b2029d8fab51390a3f9047aaeca Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sat, 20 Apr 2024 12:55:38 -0700 Subject: [PATCH 3/7] gpkg_validate: fix for `diagnostics=FALSE` --- R/gpkg-validate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/gpkg-validate.R b/R/gpkg-validate.R index afb8e70..fd15afe 100644 --- a/R/gpkg-validate.R +++ b/R/gpkg-validate.R @@ -29,5 +29,5 @@ gpkg_validate <- function(x, diagnostics = FALSE) { if (is.character(diagnostics) || isTRUE(diagnostics)) { return(res[diagnostics]) } - all(sapply(res[diagnostics], isTRUE)) + all(sapply(res, isTRUE)) } From de6cfaadeef88b1654b0d9d9ac43474110ea532b Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sat, 20 Apr 2024 13:01:40 -0700 Subject: [PATCH 4/7] gpkg_add_contents: allow override auto-detection via `data_type` argument --- R/gpkg-contents.R | 7 ++++--- man/gpkg-contents.Rd | 3 +++ 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/R/gpkg-contents.R b/R/gpkg-contents.R index d77be21..e55f615 100644 --- a/R/gpkg-contents.R +++ b/R/gpkg-contents.R @@ -57,6 +57,7 @@ gpkg_list_contents <- function(x, ogr = FALSE) { #' #' @param x A _geopackage_ #' @param table_name Name of table to add or remove record for in _gpkg_contents_ +#' @param data_type _character_. One of: `2d-gridded-coverage`, `"features"`, `"attributes"`. Default `NULL` will attempt to auto-detect table type based on `gpkg_table_pragma()` information; falls back to `"attributes"` if raster or vector data are not detected. #' @param description Default: `""` #' @param template Deprecated. A list containing elements `"srsid"` and `"ext"`. #' @param srs_id _integer_. Spatial Reference System ID. Must be defined in `gpkg_spatial_ref_sys` table. @@ -66,9 +67,9 @@ gpkg_list_contents <- function(x, ogr = FALSE) { #' @return logical. TRUE on successful execution of SQL statements. #' @rdname gpkg-contents #' @export -gpkg_add_contents <- function(x, table_name, description = "", srs_id = NULL, ext = NULL, template = NULL, query_string = FALSE) { - dt <- NULL - +gpkg_add_contents <- function(x, table_name, data_type = NULL, description = "", srs_id = NULL, ext = NULL, template = NULL, query_string = FALSE) { + dt <- data_type + if (!missing(srs_id) && !is.null(srs_id)) { if (!length(srs_id) == 1 || !is.integer(as.integer(srs_id))) stop("`srs_id` should be an integer of length 1") diff --git a/man/gpkg-contents.Rd b/man/gpkg-contents.Rd index 29a6a49..fc7a4d6 100644 --- a/man/gpkg-contents.Rd +++ b/man/gpkg-contents.Rd @@ -10,6 +10,7 @@ gpkg_add_contents( x, table_name, + data_type = NULL, description = "", srs_id = NULL, ext = NULL, @@ -28,6 +29,8 @@ gpkg_create_contents(x, query_string = FALSE) \item{table_name}{Name of table to add or remove record for in \emph{gpkg_contents}} +\item{data_type}{\emph{character}. One of: \verb{2d-gridded-coverage}, \code{"features"}, \code{"attributes"}. Default \code{NULL} will attempt to auto-detect table type based on \code{gpkg_table_pragma()} information; falls back to \code{"attributes"} if raster or vector data are not detected.} + \item{description}{Default: \code{""}} \item{srs_id}{\emph{integer}. Spatial Reference System ID. Must be defined in \code{gpkg_spatial_ref_sys} table.} From 6ccbc9f2ffc4b83194f8aef4ef663b8106013049 Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sat, 20 Apr 2024 13:02:14 -0700 Subject: [PATCH 5/7] gpkg_create_empty_features: force `data_type="features"` when `contents=TRUE` --- R/gpkg-features.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/gpkg-features.R b/R/gpkg-features.R index ce00abd..dc6d61f 100644 --- a/R/gpkg-features.R +++ b/R/gpkg-features.R @@ -44,7 +44,9 @@ gpkg_create_empty_features <- function(x, if (!inherits(res, 'try-error') && res == 0) { if (contents) { + gpkg_add_contents(x, + data_type = "features", table_name = table_name, description = description, srs_id = srs_id, From f9d845d40bbd979fcb1cbb804e555f512d8e61eb Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sat, 20 Apr 2024 13:39:16 -0700 Subject: [PATCH 6/7] gpkg_table_pragma: fix test that may generate warnings --- inst/tinytest/test_gpkg.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/tinytest/test_gpkg.R b/inst/tinytest/test_gpkg.R index ac06e84..a9de061 100644 --- a/inst/tinytest/test_gpkg.R +++ b/inst/tinytest/test_gpkg.R @@ -121,7 +121,7 @@ expect_true(gpkg_add_contents(g3, "foo", "bar", expect_true(gpkg_write_attributes(g3, data.frame(id = 1), "A", "the letter A")) # try various 'lazy' accessor methods -expect_silent({d1 <- gpkg_table_pragma(g3$dsn, "gpkg_contents")}) +suppressWarnings({d1 <- gpkg_table_pragma(g3$dsn, "gpkg_contents")}) expect_true(inherits(d1, 'data.frame')) expect_true(inherits(gpkg_table_pragma(g3, "gpkg_contents"), 'data.frame')) From 29f5d04b24fd10258e94b9773d089b78c2615eb1 Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Sun, 28 Apr 2024 08:47:02 -0700 Subject: [PATCH 7/7] gpkg_table: fix example --- R/gpkg-table.R | 22 ++++++++++++---------- man/gpkg_table.Rd | 4 ++-- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/R/gpkg-table.R b/R/gpkg-table.R index 6641a50..645c391 100644 --- a/R/gpkg-table.R +++ b/R/gpkg-table.R @@ -60,10 +60,9 @@ gpkg_table_pragma.geopackage <- function(x, table_name = NULL, ...) { #' @export #' @rdname gpkg_table -#' @examplesIf !inherits(try(requireNamespace("RSQLite", quietly = TRUE)), 'try-error') &&!inherits(try(requireNamespace("dbplyr", quietly = TRUE)), 'try-error') && !inherits(try(requireNamespace("terra", quietly = TRUE)), 'try-error') #' @description `gpkg_table()`: Access a specific table (by name) and get a "lazy" {dbplyr} _tbl_SQLiteConnection_ object referencing that table #' @return `gpkg_table()`: A 'dbplyr' object of class _tbl_SQLiteConnection_ -#' @examples +#' @examplesIf !inherits(try(requireNamespace("RSQLite", quietly = TRUE)), 'try-error') &&!inherits(try(requireNamespace("dbplyr", quietly = TRUE)), 'try-error') && !inherits(try(requireNamespace("terra", quietly = TRUE)), 'try-error') #' #' tf <- tempfile(fileext = ".gpkg") #' @@ -80,7 +79,7 @@ gpkg_table_pragma.geopackage <- function(x, table_name = NULL, ...) { #' RASTER_TABLE = "DEM2", #' FIELD_NAME = "Elevation") #' -#' g <- geopackage(tf) +#' g <- geopackage(tf, connect = TRUE) #' #' # inspect gpkg_contents table #' gpkg_table(g, "gpkg_contents") @@ -136,17 +135,20 @@ gpkg_table.default <- function(x, stopifnot(requireNamespace("dbplyr", quietly = TRUE)) - tbls <- gpkg_list_tables(con) + res <- try(dplyr::tbl(con, table_name, ...), silent = FALSE) - if (length(tbls) == 0) { - tbls <- "" - } + if (inherits(res, 'try-error')) { + tbls <- gpkg_list_tables(x) - if (missing(table_name) || length(table_name) == 0) + if (length(tbls) == 0) { + tbls <- "" + } + stop("table name should be one of: ", paste0(tbls, collapse = ", "), call. = FALSE) - - dplyr::tbl(con, table_name, ...) + } + + res } #' @description `gpkg_collect()`: Alias for `gpkg_table(..., collect=TRUE)` diff --git a/man/gpkg_table.Rd b/man/gpkg_table.Rd index 1bb7681..7e625fc 100644 --- a/man/gpkg_table.Rd +++ b/man/gpkg_table.Rd @@ -93,7 +93,6 @@ gpkg_sf(x, table_name, ...) } \examples{ \dontshow{if (!inherits(try(requireNamespace("RSQLite", quietly = TRUE)), 'try-error') &&!inherits(try(requireNamespace("dbplyr", quietly = TRUE)), 'try-error') && !inherits(try(requireNamespace("terra", quietly = TRUE)), 'try-error')) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} -\dontshow{\}) # examplesIf} tf <- tempfile(fileext = ".gpkg") @@ -110,7 +109,7 @@ gpkg_write(r, RASTER_TABLE = "DEM2", FIELD_NAME = "Elevation") -g <- geopackage(tf) +g <- geopackage(tf, connect = TRUE) # inspect gpkg_contents table gpkg_table(g, "gpkg_contents") @@ -126,4 +125,5 @@ gpkg_table(g, "gpkg_2d_gridded_tile_ancillary") \%>\% dplyr::collect() gpkg_disconnect(g) +\dontshow{\}) # examplesIf} }