R/pcheck.functions.R

In FIESTAutils: Utility Functions for Forest Inventory Estimation and Analysis

# pcheck.logical	- Checks logical function parameters
# pcheck.unique	     - Check for unique records
# pcheck.varchar	- Checks string variable parameter
# pcheck.table
# pcheck.outfolder
# pcheck.states
# pcheck.object
# pcheck.output
# pcheck.colors
# pcheck.areaunits
# pcheck.spatial - checks or gets Vector layer from file name or spatial object
# pcheck.params - function to check input list parameters
# pcheck.opts - function to check input parameter options

#' @rdname pcheck_desc
#' @export
pcheck.logical <- function (var2check, varnm=NULL, title=NULL, first="YES",
	gui=FALSE, stopifnull=FALSE) {
  ## DESCRIPTION: Checks logical function parameters

  msg <- ifelse (!is.null(varnm), paste(varnm, "must be logical"),
	"variable must be logical")
  second <- ifelse(toupper(first) == "YES", "NO", "YES")
  if (is.null(var2check)) {
    if (gui) {
      resp <- select.list(c(first, second), title=title, multiple=FALSE)
      if (resp == "") stop("")
      var2check <- ifelse(resp == "YES", TRUE, FALSE)
    } else {
      if (stopifnull) {
        stop(paste(varnm, "is invalid"))
      } else {
        return(NULL)
      }
    }
  } else if (!is.logical(var2check)) {
    stop(varnm, " must be logical")
  }
  return(var2check)
}

#' @rdname pcheck_desc
#' @export
pcheck.unique <- function(tab, uniqueid, gui=FALSE, tabnm=NULL,
	warn=NULL, stopifnull=FALSE, stopifinvalid=TRUE, multiple=FALSE, ...){
  ## DESCRIPTION: Checks string variable parameter

  tab <- pcheck.table(tab)
  uniqueid <- c("PLT_CN", "CONDID")

  if (is.null(tabnm)) {
    tabnm <- "data frame"
  }
  setkeyv(tab, uniqueid)

  if (!tab[, uniqueN(.SD) == .N, .SDcols=key(tab)]) {
    stop("uniqueid for ", tabnm, " is not unique: ", toString(uniqueid))
  }
  return(tab)
}

#' @rdname pcheck_desc
#' @export
pcheck.varchar <- function(var2check, varnm=NULL, checklst, gui=FALSE, caption=NULL,
	warn=NULL, stopifnull=FALSE, stopifinvalid=TRUE, multiple=FALSE, ...){
  ## DESCRIPTION: Checks string variable parameter

  if (is.null(varnm)) {
    varnm <- "varnm"
  } else {
    if (!is.character(varnm)) {
      warning("varnm must be a string\n")
    }
  }
  #if (is.null(var2check) && stopifnull) stop(paste(varnm, "is NULL\n"))
  if (is.null(caption)) {
    caption <- paste0(varnm, "?")
  }
  if (is.null(warn)) {
    warn <- ifelse(!is.null(checklst) && length(checklst) < 6,
		paste(varnm, "must be in following list:", toString(checklst)),
		paste(varnm, "is invalid\n"))
  }

  if (is.null(var2check) || any(is.na(var2check)) || length(var2check) == 0 || any(gsub(" ", "", var2check) == "")) {
    if (gui) {
      var2check <- select.list(checklst, title=caption, multiple=multiple, ...)
      if (length(var2check) == 0 || any(var2check == "")) {
        stop("NULL")
      }
    } else {
      if (stopifnull) {
        stop(paste(varnm, "is NULL\n"))
      } else {
        return(NULL)
      }
    }
  } else if (!is.vector(var2check)) {
    stop(varnm, " must be a vector")
  } else if (!multiple && length(var2check) > 1) {
    stop(varnm, " must be a vector of length 1")
  } else if (!is.character(var2check)) {
    stop(varnm, " must be a string vector")
  } else if (!all(var2check %in% checklst)) {
    if (all(toupper(var2check) %in% checklst)) {
      var2check <- toupper(var2check)
    } else if (all(tolower(var2check) %in% checklst)) {
      var2check <- tolower(var2check)
    } else if (all(capfirst(var2check) %in% checklst)) {
      var2check <- capfirst(var2check)
    } else if (gui) {
      message(warn)
      var2check <- select.list(checklst, title=caption, multiple=multiple, ...)
      if (length(var2check) == 0 || any(var2check == "")) stop("")
    } else {
      if (stopifinvalid) {
        if (multiple) {
          warn <- message("invalid variable: ",
				toString(var2check[which(!var2check %in% checklst)]),
				"\n possible values: ", toString(checklst),"\n")
        }
        stop(warn)
      } else {
        return(NULL)
      }
    }
  }
  return(var2check)
}

#' @rdname pcheck_desc
#' @export
pcheck.dsn <- function(dsn, dbconnopen=TRUE) {
  if (is.null(dsn)) {
    stop("dsn is null")
  }
  if (!file.exists(dsn)) {
    extlst <- c("shp", "csv", "sqlite", "gpkg", "gdb", "db", "db3")
    ext <- extlst[sapply(extlst, function(x, dsn)
				file.exists(paste(dsn, x, sep=".")), dsn)]
    if (length(ext) == 1)
      dsn <- paste(dsn, ext, sep=".")
  }
  tabext <- getext(dsn)
  if (any(is.na(tabext)) || any(tabext == "NA")) {
    stop("dsn must include extension")
  }
  if (tabext %in% c("sqlite", "gpkg")) {
    return(DBtestSQLite(dsn, dbconnopen=dbconnopen))
  } else if (tabext == "shp") {
    return(dsn)
  } else {
    if (!file.exists(dsn)) stop("file does not exist")
    #stop("file format currently not supported")
  }
}

