read_gpkg.R

#' Is x an GeoPackage filename or path?
#'
#' @param x File name or path name
#' @noRd
is_gpkg <- function(x) {
    grepl("\\.gpkg$", x)
}

#' Check if x is a GeoPackage file
#'
#' @inheritParams is_gpkg
#' @inheritParams cli::cli_abort
#' @noRd
#' @importFrom rlang caller_arg
check_gpkg <- function(x,
                       arg = rlang::caller_arg(),
                       call = .envir,
                       .envir = parent.frame()) {
    if (is_gpkg(x)) {
        return(invisible(NULL))
    }
    
    cli::cli_abort(
        "{.arg {arg}} must be a GeoPackage (gpkg) file.",
        call = call,
        .envir = .envir
    )
}

#' Connect to GeoPackage data source
#'
#' @param dsn Path or url for GeoPackage file. Optional if conn is provided.
#' @param conn Connection from [RSQLite::dbConnect()]. Optional if dsn is provided.
#' @inheritParams check_gpkg
#' @noRd
connect_gpkg <- function(dsn = NULL,
                         conn = NULL,
                         call = .envir,
                         .envir = parent.frame()) {
    if (!is.null(dsn)) {
        check_gpkg(dsn, call = call, .envir = .envir)
        
        if (!is.null(conn)) {
            cli::cli_abort(
                "Exactly one of {.arg conn} or {.arg dsn} must be supplied.",
                call = call,
                .envir = .envir
            )
        }
        
        is_pkg_installed("RSQLite")
        is_pkg_installed("DBI")
    }
    
    conn %||% DBI::dbConnect(RSQLite::SQLite(), dsn)
}

#' Read a GeoPackage table
#'
#' @inheritParams connect_gpkg
#' @param table_name Name of a GeoPackage table to read
#' @noRd
read_gpkg_table <- function(dsn = NULL,
                            conn = NULL,
                            table_name = NULL,
                            call = .envir,
                            .envir = parent.frame()) {
    conn <- connect_gpkg(dsn, conn, call, .envir)
    
    if (is.null(table_name)) {
        cli::cli_abort(
            "{.arg table_name} must be provided.",
            call = call,
            .envir = .envir
        )
    }
    
    cli::cli_inform("Accessing the {.val {table_name}} table.")
    DBI::dbReadTable(conn, table_name)
}

#' Read GeoPackage tables associated with an extension
#'
#' Supports the metadata extension
#' <http://www.geopackage.org/guidance/extensions/metadata.html> and the Schema
#' extension <http://www.geopackage.org/guidance/extensions/schema.html>
#'
#' @inheritParams check_gpkg_extension
#' @inheritParams read_gpkg_table
#' @noRd
#' @importFrom purrr map
read_gpkg_extension <- function(dsn = NULL,
                                conn = NULL,
                                extension,
                                table_name = NULL,
                                call = .envir,
                                .envir = parent.frame(),
                                ...) {
    conn <- connect_gpkg(dsn, conn, call, .envir)
    
    check_gpkg_extension(
        dsn = NULL, conn = conn,
        extension, table_name, call, .envir
    )
    
    purrr::map(
        table_name,
        ~ read_gpkg_table(
            dsn = NULL, conn = conn,
            table_name = .x, call, .envir
        )
    )
}

#' @name read_gpkg_schema
#' @rdname read_gpkg_extension
#' @noRd
read_gpkg_schema <- function(dsn, ...) {
    read_gpkg_extension(
        dsn,
        "gpkg_schema",
        c("gpkg_data_columns", "gpkg_data_column_constraints"),
        ...
    )
}

#' @name read_gpkg_schema
#' @rdname read_gpkg_extension
#' @noRd
read_gpkg_metadata <- function(dsn, ...) {
    read_gpkg_extension(
        dsn,
        "gpkg_metadata",
        c("gpkg_metadata", "gpkg_metadata_reference"),
        ...
    )
}

#' Check if extension is in gpkg_extensions table and GeoPackage file has
#' extension related table names
#'
#' @param extension Extension name
#' @param table_name One or more table names required for the corresponding
#'   extension.
#' @noRd
check_gpkg_extension <- function(dsn = NULL,
                                 conn = NULL,
                                 extension,
                                 table_name = NULL,
                                 call = .envir,
                                 .envir = parent.frame()) {
    conn <- connect_gpkg(dsn, conn)
    
    gpkg_extensions <-
        DBI::dbReadTable(conn, "gpkg_extensions")
    
    extension_tables <-
        gpkg_extensions[gpkg_extensions$extension_name %in% extension, ]
    
    if (nrow(extension_tables) == 0) {
        cli::cli_abort(
            "{.arg extension} {.val {extension}} can't be found in the {.val gpkg_extensions} table.",
            call = call,
            .envir = .envir
        )
    }
    
    has_tables <-
        purrr::map_lgl(
            table_name,
            ~ DBI::dbExistsTable(conn, .x) &&
                (.x %in% extension_tables$table_name)
        )
    
    if (all(has_tables)) {
        return(invisible(NULL))
    }
    
    cli::cli_abort(
        "{.arg table_name} {.val {table_name[!has_tables]}} can't be found for extension {.val {extension}}.",
        call = call,
        .envir = .envir
    )
}