FIESTA: Forest Inventory Estimation and Analysis

#' Database - Extracts plot coordinates.
#' 
#' Extracts public plot coordinates for an FIA evaluation or a custom 
#' evaluation. Plots are extracted from FIA's public Datamart 
#' (https://apps.fs.usda.gov/fia/datamart/datamart.html) or other defined
#' datasource. 
#' 
#' 
#' @param states String or numeric vector. Name (e.g., 'Arizona','New Mexico')
#' or code (e.g., 4, 35) of state(s) for evalid. If all states in one or more
#' FIA Research Station is desired, set states=NULL and use RS argument to
#' define RS.
#' @param RS String vector. Name of research station(s) to get public XY
#' coordinates for ('RMRS','SRS','NCRS','NERS','PNWRS'). Do not use if states 
#' is populated. See FIESTA::ref_statecd for reference to RS and states.
#' @param datsource String. Source of FIA data for defining FIA evaluations or 
#' appending variables ('datamart', 'sqlite', 'obj', 'csv'). If datsource = NULL, 
#' datsource = xy_datsource. If datsource = 'datamart', data are downloaded
#' extracted from FIA DataMart (http://apps.fs.usda.gov/fia/datamart/datamart.html). 
#' If datsource='sqlite', specify database name(s) in data_dsn and table name(s) 
#' in dbTabs() argument. If datsource = ('obj','csv'), specify *.csv file name in 
#' dbTabs argument.
#' @param data_dsn String. Name of database with plot_layer and/or ppsa_layer.
#' @param dbTabs String or R Object. If data_dsn = 'datamart', name of table(s) 
#' in FIA DataMart. If data_dsn = 'sqlite', name of layer(s) in database. If 
#' datsource = 'csv', name of CSV file(s). If datsource = 'obj', name of R object.
#' @param pjoinid String. Variable in plot table to join to XY data, if 
#' plot_layer is not NULL. Not necessary to be unique. If using most current 
#' XY coordinates, use identifier for a plot (e.g., PLOT_ID).
#' @param eval String. Type of evaluation time frame for data extraction 
#' ('FIA', 'custom'). See eval_opts for more further options. 
#' @param eval_opts List of evaluation options for 'FIA' or 'custom'
#' evaluations to determine the set of data returned. See help(eval_options)
#' for a list of options.
#' @param invtype String. Type of FIA inventory to extract ('PERIODIC',
#' 'ANNUAL').  Only one inventory type (PERIODIC/ANNUAL) at a time.
#' @param coordType String. c('PUBLIC', 'ACTUAL'). Defines type of coordinates and is
#' used for the output name.
#' @param intensity1 Logical. If TRUE, includes only XY coordinates where 
#' INTENSITY = 1 (FIA base grid).
#' @param pvars2keep String vector. One or more variables in plot_layer to append 
#' to output.
#' @param returndata Logical. If TRUE, returns XY data as a list object with
#' query.
#' @param savedata Logical. If TRUE, saves XY data. Specify outfolder and 
#' format using savedata_opts. 
#' @param savedata_opts List. See help(savedata_options()) for a list
#' of options. Only used when savedata = TRUE or exportsp = TRUE.
#' @param dbconnopen Logical. If TRUE, the dbconn connection is not closed. 
#' @param evalInfo List. List object output from DBgetEvalid or DBgetXY 
#' FIESTA functions. 
#'
#' @return if returndata=TRUE, a list of the following objects: 
#' \item{xy}{ Data frame. XY data from database. The output name is based on
#' coordType parameter (e.g., xy_PUBLIC). the data frame include xy.uniqueid,
#' xvar, yvar and appended plot variables in pvars2keep if plot_layer is not 
#' NULL. The default plot variables included are 'STATECD','UNITCD','COUNTYCD',
#' 'PLOT','PLOT_ID' (ID+STATECD+UNTCD+COUNTYCD+PLOT), 'COUNTYFIPS'. 
#' If issp=TRUE, returns an sf object. }
#' 
#' If savedata=TRUE, outputs the xy* based on savedata_opts. 
#' If exportsp=TRUE, the output xy saved as spatial layer based on savedata_opts.
#' @note
#' 
#' If no parameters are included, the user is prompted for input. If partial
#' parameters, the default parameter values are used for those not specified.
#' 
#' @author Tracey S. Frescino
#' @keywords data
#' @examples
#' \dontrun{
#' # Most current evaluation and shapefile with public coordinates
#' COxylst <- DBgetPLTIDS(states = "Colorado",
#'                    eval = "FIA",
#'                    eval_opts=eval_options(Endyr = 2019))
#' names(COxylst)
#' 
#' head(COxylst$xy_PUBLIC)
#' COxylst$xyqry
#' }
#' @export DBgetPLTIDS
DBgetPLTIDS <- function (states = NULL, 
                     RS = NULL, 
                     datsource = NULL,
                     data_dsn = NULL, 
                     dbTabs = dbTables(),
                     eval = "FIA",
                     eval_opts = eval_options(),
                     invtype = "ANNUAL", 
                     intensity = 1, 
                     pvars2keep = NULL,
                     returndata = TRUE, 
                     savedata = FALSE, 
                     savedata_opts = NULL,
                     ) {

  ## DESCRIPTION: Get the most current coordinates in the FIA database

  
  ##################################################################
  ## CHECK INPUT PARAMETERS
  ##################################################################
  
  ## Check arguments
  input.params <- names(as.list(match.call()))[-1]
  if (!all(input.params %in% names(formals(DBgetPLTIDS)))) {
    miss <- input.params[!input.params %in% formals(DBgetXY)]
    stop("invalid parameter: ", toString(miss))
  } 
  
  ## Check parameter lists
  pcheck.params(input.params, savedata_opts=savedata_opts, eval_opts=eval_opts,
                xy_opts=xy_opts)
  
  
  ## Set eval_options 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_opts values
  if (length(eval_opts) > 0) {
    for (i in 1:length(eval_opts)) {
      if (names(eval_opts)[[i]] %in% names(eval_defaults_list)) {
        assign(names(eval_opts)[[i]], eval_opts[[i]])
      } else {
        stop(paste("Invalid parameter: ", names(eval_opts)[[i]]))
      }
    }
  } else {
    message("no evaluation timeframe specified...")
    message("see eval and eval_opts parameters (e.g., eval='custom', eval_opts=eval_options(Cur=TRUE))\n")
    stop()
  }
  
  ## Set dbTables defaults
  dbTables_defaults_list <- formals(dbTables)[-length(formals(dbTables))]
  for (i in 1:length(dbTables_defaults_list)) {
    assign(names(dbTables_defaults_list)[[i]], dbTables_defaults_list[[i]])
  }
  ## Set user-supplied dbTables values
  if (length(dbTabs) > 0) {
    for (i in 1:length(dbTabs)) {
      if (names(dbTabs)[[i]] %in% names(dbTables_defaults_list)) {
        assign(names(dbTabs)[[i]], dbTabs[[i]])
      } else {
        stop(paste("Invalid parameter: ", names(dbTabs)[[i]]))
      }
    }
  }
  
  
  ########################################################################
  ### DBgetEvalid()
  ########################################################################
  iseval <- FALSE
  if (eval == "FIA") {
    evalCur <- ifelse (Cur || !is.null(Endyr), TRUE, FALSE) 
    evalAll <- ifelse (All, TRUE, FALSE) 
    evalEndyr <- Endyr
    measCur=allyrs <- FALSE
    measEndyr <- NULL
    
  } else {
    measCur <- ifelse (Cur || !is.null(Endyr), TRUE, FALSE) 
    allyrs <- ifelse (All, TRUE, FALSE) 
    if (length(Endyr) > 1) {
      stop("only one Endyr allowed for custom estimations")
    }
    measEndyr <- Endyr
    evalCur=evalAll <- FALSE
    evalEndyr <- NULL
  }
  
  ####################################################################
  ## Get states, Evalid and/or invyrs info
  ##########################################################
  evalInfo <- tryCatch(
    DBgetEvalid(states = states, 
                RS = RS, 
                datsource = datsource,
                data_dsn = data_dsn,
                dbTabs = list(plot_layer=plot_layer),
                dbconn = dbconn,
                dbconnopen = TRUE,
                invtype = invtype, 
                evalid = evalid, 
                evalCur = evalCur, 
                evalEndyr = evalEndyr, 
                evalType = evalType,
                gui = gui),
    error = function(e) {
      message(e,"\n")
      return(NULL) })
  if (is.null(evalInfo)) {
    iseval <- FALSE
  }
  if (is.null(evalInfo)) {
    message("no data to return")
    return(NULL)
  }
  states <- evalInfo$states
  rslst <- evalInfo$rslst
  evalidlist <- evalInfo$evalidlist
  invtype <- evalInfo$invtype
  invyrtab <- evalInfo$invyrtab
  if (length(evalidlist) > 0) {
    invyrlst <- evalInfo$invyrs
    iseval <- TRUE
    savePOP <- TRUE
  }
  dbconn <- evalInfo$dbconn
  SURVEY <- evalInfo$SURVEY
  if (!is.null(SURVEY)) {
    surveynm <- "SURVEY"
    setkey(SURVEY, "CN")
  }
  
  POP_PLOT_STRATUM_ASSGN <- evalInfo$POP_PLOT_STRATUM_ASSGN
  PLOT <- evalInfo$PLOT
  
  

  ####################################################################
  ## Check custom Evaluation data
  ####################################################################
  if (!iseval) {
    evalchk <- customEvalchk(states = states, 
                             measCur = measCur, 
                             measEndyr = measEndyr, 
                             allyrs = allyrs, 
                             invyrs = invyrs, 
                             measyrs = measyrs,
                             invyrtab = invyrtab)
    if (is.null(evalchk)) {
      stop("must specify an evaluation timeframe for data extraction... \n", 
		"...see eval_opts parameter, (e.g., eval_opts=eval_options(Cur=TRUE))")
    }
    measCur <- evalchk$measCur
    measEndyr <- evalchk$measEndyr
    allyrs <- evalchk$allyrs
    invyrs <- evalchk$invyrs
    measyrs <- evalchk$measyrs
    invyrlst <- evalchk$invyrlst
    measyrlst <- evalchk$measyrlst
  }
  
  
  pjoinid=pltassgnid <- c("STATECD", "UNITCD", "COUNTYCD", "PLOT")
 
  measCur = FALSE 
  invyrs = NULL
  measyrs = NULL
  evalid = 81901
  
  source("E:\\workspace\\jyamamoto\\FIESTA_EVALIDator_compare\\pwith.qry.R")
  pwithqry <- getpwithqry(dbconn = dbconn, 
                          popevalid = evalid, 
                          states = states, 
                          pjoinid = pjoinid,
                          plotCur = measCur, 
                          varCur = "MEASYEAR", 
                          Endyr = measEndyr, 
                          invyrs = invyrs, 
                          measyears = measyrs, 
                          SCHEMA. = NULL, 
                          invtype = "ANNUAL",
                          subcycle99 = FALSE, 
                          intensity = NULL, 
                          popSURVEY = FALSE, 
                          Type = Type, 
                          plotnm = "plot", 
                          ppsanm = "pop_plot_stratum_assgn", 
                          pltassgnid = pjoinid, 
                          surveynm = "survey", 
                          pltflds = pltflds, 
                          ppsaflds = ppsaflds,
                          dbconnopen = TRUE) 
ewhereqry <- pwithqry$ewhereqry
selectqry <- pwithqry$selectqry

plotCur = TRUE 
pltassgnid = pjoinid
syntax = "sql"
evalid=popevalid =  NULL

varCur = "MEASYEAR" 
Endyr = 2019 
invyrs = invyrs 
measyears = measyrs 
SCHEMA. = NULL 
invtype = "ANNUAL"
subcycle99 = FALSE 
intensity = NULL 
popSURVEY = FALSE 
Type = Type 
plotnm = "plot" 
ppsanm = "pop_plot_stratum_assgn" 
surveynm = "survey" 
pltflds = pltflds 
ppsaflds = ppsaflds 
dbconnopen = FALSE

  withqry <- getpwithqry(evalid = evalid, 
           pjoinid = pid,
           intensity = intensity,
           plotnm = pnm,
           pltflds = pflds,
           ppsanm = ppsanm,
		   ppsaflds = ppsaflds,
		   pvars = pvars)
  } else {
  
    ## Get statecd for filter
    stcds <- pcheck.states(states, "VALUE")
    statecdnm <- findnm("STATECD", xyvars, returnNULL=TRUE)
    stabbr <- pcheck.states(states, "ABBR")
 
  
    if (length(unlist(invyrs)) > 1) {
	
	  if (exists(pnm) && !is.function(get(pnm)) &&!is.null(get(pnm))) {
		setkeyv(get(pnm), pid)
	  } 

	  withqry <- getpwithqry(states = stcds, 
           pjoinid = pid,
           intensity = intensity,
           plotnm = pnm,
		   pltflds = pflds,
           invyrs = unlist(invyrs),
		   pvars = pltvars,
		   popSURVEY = popSURVEY,
		   surveynm = surveynm,
		   Type = Type)

    } else if (length(unlist(measyrs)) > 1) {

	  if (exists(pnm) && !is.function(get(pnm)) &&!is.null(get(pnm))) {
		setkeyv(get(pnm), pid)
	  } 
	
      withqry <- getpwithqry(states = stcds, 
           pjoinid = pid,
           intensity = intensity,
           plotnm = pnm,
		   pltflds = pflds,
           measyears = unlist(measyrs),
		   pvars = pltvars,
		   popSURVEY = popSURVEY,
		   surveynm = surveynm,
		   Type = Type) 
		   
    } else if (measCur) {

      ## Set key variable in pnm
	  if (exists(pnm) && !is.function(get(pnm)) &&!is.null(get(pnm))) {
	    keyvars <- c("STATECD", "UNITCD", "COUNTYCD", "PLOT", "INVYR")
        keyvars <- keyvars[keyvars %in% xyflds]
		setkeyv(get(pnm), keyvars)
	  } 
	  	  		
      withqry <- getpwithqry(states = stcds, 
	                        plotCur = TRUE,
	                        Endyr = measEndyr,	                        
                            varCur = varCur, 
                            SCHEMA. = SCHEMA., 
                            intensity = intensity, 
                            plotnm = pnm,
                            pjoinid = pid,
                            surveynm = surveynm,
                            popSURVEY = popSURVEY,
							pltflds = pflds,
							pvars = pltvars,
                            Type = Type)							        
							
    } else if (allyrs) {

	  if (exists(pnm) && !is.function(get(pnm)) &&!is.null(get(pnm))) {
		setkeyv(get(pnm), pid)
	  } 
	
      withqry <- getpwithqry(states = stcds, 
           pjoinid = pid,
           intensity = intensity,
           plotnm = pnm,
		   pltflds = pflds,
           allyrs = TRUE,
		   pvars = pltvars,
		   popSURVEY = popSURVEY,
		   surveynm = surveynm,
		   Type = Type) 
	}
  }
  
  ##################################################################################
  ##################################################################################
  ## Generate queries
  ##################################################################################

  ## Create invyrtab query 
  ###########################################################
  xycoords.qry <- paste0(withqry, "\n", xyqry)
  message(xycoords.qry)

 if (xy_datsource == "sqlite") {
    xyx <- tryCatch( DBI::dbGetQuery(xyconn, xycoords.qry),
			error = function(e) {
                  message(e, "\n")
                  return(NULL) })
    if (!iseval && is.null(invyrtab) && !is.null(invyrtab.qry)) {
      invyrtab <- tryCatch( DBI::dbGetQuery(xyconn, invyrtab.qry),
			error = function(e) {
                  message(e, "\n")
                  return(NULL) }) 
    }      
  } else {

    xyx <- tryCatch( sqldf::sqldf(xycoords.qry, 
						stringsAsFactors = FALSE), 
			error = function(e) {
                  message(e, "\n")
                  return(NULL) })

    if (!iseval && is.null(invyrtab) && !is.null(invyrtab.qry)) {
      invyrtab <- tryCatch( sqldf::sqldf(invyrtab.qry, 
						stringsAsFactors = FALSE),
			error = function(e) {
                  return(NULL) }) 
    } 
    xyx <- setDT(xyx)     
  }

  if (is.null(xyx) || nrow(xyx) == 0) {
    warning("invalid xy query\n")
    message(xycoords.qry)
    stop()
  }

  ## Change CN to PLT_CN if exists
  if ("CN" %in% names(xyx) && !"PLT_CN" %in% names(xyx)) {
    setnames(xyx, "CN", "PLT_CN")
    xy.uniqueid <- "PLT_CN"
    xyjoinid <- "PLT_CN"
  }

  ## Remove KNOWN plots that are no longer in inventory
  if (measCur || !is.null(measEndyr)) {
    xyx <- xyx[!xyx$PLT_CN %in% FIESTAutils::kindcd3old$CN, ]
  }
   
  if (all(c("STATECD", "UNITCD", "COUNTYCD", "PLOT") %in% names(xyx))) {
    xyx[["PLOT_ID"]] <- paste0("ID", 
		formatC(xyx$STATECD, width=2, digits=2, flag=0), 
          	formatC(xyx$UNITCD, width=2, digits=2, flag=0),
          	formatC(xyx$COUNTYCD, width=3, digits=3, flag=0),
          	formatC(xyx$PLOT, width=5, digits=5, flag=0)) 
  }

  ## Change names of X/Y variables to *_PUBLIC
  if (xvar == "LON" && yvar == "LAT") {
    setnames(xyx, c("LON", "LAT"), c("LON_PUBLIC", "LAT_PUBLIC"))
    xvar <- "LON_PUBLIC"
    yvar <- "LAT_PUBLIC"
  }

  if (all(c("STATECD", "COUNTYCD") %in% names(xyx))) {
    xyx$COUNTYFIPS <- paste0(formatC(xyx$STATECD, width=2, digits=2, flag=0), 
          		formatC(xyx$COUNTYCD, width=3, digits=3, flag=0))
  }
  if (Cur) {
    xyoutnm <- paste0("xyCur_", coordType)
    assign(xyoutnm, xyx)
  } else {
    xyoutnm <- paste0("xy_", coordType)
    assign(xyoutnm, xyx)
  } 

  if (is.null(out_layer) || out_layer == "outdat") {
    out_layer <- xyoutnm
    if (issp) {
      outsp_layer <- paste0("sp", xyoutnm)
    }
  }

  if (issp) {
    spxyoutnm <- paste0("sp", xyoutnm)
     
    if (all(c(xvar, yvar) %in% names(xyx))) {

      ## Generate shapefile
      assign(spxyoutnm, spMakeSpatialPoints(xyplt = xyx, 
                     xvar = xvar, yvar = yvar, xy.uniqueid = xy.uniqueid, 
                     xy.crs = 4269, addxy = FALSE, 
                     exportsp = exportsp,
                     savedata_opts=list(out_dsn=out_dsn, 
                               out_fmt=outsp_fmt,
                               outfolder=outfolder, out_layer=outsp_layer, 
		                    outfn.date=outfn.date, 
                               overwrite_layer=overwrite_layer, 
		                    append_layer=append_layer, outfn.pre=outfn.pre) ))
    } else { 
      message("need ", xvar, " and ", yvar, " variables to generate spatial xy")
    }
  }
 
  ###############################################################################
  ## SAVE data
  ###############################################################################
  if (savedata) {
    index.unique.xyplt <- xy.uniqueid
    
    datExportData(get(xyoutnm),  
          index.unique = index.unique.xyplt,
          savedata_opts = list(outfolder = outfolder, 
                              out_fmt = out_fmt, 
                              out_dsn = out_dsn, 
                              out_layer = out_layer,
                              outfn.pre = outfn.pre, 
                              outfn.date = outfn.date, 
                              overwrite_layer = overwrite_layer,
                              append_layer = append_layer, 
                              add_layer = TRUE))
  }

  ## Set xyjoinid
  if (is.null(xyjoinid)) {
    xyjoinid <- xy.uniqueid
  }
 
  ## GENERATE RETURN LIST
  ###########################################################
  if (returndata) {
    returnlst <- list()
    if (issp) {
      returnlst$spxy <- get(spxyoutnm)
    } 
    returnlst[[xyoutnm]] <- get(xyoutnm)
    returnlst$xyqry <- xycoords.qry
    returnlst$xy_opts <- list(xy.uniqueid=xy.uniqueid, 
                             xvar=xvar, yvar=yvar, 
                             xy.crs=xy.crs, xyjoinid=xyjoinid)
    returnlst$pjoinid <- pjoinid
    returnlst$invyrlst <- invyrlst
    
    if (dbconnopen) {
      returnlst$dbconn <- dbconn
    }
    returnlst$evalInfo <- evalInfo
 
    if (!is.null(ppsanm) && exists(ppsanm)) {
      returnlst$pop_plot_stratum_assgn <- get(ppsanm)
    }

    ## Return data list
    return(returnlst)
  } 

  if (datsource == "sqlite" && !dbconnopen) {
    DBI::dbDisconnect(dbconn)
  } 

}