#' @rdname pcheck_desc
#' @export
pcheck.table <- function(tab=NULL, conn=NULL, tab_dsn=NULL, tabnm=NULL, tabqry=NULL,
	caption=NULL, returnsf=TRUE, factors=FALSE, returnDT=TRUE, warn=NULL,
	stopifnull=FALSE, stopifinvalid=FALSE, nullcheck=FALSE, obj=FALSE, 
    checkonly=FALSE, gui=FALSE) {

  ## DESCRIPTION: This function checks the table parameter..  if NULL, it prompts the
  ##      user with gui options to select the table of interest.
  ## ARGUMENTS:
  ## tab - Dataframe or layer name in tab_dsn
  ## tab_dsn - String. data source name where tab resides
  ## tabqry - Database query for extracting tab (if tab_dsn != NULL)
  ## caption  String. Caption
  ## shp  Logical. If TRUE and tab is a shapefile, return a shapefile.

  ## Set global variables
  x=tabx <- NULL

  ## Define accepted file format extents
  extlst <- c("shp", "csv", "sqlite", "sqlite3", "db", "db3", "gpkg", "gdb")

  if (!factors) {
    options.old <- options()
    options(stringsAsFactors=FALSE)
    on.exit(options(options.old), add=TRUE)
  }

  ## Adds to file filters to Cran R Filters table.
  if (.Platform$OS.type=="windows") {
    Filters=rbind(Filters,shp=c("Shapefiles (*.shp)", "*.shp"))
    Filters=rbind(Filters,csv=c("Comma-delimited files (*.csv)", "*.csv"))
    Filters=rbind(Filters,sqlite=c("SQLite database (*.sqlite)", "*.sqlite"))
    Filters=rbind(Filters,sqlite=c("SQLite database (*.db)", "*.db"))
    Filters=rbind(Filters,sqlite=c("SQLite database (*.db3)", "*.db3"))
    Filters=rbind(Filters,gpkg=c("GeoPackage SQLite database (*.gpkg)", "*.gpkg")) }
  tabdblst <- c("sqlite", "sqlite3", "db", "db3", "gpkg")

  if (is.null(tabnm)) {
    tabnm <- "tab"
  }
  if (is.null(caption)) {
    caption <- "Table?"
  }

  selectlst <- c("NONE", "R Object", "csv", "database")
  if (returnsf) {
    selectlst <- c(selectlst, "*.shp" )
  }
  ## Check gui
  if (gui && !.Platform$OS.type=="windows") {
    stop("gui not supported")
  }

  
  if (is.object(tab) && is.data.frame(tab)) {
    conn <- NULL
  }	

  if (!is.null(conn)) {
    conntest <- tryCatch(DBI::dbIsValid(conn),
                         error=function(err) {
                           return(NULL)
                           } )
    if (is.null(conntest)) {
      if (stopifnull) {
	    message("invalid database connection: ", conn, "\n")
        stop()
      } else {
        return(NULL)
      }
    } else {
      tablst <- DBI::dbListTables(conn)
      if (is.character(tab) && length(tab) == 1) {
        tabnm <- findnm(tab, tablst, returnNULL=TRUE)
        if (is.null(tabnm)) {
		  if (stopifnull) {
            stop(tab, " is not in database")
          } else {
		    message(tab, " is not in database")
		    return(NULL)
		  }
		}
		if (checkonly) {
		  return(tab)
		}
        if (!is.null(tabqry)) {
          tabx <- tryCatch(DBI::dbGetQuery(conn, tabqry),
			      error=function(e) {
			      #print(e)
			      return(NULL)})
          if (is.null(tabx)) {
            message("tabqry is invalid")
			return(NULL)
          } else {
            tab <- tabx
          }
        } else {
          tab <- DBI::dbReadTable(conn, tabnm)
        }
        if (returnDT) {
          return(setDT(tab))
        } else {
          return(tab)
        }
      } else {
        if (stopifnull) {
          stop("invalid tab... must be character name in database")
        } else {
          return(NULL)
        }
      }
    }
  } else if (is.null(tab) && is.null(tab_dsn)) {
    if (gui) {
      tabresp <- select.list(selectlst, title=caption, multiple=FALSE)
      if (tabresp=="") {
        stop("")
      } else if (tabresp == "NONE") {
        tabx <- NULL
      } else if (tabresp == "R Object") {
        objlst <- c(ls(pos=1, all.names=TRUE),
		ls(envir=as.environment("package:FIESTA"), pattern="WY"))
        objlst <- objlst[sapply(objlst, function(x) is.data.frame(get(x)))]
        tabobj <- select.list(objlst, title=caption, multiple=FALSE)
        if (tabobj == "") stop("")
        tabx <- get(tabobj, pos=1)
        if (sum(grepl("Spatial", class(tab)) > 0))
          if (!returnsf) tabx <- tabx$data
      } else if (tabresp == "csv") {
        tabfn <- choose.files(default=getwd(), caption=caption,
			filters=Filters[c("csv", "All"),], multi=FALSE)
        if (tabfn == "") stop("")
      } else if (tabresp == "shp") {
        shpfn <- choose.files(default=getwd(), caption="Select point shapefile",
            filters=Filters[c("shp", "All"),], multi=FALSE)
        if (is.null(shpfn)) stop("")
      } else if (tabresp == "database") {
        tab_dsn <- choose.files(default=getwd(), caption="Select database file",
            filters=Filters[c(tabdblst, "All"),], multi=FALSE)
        if (tab_dsn == "") stop("")
      }
    }
    if (is.null(tabx) && stopifnull) {
      stop(paste(tabnm, "is NULL"))
    }
  }

  if (!is.null(tab)) {
    if (is.character(tab)) {
      if (length(tab) > 1) {
        if (stopifinvalid) {
          stop("x has length > 1")
        } else {
          return(NULL)
        }
      }
        
      if (obj && exists(tab, envir=.GlobalEnv) && is.data.frame(get(tab))) {
        #message(tab, " exists in Global Environment")
        return(get(tab))
      } else if (file.exists(tab) && !is.null(tab_dsn)) {
        tab_dsn <- tab
      }
    }
    if ("sf" %in% class(tab)) {
      if (returnsf) {
        return(tab)
      } else {
        tab <- sf::st_drop_geometry(tab)
        if (returnDT) tab <- data.table(tab)
        return(tab)
      }
    } else if (canCoerce(tab, "sf")) {
      tabx <- sf::st_as_sf(tab)
      if (returnsf) {
        return(tabx)
      } else {
        tab <- sf::st_drop_geometry(tab)
        if (returnDT) tab <- data.table(tab)
        return(tab)
      }
    } else if (is.data.frame(tab)) {
      if (nrow(tab) == 0) {
        warn <- ifelse (!is.null(warn), warn, paste(tabnm, "is a data frame with 0 rows"))
        if (stopifnull) stop(warn)
        message(warn)
        return(NULL)
      } else {
        if (returnDT) {
          tab <- data.table(tab)
        } else {
          tab <- data.frame(tab)
        }
        if (!is.null(tabqry)) {
          tabx2 <- tryCatch(sqldf::sqldf(tabqry, tab),
			      error=function(e) {
			      #print(e)
			      return(NULL)})
          if (is.null(tabx2)) {
            message("tabqry is invalid")
            tab <- tabx2
          } else {
            #message("tabqry applied to tab")
          }
        }
        return(tab)
      }
    } else if (!is.character(tab)) {
      stop(tabnm, " must be an sf object or character layer name")
    }
  }

  if (is.null(tab_dsn)) {
    tab_dsn <- tab
  }
  if (!is.null(tab_dsn) && !file.exists(tab_dsn)) {
    ext <- extlst[sapply(extlst, function(x, tab_dsn)
				file.exists(paste(tab_dsn, x, sep=".")), tab_dsn)]
    if (length(ext) == 1 && ext == "shp")
        tab_dsn <- paste(tab_dsn, ext, sep=".")
  } else {
    if (is.null(tab)) return(NULL)
  }
  
  tabext <- getext(tab_dsn)

  if (any(is.na(tabext)) || any(tabext == "NA")) {
    if (dir.exists(tab_dsn) && file.exists(paste(tab_dsn, tab, sep="/"))) {
      tab_dsn <- paste(tab_dsn, tab, sep="/")
      tabext <- getext(tab_dsn)
    } else {
      if (!stopifinvalid) {
        return(NULL)
      } else {
        stop(tabnm, " is invalid")       
	  }
    }
  }

  if (tabext == "shp") {
    tabx <- sf::st_read(tab_dsn, quiet=TRUE)

    if (!is.null(tabqry)) {
      tabx2 <- tryCatch(sqldf::sqldf(tabqry, tabx),
			error=function(e) {
			#print(e)
			return(NULL)})
      if (is.null(tabx2)) {
        message("tabqry is invalid")
        tabx <- tabx2
      }
    }

  } else if (tabext == "gdb") {
    tabx <- pcheck.spatial(tab, dsn=tab_dsn)

    if (!is.null(tabqry)) {
      tabx2 <- tryCatch(sqldf::sqldf(tabqry, tabx),
			error=function(e) {
			#print(e)
			return(NULL)})
      if (is.null(tabx2)) {
        message("tabqry is invalid")
        tabx <- tabx2
      }
    }

  } else if (tabext %in% tabdblst) {
    if (is.null(tab) || !is.character(tab)) {
      if (!stopifinvalid) {
        return(NULL)
      } else {
        stop("tab is invalid")
      }
    }

    if (tabext %in% c("sqlite", "sqlite3", "db", "db3", "gpkg")) {
      dbconn <- DBtestSQLite(tab_dsn, dbconnopen=TRUE, showlist=FALSE)
      tablst <- DBI::dbListTables(dbconn)
      if (!tab %in% tablst) {
        if (tolower(tab) %in% tablst) {
          tab <- tolower(tab)
        } else if (toupper(tab) %in% tablst) {
          tab <- toupper(tab)
        } else {
          stop(tab, " not in ", tab_dsn)
        }
      }
      if (!is.null(tabqry) && any(!is.na(tabqry))) {
        tabx <- data.table(DBI::dbGetQuery(dbconn, tabqry))
      } else {
        tabx <- data.table(DBI::dbReadTable(dbconn, tab))
      }
      DBI::dbDisconnect(dbconn)
    } else {
      stop("file format currently not supported")
    }
  } else {
    tabx <- tryCatch(data.table::fread(tab_dsn, integer64="numeric"),
			error=function(e) {
			#print(e)
			return(NULL)})
    if (is.null(tabx)) {
      if (!tabext %in% extlst) {
        stop("file format is currently not supported")
      } else {
        stop("file is invalid or does not exist")
      }
    }
    if (!is.null(tabqry)) {
      tabx2 <- tryCatch(sqldf::sqldf(tabqry, tabx),
			error=function(e) {
			#print(e)
			return(NULL)})
      if (is.null(tabx2)) {
        message("tabqry is invalid")
        tabx <- tabx2
      }
    }
  }

  if (nullcheck) {
    if (sum(apply(tabx, 1, function(x) sum(is.na(x) | x=="NA" | x=="")) == ncol(x)) > 0)
      tabx <- tabx[apply(tabx, 1, function(x) sum(is.na(x) | x=="NA" | x=="")) != ncol(x),]
  }

  if (returnsf && is(tabx, "sf")) {
    return(tabx)
  } else {
    if (returnDT) {
      if (!is.data.table(tabx)) {
        return(data.table(tabx))
      } else {
        return(tabx)
      }
    } else {
      return(setDF(tabx))
    }
  }
}

