From 28573a94494097d366e0943e6c8ed44445726c8c Mon Sep 17 00:00:00 2001 From: Tracey Date: Fri, 27 Oct 2023 13:18:35 -0600 Subject: [PATCH] clean up code --- R/check.auxiliary.R | 2 +- R/check.popdataCHNG.R | 16 +++---- R/check.popdataPLT.R | 49 ++++++++++++-------- R/check.popdataVOL.R | 47 ++++++++++--------- R/check.tree.R | 12 ++--- R/modGBchng.R | 8 ++-- R/modGBtree.R | 17 ++++--- R/modSAtree.R | 103 ++++++++++++++++++++++-------------------- R/spGetPlots.R | 55 +++++++++++----------- 9 files changed, 163 insertions(+), 146 deletions(-) diff --git a/R/check.auxiliary.R b/R/check.auxiliary.R index b1b9d115..bfb2340a 100644 --- 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 index 261a2186..11ef6d5a 100644 --- 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 index e5abd297..8c36357f 100644 --- 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 index 63bda14a..a599fd74 100644 --- 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 index 44639258..d99773a5 100644 --- 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 index c12d6a5e..a4ac7a11 100644 --- a/R/modGBchng.R +++ b/R/modGBchng.R @@ -28,7 +28,7 @@ #' \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 } @@ -36,7 +36,7 @@ #' 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) diff --git a/R/modGBtree.R b/R/modGBtree.R index 6187a19f..7e6d9ecf 100644 --- a/R/modGBtree.R +++ b/R/modGBtree.R @@ -397,11 +397,9 @@ modGBtree <- function(GBpopdat, } } - ################################################################## ## CHECK PARAMETER INPUTS ################################################################## - list.items <- c("condx", "pltcondx", "treex", "cuniqueid", "condid", "tuniqueid", "ACI.filter", "unitarea", "unitvar", "stratalut", "strvar", "plotsampcnt", "condsampcnt") @@ -502,9 +500,9 @@ modGBtree <- function(GBpopdat, invyr <- sort(unique(pltcondf$INVYR)) } - ################################################################################### + ############################################################################# ### Check row and column data - ################################################################################### + ############################################################################# rowcolinfo <- check.rowcol(gui=gui, esttype=esttype, conn=conn, treef=treef, seedf=seedf, condf=pltcondf, cuniqueid=cuniqueid, @@ -546,9 +544,9 @@ modGBtree <- function(GBpopdat, uniquecol[[unitvar]] <- factor(uniquecol[[unitvar]]) } - ##################################################################################### + ############################################################################### ### Get estimation data from tree table - ##################################################################################### + ############################################################################### adjtree <- ifelse(adj %in% c("samp", "plot"), TRUE, FALSE) treedat <- check.tree(gui=gui, treef=treef, seedf=seedf, estseed=estseed, bycond=TRUE, condf=condf, bytdom=bytdom, @@ -586,15 +584,16 @@ modGBtree <- function(GBpopdat, tdomvarlst <- treedat$tdomvarlst estunits <- treedat$estunits - ##################################################################################### + ############################################################################### ### Get titles for output tables - ##################################################################################### + ############################################################################### alltitlelst <- check.titles(dat=tdomdat, esttype=esttype, estseed=estseed, woodland=woodland, sumunits=sumunits, title.main=title.main, title.ref=title.ref, title.rowvar=title.rowvar, title.rowgrp=title.rowgrp, title.colvar=title.colvar, title.unitvar=title.unitvar, - title.filter=title.filter, title.unitsn=estunits, title.estvarn=title.estvar, + title.filter=title.filter, title.unitsn=estunits, + title.estvarn=title.estvar, unitvar=unitvar, rowvar=rowvar, colvar=colvar, estvarn=estvar, estvarn.filter=estvar.filter, addtitle=addtitle, returntitle=returntitle, diff --git a/R/modSAtree.R b/R/modSAtree.R index 1f11ed1a..1c455cfd 100644 --- a/R/modSAtree.R +++ b/R/modSAtree.R @@ -198,7 +198,7 @@ modSAtree <- function(SApopdatlst = NULL, na.fill = "NONE", savedata = FALSE, savesteps = FALSE, - multest = FALSE, + multest = TRUE, addSAdomsdf = TRUE, SAdomvars = NULL, savemultest = FALSE, @@ -493,7 +493,7 @@ modSAtree <- function(SApopdatlst = NULL, ##################################################################################### ## GENERATE ESTIMATES ##################################################################################### - #setnames(cdomdat, dunitvar, "DOMAIN") + #setnames(tdomdat, dunitvar, "DOMAIN") ## Define empty lists @@ -530,7 +530,10 @@ modSAtree <- function(SApopdatlst = NULL, } } + ## Loop through SApopdatlst + ############################################# largebnd.unique2 <- largebnd.unique + for (i in 1:length(SApopdatlst)) { SApopdatnm <- names(SApopdatlst)[i] if (is.null(SApopdatnm)) { @@ -717,8 +720,8 @@ modSAtree <- function(SApopdatlst = NULL, } } } - cdomdat <- merge(condx, tdomdat, by=c(cuniqueid, condid), all.x=TRUE) - #cdomdat <- DT_NAto0(tdomdat, estvar.name, 0) + tdomdat <- merge(condx, tdomdat, by=c(cuniqueid, condid), all.x=TRUE) + #tdomdat <- DT_NAto0(tdomdat, estvar.name, 0) } ##################################################################################### @@ -726,7 +729,7 @@ modSAtree <- function(SApopdatlst = NULL, ##################################################################################### dunit_totest=dunit_rowest=dunit_colest=dunit_grpest=rowunit=totunit <- NULL response <- estvar.name - #setnames(cdomdat, dunitvar, "DOMAIN") + #setnames(tdomdat, dunitvar, "DOMAIN") if (i == 1) { message("getting estimates for ", response, "...") @@ -742,33 +745,33 @@ modSAtree <- function(SApopdatlst = NULL, ## check largebnd.unique ######################################################## if (!is.null(largebnd.unique2) && !is.null(SAdomsdf)) { - cdomdat <- merge(cdomdat, + tdomdat <- merge(tdomdat, unique(setDT(SAdomsdf)[, c(smallbnd.dom, largebnd.unique), with=FALSE]), by=smallbnd.dom) #addSAdomsdf <- TRUE #SAdomvars <- unique(c(SAdomvars, largebnd.unique)) largebnd.unique <- largebnd.unique2 } else { - cdomdat$LARGEBND <- 1 + tdomdat$LARGEBND <- 1 largebnd.unique <- "LARGEBND" - cdomdat$LARGEBND <- 1 + tdomdat$LARGEBND <- 1 } ## get unique largebnd values - largebnd.vals <- sort(unique(cdomdat[[largebnd.unique]])) - largebnd.vals <- largebnd.vals[table(cdomdat[[largebnd.unique]]) > 30] + largebnd.vals <- sort(unique(tdomdat[[largebnd.unique]])) + largebnd.vals <- largebnd.vals[table(tdomdat[[largebnd.unique]]) > 30] ## Add AOI if not in data ###################################### - if (!"AOI" %in% names(cdomdat)) { - cdomdat$AOI <- 1 + if (!"AOI" %in% names(tdomdat)) { + tdomdat$AOI <- 1 dunitlut$AOI <- 1 } ## Get estimate for total ###################################### ## Sum estvar.name by dunitvar (DOMAIN), plot, domain - tdomdattot <- setDT(cdomdat)[, lapply(.SD, sum, na.rm=TRUE), + tdomdattot <- setDT(tdomdat)[, lapply(.SD, sum, na.rm=TRUE), by=c(largebnd.unique, dunitvar, "AOI", cuniqueid, "TOTAL", prednames), .SDcols=estvar.name] @@ -792,9 +795,9 @@ modSAtree <- function(SApopdatlst = NULL, #dat=tdomdattot #largebnd.val=largebnd.vals #domain="TOTAL" -#largebnd.unique=lunique +#largebnd.unique="LARGEBND" - dunit_estlst <- + dunit_totestlst <- tryCatch( lapply(largebnd.vals, SAest.large, dat=tdomdattot, @@ -810,38 +813,38 @@ modSAtree <- function(SApopdatlst = NULL, message(e, "\n") return(NULL) }) - if (is.null(dunit_estlst)) { + if (is.null(dunit_totestlst)) { return(NULL) } if (length(largebnd.vals) > 1) { - dunit_est <- do.call(rbind, do.call(rbind, dunit_estlst)[,"est.large"]) + dunit_est <- do.call(rbind, do.call(rbind, dunit_totestlst)[,"est.large"]) if (multest || SAmethod == "unit") { - predselect.unit <- do.call(rbind, dunit_estlst)[,"predselect.unit"] + predselect.unit <- do.call(rbind, dunit_totestlst)[,"predselect.unit"] } if (multest || SAmethod == "area") { - predselect.area <- do.call(rbind, dunit_estlst)[,"predselect.area"] + predselect.area <- do.call(rbind, dunit_totestlst)[,"predselect.area"] } #names(prednames.select) <- largebnd.vals if (save4testing) { - pdomdat <- do.call(rbind, do.call(rbind, dunit_estlst)[,"pltdat.dom"]) - dunitlut <- do.call(rbind, do.call(rbind, dunit_estlst)[,"dunitlut.dom"]) + pdomdat <- do.call(rbind, do.call(rbind, dunit_totestlst)[,"pltdat.dom"]) + dunitlut <- do.call(rbind, do.call(rbind, dunit_totestlst)[,"dunitlut.dom"]) } - SAobjlst[[SApopdatnm]] <- do.call(rbind, dunit_estlst)[,"SAobjlst.dom"] + SAobjlst[[SApopdatnm]] <- do.call(rbind, dunit_totestlst)[,"SAobjlst.dom"] } else { - dunit_est <- do.call(rbind, dunit_estlst)[,"est.large"]$est.large + dunit_est <- do.call(rbind, dunit_totestlst)[,"est.large"]$est.large if (multest || SAmethod == "unit") { - predselect.unit <- do.call(rbind, dunit_estlst)[,"predselect.unit"]$predselect.unit + predselect.unit <- do.call(rbind, dunit_totestlst)[,"predselect.unit"]$predselect.unit } if (multest || SAmethod == "area") { - predselect.area <- do.call(rbind, dunit_estlst)[,"predselect.area"]$predselect.area + predselect.area <- do.call(rbind, dunit_totestlst)[,"predselect.area"]$predselect.area } if (save4testing) { - pdomdat <- do.call(rbind, dunit_estlst)[,"pltdat.dom"]$pltdat.dom - dunitlut <- do.call(rbind, dunit_estlst)[,"dunitlut.dom"]$dunitlut.dom + pdomdat <- do.call(rbind, dunit_totestlst)[,"pltdat.dom"]$pltdat.dom + dunitlut <- do.call(rbind, dunit_totestlst)[,"dunitlut.dom"]$dunitlut.dom } - SAobjlst[[SApopdatnm]] <- do.call(rbind, dunit_estlst)[,"SAobjlst.dom"]$SAobjlst.dom + SAobjlst[[SApopdatnm]] <- do.call(rbind, dunit_totestlst)[,"SAobjlst.dom"]$SAobjlst.dom } if (multest || SAmethod == "unit") { @@ -867,28 +870,28 @@ modSAtree <- function(SApopdatlst = NULL, estlst[[SApopdatnm]] <- dunit_est if (rowcolinfo$rowvar != "TOTAL") { - cdomdatsum <- setDT(cdomdat)[, lapply(.SD, sum, na.rm=TRUE), + tdomdatsum <- setDT(tdomdat)[, lapply(.SD, sum, na.rm=TRUE), by=c(largebnd.unique, dunitvar, cuniqueid, rowcolinfo$rowvar, prednames), .SDcols=estvar.name] - if (!"DOMAIN" %in% names(cdomdatsum)) { - cdomdatsum$DOMAIN <- cdomdatsum[[dunitvar]] - cdomdatsum[[dunitvar]] <- NULL + if (!"DOMAIN" %in% names(tdomdatsum)) { + tdomdatsum$DOMAIN <- tdomdatsum[[dunitvar]] + tdomdatsum[[dunitvar]] <- NULL } - if (!"AOI" %in% names(cdomdatsum)) { - cdomdatsum$AOI <- 1 + if (!"AOI" %in% names(tdomdatsum)) { + tdomdatsum$AOI <- 1 } #dunitlut <- data.table(SApopdat$dunitlut) -#dat=cdomdatsum +#dat=tdomdatsum #largebnd.val=largebnd.vals #domain=rowcolinfo$rowvar #largebnd.unique=lunique - dunit_estlst_row <- + dunit_rowestlst <- tryCatch( lapply(largebnd.vals, SAest.large, - dat=cdomdatsum, cuniqueid=cuniqueid, + dat=tdomdatsum, cuniqueid=cuniqueid, largebnd.unique=largebnd.unique, dunitlut=dunitlut, dunitvar="DOMAIN", prednames=prednames, domain=rowcolinfo$rowvar, response=response, showsteps=showsteps, savesteps=savesteps, @@ -900,31 +903,31 @@ modSAtree <- function(SApopdatlst = NULL, return(NULL) }) if (length(largebnd.vals) > 1) { - dunit_est_row <- do.call(rbind, do.call(rbind, dunit_estlst_row)[,"est.large"]) + dunit_est_row <- do.call(rbind, do.call(rbind, dunit_rowestlst)[,"est.large"]) if (multest || SAmethod == "unit") { - predselect.unit_row <- do.call(rbind, dunit_estlst_row)[,"predselect.unit"] + predselect.unit_row <- do.call(rbind, dunit_rowestlst)[,"predselect.unit"] } if (multest || SAmethod == "area") { - predselect.area_row <- do.call(rbind, dunit_estlst_row)[,"predselect.area"] + predselect.area_row <- do.call(rbind, dunit_rowestlst)[,"predselect.area"] } if (save4testing) { - pdomdat_row <- do.call(rbind, do.call(rbind, dunit_estlst_row)[,"pltdat.dom"]) - dunitlut_row <- do.call(rbind, do.call(rbind, dunit_estlst_row)[,"dunitlut.dom"]) + pdomdat_row <- do.call(rbind, do.call(rbind, dunit_rowestlst)[,"pltdat.dom"]) + dunitlut_row <- do.call(rbind, do.call(rbind, dunit_rowestlst)[,"dunitlut.dom"]) } - SAobjlst_row[[SApopdatnm]] <- do.call(rbind, dunit_estlst_row)[,"SAobjlst.dom"] + SAobjlst_row[[SApopdatnm]] <- do.call(rbind, dunit_rowestlst)[,"SAobjlst.dom"] } else { - dunit_est_row <- do.call(rbind, dunit_estlst_row)[,"est.large"]$est.large + dunit_est_row <- do.call(rbind, dunit_rowestlst)[,"est.large"]$est.large if (multest || SAmethod == "unit") { - predselect.unit_row <- do.call(rbind, dunit_estlst_row)[,"predselect.unit"]$predselect.unit + predselect.unit_row <- do.call(rbind, dunit_rowestlst)[,"predselect.unit"]$predselect.unit } if (multest || SAmethod == "area") { - predselect.area_row <- do.call(rbind, dunit_estlst_row)[,"predselect.area"]$predselect.area + predselect.area_row <- do.call(rbind, dunit_rowestlst)[,"predselect.area"]$predselect.area } if (save4testing) { - pdomdat_row <- do.call(rbind, dunit_estlst_row)[,"pltdat.dom"]$pltdat.dom - dunitlut_row <- do.call(rbind, dunit_estlst_row)[,"dunitlut.dom"]$dunitlut.dom + pdomdat_row <- do.call(rbind, dunit_rowestlst)[,"pltdat.dom"]$pltdat.dom + dunitlut_row <- do.call(rbind, dunit_rowestlst)[,"dunitlut.dom"]$dunitlut.dom } - SAobjlst_row[[SApopdatnm]] <- do.call(rbind, dunit_estlst_row)[,"SAobjlst.dom"]$SAobjlst.dom + SAobjlst_row[[SApopdatnm]] <- do.call(rbind, dunit_rowestlst)[,"SAobjlst.dom"]$SAobjlst.dom } if (multest || SAmethod == "unit") { @@ -1330,7 +1333,7 @@ modSAtree <- function(SApopdatlst = NULL, rawdat <- tabs$rawdat names(rawdat)[names(rawdat) == "unit_totest"] <- "dunit_totest" names(rawdat)[names(rawdat) == "unit_rowest"] <- "dunit_rowest" - rawdat$domdat <- setDF(cdomdat) + rawdat$domdat <- setDF(tdomdat) if (savedata) { if (!is.null(title.estpse)) { diff --git a/R/spGetPlots.R b/R/spGetPlots.R index ddb45c7f..ef4213db 100644 --- a/R/spGetPlots.R +++ b/R/spGetPlots.R @@ -77,10 +77,10 @@ #' @param returnxy Logical. If TRUE, save xy coordinates to outfolder. #' @param returndata Logical. If TRUE, returns data objects. #' @param savedata Logical. If TRUE, saves data to outfolder. -#' @param savexy Logical. If TRUE, and savedata=TRUE, saves XY data to outfolder. +#' @param savexy Logical. If TRUE, saves XY data to outfolder. #' @param savebnd Logical. If TRUE, and savedata=TRUE, saves bnd. If #' out_fmt='sqlite', saves to a SpatiaLite database. -#' @param exportsp Logical. If TRUE, and savedata=TRUE, saves xy data as +#' @param exportsp Logical. If TRUE, and savexy=TRUE, saves xy data as #' spatial data. If FALSE, saves xy data as table. #' @param savedata_opts List. See help(savedata_options()) for a list #' of options. Only used when savedata = TRUE. @@ -164,7 +164,7 @@ spGetPlots <- function(bnd = NULL, clipxy = TRUE, pjoinid = NULL, showsteps = FALSE, - returnxy = FALSE, + returnxy = TRUE, returndata = TRUE, savedata = FALSE, savexy = FALSE, @@ -456,6 +456,11 @@ spGetPlots <- function(bnd = NULL, ## Check pltids pltids <- pcheck.table(pltids) + + ## Check xyjoinid + xyjoinid <- pcheck.varchar(var2check=xyjoinid, varnm="xyjoinid", + checklst=names(pltids), gui=gui, caption="JoinID in pltids?", + stopifnull=FALSE) if (!is.null(pltids)) { Endyr.filter <- check.logic(pltids, Endyr.filter) @@ -463,7 +468,7 @@ spGetPlots <- function(bnd = NULL, ## Check xyjoinid xyjoinid <- pcheck.varchar(var2check=xyjoinid, varnm="xyjoinid", checklst=names(pltids), gui=gui, caption="JoinID in pltids?", - stopifnull=TRUE) + stopifnull=TRUE) ## Check stbnd.att stbnd.att <- pcheck.varchar(var2check=stbnd.att, varnm="stbnd.att", @@ -1130,17 +1135,16 @@ spGetPlots <- function(bnd = NULL, } if (nrow(stpltids) > 0) { - ## Subset data to stpltids plt <- PLOT[PLOT[[pjoinid]] %in% stpltids[[xyjoinid]],] if (nrow(plt) != nrow(stpltids)) { message("there are ", abs(nrow(plt) - nrow(stpltids)), " plots in ", state, " that do not match pltids") #spxy[!spxy[[xyjoinid]] %in% plt[[pjoinid]],] - messagedf(stpltids[!stpltids[[xyjoinid]] %in% PLOT[[pjoinid]],]) + messagedf(stpltids[[xyjoinid]][!stpltids[[xyjoinid]] %in% PLOT[[pjoinid]]]) } pids <- plt[[puniqueid]] - + ## Subset other tables in list stcliptabs$plt <- plt for (tabnm in names(tabs)[names(tabs) != "plt"]) { @@ -1243,21 +1247,21 @@ spGetPlots <- function(bnd = NULL, if (savedata) { if (savebnd) { spExportSpatial(bndx, - savedata_opts=list(outfolder=outfolder, - out_fmt=out_fmt, - out_dsn=out_dsn, - out_layer="bnd", - outfn.pre=outfn.pre, - outfn.date=outfn.date, - overwrite_layer=overwrite_layer, - append_layer=append_layer, - add_layer=TRUE)) + savedata_opts=list(outfolder=outfolder, + out_fmt=out_fmt, + out_dsn=out_dsn, + out_layer="bnd", + outfn.pre=outfn.pre, + outfn.date=outfn.date, + overwrite_layer=overwrite_layer, + append_layer=append_layer, + add_layer=TRUE)) } - - if (savexy) { - if (!is.null(spxy)) { - if (exportsp) { - spExportSpatial(spxy, + } + if (savexy) { + if (!is.null(spxy)) { + if (exportsp) { + spExportSpatial(spxy, savedata_opts=list(outfolder=outfolder, out_fmt=out_fmt, out_dsn=out_dsn, @@ -1267,8 +1271,8 @@ spGetPlots <- function(bnd = NULL, overwrite_layer=overwrite_layer, append_layer=append_layer, add_layer=TRUE)) - } else { - datExportData(sf::st_drop_geometry(spxy), + } else { + datExportData(sf::st_drop_geometry(spxy), savedata_opts=list(outfolder=outfolder, out_fmt=out_fmt, out_dsn=out_dsn, @@ -1278,11 +1282,10 @@ spGetPlots <- function(bnd = NULL, overwrite_layer=overwrite_layer, append_layer=append_layer, add_layer=TRUE)) - } - } + } } else { datExportData(pltids, - savedata_opts=list(outfolder=outfolder, + savedata_opts=list(outfolder=outfolder, out_fmt=out_fmt, out_dsn=out_dsn, out_layer="pltids",