Merge pull request #9 from brownag/gpkg-connect1

Updates to `gpkg_connect()`

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gpkg
 Type: Package
 Title: Utilities for the OGC 'GeoPackage' Format
-Version: 0.0.5.9001
+Version: 0.0.5.9002
 Authors@R: person(given="Andrew", family="Brown", email="brown.andrewg@gmail.com", role = c("aut", "cre"))
 Maintainer: Andrew Brown <brown.andrewg@gmail.com>
 Description: High-level wrapper functions to build Open Geospatial Consortium (OGC) 'GeoPackage' files (<https://www.geopackage.org/>). 'GDAL' utilities for read and write of spatial data are provided via the 'terra' package. Additional 'GeoPackage' and 'SQLite' specific functions manipulate attributes and tabular data via the 'RSQLite' package.

NAMESPACE

@@ -54,6 +54,7 @@ export(gpkg_write_attributes)
 importFrom(DBI,dbConnect)
 importFrom(DBI,dbDisconnect)
 importFrom(DBI,dbGetQuery)
+importFrom(DBI,dbIsValid)
 importFrom(DBI,dbListTables)
 importFrom(methods,show)
 importFrom(utils,packageVersion)

R/gpkg-connection.R

@@ -1,6 +1,9 @@
 
 #' Create SQLite Connection to GeoPackage
 #'
+#' Method for creating and connecting `SQLiteConnection` object stored within `geopackage` object.
+#' @details The S3 method for `geopackage` objects uses in-place modification to update the parent object by name. That is, if you call `gpkg_connect()` on an object `g` then as a side-effect `g` is updated in the user environment. This behavior is considered by many to be non-idiomatic for R, but it is useful to provide a simple way to connect an existing object without having to retain references to pointers to connection objects. To avoid replacement of object values in the parent frame, you can use the `character` method. That is `g <- gpkg_connect(g$dsn)` is equivalent to `gpkg_connect(g)` when `g` is a `geopackage`.
+#'
 #' @param x Path to GeoPackage
 #'
 #' @return A DBIConnection (SQLiteConnection) object. `NULL` on error.
@@ -12,7 +15,10 @@ gpkg_connect <- function(x)
 #' @export
 #' @rdname gpkg-connnection
 gpkg_connect.geopackage <- function(x) {
+  obj <- as.character(substitute(x))
   x$con <- gpkg_connect(x$dsn)$con
+  # update object in parent frame
+  try(assign(obj, x, envir = parent.frame()))
   x
 }
 
@@ -71,6 +77,7 @@ gpkg_disconnect.SQLiteConnection <- function(x) {
 #' @param x A _geopackage_ object, a path to a GeoPackage or an _SQLiteConnection_
 #' @return An SQLiteConnection with logical attribute `"disconnect"` indicating whether it should be disconnected after use.
 #' @noRd
+#' @importFrom DBI dbIsValid
 #' @keywords internal
 .gpkg_connection_from_x <- function(x) {
 
@@ -91,7 +98,9 @@ gpkg_disconnect.SQLiteConnection <- function(x) {
     disconnect <- FALSE
   } else stop('`x` should be `geopackage` object, a path to a GeoPackage or an _SQLiteConnection_')
 
-  if (!is.null(con)) { 
+  if (!DBI::dbIsValid(con)) {
+    attr(con, 'disconnect') <- TRUE
+  } else if (!is.null(con)) { 
     attr(con, 'disconnect') <- disconnect
   }
   con

R/gpkg-extensions.R

@@ -3,6 +3,11 @@
 #' @param x a `geopackage`
 #' @export
 gpkg_add_metadata_extension <- function(x) {
+  tbls <- gpkg_list_tables(x)
+
+  if (!"gpkg_extensions" %in% tbls)
+    .gpkg_add_extensions(x, tbls)
+
   # TODO: insert if not exists
   RSQLite::dbExecute(x$con, "INSERT INTO gpkg_extensions(table_name,column_name,extension_name,definition,scope) VALUES (
   'gpkg_metadata', NULL, 'gpkg_metadata', 'http://www.geopackage.org/spec121/#extension_metadata', 'read-write'
@@ -11,44 +16,68 @@ gpkg_add_metadata_extension <- function(x) {
   'gpkg_metadata_reference', NULL, 'gpkg_metadata', 'http://www.geopackage.org/spec121/#extension_metadata', 'read-write'
   )")
 
-  RSQLite::dbExecute(x$con, "CREATE TABLE gpkg_metadata (
-    id INTEGER PRIMARY KEY AUTOINCREMENT,
-    md_scope TEXT NOT NULL DEFAULT 'dataset',
-    md_standard_uri TEXT NOT NULL,
-    mime_type TEXT NOT NULL DEFAULT 'text/xml',
-    metadata TEXT NOT NULL DEFAULT ''
-  );")
-
-  RSQLite::dbExecute(x$con, "CREATE TABLE gpkg_metadata_reference (
-    reference_scope TEXT NOT NULL,
-    table_name TEXT,
-    column_name TEXT,
-    row_id_value INTEGER,
-    timestamp DATETIME NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ','now')),
-    md_file_id INTEGER NOT NULL,
-    md_parent_id INTEGER,
-    CONSTRAINT crmr_mfi_fk FOREIGN KEY (md_file_id) REFERENCES gpkg_metadata(id),
-    CONSTRAINT crmr_mpi_fk FOREIGN KEY (md_parent_id) REFERENCES gpkg_metadata(id)
-  );")
+  if (!"gpkg_metadata" %in% tbls)
+    RSQLite::dbExecute(x$con, "CREATE TABLE gpkg_metadata (
+      id INTEGER PRIMARY KEY AUTOINCREMENT,
+      md_scope TEXT NOT NULL DEFAULT 'dataset',
+      md_standard_uri TEXT NOT NULL,
+      mime_type TEXT NOT NULL DEFAULT 'text/xml',
+      metadata TEXT NOT NULL DEFAULT ''
+    );")
+
+  if (!"gpkg_metadata_reference" %in% tbls)
+    RSQLite::dbExecute(x$con, "CREATE TABLE gpkg_metadata_reference (
+      reference_scope TEXT NOT NULL,
+      table_name TEXT,
+      column_name TEXT,
+      row_id_value INTEGER,
+      timestamp DATETIME NOT NULL DEFAULT (strftime('%Y-%m-%dT%H:%M:%fZ','now')),
+      md_file_id INTEGER NOT NULL,
+      md_parent_id INTEGER,
+      CONSTRAINT crmr_mfi_fk FOREIGN KEY (md_file_id) REFERENCES gpkg_metadata(id),
+      CONSTRAINT crmr_mpi_fk FOREIGN KEY (md_parent_id) REFERENCES gpkg_metadata(id)
+    );")
+
+  0
 }
 
 #' Add Related Tables extension
 #'
 #' @param x a `geopackage`
 #' @export
 gpkg_add_relatedtables_extension <- function(x) {
+
+  tbls <- gpkg_list_tables(x)
+
+  if (!"gpkg_extensions" %in% tbls)
+    .gpkg_add_extensions(x, tbls)
+
   RSQLite::dbExecute(x$con, "INSERT INTO gpkg_extensions(table_name,column_name,extension_name,definition,scope) VALUES (
     'gpkgext_relations', NULL, 'related_tables', 'http://docs.opengeospatial.org/is/18-000/18-000.html#_gpkg_extensions', 'read-write'
   )")
-
-  RSQLite::dbExecute(x$con, "CREATE TABLE 'gpkgext_relations' (
-    id INTEGER PRIMARY KEY AUTOINCREMENT,
-    base_table_name TEXT NOT NULL,
-    base_primary_column TEXT NOT NULL DEFAULT 'id',
-    related_table_name TEXT NOT NULL,
-    related_primary_column TEXT NOT NULL DEFAULT 'id',
-    relation_name TEXT NOT NULL,
-    mapping_table_name TEXT NOT NULL UNIQUE
-   );")
-
+
+  if (!"gpkgext_relations" %in% tbls)
+    RSQLite::dbExecute(x$con, "CREATE TABLE 'gpkgext_relations' (
+      id INTEGER PRIMARY KEY AUTOINCREMENT,
+      base_table_name TEXT NOT NULL,
+      base_primary_column TEXT NOT NULL DEFAULT 'id',
+      related_table_name TEXT NOT NULL,
+      related_primary_column TEXT NOT NULL DEFAULT 'id',
+      relation_name TEXT NOT NULL,
+      mapping_table_name TEXT NOT NULL UNIQUE
+     );")
+  0
 }
+
+.gpkg_add_extensions <- function(x, tbls = gpkg_list_tables(x)) {
+
+  if (!"gpkg_extensions" %in% tbls)
+    RSQLite::dbExecute(x$con, "CREATE TABLE gpkg_extensions (
+        table_name TEXT,
+        column_name TEXT,
+        extension_name TEXT NOT NULL,
+        definition TEXT NOT NULL,
+        scope TEXT NOT NULL,
+        CONSTRAINT ge_tce UNIQUE (table_name, column_name, extension_name)
+      );")
+}

R/gpkg-util.R

@@ -56,8 +56,8 @@ gpkg_source.geopackage <- function(x) {
 #' @export
 gpkg_list_tables <- function(x) {
   con <- .gpkg_connection_from_x(x)
-  res <- NULL
-  if (!is.null(con)) {
+  res <- character(0)
+  if (!is.null(con) && DBI::dbIsValid(con)) {
     res <- DBI::dbListTables(con)
     if (attr(con, 'disconnect')) {
       DBI::dbDisconnect(con)

inst/tinytest/test_gpkg.R

@@ -126,9 +126,11 @@ expect_warning({d1 <- gpkg_table_pragma(g3$dsn, "gpkg_contents")})
 expect_true(inherits(d1, 'data.frame'))
 expect_true(inherits(gpkg_table_pragma(g3$con, "gpkg_contents"), 'data.frame'))
 
-expect_silent({d2 <- gpkg_table(g3$dsn, "gpkg_contents")})
-expect_true(inherits(gpkg_tbl(g3$con, "gpkg_contents"), 'tbl_SQLiteConnection'))
-expect_true(inherits(d2, 'tbl_SQLiteConnection'))
+if (requireNamespace("dbplyr", quietly = TRUE)) {
+  expect_silent({d2 <- gpkg_table(g3$dsn, "gpkg_contents")})
+  expect_true(inherits(gpkg_tbl(g3$con, "gpkg_contents"), 'tbl_SQLiteConnection'))
+  expect_true(inherits(d2, 'tbl_SQLiteConnection'))
+}
 
 # verify insert/delete of dummy gpkg_contents rows
 expect_equal(nrow(gpkg_query(g3, "select * from gpkg_contents;")), 2)
@@ -140,7 +142,7 @@ expect_equal(gpkg_execute(g3, "select * from gpkg_contents;"), 0)
 expect_true(gpkg_disconnect(g3$con))
 
 # add bounding polygon vector dataset
-b <- terra::as.polygons(gpkg_tables(g)[["DEM1"]], ext = TRUE)
+b <- terra::as.polygons(gpkg_rast(g, "DEM1"), ext = TRUE)
 expect_silent(gpkg_write(list(layer1 = b, layerB = b), destfile = gpkg_tmp, insert = TRUE))
 
 if (utils::packageVersion("terra") >= "1.7.33") {
@@ -160,8 +162,10 @@ expect_silent(gpkg_write(list(myattr = d), destfile = gpkg_tmp, append = TRUE))
 tl <- gpkg_list_tables(g)
 expect_true(is.character(tl) && all(c("layer1", "myattr") %in% tl))
 
-tlex <- gpkg_tables(g)
-expect_equal(length(tlex), 5)
+if (requireNamespace("dbplyr", quietly = TRUE)) {
+  tlex <- gpkg_tables(g)
+  expect_equal(length(tlex), 5)
+}
 
 expect_true(inherits(gpkg_2d_gridded_coverage_ancillary(g), 'data.frame'))
 
@@ -173,8 +177,11 @@ expect_true(gpkg_is_connected(g))
 expect_stdout(gpkg_read(g))
 
 # extensions
-expect_equal(gpkg_add_metadata_extension(g), 0)
-expect_equal(gpkg_add_relatedtables_extension(g), 0)
+gempty <- geopackage(connect = TRUE)
+expect_equal(gpkg_add_metadata_extension(gempty), 0)
+expect_equal(gpkg_add_relatedtables_extension(gempty), 0)
+gpkg_disconnect(gempty)
+unlink(gempty$dsn)
 
 # TODO: validator
 expect_error(gpkg_validate(g))