#' @rdname pcheck_desc
#' @export
pcheck.outfolder <- function(outfolder, default=getwd(), gui=FALSE) {
  if (is.null(outfolder)) {
    if (gui && .Platform$OS.type=="windows") {
      outfolder <- choose.dir(default=getwd(), caption="Select folder")
      if (is.na(outfolder)) stop("")
    } else {
      if (is.null(default)) {
        return(NULL)
      } else if (is.null(outfolder)) {
        message("outfolder is NULL, defaulting to working directory")
        outfolder <- getwd()
      }
      #return(NULL)
    }
  } else {

    if (!is.character(outfolder)) {
      stop("outfolder must be character string")
    } else if (!dir.exists(outfolder)) {
      stop("invalid outfolder")
    }
  }
  return(normalizePath(outfolder, winslash="/"))
}


#' @rdname pcheck_desc
#' @export
pcheck.states <- function (states, statereturn="MEANING", gui=FALSE, RS=NULL,
	stopifnull=FALSE, ...) {
  ## DESCRIPTION:
  ## Check states and return in proper format
  ##
  ## ARGUMENTS:
  ## states		String or Numeric Vector: Name or code of states
  ## statereturn	String. Format to return state in ("VALUE", "MEANING", "ABBR", "RSCD", "RS")
  ## gui		Logical. TRUE, if gui is allowed.
  ## RS		String Vector: Research unit (optional).
  ## ...		Other parameters to select.list

  ref_state <- FIESTAutils::ref_statecd
  if (!statereturn %in% names(ref_state)) stop("statereturn is invalid")

  if (!is.null(RS)) {
    if (all(RS %in% ref_state$RS)) {
      ref_state <- ref_state[ref_state$RS %in% RS, ]
    } else {
      warning("RS is invalid")
    }
  }

  ## If NULL and gui=TRUE, prompt user
  if (is.null(states)) {
    if (gui) {
      states <- select.list(ref_state[[statereturn]], title="States", multiple=TRUE, ...)
      if (length(states) == 0) stop("")
    } else {
      if (!is.null(RS)) {
        states <- ref_state[[statereturn]]
        message(paste("returning all states in", paste(RS, collapse=",")))
      } else {
        if (stopifnull) stop("invalid state\n")
        return(NULL)
      }
    }
  }

  ## Check state name(s)
  if (!is.vector(states)) 
    stop("states must be vector of codes or names")

  if (!all(states %in% c(ref_state$VALUE, ref_state$ABBR, ref_state$MEANING))) {
    states2 <- sub("_", " ", states)

    if (!all(states2 %in% c(ref_state$VALUE, ref_state$ABBR, ref_state$MEANING))) {
      ## Make sure all states have first letter capital
      states2 <- capfirst(states, allwords=TRUE)

      if (!all(states2 %in% c(ref_state$VALUE, ref_state$ABBR, ref_state$MEANING))) {
        states.miss <- states[which(!states %in% c(ref_state$VALUE, ref_state$ABBR,
		  ref_state$MEANING))]
        if (length(states.miss) > 0) {
          stop("invalid states: ", states.miss, "\n")
        } else {
          return(NULL)
        }
      }
    }
    states <- states2
  }

  if (all(states %in% ref_state$VALUE) && is.character(states))
    states <- as.numeric(states)

  ## Set column where state name is from
  col <- ifelse(all(states %in% ref_state$VALUE), "VALUE",
		ifelse(all(states %in% ref_state$ABBR), "ABBR",
			ifelse(all(states %in% ref_state$MEANING), "MEANING")))
  if (col == "VALUE") states <- as.numeric(states)

  ## Get states to return
  if (statereturn != col) {
    states2return <- ref_state[ref_state[,col] %in% states,
		statereturn]
  } else {
    states2return <- states
  }

  return(states2return)
}

#' @rdname pcheck_desc
#' @export
pcheck.object <- function(obj=NULL, objnm=NULL, warn=NULL, caption=NULL,
	stopifnull=FALSE, gui=FALSE, list.items=NULL){
  ## DESCRIPTION: checks object name

  ## Adds to file filters to Cran R Filters table.
  if (.Platform$OS.type=="windows") {
    Filters=rbind(Filters,obj=c("Rda Objects (*.rda)", "*.rda")) 
    Filters=rbind(Filters,obj=c("Rds Objects (*.rds)", "*.rds")) 
  }

  ## Set global variables
  objx <- NULL

  if (is.null(objnm)) objnm <- "obj"
  if (is.null(caption)) caption <- "Object?"

  selectlst <- c("NONE", "object", "rda", "rds")

  ## Check gui
  if (gui && !.Platform$OS.type=="windows")
    stop("gui not supported")
  if (is.null(obj)) {
    if (gui) {
      objresp <- select.list(selectlst, title=caption, multiple=FALSE)
      if (objresp=="") {
        stop("")
      } else if (objresp == "NONE") {
        objx <- NULL
      } else if (objresp == "R Object") {
        objlst <- c(ls(pos=1, all.names=TRUE),
		ls(envir=as.environment("package:FIESTA"), pattern="WY"))
        objlst <- objlst[sapply(objlst, function(x) is.data.frame(get(x)))]
        obj <- select.list(objlst, title=caption, multiple=FALSE)
        if (obj == "") stop("")
        objx <- get(obj, pos=1)
        #if (!is.list(objx)) stop("must be list object")
      } else if (objresp == "rda") {
        objfn <- choose.files(default=getwd(), caption=caption,
			filters=Filters[c("rda", "All"),], multi=FALSE)
        if (objfn == "") stop("")
        objx <- get(load(objfn))
        #if (!is.list(objx)) stop("must be list object")
      } else if (objresp == "rds") {
        objfn <- choose.files(default=getwd(), caption=caption,
			filters=Filters[c("rds", "All"),], multi=FALSE)
        if (objfn == "") stop("")
        objx <- readRDS(file = objfn)
        #if (!is.list(objx)) stop("must be list object")
      }
    }
    if (is.null(objx) && stopifnull) stop(paste(objnm, "is NULL"))
      return(NULL)
  }
 
  if (!is.null(obj)) {
    if (is.character(obj)) {
      if (exists(obj, envir=.GlobalEnv) && is.list(get(obj))) {
        #message(tab, " exists in Global Environment")
        return(get(obj))
      } else if (any(!is.na(getext(obj))) && file.exists(obj)) {
        objext <- getext(obj)
        if (objext == "rda") {
          objx <- get(load(obj))
        } else if (objext == "rds") {
          objx <- readRDS(file = obj)
        } else {
          stop("obj not supported")
        }
      } else if (any(!is.na(getext(obj))) && !file.exists(obj)) {
        stop("file does not exist")
      } else if (any(is.na(getext(obj)))) {
        stop(objnm, " must be a list object or filename")
      } else {F
        stop(objnm, " must be a list object or filename")
      }
    } else if (!is.list(obj)) {
      stop(objnm, " must be a list object or filename")
    } else {
      objx <- obj
    }
  }
 
  if (!is.null(list.items)) {
    if (!all(list.items %in% names(objx))) {
      missitems <- list.items[!list.items %in% names(objx)]
      stop(objnm, " must include the following item in list: ", toString(missitems))
    } else {
      if (any(unlist(lapply(objx[list.items], is.null)))) {
        listnames <- (names(which(unlist(lapply(objx[list.items], is.null)))))
		if (stopifnull) {
          stop("tables are null: ", toString(listnames))
		}
      }
    }
  }

  return(objx)
}

