Method for cloning local NASIS tables into static SQLite file

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: soilDB
 Type: Package
 Title: Soil Database Interface
-Version: 2.6.0
-Date: 2020-12-02
+Version: 2.6.1
+Date: 2021-01-06
 Authors@R: c(person(given="Dylan", family="Beaudette", role = c("aut"), email = "[email protected]"),
              person(given="Jay", family="Skovlin", role = c("aut")), 
              person(given="Stephen", family="Roecker", role = c("aut")), 

R/createStaticNASIS.R

@@ -0,0 +1,120 @@
+#' Method for "dumping" contents of an entire NASIS table
+#'
+#' @param table_name Character name of table.
+#' @param static_path Optional: path to SQLite database containing NASIS table structure; Default: \code{NULL}
+#'
+#' @return A data.frame or other result of \code{DBI::dbGetQuery}
+#'
+.dump_NASIS_table <- function(table_name, static_path = NULL) {
+  # connect to NASIS, identify columns 
+  con <- dbConnectNASIS(static_path) 
+  allcols <- "*"
+
+  # handling for MSSQL/ODBC weirdness
+  if (is.null(static_path)) {
+    columns <- odbc::odbcConnectionColumns(con, table_name)
+
+    # re-arrange VARCHAR(MAX) columns
+    longcols <- subset(columns, columns$field.type == "varchar" & columns$column_size == 0)$name
+    allcols <- columns$name
+
+    if (length(longcols) > 0) {
+      allcols[which(allcols %in% longcols)] <- NA
+      allcols <- c(na.omit(allcols), longcols)
+    }
+  }
+
+  # construct query and return result
+  q <- sprintf("SELECT %s FROM %s", paste(allcols, collapse = ", "), table_name)
+  return(dbQueryNASIS(con, q))
+}
+
+#' Create a memory or file-based instance of NASIS database (for selected tables) 
+#'
+#' @param tables Character vector of target tables. Default: \code{NULL} is all tables meeting the following criteria.
+#' @param SS Logical. Include "selected set" tables (ending with suffix \code{"_View1"}). Default: \code{FALSE}
+#' @param systables Logical. Include "system" tables (starting with prefix \code{"system"}). Default: \code{FALSE}
+#' @param static_path Optional: path to SQLite database containing NASIS table structure; Default: \code{NULL}
+#' @param output_path Optional: path to new/existing SQLite database to write tables to. Default: \code{NULL} returns table results as named list.
+#' @return A named list of results from calling \code{dbQueryNASIS} for all columns in each NASIS table.
+#' @export
+#' 
+#' @importFrom odbc dbListTables 
+#' @importFrom RSQLite dbListTables RSQLite
+#' @importFrom DBI dbConnect dbDisconnect dbWriteTable
+#' 
+#' @examples
+#' 
+#' \dontrun{
+#'  str(createStaticNASIS(tables = c("calculation","formtext")))
+#' }
+#' 
+createStaticNASIS <- function(tables = NULL, SS = FALSE, systables = FALSE, 
+                              static_path = NULL, output_path = NULL)  {
+  # can make static DB from another static DB, or default is local NASIS install (static_path=NULL)
+  con <- dbConnectNASIS(static_path = static_path) 
+
+  nasis_table_names <- NULL
+
+  # explicit handling of the connection types currently allowed
+  if (inherits(con, 'OdbcConnection')) nasis_table_names <- odbc::dbListTables(con)
+
+  # you can read/write from SQLite with this method just as well as ODBC
+  if (inherits(con, 'SQLiteConnection')) nasis_table_names <- RSQLite::dbListTables(con)
+
+  # must know names of tables in data source
+  stopifnot(!is.null(nasis_table_names))
+
+  # never pull the system table
+  if (!systables) { 
+    systables <- grep("^system", nasis_table_names)
+
+    if (length(systables) > 0) {
+      nasis_table_names <- nasis_table_names[-systables]
+    }
+  }
+
+  # keep only explicitly listed tables, if any
+  if (!is.null(tables) & length(tables) > 0 & is.character(tables)) {
+    nasis_table_names <- nasis_table_names[nasis_table_names %in% tables]
+  }
+
+  # remove selected set tables
+  if (!SS) {
+    sstables <- grep("_View1$", nasis_table_names)
+    nasis_table_names <- nasis_table_names[!nasis_table_names %in% sstables]
+  }
+
+  # return list result if no output path
+  if (is.null(output_path)) {
+
+    # return named list of data.frames or try-error (one per table)
+    res <- lapply(nasis_table_names, function(n) try(.dump_NASIS_table, static_path))
+    names(res) <- nasis_table_names
+    return(res)
+
+  # otherwise, we are writing SQLite to output_path
+  } else {
+
+    # TODO: validation of output_path?
+
+    # create sqlite db
+    outcon <- DBI::dbConnect(RSQLite::SQLite(), output_path)
+
+    # returns TRUE, invisibly, or try-error (one per table)
+    return(lapply(nasis_table_names, function(n) {
+        return(try({
+          DBI::dbWriteTable(conn = outcon, name =  n, 
+                            value = .dump_NASIS_table(n, 
+                                                      static_path = static_path), 
+                            overwrite = TRUE)
+        }))
+    }))
+
+    # close output connection 
+    DBI::dbDisconnect(outcon)
+  }
+
+  # close input connection
+  DBI::dbDisconnect(con)
+}

R/fetchNASISLabData.R

@@ -2,7 +2,7 @@
 fetchNASISLabData <- function(SS = TRUE) {
 
 	# test connection
-	if (!local_NASIS_defined())
+	if (!local_NASIS_defined(static_path))
 			stop('Local NASIS ODBC connection has not been setup. Please see the `setup_ODBC_local_NASIS.pdf` document included with this package.')
 
 	# 1. load data in pieces, results are DF objects

R/fetchNASIS_pedons.R

@@ -7,7 +7,7 @@
                                static_path = NULL) {
 
   # test connection
-  if (!local_NASIS_defined())
+  if (!local_NASIS_defined(static_path))
     stop('Local NASIS ODBC connection has not been setup. Please see `http://ncss-tech.github.io/AQP/soilDB/setup_local_nasis.html`.')
 
   # sanity check

R/fetchVegdata.R

@@ -4,7 +4,7 @@
 fetchVegdata <- function(SS=TRUE, stringsAsFactors = default.stringsAsFactors()) {
 
   # test connection
-  if (!local_NASIS_defined())
+  if (!local_NASIS_defined(static_path))
     stop('Local NASIS ODBC connection has not been setup. Please see `http://ncss-tech.github.io/AQP/soilDB/setup_local_nasis.html`.')
 
 	# 1. load data in pieces

R/getHzErrorsNASIS.R

@@ -1,19 +1,20 @@
 #' Check pedon horizon table for logic errors
 #'
 #' @param strict how strict should horizon boundaries be checked for consistency: TRUE=more | FALSE=less
-#'
+#' @param SS 	fetch data from the currently loaded selected set in NASIS or from the entire local database (default: TRUE)
+#' @param static_path Optional: path to local SQLite database containing NASIS table structure; default: NULL
 #' @return A data.frame containing problematic records with columns: 'peiid','pedon_id','hzdept','hzdepb','hzname' 
 #' @export
 #'
-getHzErrorsNASIS <- function(strict = TRUE) {
+getHzErrorsNASIS <- function(strict = TRUE, SS = TRUE, static_path = NULL) {
 
-  if (!local_NASIS_defined())
+  if (!local_NASIS_defined(static_path))
     stop('Local NASIS ODBC connection has not been setup. Please see `http://ncss-tech.github.io/AQP/soilDB/setup_local_nasis.html`.')
 
 	# get data
-	site_data <- get_site_data_from_NASIS_db()
+	site_data <- get_site_data_from_NASIS_db(SS = SS, static_path = static_path)
 	site_data$pedon_id <- NULL
-	hz_data <- get_hz_data_from_NASIS_db()
+	hz_data <- get_hz_data_from_NASIS_db(SS = SS, static_path = static_path)
 
 	if (nrow(site_data) == 0) {
 	  message("No Site records in NASIS database")

R/get_cosoilmoist_from_NASIS.R

@@ -1,4 +1,4 @@
-get_cosoilmoist_from_NASIS <- function(impute = TRUE, stringsAsFactors = default.stringsAsFactors(), static_path = NULL) {
+get_cosoilmoist_from_NASIS <- function(SS = TRUE, impute = TRUE, stringsAsFactors = default.stringsAsFactors(), static_path = NULL) {
 
   q.cosoilmoist <- "SELECT dmuiidref AS dmuiid, coiid, compname, comppct_r, drainagecl, month, flodfreqcl, floddurcl, pondfreqcl, ponddurcl, cosoilmoistiid, soimoistdept_l, soimoistdept_r, soimoistdept_h, soimoistdepb_l, soimoistdepb_r, soimoistdepb_h, soimoiststat
 
@@ -14,6 +14,11 @@ get_cosoilmoist_from_NASIS <- function(impute = TRUE, stringsAsFactors = default
   if (inherits(channel, 'try-error'))
     return(data.frame())
 
+  # toggle selected set vs. local DB
+  if (SS == FALSE) {
+    q.cosoilmoist <- gsub(pattern = '_View_1', replacement = '', x = q.cosoilmoist, fixed = TRUE)
+  }
+
   # exec query
   d.cosoilmoist <- dbQueryNASIS(channel, q.cosoilmoist)