clean up code

USDAForestService · Oct 27, 2023 · 28573a9 · 28573a9
1 parent 58c93f0
commit 28573a9
Show file tree

Hide file tree

Showing 9 changed files with 163 additions and 146 deletions.
diff --git a/R/check.auxiliary.R b/R/check.auxiliary.R
@@ -260,7 +260,7 @@ check.auxiliary <- function(pltx, puniqueid, module="GB", strata=FALSE,
     pltx[[unitvar12]] <- paste(pltx[[unitvar2]], pltx[[unitvar]], sep="-")
     if (!is.null(unitarea)) {
       unitarea[[unitvar12]] <- paste(unitarea[[unitvar2]], unitarea[[unitvar]], sep="-")
-      unitarea[, c(unitvar, unitvar2) := NULL]
+      #unitarea[, c(unitvar, unitvar2) := NULL]
     }
 
     if (!is.null(RHGlut)) {

diff --git a/R/check.popdataCHNG.R b/R/check.popdataCHNG.R
@@ -1,11 +1,11 @@
-check.popdataCHNG <- function(tabs, tabIDs, popType=popType, 
-     pltassgnx, pltassgnid, pfromqry, palias, pjoinid, whereqry, 
-     adj, ACI, pltx=NULL, puniqueid="CN", dsn=NULL, dbconn=NULL, 
-     condid="CONDID", areawt="CONDPROP_UNADJ",
-     MICRO_BREAKPOINT_DIA=5, MACRO_BREAKPOINT_DIA=NULL, diavar="DIA",
-     areawt_micr="MICRPROP_UNADJ", areawt_subp="SUBPPROP_UNADJ", 
-     areawt_macr="MACRPROP_UNADJ",
-     nonsamp.cfilter=NULL, nullcheck=FALSE, cvars2keep=NULL, gui=FALSE){
+check.popdataCHNG <- function(tabs, tabIDs, popType = popType, 
+     pltassgnx, pltassgnid, pfromqry, palias, pjoinid, whereqry, adj, ACI, 
+     pltx = NULL, puniqueid = "CN", dsn = NULL, dbconn = NULL, 
+     condid = "CONDID", areawt = "CONDPROP_UNADJ",
+     MICRO_BREAKPOINT_DIA = 5, MACRO_BREAKPOINT_DIA = NULL, diavar = "DIA",
+     areawt_micr = "MICRPROP_UNADJ", areawt_subp = "SUBPPROP_UNADJ", 
+     areawt_macr = "MACRPROP_UNADJ",
+     nonsamp.cfilter = NULL, nullcheck = FALSE, cvars2keep = NULL, gui = FALSE){
 
   ###################################################################################
   ## DESCRIPTION: Checks data inputs for CHNG popType

diff --git a/R/check.popdataPLT.R b/R/check.popdataPLT.R
@@ -41,7 +41,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
   STATECD=PLOT_STATUS_CD=PSTATUSCD=plotsampcnt=nfplotsampcnt=INVYR=
 	NF_PLOT_STATUS_CD=NF_COND_STATUS_CD=TPA_UNADJ=methodlst=nonresplut=
 	plotqry=pfromqry=pltassgnqry=unitareaqry=stratalutqry=whereqry=palias=
-	P2POINTCNT=plt=dbconn_pltassgn <- NULL
+	P2POINTCNT=plt=dbconn_pltassgn=popwhereqry <- NULL
 
 
   ###################################################################################
@@ -171,8 +171,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
 		plt <- "plot"
 	  }
 	}
-	evalid <- popFilter$evalid
-	invyrs <- popFilter$invyrs
+
 	if (!is.null(evalid)) {	
       ## Filter for population data
 	  if (is.data.frame(pltassgn)) {
@@ -209,7 +208,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
           pjoinid <- pltassgnid
         } else {
           palias <- "p"
-          pfromqry <- getpfromqry(popevalid, dsn=dsn, ppsanm=ppsanm, 
+          pfromqry <- getpfromqry(evalid=evalid, popevalid, ppsanm=ppsanm, 
 				ppsaid=pltassgnid, pjoinid=pjoinid, plotnm=plt, dbconn=dbconn)
         }
         whereqry <- paste0("where evalid in(", toString(evalid), ")")
@@ -269,7 +268,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
       if (!is.null(evalid) && !is.null(evalidnm)) {
         unitareaqry <- paste(unitareaqry, "where", evalidnm, "in(", toString(popevalid), ")")
       }
-      unitarea <- pcheck.table(unitarea, tab_dsn=dsn, conn=dbconn,
+      unitarea <- pcheck.table(unitarea, conn=dbconn,
            tabnm="unitarea", caption="unitarea?",
 		    nullcheck=nullcheck, tabqry=unitareaqry, returnsf=FALSE)
     } 
@@ -283,7 +282,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
       if (!is.null(evalid) && !is.null(evalidnm)) {
         stratalutqry <- paste(stratalutqry, "where", evalidnm, "in(", toString(popevalid), ")")
       }
-	  stratalut <- pcheck.table(stratalut, tab_dsn=dsn, conn=dbconn,
+	  stratalut <- pcheck.table(stratalut, conn=dbconn,
           tabnm="stratalut", caption="stratalut?",
 		  nullcheck=nullcheck, tabqry=stratalutqry, returnsf=FALSE)
     }
@@ -292,10 +291,10 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
   ###################################################################################
   ## Import tables
   ###################################################################################
-  pltx <- pcheck.table(plt, tab_dsn=dsn, conn=dbconn, 
+  pltx <- pcheck.table(plt, conn=dbconn, 
                        tabnm="plt", caption="plot table?",
 		               nullcheck=nullcheck, tabqry=plotqry, returnsf=FALSE)
-  pltassgnx <- pcheck.table(pltassgn, tab_dsn=dsn, conn=dbconn_pltassgn,
+  pltassgnx <- pcheck.table(pltassgn, conn=dbconn_pltassgn,
                             tabnm="pltassgn", caption="plot assignments?", 
                             nullcheck=nullcheck, tabqry=pltassgnqry, returnsf=FALSE)
 
@@ -323,7 +322,6 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
         }
         pltx <- pltx[!is.na(pltx[[puniqueid]]), ]
       }
-
       ## Set key
       setkeyv(pltx, puniqueid)
     }
@@ -345,6 +343,7 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
         pltassgnx <- datFilter(pltassgnx, getfilter("EVALID", popevalid, syntax="R"))$xf
         if (nrow(pltassgnx) == 0) {
           stop("evalid removed all records")
+		  return(NULL)
         }
       }
       if (any(duplicated(pltassgnx[[pltassgnid]]))) {
@@ -400,6 +399,14 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
     }
   }
 
+  ## Check for duplicate plots
+  locvars <- c("STATECD", "UNITCD", "COUNTYCD", "PLOT")
+  locvars <- locvars[locvars %in% names(pltx)] 
+  if (any(pltx[, duplicated(.SD), .SDcols=locvars]) & (!popType %in% c("GRM", "CHNG"))) {
+    warning("duplicated plot locations exist... invalid for estimation")
+	return(NULL)
+  }
+
   ##################################################################################
   ## Check filter(s) for population data
   ##################################################################################
@@ -426,7 +433,8 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
 	       checklst=names(pltx), warn="INTENSITY variable not in plt")
     intensitymiss <- intensity[!all(intensity %in% unique(pltx[[intensitynm]]))]
     if (length(intensitymiss) > 0) {
-      stop("invalid intensity: ", toString(intensitymiss))
+      warning("invalid intensity: ", toString(intensitymiss))
+	  return(NULL)
     }
     intensity.filter <- getfilter(intensitynm, intensity)
     pltx <- datFilter(pltx, intensity.filter)$xf