#' @rdname pcheck_desc
#' @export
pcheck.output <- function(out_fmt = "csv", outsp_fmt = "shp", 
                          out_dsn = NULL, outfolder = NULL,
                          outfn.pre = NULL, outfn.date = FALSE, 
                          overwrite_dsn = FALSE, overwrite_layer = TRUE, 
                          add_layer = TRUE, append_layer = FALSE,
                          createSQLite=FALSE, out_conn = NULL, 
                          outconn = NULL,
                          dbconnopen = FALSE, gui = FALSE, 
                          savedata_opts = NULL) {
  
  if (!is.null(savedata_opts)) {
    outfolder <- savedata_opts$outfolder
    out_dsn <- savedata_opts$out_dsn
    outfn.pre <- savedata_opts$outfn.pre
    outfn.date <- savedata_opts$outfn.date
    overwrite_dsn <- savedata_opts$overwrite_dsn
    overwrite_layer <- savedata_opts$overwrite_layer
    add_layer <- savedata_opts$add_layer
    append_layer <- savedata_opts$append_layer
    out_fmt <- savedata_opts$out_fmt
    outsp_fmt <- savedata_opts$outsp_fmt
    outconn = savedata_opts$outconn
  } else {
    if (is.null(outconn) && !is.null(out_conn)) {
      outconn <- out_conn
    }
  }

  ## check out_fmt
  ###########################################################
  #out_fmtlst <- c('sqlite', 'sqlite3', 'db', 'db3', 'gpkg', 'csv', 'gdb', 'shp')
  out_fmtlst <- c('sqlite', 'sqlite3', 'db', 'db3', 'gpkg', 'csv', 'shp')
  out_fmt <- pcheck.varchar(out_fmt, varnm="out_fmt", checklst=out_fmtlst,
		caption="Out format", gui=gui)
  
  ## check out_fmt
  ###########################################################
  outsp_fmtlst <- c('sqlite', 'sqlite3', 'db', 'db3', 'gpkg', 'shp')
  outsp_fmt <- pcheck.varchar(outsp_fmt, varnm="outsp_fmt", checklst=outsp_fmtlst,
                            caption="Out spatial format", gui=gui)
  
  
  ## check outfn.date
  outfn.date <- pcheck.logical(outfn.date, varnm="outfn.date",
		title="outfn.date", first="NO", gui=gui)

  ## check overwrite_dsn
  overwrite_dsn <- pcheck.logical(overwrite_dsn, varnm="overwrite_dsn",
		title="overwrite_dsn", first="NO", gui=gui)

  ## check overwrite_layer
  overwrite_layer <- pcheck.logical(overwrite_layer, varnm="overwrite_layer",
		title="overwrite_layer", first="NO", gui=gui)

  ## check add_layer
  add_layer <- pcheck.logical(add_layer, varnm="add_layer",
		title="add data to dsn", first="NO", gui=gui)

  ## check append_layer
  append_layer <- pcheck.logical(append_layer, varnm="append_layer",
		title="append data", first="NO", gui=gui)


  ## check outfn.pre
  if (!is.null(outfn.pre) && (!is.vector(outfn.pre) || length(outfn.pre) > 1)) {
    stop("invalid outfn.pre")
  }

  ## check layer.pre
  #if (!is.null(layer.pre) && (!is.vector(layer.pre) || length(layer.pre) > 1)) {
  #  stop("invalid layer.pre")
  #}

  if (!is.null(outconn)) {
    outconnchk <- tryCatch(
      DBI::dbIsValid(outconn),
                 error = function(e) {
                 return(NULL) })
    if (is.null(outconnchk)) {
      message("outconn is invalid...\n", outconn)
      stop()
    }  
    
    ## check out_fmt
    outconn_class <- class(outconn)
    if (outconn_class == "SQLiteConnection") {
      if (out_fmt != "sqlite") out_fmt <- "sqlite"
    } else if (outconn_class == "PqConnection") {
      if (out_fmt != "postgres") out_fmt <- "postgres"
    }

    out_dsn <- DBI::dbGetInfo(outconn)$dbname
    outfolder <- NULL
    if (append_layer) {
      overwrite_layer <- FALSE
    }
 
    return(list(out_dsn = out_dsn, outfolder = outfolder, 
                out_fmt = out_fmt,
		            overwrite_layer = overwrite_layer, 
		            append_layer = append_layer,
		            outfn.date = outfn.date, outfn.pre = outfn.pre, 
		            outconn = outconn))
  }
  
  if (is.null(out_dsn) && any(c(out_fmt, outsp_fmt) %in% c("csv", "shp"))) {
    outfolder <- pcheck.outfolder(outfolder)
    if (append_layer) {
      overwrite_layer <- FALSE
    }
    return(list(out_dsn = NULL, outfolder = outfolder, 
                out_fmt = out_fmt,
                outsp_fmt = outsp_fmt,
		            overwrite_layer = overwrite_layer, 
		            append_layer = append_layer,
		            outfn.date = outfn.date, outfn.pre = outfn.pre))
  }

  ## Check file name
  chkfn <- checkfilenm(out_dsn, outfolder=outfolder)
  if (is.null(chkfn)) {
    ext <- "db"
    if (is.null(out_dsn)) {
      stop("out_dsn is NULL")
    }
    if (is.na(getext(out_dsn))) {
      if (out_fmt == "sqlite") {
        extlst <- c("sqlite", "db", "sqlite3", "db3")
      } else {
        extlst <- out_fmt
      }
      i <- 1
      while (is.null(chkfn) && i <= length(extlst)) {
        exttest <- extlst[i]
        chkfn <- checkfilenm(out_dsn, outfolder=outfolder, ext=exttest)
        if (!is.null(chkfn)) {
          ext <- exttest
        }
        i <- i + 1
      }
    }
  } else {
    ext <- getext(chkfn)
  }
 
  if (is.null(chkfn) || overwrite_dsn || !overwrite_dsn) {
    out_dsn <- getoutfn(out_dsn, outfn.pre = outfn.pre, 
                        outfolder = outfolder,
		                    outfn.date = outfn.date, 
		                    overwrite = overwrite_dsn, 
		                    outfn.default = "data",
		                    ext = ext, add = add_layer, 
		                    append = append_layer)
    if (any(out_fmt %in% c("sqlite", "gpkg")) && createSQLite) {
      gpkg <- ifelse(out_fmt == "gpkg", TRUE, FALSE)
      out_dsn <- DBcreateSQLite(out_dsn, gpkg=gpkg)

      if (dbconnopen) {
        outconn <- DBI::dbConnect(RSQLite::SQLite(), out_dsn, 
                    loadable.extensions = TRUE)
      }
    }
  } else {
    out_dsn <- chkfn
  }

  outfolder <- normalizePath(dirname(out_dsn))
  out_dsn <- basename(out_dsn)

  ## check append_layer
  if (append_layer) {
    overwrite_layer <- FALSE
  }
  if (overwrite_layer) {
    overwrite_dsn <- FALSE
  }

  return(list(out_fmt = out_fmt, 
              outsp_fmt = outsp_fmt, 
              outfolder = outfolder, 
              out_dsn = out_dsn,
	            overwrite_dsn = overwrite_dsn, 
              overwrite_layer = overwrite_layer,
	            add_layer = add_layer, append_layer = append_layer, 
              outfn.date = outfn.date,
              outconn = outconn))
}


#' @rdname pcheck_desc
#' @export
pcheck.colors <- function(colorlst, n) {

   ## Check colorlst
   brewerlst <- c("Accent", "Dark2", "Paired", "Pastel1", "Pastel2", "Set1", "Set2", "Set3")
   brewercblst <- c("Dark2", "Paired", "Set2")
   if (!is.vector(colorlst) || !is.character(colorlst)) {
     stop("colorlst must be a character vector of color names, hexadecimal codes, or brewer palettes")
   }
   if (length(colorlst) == 1 && any(colorlst %in% brewerlst)) {
     if (n < 3) {
       stop("minimum number for brewer palettes is 3")
     }
     colorlst <- RColorBrewer::brewer.pal(n, colorlst)
   } else if (length(colorlst) != n) {
     stop("number of colors is invalid")
   }
   return(colorlst)
}

