check.popdataCHNG <-
function(tabs, tabIDs, popType,
datindb, pltaindb,
pltidsWITHqry,
pltidsid, pltidvars,
plotnm,
pdoms2keep = NULL,
pltidsadjindb = FALSE,
defaultVars = TRUE,
pltassgnid,
pltassgnx,
POP_PLOT_STRATUM_ASSGN,
adj, ACI, plotlst,
pwhereqry = NULL,
condid = "CONDID",
areawt = "SUBPTYP_PROP_CHNG", areawt2 = NULL,
MICRO_BREAKPOINT_DIA = 5,
MACRO_BREAKPOINT_DIA = NULL,
unitvars = NULL,
strunitvars = NULL,
nonsamp.cfilter = NULL,
cvars2keep = NULL,
dbconn = NULL, SCHEMA. = "",
getdataWITHqry = NULL,
getdataCNs = NULL,
returndata = FALSE,
savedata = FALSE,
outlst = NULL,
gui = FALSE){
##############################################################################
## DESCRIPTION: Checks data inputs for CHNG estimation
## Define variables necessary for estimation:
## - cvars2keep = c('PROP_BASIS', 'COND_NONSAMPLE_REASN_CD')
## Check if data are in a database (datindb) and if dbconn is valid.
## 1. Get table names used in estimation from tabs.
## - PLOT; COND; SUBP_COND_CHNG_MTRX
## - TREE (if popType = 'GRM'); SEEDLING (if popType = 'GRM')
## - TREE_GRM_COMPONENT, TREE_GRM_BEGIN, TREE_GRM_MIDPT (if popType = 'GRM')
## 2. Check for necessary variables in tables.
## plot - PREV_PLT_CN
## cond - (cuniqueid, condid, cvars2keep)
## subp_cond_chng_mtrx - PREVCOND
## 3. Build query for adjustment factors and append to pltids
## 4. Build and run queries for PLOT/COND (pltcondx)
## 5. Build CASE statement for adding adjustment factors to SELECT
## 6. Create return list with pltidsadj, adjfactors, and pltcondx/areawtx, if returndata=TRUE
## 7. Build and run queries for other necessary tables (if returndata/savedata = TRUE)
## 7.1 Return and/or save plot data (pltx / PLOT)
## 7.2 Return and/or save cond data (condx / COND)
## 7.3. Return and/or save subplot change data (sccmx / SUBP_COND_CHNG_MTRX)
## 7.4. Return and/or save tree data (treex / TREE)
## 7.5. Return grm data (grmx / TREE_GRM_COMPONENT)
## 7.6 Return grm begin data (beginx / TREE_GRM_BEGIN)
## 7.7. Return grm begin data (midptx / TREE_GRM_MIDPT)
## 7.8. Return seedling data (seedx / SEEDLING)
##
## 8. Check COND_STATUS_CD and generate table with number of conditions
## 8.1. Sampled conditions
## 8.2. Sampled nonforest conditions
##
## 9. Build FROM statement for estimation queries
## 10. Return data objects
###################################################################################
## Set global variables
grmx=beginx=midptx=SUBPTYP_PROP_ADJ=SUBPTYP_PROP_CHNG=ADJ_FACTOR_COND <- NULL
dbqueries=dbqueriesWITH <- list()
cpropvars <- list(COND="CONDPROP_UNADJ", SUBP="SUBPPROP_UNADJ", MACR="MACRPROP_UNADJ")
tpropvars <- list(SUBP="SUBPPROP_UNADJ", MACR="MACRPROP_UNADJ", MICR="MICRPROP_UNADJ")
diavar <- "DIA"
pltcondindb <- datindb
###################################################################################
## Define variables necessary for estimation
###################################################################################
cvars2keep <- unique(c(cvars2keep, "PROP_BASIS", "COND_NONSAMPLE_REASN_CD"))
##############################################################################
## Check if data are in a database (datindb) and if dbconn is valid
##############################################################################
if (datindb) {
if (is.null(dbconn) || !DBI::dbIsValid(dbconn)) {
message("the database connection is invalid")
stop()
} else {
dbtablst <- DBI::dbListTables(dbconn)
}
}
##############################################################################
## 1. Get table names used in estimation from tabs
##############################################################################
## plot table
plotnm <- plotlst$tabnm
puniqueid <- plotlst$tabid
pltx <- plotlst$tabx
pltflds <- plotlst$tabflds
if (is.null(pltx)) {
pltxnm <- plotnm
} else {
pltxnm <- "pltx"
}
## cond table
tabnames <- c("condu", "cond")
condlst <- popTabchk(tabnames, tabtext = "cond",
tabs, tabIDs, dbtablst, dbconn, datindb)
condnm <- condlst$tabnm
condflds <- condlst$tabflds
cuniqueid <- condlst$tabid
condx <- condlst$tabx
plota. <- "p."
conda. <- "c."
sccma. <- "sccm."
pltidsa. <- "pltids."
## subp_cond_chng_mtrx table
sccmlst <- popTabchk(c("subp_cond_chng_mtrx", "sccm"),
tabtext = "subp_cond_chng_mtrx",
tabs, tabIDs, dbtablst, dbconn, datindb)
sccmnm <- sccmlst$tabnm
sccmflds <- sccmlst$tabflds
sccmid <- sccmlst$tabid
sccmx <- sccmlst$tabx
if (!is.null(sccmx) && is.data.frame(sccmx)) {
sccmnm <- "sccmx"
}
if (is.null(condnm)) {
stop("must include cond for CHNG estimates")
}
## If pltassgn is not in database but all other tables are in database,
## we need to load tables to memory and subset for population queries.
if (datindb && !pltaindb) {
## Build cond FROM query
if (!is.null(getdataWITHqry) && !is.null(getdataCNs)) {
condjoinqry <- getjoinqry(cuniqueid, pltidsid, conda., pltidsa.)
condfromqry <- paste0("\n JOIN ", SCHEMA., condnm, " c ", condjoinqry)
## Build cond SELECT query
if (defaultVars) {
condvars <- condflds[condflds %in% DBvars.default()$condvarlst]
} else {
condvars <- "*"
}
condselectqry <- toString(paste0(conda., condvars))
## Build final cond query, including getdataWITHqry
condqry <- paste0(getdataWITHqry,
"\n-------------------------------------------",
"\n SELECT ", condselectqry,
"\n FROM pltids",
condfromqry)
dbqueries$COND <- condqry
## Run final cond query, including pltidsqry
if (datindb) {
condx <- tryCatch(
DBI::dbGetQuery(dbconn, condqry),
error=function(e) {
message(e,"\n")
return(NULL)})
} else {
condx <- tryCatch(
sqldf::sqldf(condqry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(condx) || nrow(condx) == 0) {
message(condqry)
return(NULL)
}
## Return and/or save cond data
condkey <- c(cuniqueid, condid)
setkeyv(setDT(condx), condkey)
## Subset condx to plots in pltassgn
condx <- condx[condx[[cuniqueid]] %in% getdataCNs,]
## Build sccm FROM query
sccmjoinqry <- getjoinqry(sccmid, pltidsid, sccma., pltidsa.)
sccmfromqry <- paste0("\n JOIN ", SCHEMA., sccmnm, " c ", sccmjoinqry)
## Build sccm SELECT query
if (defaultVars) {
sccmvars <- sccmflds[sccmflds %in% DBvars.default()$sccmvarlst]
} else {
sccmvars <- "*"
}
sccmselectqry <- toString(paste0(sccma., sccmvars))
## Build final sccm query, including getdataWITHqry
sccmqry <- paste0(getdataWITHqry,
"\n-------------------------------------------",
"\n SELECT ", sccmselectqry,
"\n FROM pltids",
sccmfromqry)
dbqueries$SCCM <- sccmqry
## Run final sccm query, including pltidsqry
if (datindb) {
sccmx <- tryCatch(
DBI::dbGetQuery(dbconn, sccmqry),
error=function(e) {
message(e,"\n")
return(NULL)})
} else {
sccmx <- tryCatch(
sqldf::sqldf(sccmqry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(sccmx) || nrow(sccmx) == 0) {
message("invalid cond query...")
message(sccmqry)
return(NULL)
}
## Set key on data.table
sccmkey <- c("PLT_CN", "CONDID", "PREV_PLT_CN", "PREVCOND")
setkeyv(setDT(sccmx), sccmkey)
## Subset condx to plots in pltassgn
sccmx <- sccmx[sccmx[[sccmid]] %in% getdataCNs,]
} else {
assign(condnm, DBI::dbReadTable(dbconn, condnm))
assign(sccmnm, DBI::dbReadTable(dbconn, sccmnm))
}
## Save data
if (savedata) {
message("saving SUBP_COND_CHNG_MTRX...")
outlst$out_layer <- "SUBP_COND_CHNG_MTRX"
if (!append_layer) index.unique.sccm <- sccmkey
datExportData(sccmx,
savedata_opts = outlst)
}
}
if (popType == "GRM") {
## tree table
treelst <- popTabchk(c("tree"), tabtext = "tree",
tabs, tabIDs, dbtablst, dbconn, datindb)
treenm <- treelst$tabnm
treeflds <- treelst$tabflds
tuniqueid <- treelst$tabid
treex <- treelst$tabx
if (is.null(treenm)) {
stop("must include tree for estimation")
}
## seedling table
seedlst <- popTabchk(c("seed", "seedling"), tabtext = "seed",
tabs, tabIDs, dbtablst, dbconn, datindb)
seednm <- seedlst$tabnm
seedflds <- seedlst$tabflds
suniqueid <- seedlst$tabid
seedx <- seedlst$tabx
## tree_grm_component table
grmlst <- popTabchk(c("grm", "tree_grm_component"), tabtext = "tree_grm_component",
tabs, tabIDs, dbtablst, dbconn, datindb)
grmnm <- grmlst$tabnm
grmflds <- grmlst$tabflds
grmid <- grmlst$tabid
grmx <- grmlst$tabx
if (is.null(grmnm)) {
stop("must include tree_grm_component for estimation")
}
## tree_grm_begin table
beginlst <- popTabchk(c("begin", "tree_grm_begin"), tabtext = "tree_grm_begin",
tabs, tabIDs, dbtablst, dbconn, datindb)
beginnm <- beginlst$tabnm
beginflds <- beginlst$tabflds
beginid <- beginlst$tabid
beginx <- beginlst$tabx
if (is.null(beginnm)) {
stop("must include tree_grm_begin for estimation")
}
## tree_grm_midpt table
midptlst <- popTabchk(c("midpt", "tree_grm_midpt"), tabtext = "tree_grm_midpt",
tabs, tabIDs, dbtablst, dbconn, datindb)
midptnm <- midptlst$tabnm
midptflds <- midptlst$tabflds
midptid <- midptlst$tabid
midptx <- midptlst$tabx
if (is.null(midptnm)) {
stop("must include tree_grm_midpt for estimation")
}
}
##############################################################################
## 2. Check for necessary variables in tables
##############################################################################
condxnm <- ifelse (!is.null(condx), "condx", condnm)
## plot table
##############################################################################
prevpltcnnm <- findnm("PREV_PLT_CN", pltflds, returnNULL = TRUE)
if (is.null(prevpltcnnm)) {
message("need PREV_PLT_CN in plot table for CHNG estimates")
stop()
}
## cond table
##############################################################################
## Check cuniqueid
cuniqueid <- pcheck.varchar(var2check = cuniqueid, varnm="cuniqueid", gui=gui,
checklst = condflds, caption="Unique identifier of plot in cond",
warn = paste(cuniqueid, "not in cond"), stopifnull = TRUE)
## Check condid
condid <- pcheck.varchar(var2check = condid, varnm="condid", gui=gui,
checklst = condflds, caption="Unique identifier of conditions in cond",
warn = paste(condid, "not in cond"), stopifnull = TRUE)
## Check cvars2keep in cond
if (!is.null(cvars2keep)) {
cvars2keepchk <- unlist(sapply(cvars2keep, findnm,
condflds, returnNULL = TRUE))
if (length(cvars2keep) < length(cvars2keep)) {
message("variables are missing from dataset: ",
toString(cvars2keep[!cvars2keep %in% cvars2keepchk]))
return(NULL)
} else {
cvars2keep <- cvars2keepchk
}
}
## subp_cond_chng_mtrx table
prevcondnm <- findnm("PREVCOND", sccmflds, returnNULL = TRUE)
if (is.null(prevcondnm)) {
message("need PREVCOND in subp_cond_chng_mtrx table for CHNG estimates")
}
##############################################################################
## 3. Build query for adjustment factors and append to pltids
##############################################################################
## Check proportion variables, including area weight
#######################################################################
cpropvars <- check.PROPvars(condflds,
propvars = unlist(cpropvars))
if (!areawt %in% sccmflds) {
stop("areawt not in dataset: ", areawt)
}
propvars <- cpropvars
if (popType == "VOL") {
tpropvars <- check.PROPvars(condflds, treeflds = treeflds,
propvars = unlist(tpropvars),
MICRO_BREAKPOINT_DIA = MICRO_BREAKPOINT_DIA,
MACRO_BREAKPOINT_DIA = MACRO_BREAKPOINT_DIA)
cvars2keep <- unique(c(cvars2keep, tpropvars))
propvars <- c(cpropvars, tpropvars)
propvars <- propvars[!duplicated(propvars)]
}
## Build and run query to calculate adjustment factors (ADJqry)
#######################################################################
pca. <- "pc."
sccma. <- "sccm."
## Build query to summarize sampled summarize subplot proportions (subcprop)
#######################################################################
## Build FROM query
plota. <- "p."
pplota. <- "pplot."
conda. <- "c."
pconda. <- "pcond."
sccma. <- "sccm."
## Build FROM query
pjoinqry <- getjoinqry(puniqueid, pltidsid, plota., pltidsa.)
pfromqry <- paste0("\n FROM pltids",
"\n JOIN ", SCHEMA., plotnm, " p ", pjoinqry)
pplotjoinqry <- getjoinqry(puniqueid, prevpltcnnm, pplota., plota.)
cjoinqry <- getjoinqry(cuniqueid, puniqueid, conda., plota.)
pcondjoinqry <- getjoinqry(cuniqueid, prevpltcnnm, pconda., plota.)
pcfromqry <- paste0(
pfromqry,
#"\n JOIN ", SCHEMA., plotnm, " pplot ", pplotjoinqry,
"\n JOIN ", SCHEMA., condnm, " c ", cjoinqry,
"\n JOIN ", SCHEMA., condnm, " pcond ", pcondjoinqry)
## Add FROM statement for subp_cond_chng_matrx
sccmjoinqry <- getjoinqry(c(sccmid, prevpltcnnm), c(pltidsid, prevpltcnnm), sccma., plota.)
sccmjoinqry <- paste0(
sccmjoinqry,
"\n AND ", sccma., condid, " = ", conda., condid,
" AND ", sccma., prevcondnm, " = ", pconda., condid)
#message(sccmjoinqry)
sccmfromqry <- paste0(pcfromqry,
"\n JOIN ", SCHEMA., sccmnm, " sccm ", sccmjoinqry)
## Build WHERE statement (i.e., excluding nonresponse)
adjwhereqry <- NULL
if (adj != "none") {
adjwhereqry <- getADJwherePLOT(condflds, conda.="c.")
## Other filters for change
#################################################################
condpropnm <- findnm("CONDPROP_UNADJ", condflds, returnNULL = TRUE)
nonsampreasonnm <- findnm("COND_NONSAMPLE_REASN_CD", condflds, returnNULL = TRUE)
propbasisnm <- findnm("PROP_BASIS", condflds, returnNULL = TRUE)
subtypnm <- findnm("SUBPTYP", sccmflds, returnNULL = TRUE)
if (any(is.null(condpropnm), is.null(propbasisnm), is.null(subtypnm),
is.null(nonsampreasonnm))) {
message("must include SUBTYP for CHNG estimates")
} else {
chg.filter <- paste0(
conda., condpropnm, " IS NOT NULL",
"\n AND ((", sccma., subtypnm, " = 3 AND ", conda., propbasisnm, " = 'MACR')",
"\n OR (", sccma., subtypnm, " = 1 AND ", conda., propbasisnm, " = 'SUBP'))",
"\n AND COALESCE(", conda., nonsampreasonnm, ", 0) = 0",
"\n AND COALESCE(", pconda., nonsampreasonnm, ", 0) = 0")
if (is.null(adjwhereqry)) {
adjwhereqry <- chg.filter
} else {
adjwhereqry <- paste0(adjwhereqry,
"\n AND ", chg.filter)
}
}
} ## END adj = 'none'
## Run sumpropCHNGqry to build SELECT statement and final query
sumpropqry <- sumpropCHNGqry(fromqry = sccmfromqry,
whereqry = adjwhereqry,
ACI = ACI,
frompltcondx = FALSE,
selectvars = NULL,
SCHEMA. = SCHEMA.)
#message(sumpropqry)
## Build and run query to calculate adjustment factors (ADJqry)
#######################################################################
## Build FROM query
adjjoinqry <- getjoinqry(sccmid, pltidsid, "c.", pltidsa.)
adjfromqry <- paste0("\n FROM pltids",
"\n JOIN subpcprop c ", adjjoinqry)
## Get getADJqry function
ADJqry <-
getADJqry(popType = popType,
adj = adj,
propvars = propvars,
adjfromqry = adjfromqry,
pwhereqry = NULL,
pltassgnid = pltassgnid,
strunitvars = strunitvars,
pltidsa. = pltidsa.,
pltidsid = pltidsid,
propqry = NULL)
#message(ADJqry)
## Build final query for adjustment factors, including pltids WITH query
adjfactors.qry <- paste0(
pltidsWITHqry, ", ",
"\n----- sum sampled subplot proportions",
"\nsubpcprop AS ",
"\n(", sumpropqry, ")",
"\n-------------------------------------------",
"\n", ADJqry
)
#message(adjfactors.qry)
## Run query to calculate adjustment factors
if (pltaindb) {
adjfactors <- tryCatch(
DBI::dbGetQuery(dbconn, adjfactors.qry),
error=function(e) {
message(e,"\n")
return(NULL)})
} else {
adjfactors <- tryCatch(
sqldf::sqldf(adjfactors.qry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(adjfactors) || nrow(adjfactors) == 0) {
message("invalid adjustment query...")
message(adjfactors.qry)
return(NULL)
}
if (adj == "samp") {
setkeyv(setDT(adjfactors), strunitvars)
} else {
setkeyv(setDT(adjfactors), pltidsid)
}
dbqueries$adjfactors <- adjfactors.qry
## Check with FIADB population data - VOL
#source("C:/_tsf/_GitHub/FIESTAnalysis/R/IEVALIDator_compare.R")
#FIADBpop <- getFIADBpop(state, evaltype = "03", evalyr, dbconn=dbconn)$pop_stratum
#popVOL_compare <- checkpop(FIADBpop, FIESTApop = adjfactors, evaltype="03")
#popVOL_compare
## Build and run final query to append adjustment factors to pltids, including ADJ query
if (adj == "samp") {
adja. <- "adj."
adjvars <- sapply(propvars, function(x) {
ifelse(grepl("PROP_UNADJ", x), paste0("ADJ_FACTOR_", sub("PROP_UNADJ", "", x)),
ifelse (grepl("prop_unadj", x), paste0("ADJ_FACTOR_", toupper(sub("prop_unadj", "", x))),
paste0(x, "_ADJ"))) })
selectvars <- toString(c(paste0(pltidsa., pltidsid), paste0(adja., adjvars)))
## Build final query for adjustment factors, including pltids WITH query
adjfactorsWITHqry <- paste0(
pltidsWITHqry, ", ",
"\n----- sum sampled subplot proportions",
"\nsubpcprop AS ",
"\n(", sumpropqry, "),",
"\n----- calculate strata-level adjustment factors",
"\nadjfactors AS",
"\n(", ADJqry, ")")
#message(adjfactorsWITH.qry)
## Build pltcondxadjFROM.qry
adjjoinqry <- getjoinqry(strunitvars, strunitvars, adja., pltidsa.)
pltidsadjFROM.qry <- paste0(
"\nFROM pltids",
"\nJOIN adjfactors adj ", adjjoinqry)
## Build pltidsadj.qry
pltidsadj.qry <- paste0(
adjfactorsWITHqry,
"\n-------------------------------------------",
paste0("\nSELECT ", selectvars,
pltidsadjFROM.qry))
## message(pltidsadj.qry)
## Build WITH query to identify pltids, including adjustment factors
pltidsadjWITHqry <- paste0(
adjfactorsWITHqry, ",",
"\n----- get plot-level adjustment factors",
"\npltidsadj AS ",
"\n(SELECT ", selectvars,
pltidsadjFROM.qry, ")")
} else {
## Build pltidsadj.qry
pltidsadj.qry <- paste0(
pltidsWITHqry,
"\n----- sum sampled subplot proportions",
"\nsubpcprop AS ",
"\n(", sumpropqry, ")",
"\n-------------------------------------------",
"\n", ADJqry)
## Build WITH query to identify pltids, including adjustment factors
pltidsadjWITHqry <- paste0(
pltidsWITHqry,
"\n----- sum sampled subplot proportions",
"\nsubpcprop AS ",
"\n(", sumpropqry, ")",
"\n----- calculate plot-level adjustment factors",
"\n", ADJqry)
}
dbqueriesWITH$pltidsWITH <- pltidsWITHqry
dbqueriesWITH$pltidsadjWITH <- pltidsadjWITHqry
## Run query to identify plotids, including adjustment factors
if (returndata || savedata) {
if (datindb) {
pltidsadj <- tryCatch(
DBI::dbGetQuery(dbconn, pltidsadj.qry),
error=function(e) {
message(e,"\n")
return(NULL)})
} else {
pltidsadj <- tryCatch(
sqldf::sqldf(pltidsadj.qry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(pltidsadj) || nrow(pltidsadj) == 0) {
message("invalid adjustment query...")
message(pltidsadj.qry)
return(NULL)
}
setkeyv(setDT(pltidsadj), pltidsid)
}
dbqueries$pltidsadj <- pltidsadj.qry
##############################################################################
## 4. Build and run queries for PLOT/COND (pltcondx).
##############################################################################
pltidsa. <- "pltids."
## Build FROM query for pltcondx query
##################################################################
pplotfromqry <- paste0(
pfromqry,
"\n JOIN ", SCHEMA., plotnm, " pplot ", pplotjoinqry)
ppcfromqry <- paste0(
pplotfromqry,
"\n JOIN ", SCHEMA., condnm, " c ", cjoinqry,
"\n JOIN ", SCHEMA., condnm, " pcond ", pcondjoinqry)
## Build SELECT query for pltcondx query
##################################################################
if (defaultVars) {
pvars <- pdoms2keep
} else {
pvars <- "*"
}
pvars <- pvars[pvars != "PREV_PLT_CN"]
pselectqry <- toString(paste0(plota., pvars))
pplotselectqry <- toString(paste0(pplota., pvars, " AS PREV_", pvars))
if (defaultVars) {
condvars <- condflds[condflds %in% DBvars.default()$condvarlst]
} else {
condvars <- "*"
}
cvars <- unique(c(condvars, cvars2keep))
cselectqry <- toString(paste0(conda., cvars))
pcondselectqry <- toString(paste0("pcond.", cvars, " AS PREV_", cvars))
pltcondflds <- unique(c(cvars, paste0("PREV_", cvars), pvars), paste0("PREV_", pvars))
## Add FORTYPGRP to SELECT query
addfortypgrp <- FALSE
if (addfortypgrp) {
ref_fortypgrp <- ref_codes[ref_codes$VARIABLE == "FORTYPCD", c("VALUE", "GROUPCD")]
ftypqry <- classqry(classcol = "c.FORTYPCD",
fromval = ref_fortypgrp$VALUE,
toval = ref_fortypgrp$GROUPCD,
classnm = "FORTYPGRPCD")
cselectqry <- paste0(cselectqry, ", ",
"\n ", ftypqry)
pftypqry <- classqry(classcol = "pcond.FORTYPCD",
fromval = ref_fortypgrp$VALUE,
toval = ref_fortypgrp$GROUPCD,
classnm = "FORTYPGRPCD")
pcondselectqry <- paste0(pcondselectqry, ", ",
"\n ", pftypqry)
pltcondflds <- c(pltcondflds, "FORTYPGRPCD")
}
## Build query for pltcondx
pltcondx.qry <- paste0("SELECT ", cselectqry, ", ",
"\n", pcondselectqry, ", ",
"\n", pselectqry, ", 1 AS TOTAL,",
"\n", pplotselectqry, ", 1 AS PREV_TOTAL",
ppcfromqry)
pltcondxqry <- paste0(pltidsWITHqry,
"\n", pltcondx.qry)
dbqueries$pltcondx <- pltcondxqry
## Build WITH query for pltcondx, including pltids WITH query
pltcondxWITH.qry <- paste0(pltidsWITHqry, ", ",
"\n----- get pltcondx",
"\npltcondx AS",
"\n(", pltcondx.qry, ")")
dbqueriesWITH$pltcondxWITH <- pltcondxWITH.qry
## Build WITH query for pltcondx, including pltidsadj WITH query
pltcondxadjWITHqry <- paste0(pltidsadjWITHqry, ", ",
"\n----- pltcondx",
"\npltcondx AS",
"\n(", pltcondx.qry, ")")
dbqueriesWITH$pltcondxadjWITH <- pltcondxadjWITHqry
## If returndata or savedata, run query for pltcondx
##################################################################
if (returndata || savedata) {
pltcondindb <- FALSE
## Run final plot/cond query, including pltidsqry
if (pltaindb) {
pltcondx <- tryCatch(
DBI::dbGetQuery(dbconn, pltcondxqry),
error=function(e) {
warning(e)
return(NULL)})
} else {
pltcondx <- tryCatch(
sqldf::sqldf(pltcondxqry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(pltcondx) || nrow(pltcondx) == 0) {
message("invalid pltcondx query...")
message(pltcondxqry)
return(NULL)
}
## Set key on data.table
pltcondkey <- c(cuniqueid, condid)
setkeyv(setDT(pltcondx), pltcondkey)
## Save data
if (savedata) {
message("saving pltcondx...")
outlst$out_layer <- "pltcondx"
if (!append_layer) index.unique.pltcondx <- pltcondkey
datExportData(pltcondx,
savedata_opts = outlst)
}
}
## 5. Build CASE statement for adding adjustment factors to SELECT
##################################################################
if (adj %in% c("samp", "plot")) {
propbasisnm <- findnm("PROP_BASIS", condflds, returnNULL=TRUE)
if ("COND" %in% names(propvars) && adjvars['COND'] %in% names(adjfactors)) {
adjcase <- adjvars['COND']
} else if (is.null(propbasisnm)) {
adjcase <- paste0("\nCASE pc.", propvars['MACR'], " IS NULL",
" THEN ", adjvars['SUBP'],
" ELSE ", adjvars['MACR'], " END")
} else {
adjcase <- paste0("\nCASE pc.", propbasisnm,
" WHEN 'MACR' THEN ", adjvars['MACR'],
" ELSE ", adjvars['SUBP'], " END")
}
}
##############################################################################
## 6. Create return list with pltidsadj, adjfactors, and pltcondx/areawtx, if returndata=TRUE.
##############################################################################
returnlst <- list(pltcondflds = pltcondflds,
cuniqueid = cuniqueid,
condid = condid, sccmid = sccmid,
adjfactors = adjfactors,
adjcase = adjcase,
adjvarlst = adjvars)
if (returndata || savedata) {
returnlst$pltcondx <- pltcondx
returnlst$pltidsadj <- pltidsadj
} else {
returnlst$pltcondx <- "pltcondx"
returnlst$pltidsadj <- "pltidsadj"
}
##############################################################################
## 7. Build and run queries for other necessary tables (if returndata = TRUE)
##############################################################################
if (returndata || savedata) {
message("returning data needed for estimation...")
# ## 7.1 Return and/or save plot data (pltx / PLOT)
# ##################################################################
#
# if (is.null(pltx) && !is.null(plotnm)) {
#
# ## Build plot SELECT query
# pselectqry <- toString(paste0(plota., c(puniqueid, pdoms2keep)))
# pplotselectqry <- toString(paste0(pplota., c(puniqueid, pdoms2keep)))
#
# ## Build final plot query, including pltidsqry
# pltqry <- paste0(getdataWITHqry,
# "\n-------------------------------------------",
# "\n SELECT ", pselectqry,
# ppcfromqry,
# "\n UNION",
# "\n SELECT ", pplotselectqry,
# ppcfromqry)
# dbqueries$PLOT <- pltqry
#
# ## un final plot query, including pltidsqry
# if (datindb) {
# pltx <- tryCatch(
# DBI::dbGetQuery(dbconn, pltqry),
# error=function(e) {
# message(e,"\n")
# return(NULL)})
# } else {
# pltx <- tryCatch(
# sqldf::sqldf(pltqry, connection = NULL),
# error = function(e) {
# message(e,"\n")
# return(NULL) })
# }
# if (is.null(pltx) || nrow(pltx) == 0) {
# message("invalid plot query...")
# message(pltqry)
# return(NULL)
# }
# }
#
# ## Return and/or save plot data
# setkeyv(setDT(pltx), puniqueid)
# if (!is.null(getdataCNs)) {
# pltx <- pltx[pltx[[puniqueid]] %in% getdataCNs,]
# }
#
# ## Add to returnlst
# if (returndata) {
# returnlst$puniqueid <- puniqueid
# }
# ## Save data
# if (savedata) {
# message("saving PLOT...")
# outlst$out_layer <- "PLOT"
# if (!append_layer) index.unique.plot <- puniqueid
# datExportData(pltx,
# savedata_opts = outlst)
# }
#
#
# ## 7.2 Return and/or save cond data (condx / COND)
# ##################################################################
#
# if (is.null(condx)) {
#
# ## Build cond FROM query
# #condjoinqry <- getjoinqry(cuniqueid, pltidsid, conda., pltidsa.)
# #condfromqry <- paste0("\n JOIN ", SCHEMA., condnm, " c ", condjoinqry)
#
# ## Build cond SELECT query
# if (defaultVars) {
# condvars <- condflds[condflds %in% DBvars.default()$condvarlst]
# } else {
# condvars <- "*"
# }
# condselectqry <- toString(paste0(conda., condvars))
# pcondselectqry <- toString(paste0(pconda., condvars))
#
# ## Build final cond query, including pltidsqry
#
# ## Build final plot query, including pltidsqry
# condqry <- paste0(getdataWITHqry,
# "\n-------------------------------------------",
# "\n SELECT ", condselectqry,
# pcfromqry,
# "\n UNION",
# "\n SELECT ", pcondselectqry,
# pcfromqry)
# dbqueries$COND <- condqry
#
# ## Run final cond query, including pltidsqry
# if (datindb) {
# condx <- tryCatch(
# DBI::dbGetQuery(dbconn, condqry),
# error=function(e) {
# message(e,"\n")
# return(NULL)})
# } else {
# condx <- tryCatch(
# sqldf::sqldf(condqry, connection = NULL),
# error = function(e) {
# message(e,"\n")
# return(NULL) })
# }
# if (is.null(condx) || nrow(condx) == 0) {
# message("invalid cond query...")
# message(condqry)
# return(NULL)
# }
#
# ## Return and/or save cond data
# condkey <- c(cuniqueid, condid)
# setkeyv(setDT(condx), condkey)
# if (!is.null(getdataCNs)) {
# condx <- condx[condx[[cuniqueid]] %in% getdataCNs,]
# }
# }
#
# ## Add to returnlst
# if (returndata) {
# returnlst$cuniqueid <- cuniqueid
# returnlst$condx <- condx
# }
# ## Save data
# if (savedata) {
# message("saving COND...")
# outlst$out_layer <- "COND"
# if (!append_layer) index.unique.cond <- condkey
# datExportData(condx,
# savedata_opts = outlst)
# }
# rm(condx)
## 7.3. Return and/or save subplot change data (sccmx / SUBP_COND_CHNG_MTRX)
##################################################################
if (is.null(sccmx)) {
## Build sccm FROM query
sccmjoinqry <- getjoinqry(sccmid, pltidsid, sccma., pltidsa.)
sccmfromqry <- paste0(
"\nJOIN ", SCHEMA., sccmnm, " sccm ", sccmjoinqry)
## Build sccm SELECT query
if (defaultVars) {
sccmvars <- "*"
}
#sccmselectqry <- toString(c(paste0("pltids.", strunitvars), paste0(sccma., sccmvars)))
sccmselectqry <- toString(paste0(sccma., sccmvars))
## Build final sccm query, including pltidsqry
sccmqry <- paste0(getdataWITHqry,
"\n-------------------------------------------",
"\n SELECT ", sccmselectqry,
"\n FROM pltids",
sccmfromqry)
## Run final sccm query, including pltidsqry
if (datindb) {
sccmx <- tryCatch(
DBI::dbGetQuery(dbconn, sccmqry),
error=function(e) {
message("invalid subp_cond_chng_matrx query...")
warning(e)
return(NULL)})
} else {
sccmx <- tryCatch(
sqldf::sqldf(sccmqry, connection = NULL),
error = function(e) {
message("invalid subp_cond_chng_matrx query...")
message(e,"\n")
return(NULL) })
}
if (is.null(sccmx) || nrow(sccmx) == 0) {
message(sccmqry)
return(NULL)
}
## Return and/or save sccm data
sccmkey <- c("PLT_CN", "CONDID", "PREV_PLT_CN", "PREVCOND")
setkeyv(setDT(sccmx), sccmkey)
if (!is.null(getdataCNs)) {
sccmx <- sccmx[sccmx[[sccmid]] %in% getdataCNs,]
}
}
## Append adjusted SUBPTYP_PROP_CHNG
sccmx[pltidsadj,
SUBPTYP_PROP_ADJ := SUBPTYP_PROP_CHNG * ADJ_FACTOR_COND]
## Add to returnlst and remove sccmx object
if (returndata) {
returnlst$sccmx <- sccmx
returnlst$sccmid <- sccmid
}
## Save data
if (savedata) {
message("saving SUBP_COND_CHNG_MATRX...")
outlst$out_layer <- "SUBP_COND_CHNG_MATRX"
if (!append_layer) index.unique.subp_cond_chng_mtrx <- sccmkey
datExportData(sccmx,
savedata_opts = outlst)
}
rm(sccmx)
##########################################################################
## If popType = 'GRM', get remeasured tree and seed data queries for GRM
## and TREE_GRM_COMPENENT, TREE_GRM_BEGIN and TREE_GRM_MIDPT queries
##########################################################################
if (popType == "GRM") {
## 7.4. Return and/or save seedling data (treex / TREE)
##################################################################
treea. <- "t."
ptreea. <- "ptree."
## Check variables
treecnnm <- findnm("CN", treeflds, returnNULL = TRUE)
prevtrecnnm <- findnm("PREV_TRE_CN", treeflds, returnNULL = TRUE)
tprevcondnm <- findnm("PREVCOND", treeflds, returnNULL = TRUE)
tsubp <- findnm("SUBP", treeflds, returnNULL = TRUE)
ttree <- findnm("TREE", treeflds, returnNULL = TRUE)
keyvars <- c(treecnnm, prevtrecnnm, tprevcondnm, tsubp, ttree)
if (any(sapply(keyvars, is.null))) {
keymiss <- keyvars[sapply(keyvars, is.null)]
stop("missing key variables in tree data: ", toString(keymiss))
}
## Build tree FROM query
tfromqry <- paste0(pcfromqry,
"\n JOIN ", SCHEMA., treenm, " t ON (", treea., tuniqueid, " = ", conda., cuniqueid,
"\n AND t.", condid, " = c.", condid, " AND ", treea., tprevcondnm, " = ", pconda., condid, ")",
"\n LEFT JOIN ", SCHEMA., treenm, " ptree ON (", ptreea., treecnnm, " = ", treea., prevtrecnnm, ")")
## Build tree SELECT query
if (defaultVars) {
treevars <- treeflds[treeflds %in% c(DBvars.default(istree=TRUE)$treevarlst,
DBvars.default(istree=TRUE)$tsumvarlst)]
} else {
treevars <- "*"
}
tselectqry <- toString(paste0(treea., unique(c(tuniqueid, treevars))))
ptreeselectqry <- toString(paste0(ptreea., unique(c(tuniqueid, treevars))))
## Build final tree query, including pltidsqry
treeqry <- paste0(pltidsWITHqry,
"\n SELECT ", tselectqry,
tfromqry,
"\nUNION",
"\n SELECT ", ptreeselectqry,
tfromqry)
dbqueries$tree <- treeqry
## Run final tree query, including pltidsqry
if (datindb) {
message("query ", treenm, "...")
treex <- tryCatch(
DBI::dbGetQuery(dbconn, treeqry),
error = function(e) {
message("invalid tree query...")
message(e,"\n")
return(NULL) })
} else {
treex <- tryCatch(
sqldf::sqldf(treeqry, connection = NULL),
error = function(e) {
message("invalid tree query...")
message(e,"\n")
return(NULL) })
}
if (is.null(treex)) {
message(treeqry)
}
## 8.2.6. Return and/or save tree data
treekey <- c(tuniqueid, condid, tsubp, ttree)
setkeyv(setDT(treex), treekey)
if (!is.null(getdataCNs)) {
treex <- treex[treex[[tuniqueid]] %in% getdataCNs,]
}
## Add to returnlst and remove treex object
if (returndata) {
returnlst$treex <- treex
returnlst$tuniqueid <- tuniqueid
}
## Save data
if (savedata) {
message("saving TREE...")
outlst$out_layer <- "TREE"
if (!append_layer) index.unique.tree <- treekey
datExportData(treex,
savedata_opts = outlst)
}
rm(treex)
## 7.5. Return grm data (grmx / TREE_GRM_COMPONENT)
##############################################################
grma. <- "grm."
## Check variables
grmtrecn <- findnm("TRE_CN", grmflds, returnNULL = TRUE)
keyvars <- grmtrecn
if (any(sapply(keyvars, is.null))) {
keymiss <- keyvars[sapply(keyvars, is.null)]
stop("missing key variables in tree_grm_component data: ", toString(keymiss))
}
## Build grm FROM query
grmjoinqry <- getjoinqry(grmtrecn, treecnnm, grma., treea.)
grmfromqry <- paste0(tfromqry,
"\n LEFT JOIN ", SCHEMA., grmnm, " grm ", grmjoinqry)
## Build grm SELECT query
if (defaultVars) {
grmvars <- grmflds[grmflds %in% DBvars.default(isgrm=TRUE)$grmvarlst]
} else {
grmvars <- "*"
}
grmselectqry <- toString(paste0("grm.", unique(c(grmid, grmvars))))
## Build final grm query, including pltidsqry
grmqry <- paste0(pltidsWITHqry,
"\n SELECT ", grmselectqry,
"\n FROM pltids",
grmfromqry)
dbqueries$grm <- grmqry
## Run final grm query, including pltidsqry
if (datindb) {
message("query ", grmnm, "...")
grmx <- tryCatch(
DBI::dbGetQuery(dbconn, grmqry),
error = function(e) {
message("invalid tree_grm_component query...")
message(e,"\n")
return(NULL) })
} else {
grmx <- tryCatch(
sqldf::sqldf(grmqry, connection = NULL),
error = function(e) {
message("invalid tree_grm_component query...")
message(e,"\n")
return(NULL) })
}
if (is.null(grmx)) {
message(grmqry)
return(NULL)
}
## Return and/or save grm data
grmkey <- c(grmtrecn)
setkeyv(setDT(grmx), grmkey)
## Add to returnlst
if (returndata) {
returnlst$grmx <- grmx
}
## Save data
if (savedata) {
message("saving TREE_GRM_COMPONENT...")
outlst$out_layer <- "TREE_GRM_COMPONENT"
if (!append_layer) index.unique.tree_grm_component <- grmkey
datExportData(grmx,
savedata_opts = outlst)
}
rm(grmx)
## 7.6. Return grm begin data (beginx / TREE_GRM_BEGIN)
##############################################################
begina. <- "begin."
## Check variables
begintrecn <- findnm("TRE_CN", beginflds, returnNULL = TRUE)
keyvars <- begintrecn
if (any(sapply(keyvars, is.null))) {
keymiss <- keyvars[sapply(keyvars, is.null)]
stop("missing key variables in tree_grm_begin data: ", toString(keymiss))
}
## Build begin FROM query
beginjoinqry <- getjoinqry(begintrecn, treecnnm, begina., treea.)
beginfromqry <- paste0(tfromqry,
"\n LEFT JOIN ", SCHEMA., beginnm, " begin ", beginjoinqry)
## Build begin SELECT query
beginvars <- "*"
beginselectqry <- toString(paste0(begina., unique(c(grmid, beginvars))))
## Build final begin query, including pltidsqry
###################################################
beginqry <- paste0(pltidsWITHqry,
"\n SELECT distinct ", beginselectqry,
beginfromqry)
dbqueries$begin <- beginqry
## Run final begin query, including pltidsqry
if (datindb) {
message("query ", beginnm, "...")
beginx <- tryCatch(
DBI::dbGetQuery(dbconn, beginqry),
error = function(e) {
message("invalid tree_grm_begin query...")
message(e,"\n")
return(NULL) })
} else {
beginx <- tryCatch(
sqldf::sqldf(beginqry, connection = NULL),
error = function(e) {
message("invalid tree_grm_begin query...")
message(e,"\n")
return(NULL) })
}
if (is.null(beginx)) {
message(beginqry)
return(NULL)
}
## Return and/or save begin data
beginkey <- c(begintrecn)
setkeyv(setDT(beginx), beginkey)
## Add to returnlst
if (returndata) {
returnlst$beginx <- beginx
}
## Save data
if (savedata) {
message("saving TREE_GRM_BEGIN...")
outlst$out_layer <- "TREE_GRM_BEGIN"
if (!append_layer) index.unique.tree_grm_begin <- beginkey
datExportData(beginx,
savedata_opts = outlst)
}
rm(beginx)
## 7.7. Return grm begin data (midptx / TREE_GRM_MIDPT)
##############################################################
midpta. <- "midpt."
## Check variables
midpttrecn <- findnm("TRE_CN", midptflds, returnNULL = TRUE)
keyvars <- midpttrecn
if (any(sapply(keyvars, is.null))) {
keymiss <- keyvars[sapply(keyvars, is.null)]
stop("missing key variables in tree_grm_midpt data: ", toString(keymiss))
}
## Build midpt FROM query
midptjoinqry <- getjoinqry(midpttrecn, treecnnm, midpta., treea.)
midptfromqry <- paste0(tfromqry,
"\nLEFT JOIN ", SCHEMA., midptnm, " midpt ", midptjoinqry)
## Build midpt SELECT query
midptvars <- "*"
midptselectqry <- toString(paste0(midpta., unique(c(grmid, midptvars))))
## Build final midpt query, including pltidsqry
midptqry <- paste0(pltidsWITHqry,
"\n SELECT distinct ", midptselectqry,
midptfromqry)
dbqueries$midpt <- midptqry
## Run final midpt query, including pltidsqry
if (datindb) {
message("query ", midptnm, "...")
midptx <- tryCatch(
DBI::dbGetQuery(dbconn, midptqry),
error = function(e) {
message("invalid tree_grm_midpt query...")
message(e,"\n")
return(NULL) })
} else {
midptx <- tryCatch(
sqldf::sqldf(midptqry, connection = NULL),
error = function(e) {
message("invalid tree_grm_midpt query...")
message(e,"\n")
return(NULL) })
}
if (is.null(midptx)) {
message(midptqry)
return(NULL)
}
## Return and/or save midpt data
midptkey <- c(midpttrecn)
setkeyv(setDT(midptx), midptkey)
## Add to returnlst
if (returndata) {
returnlst$midptx <- midptx
}
## Save data
if (savedata) {
message("saving TREE_GRM_MIDPT...")
outlst$out_layer <- "TREE_GRM_MIDPT"
if (!append_layer) index.unique.tree_grm_midpt <- midptkey
datExportData(midptx,
savedata_opts = outlst)
}
rm(midptx)
## 7.8. Return seedling data (seedx / SEEDLING)
##############################################################
if (!is.null(seednm)) {
seeda. <- "s."
## Check variables
treecnnm <- findnm("CN", treeflds, returnNULL = TRUE)
prevtrecnnm <- findnm("PREV_TRE_CN", treeflds, returnNULL = TRUE)
tprevcondnm <- findnm("PREVCOND", treeflds, returnNULL = TRUE)
scondidnm <- findnm("CONDID", seedflds, returnNULL = TRUE)
ssubp <- findnm("SUBP", seedflds, returnNULL = TRUE)
keyvars <- c(treecnnm, prevtrecnnm, tprevcondnm, scondidnm, ssubp)
if (any(sapply(keyvars, is.null))) {
keymiss <- keyvars[sapply(keyvars, is.null)]
stop("missing key variables in seedling data: ", toString(keymiss))
}
## Build seed FROM query
seedjoinqry <- getjoinqry(c(suniqueid, condid), c(cuniqueid, condid), seeda., conda.)
sfromqry <- paste0(pcfromqry,
"\n JOIN ", SCHEMA., seednm, " s ",
seedjoinqry)
## Build seed SELECT query
if (defaultVars) {
seedvars <- seedflds[seedflds %in% c(DBvars.default(isseed=TRUE)$seedvarlst,
DBvars.default(isseed=TRUE)$ssumvarlst)]
} else {
seedvars <- "*"
}
sselectqry <- toString(paste0("s.", unique(c(suniqueid, seedvars))))
## Build final seed query, including pltidsqry
seedqry <- paste0(pltidsWITHqry,
"\n SELECT ", sselectqry,
sfromqry)
dbqueries$seed <- seedqry
## Run final seed query, including pltidsqry
if (datindb) {
message("query ", seednm, "...")
seedx <- tryCatch(
DBI::dbGetQuery(dbconn, seedqry),
error = function(e) {
message("invalid seedling query...")
message(e,"\n")
return(NULL) })
} else {
seedx <- tryCatch(
sqldf::sqldf(seedqry, connection = NULL),
error = function(e) {
message("invalid seedling query...")
message(e,"\n")
return(NULL) })
}
if (is.null(seedx)) {
message(seedqry)
}
## Return and/or save seedling data
seedkey <- c(suniqueid, condid, ssubp)
setkeyv(setDT(seedx), seedkey)
## Add to returnlst
if (returndata) {
returnlst$seedx <- seedx
}
## Save data
if (savedata) {
message("saving SEEDLING...")
outlst$out_layer <- "SEEDLING"
if (!append_layer) index.unique.seedling <- seedkey
datExportData(seedx,
savedata_opts = outlst)
}
rm(seedx)
}
}
}
if (popType == "LULC") {
lulcqry <-
"SELECT distinct c.PLT_CN, c.CONDID,
pcond.COND_STATUS_CD PREV_COND_STATUS_CD, c.COND_STATUS_CD,
pcond.LAND_COVER_CLASS_CD PREV_LAND_COVER_CLASS_CD, c.LAND_COVER_CLASS_CD,
pcond.PRESNFCD PREV_PRESNFCD, c.PRESNFCD,
case when pcond.PRESNFCD is null
then pcond.COND_STATUS_CD
else pcond.PRESNFCD end as PREV_LANDUSECD,
case when c.PRESNFCD is null
then c.COND_STATUS_CD
else c.PRESNFCD end as LANDUSECD, chg.*
FROM pltx p
JOIN cond_pcondx c ON (c.PLT_CN = p.CN)
JOIN cond_pcondx pcond ON (pcond.PLT_CN = p.PREV_PLT_CN)
JOIN sccm_condx chg ON(chg.PLT_CN = c.PLT_CN and chg.CONDID = c.CONDID)
WHERE COALESCE(c.COND_NONSAMPLE_REASN_CD, 0) = 0
AND COALESCE(pcond.COND_NONSAMPLE_REASN_CD, 0) = 0"
lulcx <- sqldf::sqldf(lulcqry)
}
##############################################################################
## 8. Check COND_STATUS_CD and generate table with number of conditions
##############################################################################
## condfromqry
condjoinqry <- getjoinqry(cuniqueid, pltidsid, conda., pltidsa.)
condfromqry <- paste0("\nJOIN ", SCHEMA., condnm, " c ", condjoinqry)
## 8.1. Sampled conditions
##########################################################################
condsampcnt <- NULL
cstatuschk <- findnm("COND_STATUS_CD", pltcondflds, returnNULL=TRUE)
if (is.null(cstatuschk)) {
message("COND_STATUS_CD not in dataset.. assuming all conditions are sampled")
} else {
ref_cond_status_cd <- ref_codes[ref_codes$VARIABLE == "COND_STATUS_CD", ]
if (length(cstatuschk) > 1) {
cstatuscdnm <- cstatuschk[1]
} else {
cstatuscdnm <- cstatuschk
}
## Generate table of sampled/nonsampled plots (if ACI, nonforest status included)
if (!pltcondindb) {
condsampcnt <- pltcondx[, .N, by=cstatuscdnm]
setnames(condsampcnt, "N", "NBRCONDS")
} else {
condsampcntqry <- paste0("\nSELECT ", cstatuscdnm, ", COUNT(*) AS NBRCONDS",
"\nFROM pltids",
condfromqry,
"\nGROUP BY ", cstatuscdnm,
"\nORDER BY ", cstatuscdnm)
condsampcntqry <- paste0(getdataWITHqry,
condsampcntqry)
if (pltcondindb) {
condsampcnt <- tryCatch(
DBI::dbGetQuery(dbconn, condsampcntqry),
error = function(e) {
message(e,"\n")
return(NULL) })
} else {
condsampcnt <- tryCatch(
sqldf::sqldf(condsampcntqry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(condsampcnt)) {
message("invalid condsampcnt query")
message(condsampcntqry)
}
}
if (!is.null(condsampcnt)) {
condsampcnt <-
cbind(COND_STATUS_NM = ref_cond_status_cd[match(condsampcnt$COND_STATUS_CD,
ref_cond_status_cd$VALUE), "MEANING"], condsampcnt)
nbrnonsampled <- condsampcnt$NBRCONDS[condsampcnt$COND_STATUS_CD == 5]
if (length(nbrnonsampled) > 0) {
message("there are ", nbrnonsampled, " nonsampled conditions")
}
}
}
## 8.2. Sampled nonforest conditions
##########################################################################
## If ACI, check NF_PLOT_STATUS_CD and generate table with number of plots
##########################################################################
if (ACI) {
nfcondsampcnt <- NULL
nfcstatuschk <- findnm("NF_COND_STATUS_CD", pltcondflds, returnNULL=TRUE)
if (is.null(nfcstatuschk)) {
message("NF_COND_STATUS_CD not in dataset.. assuming all ACI nonforest conditions")
} else {
ref_nf_cond_status_cd <- ref_codes[ref_codes$VARIABLE == "NF_COND_STATUS_CD", ]
if (length(nfcstatuschk) > 1) {
nfcstatuscdnm <- nfcstatuschk[1]
} else {
nfcstatuscdnm <- nfcstatuschk
}
if (!pltcondindb) {
nfcondsampcnt <- pltcondx[, .N, by=nfcstatuscdnm]
setnames(nfcondsampcnt, "N", "NBRCONDS")
} else {
## Generate table of sampled/nonsampled conditions (if ACI, nonforest status included)
nfcondsampcntqry <- paste0("\nSELECT c.", nfcstatuscdnm, ", COUNT(*) AS NBRCONDS",
"\nFROM pltids",
condfromqry,
"\nGROUP BY ", nfcstatuscdnm,
"\nORDER BY ", nfcstatuscdnm)
nfcondsampcntqry <- paste0(getdataWITHqry,
nfcondsampcntqry)
if (pltcondindb) {
nfcondsampcnt <- tryCatch(
DBI::dbGetQuery(dbconn, nfcondsampcntqry),
error = function(e) {
message(e,"\n")
return(NULL) })
} else {
nfcondsampcnt <- tryCatch(
sqldf::sqldf(nfcondsampcntqry, connection = NULL),
error = function(e) {
message(e,"\n")
return(NULL) })
}
if (is.null(nfcondsampcnt)) {
message("invalid nfcondsampcnt query")
message(nfcondsampcntqry)
}
}
if (!is.null(nfcondsampcnt)) {
nfcondsampcnt <- nfcondsampcnt[!is.na(nfcondsampcnt$NF_COND_STATUS_CD), ]
if (nrow(nfcondsampcnt) > 0) {
nfcondsampcnt <-
cbind(NF_COND_STATUS_NM = ref_cond_status_cd[match(nfcondsampcnt$NF_COND_STATUS_CD,
ref_cond_status_cd$VALUE), "MEANING"], nfcondsampcnt)
## Append to condsampcnt
if (!is.null(condsampcnt)) {
condsampcnt <- rbindlist(list(condsampcnt, nfcondsampcnt), use.names=FALSE)
} else {
condsampcnt <- nfcondsampcnt
}
## Create nonsamp.cfilter
if (!is.null(nfcstatuscdnm) && (is.null(nonsamp.cfilter) || nonsamp.cfilter == "")) {
nfnonsamp.cfilter <- paste("c.", "NF_COND_STATUS_CD <> 5")
}
if (!is.null(nonsamp.cfilter)) {
nonsamp.cfilter <- paste0(nonsamp.cfilter, " AND ", nfnonsamp.cfilter)
} else {
nonsamp.cfilter <- nfnonsamp.cfilter
}
nbrnfnonsampled <- nfcondsampcnt$NBRCONDS[nfcondsampcnt$NF_COND_STATUS_CD == 5]
if (length(nbrnfnonsampled) > 0) {
message("there are ", nbrnfnonsampled, " nonsampled nonforest conditions")
}
}
}
}
}
## Add condsampcnt to returnlst
if (!is.null(condsampcnt)) {
returnlst$condsampcnt <- as.data.frame(condsampcnt)
}
## 9. Build FROM statement for estimation queries
######################################################################################
if (datindb) {
estpcfromqry <- paste0(
"\n FROM ", SCHEMA., plotnm, " p",
"\n JOIN ", SCHEMA., plotnm, " pplot ON (", pplota., puniqueid, " = ", plota., puniqueid, ")",
"\n JOIN ", SCHEMA., condnm, " c ON (", conda., cuniqueid, " = ", plota., puniqueid, ")",
"\n JOIN ", SCHEMA., condnm, " pcond ON (", pconda., cuniqueid, " = ", plota., prevpltcnnm, ")")
} else {
estpcfromqry <- paste0(
"\n FROM pltcondf cond",
"\n JOIN pltcondf pcond ON (", pconda., cuniqueid, " = ", conda., prevpltcnnm, ")")
}
## Add from statement for subp_cond_chng_matrx
estfromqry <- paste0(estpcfromqry,
"\n JOIN ", SCHEMA., sccmnm, " sccm ON(", sccma., sccmid, " = c.", cuniqueid,
"\n AND ", sccma., prevpltcnnm, " = ", pconda., cuniqueid,
"\n AND ", sccma., condid, " = ", conda., condid,
"\n AND ", sccma., prevcondnm, " = ", pconda., condid, ") ")
## 10. Return data objects
######################################################################################
if (!returndata) {
returnlst$sccmx <- sccmnm
if (popType == "GRM") {
if (!is.null(treenm)) {
returnlst$treex <- treenm
returnlst$tuniqueid <- tuniqueid
}
returnlst$grmx <- grmnm
returnlst$beginx <- beginnm
returnlst$midptx <- midptnm
if (!is.null(seednm)) {
returnlst$seedx <- seednm
returnlst$suniqueid <- suniqueid
}
}
if (popType == "LULC") {
returnlst$lulcx <- lulcx
}
}
returnlst$dbqueries <- dbqueries
returnlst$dbqueriesWITH <- dbqueriesWITH
returnlst$estfromqry <- estfromqry
return(returnlst)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.