@@ -438,7 +446,8 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
 	       checklst=names(pltx), warn="INVYR variable not in plt")
     invyrsmiss <- invyrs[!all(invyrs %in% unique(pltx[[invyrsnm]]))]
     if (length(invyrsmiss) > 0) {
-      stop("invalid invyrs: ", toString(invyrsmiss))
+      warning("invalid invyrs: ", toString(invyrsmiss))
+	  return(NULL)
     }
     invyrs.filter <- getfilter(invyrsnm, invyrs)
     pltx <- datFilter(pltx, invyrs.filter)$xf
@@ -489,11 +498,13 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
 
     if (any(prednames %in% pmissvars)) {
       prednames[which(!prednames %in% pmissvars)]
-      stop("predname not in tables: ", paste(prednames, collapse=", "))
+      warning("predname not in tables: ", paste(prednames, collapse=", "))
+	  return(NULL)
     }
     if (any(unitvars %in% pmissvars)) {
       unitvars[which(!unitvars %in% pmissvars)]
-      stop("unitvar not in tables: ", paste(unitvars, collapse=", "))
+      warning("unitvar not in tables: ", paste(unitvars, collapse=", "))
+	  return(NULL)
     }
   }
   #pdoms2keep <- unique(pdoms2keep[which(!pdoms2keep %in% pmissvars)])