#' @rdname pcheck_desc
#' @export
pcheck.areaunits <- function(unitarea, areavar, areaunits, metric=FALSE) {
  ## Description: check areaunits for conversions

  gui <- FALSE
#  ## Check outunits
#  outunits <- pcheck.varchar(var2check=outunits, varnm="outunits",
#	gui=gui, checklst=c("ENGLISH", "METRIC"), caption="Area output units?",
#	stopifnull=TRUE)

  ## check metric
  metric <- pcheck.logical(metric, varnm="metric",
		title="Metric units", first="NO", gui=gui)
  if (metric) {
    outunits <- "hectares"
  } else {
    outunits <- "acres"
  }

  areausedvar <- checknm("AREAUSED", names(unitarea))
  unitarea[[areausedvar]] <- unitarea[[areavar]]
  if (areaunits != outunits) {
    if (any(areaunits == "acres") && any(outunits == "hectares")) {
      unitarea[[areausedvar]] <- unitarea[[areausedvar]] * 0.4046860
    } else if (any(areaunits == "hectares") && any(outunits == "acres")) {
      unitarea[[areausedvar]] <- unitarea[[areausedvar]] / 0.4046860
    } else {
      stop("invalid units... cannot convert ", areaunits, " to ", outunits)
    }
  }
  unitarea[[areavar]] <- NULL
  areavar <- areausedvar
  return(list(unitarea=unitarea, areavar=areavar, outunits=outunits))
}

#' @rdname pcheck_desc
#' @export
pcheck.spatial <- function(layer=NULL, dsn=NULL, sql=NA, fmt=NULL, tabnm=NULL,
	caption=NULL, stopifnull=FALSE, gui=FALSE, polyfix=FALSE,
	dropgeom=FALSE, stopifnoCRS=TRUE, checkonly=FALSE) {
  ## DESCRIPTION: checks or gets Vector layer from file name or spatial object.
  ## ARGUMENTS:
  ## dsn		String. The name of the database or path of shapefile (data source name)
  ##				or R Spatial Object.
  ## layer  	String. The name of layer in database or R Spatial Object.
  ## caption  	String. The text to add for gui window caption.
  ## checkonly	Logical. If TRUE, check layer only, do not return.

  ## Adds to file filters to Cran R Filters table.
  if (.Platform$OS.type == "windows") {
    Filters <- rbind(Filters,shp=c("Shapefiles (*.shp)", "*.shp"))
    Filters <- rbind(Filters,gpkg=c("GeoPackages (*.gpkg)", "*.gpkg"))
    Filters <- rbind(Filters,gdb=c("Esri file geodatabase (*.gdb)", "*.gdb"))
    Filters <- rbind(Filters,sqlite=c("SQLite/Spatialite (*.sqlite)", "*.sqlite"))
  }

  ## Check for installed packages
  if (!is.null(fmt)) {
#    if (fmt == "gdb") {
#      if (!"arcgisbinding" %in% rownames(utils::installed.packages())) {
#        message("importing spatial layers from *gdb requires package arcgisbinding")
#      }
#    }
  }
  fmtlst <- c("shp", "sqlite", "gpkg", "gdb")
  stringsAsFactors <- FALSE

  if (is.null(tabnm)) tabnm <- "layer"
  if (is.null(caption)) caption <- ""

  ## Return NULL
  if (is.null(layer) && is.null(dsn)) {
    if (checkonly) {
      return(FALSE)
    } else {
      return(NULL)
    }
  }

  ## Check layer - if sf object
  if (!is.null(layer)) {
    if (length(inherits(layer, "list")) && inherits(layer, "list")) {
      if (length(layer) != 1) {
        stop("invalid layer")
      } else {
        layer <- layer[[1]]
      }
    }
    if ("SpatVector" %in% class(layer)) {
      layer <- sf::st_as_sf(layer) 
    }
    if (any(c("sf", "data.frame") %in% class(layer))) {
      if (nrow(layer) == 0) {
        if (checkonly) {
          return(FALSE)
        } else {
          stop("no rows in layer")
        }
      } else {
        if (checkonly) {
          return(TRUE)
        } else {
          return(layer)
        }
      }
    } else if (methods::canCoerce(layer, "sf")) {
      return(sf::st_as_sf(layer, stringsAsFactors=stringsAsFactors))
    } else if (is.character(layer) && is.null(dsn) && file.exists(layer)) {
      dsn <- layer
    }
  }

  if (!is.null(dsn)) {
    ext.dsn <- getext(dsn)
    if (!file.exists(dsn) && (any(is.na(ext.dsn)) || any(ext.dsn == "NA"))) {
      if (!is.null(fmt) && any(fmt %in% fmtlst))
        dsn <- paste(dsn, fmt, sep=".")
      if (!file.exists(dsn)) dsn <- NULL
    }
    if (ext.dsn %in% c("shp")) {
      if (checkonly) {
        return(TRUE)
      } else {
        layer <- basename.NoExt(dsn)
        splayer <- suppressWarnings(sf::st_read(dsn=dsn, layer=layer,
				stringsAsFactors=stringsAsFactors, quiet=TRUE))
      }
    } else if (ext.dsn %in% c("csv")) {
      layer <- basename.NoExt(dsn)
    } else if (!gui && is.null(layer)) {
      stop("layer is NULL")
    }
  } else {
    ext.layer <- getext(layer)
    if (any(!is.na(ext.layer)) && any(ext.layer != "NA") && file.exists(layer)) {
      if (ext.layer %in% c("shp", "csv")) {
        dsn <- layer
        layer <- basename.NoExt(dsn)
      } else {
        stop(ext.layer, " not supported")
      }
    } else {
      stop("layer is invalid")
    }
  }

  ######################################################
  ## Check dsn
  ######################################################
  if (gui && .Platform$OS.type=="windows") {
    if (is.null(dsn)) {
      fmt <- utils::select.list(fmtlst, title="dsn format?", multiple=FALSE)
      if (fmt == "gdb") {
        dsn <- choose.dir(default=getwd(), caption="Select database")
      } else if (fmt %in% c("sqlite", "gpkg")) {
        dsn <- choose.files(default=getwd(), caption="Select database")
      } else if (fmt == "shp") {
        dsn <- choose.files(default=getwd(), caption="Select database")
      } else {
        stop("format not currently supported")
      }
    } else {
      fmt <- ext.dsn
    }
    if (fmt %in% c("shp", "csv")) {
      layer <- basename.NoExt(dsn)
    } else {
      layerlst <- sf::st_layers(dsn)$name
      layer <- utils::select.list(layerlst, title="Select layer", multiple=FALSE)
    }
  }

  if (is.null(dsn)) {
    message("dsn is NULL")
    if (checkonly) {
      return(FALSE)
    } else {
      stop("dsn is NULL")
    }
  }

  ######################################################
  ## Check layer
  ######################################################
  layerlst <- tryCatch(sf::st_layers(dsn),
                       error = function(e) {
                         message(e,"\n")
                         return(NULL) })
  if (is.null(layerlst)) {
    if (file.exists(dsn)) {
      stop("file exists... but not spatial")
    } else {
      stop("file does not exist")
    }
  }

  ## Note: if dsn is a SpatiaLite database, only spatial layers are listed
  if (!layer %in% layerlst$name) {
    if (checkonly) {
      return(FALSE)
    }
    if (ext.dsn == "sqlite") {
      return(pcheck.table(tab=layer, tab_dsn=dsn))
    } else {
      stop(layer, " is not in database")
    }
  } else {
    if (checkonly) {
      return(TRUE)
    }
  }
  geomtype <- layerlst$geomtype[layerlst$name == layer][[1]]

  if (!is.na(geomtype)) {
    if (!checkonly) {
      chkarc <- NULL
      if (ext.dsn %in% c("gdb", "gpkg")) {
#        if ("arcgisbinding" %in% rownames(utils::installed.packages())) {
#          chkarc <- tryCatch(arcgisbinding::arc.check_product(),
#				error=function(err) {
#					message(err, "\n")
#					return(NULL)
#				} )
#        }
#      }
#      if (ext.dsn == "gdb" && !is.null(chkarc)) {
#        tabS4 <- arcgisbinding::arc.open(paste0(dsn, "/", layer))
#        if (!is.na(sql)) {
#          sql <- check.logic(names(tabS4@fields), sql, xvect=TRUE, syntax="sql")
#          tab <- tryCatch(arcgisbinding::arc.select(tabS4, where_clause=sql),
#				error=function(err) {
#					message(err, "\n")
#					return(NULL)
#				} )
#        } else {
#          tab <- tryCatch(arcgisbinding::arc.select(tabS4),
#				error=function(err) {
#					message(err, "\n")
#					return(NULL)
#				} )
#        }
#        if (!is.null(tab)) {
#          return(tab)
#        } else {
#          stop(layer, " is invalid")
#        }
#      } else {
        #message("sql query not used")

        if (!is.na(sql)) {
          sflayer <- tryCatch(sf::st_read(dsn=dsn, layer=layer, 
				      query=paste0("select * from ", layer, " where ", sql),
				      stringsAsFactors=stringsAsFactors, quiet=TRUE),
				      error=function(err) {
					      message(err, "\n")
					      return(NULL)
				      } )
        } else {
          sflayer <- tryCatch(sf::st_read(dsn=dsn, layer=layer,
				      stringsAsFactors=stringsAsFactors, quiet=TRUE),
				      error=function(err) {
					       message(err, "\n")
					       return(NULL)
				      } )
        }

        return(sflayer)
      }
    } else {
      return(list(dsn=dsn, layer=layer))
    }
  } else {
#    if (ext.dsn == "gdb" && !is.null(sql) && !is.na(sql) &&
#		"arcgisbinding" %in% rownames(utils::installed.packages())) {
#      arcgisbinding::arc.check_product()
#
#      tabS4 <- arcgisbinding::arc.open(paste0(dsn, "/", layer))
#      if (!is.na(sql) && !is.null(sql)) {
#        sql <- check.logic(names(tabS4@fields), sql, xvect=TRUE)
#        tab <- tryCatch(arcgisbinding::arc.select(tabS4, where_clause=sql),
#				error=function(err) {
#					message(err, "\n")
#					return(NULL)
#				} )
#        if (is.null(tab)) {
#          stop(layer, " is invalid")
#        }
#        splayer <- arcgisbinding::arc.data2sf(tab)
#      } else {
#        splayer <- suppressWarnings(sf::st_read(dsn=dsn, layer=layer,
#				stringsAsFactors=stringsAsFactors, quiet=TRUE))
#      }
#    } else {
      splayer <- suppressWarnings(sf::st_read(dsn=dsn, layer=layer,
				stringsAsFactors=stringsAsFactors, quiet=TRUE))
#    }
  }

  if ("sf" %in% class(splayer)) {

    if (nrow(splayer) == 0 && stopifnull) {
      msg <- "layer has 0 records"
      if (stopifnull) {
        stop(msg)
      } else {
        message(msg)
      }
    }

    ## Check if projection
    ############################################################
    if (is.na(sf::st_crs(splayer))) {
      msg <- paste("projection is not defined for:", dsn)
      if (stopifnoCRS) {
        stop(msg)
      } else {
        message(msg)
      }
    }

    ## If polyfix
    ############################################################
    if (polyfix) {
      ## check for empty geometry
      if (sum(sf::st_is_empty(splayer)) > 0) {
        message("there is missing geometry")
        splayer <- splayer[!sf::st_is_empty(splayer),]
      }
      #splayer <- polyfix.sf(splayer)
      if (any(!sf::st_is_valid(splayer))) {
	      splayer <- sf::st_make_valid(splayer)
      }
    } else {
      
      ## check for empty geometry
      if (sum(sf::st_is_empty(splayer)) > 0) {
        message("there is missing geometry... set polyfix = TRUE")
      }
    }

    ## Drop geometry in table
    ############################################################
    if (dropgeom) {
      splayer <- sf::st_drop_geometry(splayer)
    }
  }

  if (checkonly) {
    return(list(dsn=dsn, layer=layer))
  } else {
    return(splayer)
  }
}

