Merge pull request #20 from brownag/v0010

gpkg v0.0.10

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="[email protected]", role = c("aut", "cre"))
 Maintainer: Andrew Brown <[email protected]>
 Description: Build Open Geospatial Consortium 'GeoPackage' files (<https://www.geopackage.org/>). '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,

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)

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

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,8 @@ 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")

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,

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)
 

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")
@@ -115,11 +114,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) {
@@ -135,11 +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 (missing(table_name) || length(table_name) == 0) stop("table name should be one of:", paste0(tbls, collapse = ", "), call = FALSE)
+  if (inherits(res, 'try-error')) {
+    tbls <- gpkg_list_tables(x)
+
+    if (length(tbls) == 0) {
+      tbls <- "<none available>"
+    }
+
+    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)`
@@ -175,7 +184,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 +203,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)
+}

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))
 }

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'))