@@ -601,7 +612,8 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
     if (!is.null(ecol)) {
       unitarea <- unitarea[unitarea[[ecol]] %in% popevalid,]
       if (nrow(unitarea) == 0) {
-        stop("evalid in unitarea does not match popevalid")
+        warning("evalid in unitarea does not match popevalid")
+		return(NULL)
       }
     }
   }
@@ -617,7 +629,8 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
       if (!is.null(ecol)) {
         stratalut <- stratalut[stratalut[[ecol]] %in% popevalid,]
         if (nrow(stratalut) == 0) {
-          stop("evalid in stratalut does not match evalid")
+          warning("evalid in stratalut does not match evalid")
+		  return(NULL)
         }
       }
     }
@@ -688,9 +701,9 @@ check.popdataPLT <- function(dsn, tabs, tabIDs, pltassgn, pltassgnid,
   pltx <- data.table(pltx[, unique(c(puniqueid, pdoms2keep, pvars2keep)), with=FALSE])
   setkeyv(pltx, puniqueid)
 
-  returnlst <- list(pltassgnx=pltassgnx, pltassgnid=pltassgnid, pltx=pltx, 
-           pfromqry=pfromqry, whereqry=whereqry, palias=palias, 
-           puniqueid=puniqueid, pjoinid=pjoinid, popevalid=popevalid, 
+  returnlst <- list(pltassgnx=pltassgnx, pltassgnid=pltassgnid, pltx=pltx,
+        pfromqry=pfromqry, whereqry=whereqry, popwhereqry=popwhereqry, 
+		puniqueid=puniqueid, pjoinid=pjoinid, popevalid=popevalid, palias=palias, 
 		unitvar=unitvar, unitarea=unitarea, unitvar2=unitvar2, areavar=areavar, 
 		areaunits=areaunits, unit.action=unit.action, ACI=ACI, 
  		P2POINTCNT=as.data.frame(P2POINTCNT), 

diff --git a/R/check.popdataVOL.R b/R/check.popdataVOL.R
@@ -1,10 +1,11 @@
 check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid, 
-    pfromqry, palias, pjoinid, whereqry, adj, ACI, pltx=NULL, puniqueid="CN",
-    dsn=NULL, dbconn=NULL, condid="CONDID", areawt="CONDPROP_UNADJ", areawt2 = NULL,
-    MICRO_BREAKPOINT_DIA=5, MACRO_BREAKPOINT_DIA=NULL, diavar="DIA",
-    areawt_micr="MICRPROP_UNADJ", areawt_subp="SUBPPROP_UNADJ",   
-    areawt_macr="MACRPROP_UNADJ", defaultVars=FALSE,
-    nonsamp.cfilter=NULL, nullcheck=FALSE, cvars2keep=NULL, gui=FALSE){
+    pfromqry, palias, pjoinid, whereqry, adj, ACI, 
+	pltx = NULL, puniqueid = "CN", dsn = NULL, dbconn = NULL, 
+	condid = "CONDID", areawt = "CONDPROP_UNADJ", areawt2 = NULL,
+    MICRO_BREAKPOINT_DIA = 5, MACRO_BREAKPOINT_DIA = NULL, diavar = "DIA",
+    areawt_micr = "MICRPROP_UNADJ", areawt_subp = "SUBPPROP_UNADJ",   
+    areawt_macr = "MACRPROP_UNADJ", defaultVars = FALSE,
+    nonsamp.cfilter = NULL, nullcheck = FALSE, cvars2keep = NULL, gui = FALSE){
 
   ###################################################################################
   ## DESCRIPTION: Checks data inputs for AREA/VOL estimation
@@ -39,10 +40,10 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
   ###################################################################################
 
   ## Set global variables
-  COND_STATUS_CD=CONDID=CONDPROP_UNADJ=SUBPPROP_UNADJ=MICRPROP_UNADJ=MACRPROP_UNADJ=
-	STATECD=cndnmlst=PROP_BASIS=ACI.filter=condsampcnt=
-	NF_COND_STATUS_CD=TPA_UNADJ=condqry=treeqry=seedqry=cfromqry=tfromqry=
-	tpropvars=treex <- NULL
+  COND_STATUS_CD=CONDID=CONDPROP_UNADJ=STATECD=NF_COND_STATUS_CD=
+	SUBPPROP_UNADJ=MICRPROP_UNADJ=MACRPROP_UNADJ=TPA_UNADJ=
+	cndnmlst=PROP_BASIS=ACI.filter=condsampcnt=
+	condqry=treeqry=seedqry=cfromqry=tfromqry=tpropvars=treex <- NULL
 
   ###################################################################################
   ## Define necessary plot and condition level variables
@@ -73,7 +74,6 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
     SCHEMA.<- NULL
     dbqueries <- list()
 
-
     ## Create query for cond
     #########################################
     if (all(!is.null(cond), is.character(cond), cond %in% tablst)) {
@@ -116,9 +116,8 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
       } else {
         tfromqry <- paste(tree, "t")
       }
-      treeqry <- paste("select distinct", toString(paste0("t.", tvars)), 
+      treeqry <- paste("select", toString(paste0("t.", tvars)), 
 				"from", tfromqry, whereqry)
-      #treeqry <- paste("select distinct t.* from", tfromqry, whereqry)
       dbqueries$tree <- treeqry
     }
 
@@ -131,7 +130,7 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
       } else {
         sfromqry <- paste(seed, "s")
       }
-      seedqry <- paste("select distinct s.* from", sfromqry, whereqry)
+      seedqry <- paste("select s.* from", sfromqry, whereqry)
       dbqueries$seed <- seedqry
     }
   }
