R/createStaticNASIS.R

In ncss-tech/soilDB: Soil Database Interface

# Method for "dumping" contents of an entire NASIS table
#
# @param table_name Character name of table.
# @param dsn 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, dsn = NULL) {
# 
#   # connect to NASIS, identify columns
#   con <- dbConnectNASIS(dsn)
#   allcols <- "*"
# 
#   columns <- NULL
#   
#   # # handling for MSSQL/ODBC weirdness
#   # # previously required for issues with nanoodbc driver 
#   # # see https://github.com/ncss-tech/soilDB/pull/149
#   # if (is.null(dsn) || inherits(con, 'OdbcConnection')) {
#   # 
#   #   # assuming that default connection uses ODBC
#   #   if (!requireNamespace("odbc"))
#   #     stop("package `odbc` is required ", call. = FALSE)
#   # 
#   #   columns <- odbc::dbListFields(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)
#   
#   q <- gsub('\\brule\\b', '\"rule\"', q)
#   
#   res <- dbQueryNASIS(con, q)
#   
#   if (is.null(columns)) {
#     columns <- data.frame(name = colnames(res))
#   }
#   
#   # put back into original order from NASIS
#   return(res[, match(colnames(res), columns$name)])
# }

#' Create a memory or file-based instance of NASIS database
#'
#' Create a memory or file-based instance of NASIS database for selected tables.
#'
#' @param tables Character vector of target tables. Default: \code{NULL} is
#'   whatever tables are listed by `DBI::dbListTables` for the connection typ
#'   being used.
#' @param SS Logical. Include "selected set" tables (ending with suffix
#'   \code{"_View_1"}). Default: \code{TRUE}
#' @param dsn Optional: path to SQLite database containing NASIS table
#'   structure; or a `DBIConnection`. 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.
#' @param new_names Optional: new table names (should match length of vector of
#'   matching `tables` in `dsn`)
#' @param verbose Show error messages from attempts to dump individual tables?
#'   Default `FALSE`
#'
#' @return A named list of results from calling \code{dbQueryNASIS} for all
#'   columns in each NASIS table.
#' 
#' @export createStaticNASIS
createStaticNASIS <- function(tables = NULL,
                              new_names = NULL,
                              SS = TRUE,
                              dsn = NULL,
                              output_path = NULL,
                              verbose = FALSE)  {
  
  # can make static DB from another static DB, or default is local NASIS install (dsn=NULL)
  con <- dbConnectNASIS(dsn = dsn)
  
  # close input connection if not defined by user
  on.exit({
    if (isFALSE(attr(con, 'isUserDefined'))) {
      DBI::dbDisconnect(con)
    }
  })
  
  nasis_table_names <- NULL

  # explicit handling of the connection types currently allowed
  if (missing(tables)) {
    if (inherits(con, 'OdbcConnection')) {

      if (requireNamespace("odbc"))
        nasis_table_names <- odbc::dbListTables(con)

    } else if (inherits(con, 'SQLiteConnection')) {

      if (requireNamespace("RSQLite"))
        nasis_table_names <- RSQLite::dbListTables(con)

    } else {
      stop("Currently only OdbcConnection and SQLiteConnection are supported", call. = FALSE)
    }

    # must know names of tables in data source
    stopifnot(!is.null(nasis_table_names))
  }

  # keep only explicitly listed tables, if any
  if (!is.null(tables) & length(tables) > 0 & is.character(tables)) {
    nasis_table_names <- tables

    if (!is.null(new_names) && length(new_names) != length(nasis_table_names))
      stop(sprintf("new table names have length %s, but found only %s NASIS tables to rename",
                   length(new_names), length(nasis_table_names)), call. = FALSE)


  } else {
    stop("no tables in database or `tables=` argument", call. = FALSE)
  }

  # remove selected set tables if SS is false
  if (!SS) {
    sstables <- nasis_table_names[grep("_View_1$", nasis_table_names)]
    nasis_table_names <- nasis_table_names[!nasis_table_names %in% sstables]
  }

  if (length(nasis_table_names) == 0) {
    warning("length of vector of table names to query is zero. check `SS` argument")
    return(NULL)
  }

  # 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(DBI::dbReadTable(con, n), silent = verbose))
    if(!is.null(new_names))
      names(res) <- new_names
    else names(res) <- nasis_table_names

    return(res)

  # otherwise, we are writing SQLite to output_path
  } else {

    # assuming that default connection uses ODBC
    if (!requireNamespace("RSQLite"))
      stop("package `RSQLite` is required ", call. = FALSE)

    # create sqlite db
    # RSQLite 2.2.4+ supports `extended_types` argument
    # When TRUE columns of type DATE, DATETIME / TIMESTAMP, and TIME are mapped to corresponding R-classes, c.f. below for details. 
    if (!inherits(output_path, 'DBIConnection'))
       outcon <- DBI::dbConnect(RSQLite::SQLite(), output_path, extended_types = TRUE)
    else outcon <- output_path

    # returns TRUE, invisibly, or try-error (one per table)
    res <- lapply(seq_along(nasis_table_names), function(i) {
        return(try({
          n <- nasis_table_names[i]

          if (!is.null(new_names))
            newname <- new_names[i]
          else newname <- n

          newdata <- try(DBI::dbReadTable(con, n), silent = verbose)
          
          # previously processed Date/Times -> character for output
          
          DBI::dbWriteTable(conn = outcon,
                            name =  newname,
                            value = newdata,
                            overwrite = TRUE)
        }))
    })

    # close output connection
    DBI::dbDisconnect(outcon)
    
    return(res)
  }
}