#' @rdname pcheck_desc
#' @export
pcheck.params <- function(input.params, strata_opts = NULL, 
                 unit_opts = NULL, table_opts = NULL, title_opts = NULL,
                 savedata_opts = NULL, multest_opts = NULL,
                 spMakeSpatial_opts = NULL, eval_opts = NULL,
                 xy_opts = NULL, database_opts = NULL,
                 datSum_opts = NULL) {
  ## DESCRIPTION: function to check input list parameters

  if (!is.null(strata_opts)) {
    if ("strata_opts" %in% input.params) {
      if (!is.list(strata_opts)) {
        strata_opts <- as.list(strata_opts)
      }
      if (is.null(names(strata_opts))) {
        stop("invalid strata_opts... see strata_options()")
      }
      formallst.strata <- names(formals(strata_options))[-length(formals(strata_options))]
      strata.params <- names(strata_opts)[!names(strata_opts) %in% c("formallst", "input.params")]
      if (!all(strata.params %in% formallst.strata)) {
        miss <- strata.params[!strata.params %in% formallst.strata]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(unit_opts)) {
    if ("unit_opts" %in% input.params) {
      if (!is.list(unit_opts)) {
        unit_opts <- as.list(unit_opts)
      }
      if (is.null(names(unit_opts))) {
        stop("invalid unit_opts... see unit_options()")
      }
      formallst.unit <- names(formals(unit_options))[-length(formals(unit_options))]
      unit.params <- names(unit_opts)[!names(unit_opts) %in% c("formallst", "input.params")]
      if (!all(unit.params %in% formallst.unit)) {
        miss <- unit.params[!unit.params %in% formallst.unit]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }
  if (!is.null(table_opts)) {
    if ("table_opts" %in% input.params) {
      if (!is.list(table_opts)) {
        table_opts <- as.list(table_opts)
      }
      if (is.null(names(table_opts))) {
        stop("invalid table_opts... see table_options()")
      }
      formallst.table <- names(formals(table_options))[-length(formals(table_options))]
      table.params <- names(table_opts)[!names(table_opts) %in% c("formallst", "input.params")]
      if (!all(table.params %in% formallst.table)) {
        miss <- table.params[!table.params %in% formallst.table]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }
  if (!is.null(title_opts)) {
    if ("title_opts" %in% input.params) {
      if (!is.list(title_opts)) {
        title_opts <- as.list(title_opts)
      }
      if (is.null(names(title_opts))) {
        stop("invalid title_opts... see title_options()")
      }
      formallst.title <- names(formals(title_options))[-length(formals(title_options))]
      title.params <- names(title_opts)[!names(title_opts) %in% c("formallst", "input.params")]
      if (!all(title.params %in% formallst.title)) {
        miss <- title.params[!title.params %in% formallst.title]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(savedata_opts)) {
    if ("savedata_opts" %in% input.params) {
      if (!is.list(savedata_opts)) {
        savedata_opts <- as.list(savedata_opts)
      }
      if (is.null(names(savedata_opts))) {
        stop("invalid savedata_opts... see savedata_options()")
      }
      formallst.savedata <- names(formals(savedata_options))[-length(formals(savedata_options))]
      savedata.params <- names(savedata_opts)[!names(savedata_opts) %in% c("formallst", "input.params")]
      if (!all(savedata.params %in% formallst.savedata)) {
        miss <- savedata.params[!savedata.params %in% formallst.savedata]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(multest_opts)) {
    if ("multest_opts" %in% input.params) {
      if (!is.list(multest_opts)) {
        multest_opts <- as.list(multest_opts)
      }
      if (is.null(names(multest_opts))) {
        stop("invalid multest_opts... see multest_options()")
      }
      formallst.multest <- names(formals(multest_options))[-length(formals(multest_options))]
      multest.params <- names(multest_opts)[!names(multest_opts) %in% c("formallst", "input.params")]
      if (!all(multest.params %in% formallst.multest)) {
        miss <- multest.params[!multest.params %in% formallst.multest]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(spMakeSpatial_opts)) {
    if ("spMakeSpatial_opts" %in% input.params) {
      if (!is.list(spMakeSpatial_opts)) {
        spMakeSpatial_opts <- as.list(spMakeSpatial_opts)
      }
      if (is.null(names(spMakeSpatial_opts))) {
        stop("invalid spMakeSpatial_opts... see spMakeSpatial_options()")
      }
      formallst.spMakeSpatial <- names(formals(spMakeSpatial_options))[-length(formals(spMakeSpatial_options))]
      spMakeSpatial.params <- names(spMakeSpatial_opts)[!names(spMakeSpatial_opts) %in% c("formallst", "input.params")]
      if (!all(spMakeSpatial.params %in% formallst.spMakeSpatial)) {
        miss <- spMakeSpatial.params[!spMakeSpatial.params %in% formallst.spMakeSpatial]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(eval_opts)) {
    if ("eval_opts" %in% input.params) {
      if (!is.list(eval_opts)) {
        eval_opts <- as.list(eval_opts)
      }
      if (is.null(names(eval_opts))) {
        stop("must specify an evaluation timeframe for data extraction... \n", 
	    "...see eval_opts parameter, (e.g., eval_opts=eval_options(Cur=TRUE))")
      }
      formallst.eval <- names(formals(eval_options))[-length(formals(eval_options))]
      eval.params <- names(eval_opts)[!names(eval_opts) %in% c("formallst", "input.params")]
      if (!all(eval.params %in% formallst.eval)) {
        miss <- eval.params[!eval.params %in% formallst.eval]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(xy_opts)) {
    if ("xy_opts" %in% input.params) {
      if (!is.list(xy_opts)) {
        xy_opts <- as.list(xy_opts)
      }
      if (is.null(names(xy_opts))) {
        stop("invalid xy_opts... see xy_options()")
      }
      formallst.xy <- names(formals(xy_options))[-length(formals(xy_options))]
      xy.params <- names(xy_opts)[!names(xy_opts) %in% c("formallst", "input.params")]
      if (!all(xy.params %in% formallst.xy)) {
        miss <- xy.params[!xy.params %in% formallst.xy]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }

  if (!is.null(database_opts)) {
    if ("database_opts" %in% input.params) {
      if (!is.list(database_opts)) {
        database_opts <- as.list(database_opts)
      }
      if (is.null(names(database_opts))) {
        stop("invalid database_opts... see database_options()")
      }
      formallst.db <- names(formals(database_options))[-length(formals(database_options))]
      database.params <- names(database_opts)[!names(database_opts) %in% c("formallst", "input.params")]
      if (!all(database.params %in% formallst.db)) {
        miss <- database.params[!database.params %in% formallst.db]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }
  
  if (!is.null(datSum_opts)) {
    if ("datSum_opts" %in% input.params) {
      if (!is.list(datSum_opts)) {
        datSum_opts <- as.list(datSum_opts)
      }
      if (is.null(names(datSum_opts))) {
        stop("invalid datSum_opts... see datSum_options()")
      }
      formallst.datSum <- names(formals(datSum_options))[-length(formals(datSum_options))]
      datSum.params <- names(datSum_opts)[!names(datSum_opts) %in% c("formallst", "input.params")]
      if (!all(datSum.params %in% formallst.datSum)) {
        miss <- datSum.params[!datSum.params %in% formallst.datSum]
        stop("invalid parameter: ", toString(miss))
      }
    }
  }
  
}


#' @rdname pcheck_desc
#' @export
pcheck.opts <- function(optionlst) {
  
  ## Description:
  ## This function sets default options.
  
  
  ## Set empty returnlst
  returnlst <- vector(mode = "list", length = length(optionlst))
  names(returnlst) <- names(optionlst)
  
  
  ## popFilters
  ###################################################################
  if ("popFilter" %in% names(optionlst)) {
    popFilter <- optionlst$popFilter
    
    ## Set popFilters defaults
    popFilters_defaults_list <- formals(popFilters)[-length(formals(popFilters))]
    
    for (i in 1:length(popFilters_defaults_list)) {
      assign(names(popFilters_defaults_list)[[i]], popFilters_defaults_list[[i]])
    }
    
    ## Set user-supplied popFilters values
    popFilter2 <- popFilters_defaults_list
    if (length(popFilter) > 0) {
      for (i in 1:length(popFilter)) {
        if (names(popFilter)[[i]] %in% names(popFilters_defaults_list)) {
          if (!is.null(popFilter[[i]])) {
            popFilter2[[names(popFilter)[[i]]]] <- popFilter[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(popFilter)[[i]]))
        }
      }
    }
    returnlst$popFilter <- popFilter2
  }
  
  
  ## database options
  ###################################################################
  if ("database_opts" %in% names(optionlst)) {
    database_opts <- optionlst$database_opts

        ## Set database defaults
    database_defaults_list <- formals(database_options)[-length(formals(database_options))]
    for (i in 1:length(database_defaults_list)) {
      assign(names(database_defaults_list)[[i]], database_defaults_list[[i]])
    }
    
    ## Set user-supplied database values
    database_opts2 <- database_defaults_list
    if (length(database_opts) > 0) {
      #if (datsource != 'postgres') {
      #  message("database_options only available for postgres datsource")
      #}
      for (i in 1:length(database_opts)) {
        if (names(database_opts)[[i]] %in% names(database_defaults_list)) {
          if (!is.null(database_opts[[i]])) {
            database_opts2[[names(database_opts)[[i]]]] <- database_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(database_opts)[[i]]))
        }
      }
    }
    returnlst$database_opts <- database_opts2
  }
  
  
  ## savedata options
  ###################################################################
  if ("savedata_opts" %in% names(optionlst)) {
    savedata_opts <- optionlst$savedata_opts

    ## Set savedata defaults
    savedata_defaults_list <- formals(savedata_options)[-length(formals(savedata_options))]
    for (i in 1:length(savedata_defaults_list)) {
      assign(names(savedata_defaults_list)[[i]], savedata_defaults_list[[i]])
    }
    
    ## Set user-supplied savedata values
    savedata_opts2 <- savedata_defaults_list
    if (length(savedata_opts) > 0) {
      for (i in 1:length(savedata_opts)) {
        if (names(savedata_opts)[[i]] %in% names(savedata_defaults_list)) {
          if (!is.null(savedata_opts[[i]])) {
            savedata_opts2[[names(savedata_opts)[[i]]]] <- savedata_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(savedata_opts)[[i]]))
        }
      }
    }
    returnlst$savedata_opts <- savedata_opts2 
  }
  
  ## unit options
  ###################################################################
  if ("unit_opts" %in% names(optionlst)) {
    unit_opts <- optionlst$unit_opts

    ## Set unit defaults
    unit_defaults_list <- formals(unit_options)[-length(formals(unit_options))]
    for (i in 1:length(unit_defaults_list)) {
      assign(names(unit_defaults_list)[[i]], unit_defaults_list[[i]])
    }
    
    ## Set user-supplied unit values
    unit_opts2 <- unit_defaults_list
    if (length(unit_opts) > 0) {
      for (i in 1:length(unit_opts)) {
        if (names(unit_opts)[[i]] %in% names(unit_defaults_list)) {
          if (!is.null(unit_opts[[i]])) {
            unit_opts2[[names(unit_opts)[[i]]]] <- unit_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(unit_opts)[[i]]))
        }
      }
    }
    returnlst$unit_opts <- unit_opts2
  }
  
  ## strata options
  ###################################################################
  if ("strata_opts" %in% names(optionlst)) {
    strata_opts <- optionlst$strata_opts

    ## Set strata defaults
    strata_defaults_list <- formals(strata_options)[-length(formals(strata_options))]
    for (i in 1:length(strata_defaults_list)) {
      assign(names(strata_defaults_list)[[i]], strata_defaults_list[[i]])
    }
    
    ## Set user-supplied strata options
    strata_opts2 <- strata_defaults_list
    if (length(strata_opts) > 0) {
      for (i in 1:length(strata_opts)) {
        if (names(strata_opts)[[i]] %in% names(strata_defaults_list)) {
          if (!is.null(strata_opts[[i]])) {
            strata_opts2[[names(strata_opts)[[i]]]] <- strata_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(strata_opts)[[i]]))
        }
      }
    }
    returnlst$strata_opts <- strata_opts2
  }
  
  ## multest options
  ###################################################################
  if ("multest_opts" %in% names(optionlst)) {
    multest_opts <- optionlst$multest_opts
    
    ## Set multest defaults
    multest_defaults_list <- formals(multest_options)[-length(formals(multest_options))]
    for (i in 1:length(multest_defaults_list)) {
      assign(names(multest_defaults_list)[[i]], multest_defaults_list[[i]])
    }
    
    ## Set user-supplied multest options
    multest_opts2 <- multest_defaults_list
    if (length(multest_opts) > 0) {
      for (i in 1:length(multest_opts)) {
        if (names(multest_opts)[[i]] %in% names(multest_defaults_list)) {
          if (!is.null(multest_opts[[i]])) {
            multest_opts2[[names(multest_opts)[[i]]]] <- multest_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(multest_opts)[[i]]))
        }
      }
    }
    returnlst$multest_opts <- multest_opts2
  }
  
  ## table options
  ###################################################################
  if ("table_opts" %in% names(optionlst)) {
    table_opts <- optionlst$table_opts
    
    ## Set table defaults
    table_defaults_list <- formals(table_options)[-length(formals(table_options))]
    for (i in 1:length(table_defaults_list)) {
      assign(names(table_defaults_list)[[i]], table_defaults_list[[i]])
    }
    
    ## Set user-supplied table options
    table_opts2 <- table_defaults_list
    if (length(table_opts) > 0) {
      for (i in 1:length(table_opts)) {
        if (names(table_opts)[[i]] %in% names(table_defaults_list)) {
          if (!is.null(table_opts[[i]])) {
            table_opts2[[names(table_opts)[[i]]]] <- table_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(table_opts)[[i]]))
        }
      }
    }
    returnlst$table_opts <- table_opts2
  }
  
  ## title options
  ###################################################################
  if ("title_opts" %in% names(optionlst)) {
    title_opts <- optionlst$title_opts
    
    ## Set title defaults
    title_defaults_list <- formals(title_options)[-length(formals(title_options))]
    for (i in 1:length(title_defaults_list)) {
      assign(names(title_defaults_list)[[i]], title_defaults_list[[i]])
    }
    
    ## Set user-supplied title options
    title_opts2 <- title_defaults_list
    if (length(title_opts) > 0) {
      for (i in 1:length(title_opts)) {
        if (names(title_opts)[[i]] %in% names(title_defaults_list)) {
          if (!is.null(title_opts[[i]])) {
            title_opts2[[names(title_opts)[[i]]]] <- title_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(title_opts)[[i]]))
        }
      }
    }
    returnlst$title_opts <- title_opts2
  }
  
  
  ## popTables
  ###################################################################
  if ("popTabs" %in% names(optionlst)) {
    popTabs <- optionlst$popTabs
    
    ## Set popTables defaults
    popTables_defaults_list <- formals(popTables)[-length(formals(popTables))]
    for (i in 1:length(popTables_defaults_list)) {
      assign(names(popTables_defaults_list)[[i]], popTables_defaults_list[[i]])
    }  
    
    ## Set user-supplied popTabs options
    popTabs2 <- popTables_defaults_list
    if (length(popTabs) > 0) {
      for (i in 1:length(popTabs)) {
        if (names(popTabs)[[i]] %in% names(popTables_defaults_list)) {
          if (!is.null(popTabs[[i]])) {
            popTabs2[[names(popTabs)[[i]]]] <- popTabs[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(popTabs)[[i]]))
        }
      }
    }
    returnlst$popTabs <- popTabs2
  }
  
  
  ## popTableIDs
  ###################################################################
  if ("popTabIDs" %in% names(optionlst)) {
    popTabIDs <- optionlst$popTabIDs
    
    ## Set popTableIDs defaults
    popTableIDs_defaults_list <- formals(popTableIDs)[-length(formals(popTableIDs))]
    for (i in 1:length(popTableIDs_defaults_list)) {
      assign(names(popTableIDs_defaults_list)[[i]], popTableIDs_defaults_list[[i]])
    }  
    
    ## Set user-supplied popTabIDs options
    popTabIDs2 <- popTableIDs_defaults_list
    if (length(popTabIDs) > 0) {
      for (i in 1:length(popTabIDs)) {
        if (names(popTabIDs)[[i]] %in% names(popTableIDs_defaults_list)) {
          if (!is.null(popTabIDs[[i]])) {
            popTabIDs2[[names(popTabIDs)[[i]]]] <- popTabIDs[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(popTabIDs)[[i]]))
        }
      }
    }
    returnlst$popTabIDs <- popTabIDs2
  }
  
  
  ## tableIDs
  ###################################################################
  if ("tabIDs" %in% names(optionlst)) {
    tabIDs <- optionlst$tabIDs
    
    ## Set tableIDs defaults
    tableIDs_defaults_list <- formals(tableIDs)[-length(formals(tableIDs))]
    for (i in 1:length(tableIDs_defaults_list)) {
      assign(names(tableIDs_defaults_list)[[i]], tableIDs_defaults_list[[i]])
    }  
    
    ## Set user-supplied popTableIDs options
    tabIDs2 <- tableIDs_defaults_list
    if (length(tabIDs) > 0) {
      for (i in 1:length(tabIDs)) {
        if (names(tabIDs)[[i]] %in% names(tableIDs_defaults_list)) {
          if (!is.null(tabIDs[[i]])) {
            tabIDs2[[names(tabIDs)[[i]]]] <- tabIDs[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(tabIDs)[[i]]))
        }
      }
    }
    returnlst$tabIDs <- tabIDs2
  }
  
  ## eval options
  ###################################################################
  if ("eval_opts" %in% names(optionlst)) {
    eval_opts <- optionlst$eval_opts
    
    ## Set eval defaults
    eval_defaults_list <- formals(eval_options)[-length(formals(eval_options))]
    for (i in 1:length(eval_defaults_list)) {
      assign(names(eval_defaults_list)[[i]], eval_defaults_list[[i]])
    }
    
    ## Set user-supplied eval options
    eval_opts2 <- eval_defaults_list
    if (length(eval_opts) > 0) {
      for (i in 1:length(eval_opts)) {
        if (names(eval_opts)[[i]] %in% names(eval_defaults_list)) {
          if (!is.null(eval_opts[[i]])) {
            eval_opts2[[names(eval_opts)[[i]]]] <- eval_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(eval_opts)[[i]]))
        }
      }
    }
    returnlst$eval_opts <- eval_opts2
  }
  
  
  ## xy options
  ###################################################################
  if ("xy_opts" %in% names(optionlst)) {
    xy_opts <- optionlst$xy_opts
    
    ## Set xy defaults
    xy_defaults_list <- formals(xy_options)[-length(formals(xy_options))]
    for (i in 1:length(xy_defaults_list)) {
      assign(names(xy_defaults_list)[[i]], xy_defaults_list[[i]])
    }
    
    ## Set user-supplied xy options
    xy_opts2 <- xy_defaults_list
    if (length(xy_opts) > 0) {
      for (i in 1:length(xy_opts)) {
        if (names(xy_opts)[[i]] %in% names(xy_defaults_list)) {
          if (!is.null(xy_opts[[i]])) {
            xy_opts2[[names(xy_opts)[[i]]]] <- xy_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(xy_opts)[[i]]))
        }
      }
    }
    returnlst$xy_opts <-xy_opts2
  }
  
  
  
  ## datSum options
  ###################################################################
  if ("datSum_opts" %in% names(optionlst)) {
    datSum_opts <- optionlst$datSum_opts
    
    ## Set datSum defaults
    datSum_defaults_list <- formals(datSum_options)[-length(formals(datSum_options))]
    for (i in 1:length(datSum_defaults_list)) {
      assign(names(datSum_defaults_list)[[i]], datSum_defaults_list[[i]])
    }
    
    ## Set user-supplied datSum values
    datSum_opts2 <- datSum_defaults_list
    if (length(datSum_opts) > 0) {
      for (i in 1:length(datSum_opts)) {
        if (names(datSum_opts)[[i]] %in% names(datSum_defaults_list)) {
          if (!is.null(datSum_opts[[i]])) {
            datSum_opts2[[names(datSum_opts)[[i]]]] <- datSum_opts[[i]]
          }
        } else {
          stop(paste("Invalid parameter: ", names(datSum_opts)[[i]]))
        }
      }
    }
    returnlst$datSum_opts <- datSum_opts2
  }
  
  
    # ## Set popTabIDs defaults
    # popTableIDs_defaults_list <- formals(popTableIDs)[-length(formals(popTableIDs))]
    # 
    # for (i in 1:length(popTableIDs_defaults_list)) {
    #   if (names(popTableIDs_defaults_list)[[i]] == "cond") {
    #     assign("cuniqueid", popTableIDs_defaults_list[[i]])
    #     popTableIDs2[[names(popTableIDs)[[i]]]] <- strata_opts[[i]]
    #     
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "plt") {
    #     assign("puniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "tree") {
    #     assign("tuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "seed") {
    #     assign("suniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "vsubpspp") {
    #     assign("vsppuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "vsubpstr") {
    #     assign("vstruniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "invsubp") {
    #     assign("invuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "subplot") {
    #     assign("subpuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "subp_cond") {
    #     assign("subcuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "cond_dwm_calc") {
    #     assign("dwmuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "grm") {
    #     assign("grmuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "plot_pplot") {
    #     assign("pplotuniqueid", popTableIDs_defaults_list[[i]])
    #   }
    #   if (names(popTableIDs_defaults_list)[[i]] == "cond_pcond") {
    #     assign("pconduniqueid", popTableIDs_defaults_list[[i]])
    #   }
    # }

  return(returnlst)
}