@@ -142,12 +141,12 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
   if (is.null(cond)) {
     stop("must include cond table")
   }
-  condx <- pcheck.table(cond, tab_dsn=dsn, conn=dbconn,
-           tabnm="cond", caption="cond table?",
-		nullcheck=nullcheck, tabqry=condqry, returnsf=FALSE)
-  treex <- pcheck.table(tree, tab_dsn=dsn, conn=dbconn,
-           tabnm="tree", caption="Tree table?",
-		nullcheck=nullcheck, gui=gui, tabqry=treeqry, returnsf=FALSE)
+  condx <- pcheck.table(cond, conn = dbconn,
+           tabnm = "cond", caption = "cond table?",
+		   nullcheck = nullcheck, tabqry = condqry, returnsf = FALSE)
+  treex <- pcheck.table(tree, conn = dbconn,
+           tabnm = "tree", caption = "tree table?",
+		   nullcheck = nullcheck, tabqry = treeqry, returnsf = FALSE)
 
   ## Define cdoms2keep
   cdoms2keep <- names(condx)
@@ -538,15 +537,15 @@ check.popdataVOL <- function(tabs, tabIDs, pltassgnx, pltassgnid,
 
   if (!is.null(treex)) {
     ## Check that the values of tuniqueid in treex are all in cuniqueid in pltcondx
-    treef <- check.matchval(treex, pltcondx, tuniqueid, cuniqueid, tab1txt="tree",
-		tab2txt="cond", subsetrows=TRUE)
+    treef <- check.matchval(treex, pltcondx, tuniqueid, cuniqueid, 
+	    tab1txt="tree", tab2txt="cond", subsetrows=TRUE)
     returnlst$treef <- treef
     returnlst$tuniqueid <- tuniqueid
   }
   if (!is.null(seedx)) {
     ## Check that the values of tuniqueid in seedx are all in cuniqueid in pltcondx
-    seedf <- check.matchval(seedx, pltcondx, suniqueid, cuniqueid, tab1txt="seed",
-		tab2txt="cond", subsetrows=TRUE)
+    seedf <- check.matchval(seedx, pltcondx, suniqueid, cuniqueid, 
+	    tab1txt="seed", tab2txt="cond", subsetrows=TRUE)
     returnlst$seedf <- seedf
   }
 

diff --git a/R/check.tree.R b/R/check.tree.R
@@ -72,7 +72,7 @@ check.tree <- function(gui, treef, seedf=NULL, estseed="none", condf=NULL,
 
 
   ### GET TREE DATA (& TREE DOMAIN DATA) AGGREGATED TO CONDITION (NUMERATOR)
-  #####################################################################################
+  ###############################################################################
   if (bytdom) {
     pivot <- ifelse(esttype == "RATIO", TRUE, FALSE)
 
@@ -108,16 +108,16 @@ check.tree <- function(gui, treef, seedf=NULL, estseed="none", condf=NULL,
     estunitsn <- treedata$estunits
   }
 
-  ###################################################################################
+  #############################################################################
   ### GET ESTIMATION DATA (& TREE DOMAIN DATA) FROM TREE TABLE AND
   ### AGGREGATE TO CONDITION (DENOMINATOR)
-  ###################################################################################
+  #############################################################################
 
   if (ratiotype == "PERTREE") {
 
-    #################################################################################
+    ###########################################################################
     ### GETS ESTIMATION DATA (DENOMINATOR)
-    #################################################################################
+    ###########################################################################
 
     ## GET TREE ESTIMATION VARIABLE (DENOMINATOR) AND CHECK IF IN TREE DATA SET
     if (is.null(estvard))
@@ -133,7 +133,7 @@ check.tree <- function(gui, treef, seedf=NULL, estseed="none", condf=NULL,
       stop("invalid estvard.name.. must be a string")
 
     ### GET TREE DATA (& TREE DOMAIN DATA) AGGREGATED TO CONDITION (DENOMINATOR)
-    #################################################################################
+    ############################################################################
     if (bytdom) {
       pivot <- ifelse(esttype == "RATIO", TRUE, FALSE)
 

diff --git a/R/modGBchng.R b/R/modGBchng.R
@@ -28,15 +28,15 @@
 #' \tab RESERVCD \tab If landarea=TIMBERLAND. Reserved status.\cr
 #' 
 #' \tab pltassgn \tab puniqueid \tab Unique identifier for each plot, to link
-#' to cond (ex. CN).\cr 
+#' to cond (e.g., CN).\cr 
 #' \tab \tab STATECD \tab Identifies state each plot is located in.\cr \tab \tab INVYR \tab Identifies inventory year of each
 #' plot.\cr 
 #' \tab \tab PLOT_STATUS_CD \tab Status of each plot (i.e. sampled, nonsampled). If not included, all plots are assumed as sampled.\cr }
 #' 
 #' For available reference tables: sort(unique(FIESTAutils::ref_codes$VARIABLE)) \cr
 #' 
 #' @param GBpopdat List. Population data objects returned from modGBpop().
-#' @param chngtype String. The type of change estimates ('TOTAL', 'ANNUAL').
+#' @param chngtype String. The type of change estimates ('total', 'annual').
 #' @param landarea String. The sample area filter for estimates ("ALL",
 #' "FOREST", "TIMBERLAND").  If landarea=FOREST, filtered to COND_STATUS_CD =
 #' 1; If landarea=TIMBERLAND, filtered to SITECLCD in(1:6) and RESERVCD = 0.
@@ -224,7 +224,7 @@
 #' @keywords data
 #' @export modGBchng
 modGBchng <- function(GBpopdat, 
-                      chngtype = "TOTAL",
+                      chngtype = "total",
                       landarea = "FOREST", 
                       pcfilter = NULL, 
                       rowvar = NULL, 
@@ -384,7 +384,7 @@ modGBchng <- function(GBpopdat,
 
   ## Check chngtype
   ########################################################
-  chngtypelst <- c('TOTAL', 'ANNUAL')
+  chngtypelst <- c('total', 'annual')
   chngtype <- pcheck.varchar(var2check=chngtype, varnm="chngtype", gui=gui,
 		checklst=chngtypelst, caption="chngtype", multiple=FALSE, stopifnull=TRUE)