#' Data - Aggregates numeric tree data by tree domain (i.e. species) to plot or
#' condition-level.
#'
#' Aggregates numeric tree domain data (e.g., SPCD) to plot or condition,
#' including options for filtering tree data or extrapolating to plot acre by
#' multiplying by TPA. Includes options for generating barplots, proportion
#' data, and cover data.
#'
#' If variable = NULL, then it will prompt user for input.
#'
#' If you want to get trees-per-acre information aggregated to plot or
#' condition level, you need to include a TPA variable in tree table. \cr For
#' tsumvars = GROWCFGS, GROWBFSL, GROWCFAL, FGROWCFGS, FGROWBFSL, or FGROWCFAL,
#' you must have TPAGROW_UNADJ \cr For tsumvars = MORTCFGS, MORTBFSL, MORTCFAL,
#' FMORTCFGS, FMORTBFSL, or FMORTCFAL, you must have TPAMORT_UNADJ \cr For
#' tsumvars = REMVCFGS, REMVBFSL, REMVCFAL, FREMVCFGS, FREMVBFSL, or FREMVCFAL,
#' you must have TPAREMV_UNADJ \cr
#'
#' If you want to adjust plot-level information by condition proportions, you
#' need to include CONDID & CONDPROP_UNADJ in cond or tree table. \cr
#'
#' If you want to adjust the aggregated tree data by the area of the strata
#' (estimation unit), you need to either have a variable in your tree data
#' named adjfact or you need to included the following variables in your
#' datasets: \cr Condition table: STATECD, CONDID, STRATA, ESTUNIT,
#' SUBPPROP_UNADJ, MICRPROP_UNADJ (if microplot trees) MACRPROP_UNADJ (if
#' macroplot trees). \cr Tree table: TPA_UNADJ
#'
#' All trees where DIA=NA are removed from analysis. These are trees that were
#' remeasured but are no longer in inventory (ex. a tree that is dead and not
#' standing in the current inventory).
#'
#' @param tree Data frame or comma-delimited file (*.csv). The tree-level table
#' with tree domain data.
#' @param seed Data frame or comma-delimited file (*.csv). The seedling table
#' with tree seedling counts. Only applicable for counts (tsumvar="PLT_CN").
#' @param cond Data frame or comma-delimited file (*.csv). Condition-level
#' table to join the aggregated tree data to, if bycond=TRUE. This table also
#' may be used for condition proportion or strata variables used if adjcond or
#' adjstrata = TRUE (See details below). This table is optional. If included,
#' CONDID must be present in table.
#' @param plt Dataframe, comma-delimited file (*.csv), or shapefile (*.shp).
#' Plot-level table to join the aggregated tree data to, if bycond=FALSE. This
#' table is optional.
#' @param subp_cond Dataframe, comma-delimited file (*.csv), or shapefile (*.shp).
#' Subplot condition-level table to use to sum condition proportions,
#' if bysubp=TRUE.
#' @param subplot Dataframe, comma-delimited file (*.csv), or shapefile (*.shp).
#' Subplot-level table to used to calculate adjustment factors, to remove
#' nonsampled conditions (SUBP_STATUS_CD = 3). This table is optional.
#' @param datsource String. Source of data ('obj', 'csv', 'sqlite', 'gdb').
#' @param data_dsn String. If datsource='sqlite', the name of SQLite database
#' (*.sqlite).
#' @param tuniqueid String. Unique identifier of the tree table. If including
#' seedling table, this should be the same for seed.
#' @param cuniqueid String. Unique identifier of the cond table if cond is NOT
#' NULL.
#' @param puniqueid String. Unique identifier of the plt table if plt is NOT
#' NULL.
#' @param bycond Logical. If TRUE, data are aggregated to the condition level
#' (by: uniqueid, CONDID). If FALSE, data are aggregated to the plot level (by:
#' uniqueid).
#' @param condid String. Unique identifier for conditions.
#' @param bysubp Logical. If TRUE, data are aggregated to the subplot level.
#' @param subpid String. Unique identifier of each subplot.
#' @param presence Logical. If TRUE, an additional table is output with tree
#' domain values as presence/absence (1/0).
#' @param tsumvar String. Name of the variable to aggregate (e.g., "BA"). For
#' summing number of trees, use tsumvar="TPA_UNADJ" with tfun=sum.
#' @param addseed Logical. If TRUE, add seedling counts to tree counts. Note:
#' tdomvar must be 'SPCD' or 'SPGRPCD'.
#' @param seedonly Logical. If TRUE, seedling counts only. Note: tdomvar
#' must be 'SPCD' or 'SPGRPCD'.
#' @param woodland String. If woodland = 'Y', include woodland tree species
#' where measured. If woodland = 'N', only include timber species. See
#' FIESTA::ref_species$WOODLAND ='Y/N'. If woodland = 'only', only include
#' woodland species.
#' @param TPA Logical. If TRUE, tsumvarlst variable(s) are multiplied by the
#' respective trees-per-acre variable (see details) to get per-acre
#' measurements.
#' @param tfun Function. Name of the function to use to aggregate the data
#' (e.g., sum, mean, max).
#' @param ACI Logical. If TRUE, if ACI (All Condition Inventory) plots exist,
#' any trees on these plots will be included in summary. If FALSE, you must
#' include condition table.
#' @param tfilter String. A filter to subset the tree data before aggregating
#' (e.g., "STATUSCD == 1"). This must be in R syntax. If tfilter=NULL, user is
#' prompted. Use tfilter="NONE" if no filters.
#' @param lbs2tons Logical. If TRUE, converts biomass or carbon variables from
#' pounds to tons (1 pound = 0.0005 short tons).
#' @param metric Logical. If TRUE, converts response to metric units based on
#' FIESTA::ref_conversion, if tsumvar is in FIESTAutils::ref_units. Note: if TPA,
#' TPA is converted to trees per hectare (TPH: 1/ tpavar * 0.4046860).
#' @param tdomvar String. The tree domain (tdom) variable used to aggregate by
#' (e.g., "SPCD", "SPGRPCD").
#' @param tdomvarlst String (vector). List of specific tree domains of tdomvar
#' to aggregate (e.g., c(108, 202)). If NULL, all domains of tdomvar are used.
#' @param tdomvar2 String. A second tree domain variable to use to aggregate by
#' (e.g. "DIACL"). The variables, tdomvar and tdomvar2 will be concatenated
#' before summed.
#' @param tdomvar2lst String (vector). List of specific tree domains of
#' tdomvar2 to aggregate. If NULL, all domains of tdomvar2 are used.
#' @param tdomprefix String. The prefix used for naming the aggregated tree
#' data, before numeric codes (e.g., "SP" = SP102, SP746).
#' @param tdombarplot Logical. If TRUE and pivot=TRUE, calls datBarplot() and
#' outputs a barplot of tdom distributions. If savedata=TRUE, barplots are
#' written to outfolder.
#' @param tdomtot Logical. If TRUE and pivot=TRUE a total of all tree domains
#' in tdomvarlst is calculated and added to output data frame.
#' @param tdomtotnm String. If tdomtot=TRUE, the variable name for the total
#' column in output data frame. If NULL, the default will be tdomvar + 'TOT'.
#' @param FIAname Logical. If TRUE, changes names of columns for SPCD and
#' SPGRPCD from code to FIA names.
#' @param spcd_name String. Output name type if tdomvar or tdomvar2 = "SPCD"
#' ('COMMON', 'SCIENTIFIC', 'SYMBOL').
#' @param pivot Logical. If TRUE, tdomvar data are transposed (pivoted) to
#' separate columns.
#' @param proportion Logical. If TRUE and pivot=TRUE, an additional table will
#' be output with tree domain data as proportions of total tsumvar.
#' @param cover Logical. If TRUE and pivot=TRUE, , an additional table will be
#' output with tree domain data as percent cover, based on proportions of
#' tsumvar (see proportion) and tree canopy cover variable in cond
#' (LIVE_CANOPY_CVR_PCT) or in plt (CCLIVEPLT). Does not include seedlings.
#' @param getadjplot Logical. If TRUE, adjustments are calculated for
#' nonsampled conditions on plot.
#' @param adjtree Logical. If TRUE, trees are individually adjusted by
#' adjustment factors. Adjustment factors must be included in tree table (see
#' adjvar).
#' @param adjvar String. If adjtree=TRUE, the name of the variable to use for
#' multiplying by adjustment (e.g., tadjfac).
#' @param adjTPA Numeric. A tree-per-acre adjustment. Use for DESIGNCD=1
#' (annual inventory), if using less than 4 subplots. If using only 1 sublot
#' for estimate, adjTPA=4. The default is 1.
#' @param NAto0 Logical. If TRUE, convert NA values to 0.
#' @param tround Number. The number of digits to round to. If NULL, default=6.
#' @param returnDT Logical. If TRUE, returns data.table object(s). If FALSE,
#' returns data.frame object(s).
#' @param savedata Logical. If TRUE, saves data to outfolder.
#' @param savedata_opts List. See help(savedata_options()) for a list
#' of options. Only used when savedata = TRUE. If out_layer = NULL,
#' default = 'tdomsum'.
#' @param dbconn Open database connection.
#' @param dbconnopen Logical. If TRUE, keep database connection open.
#' @param gui Logical. If gui, user is prompted for parameters.
#'
#' @return tdomdata - a list of the following objects:
#'
#' \item{tdomdat}{ Data frame. Plot or condition-level table with aggregated
#' tree domain (tdom) attributes (filtered). }
#' \item{tdomsum}{ Data frame. The tdom look-up table with data aggregated
#' by species. }
#' \item{tdomvar}{ String. Name of the tdom variable used to aggregate by. }
#' \item{tsumvar}{ String. Name of the aggregated output variable. }
#' \item{tdomlst}{ Vector. List of the aggregated tree data in tdomdat. }
#' \item{tdomdat.pres}{ Data frame. Plot or condition-level table with
#' aggregated tree domain attributes represented as presence/absence (1/0). }
#' \item{tdomdat.prop}{ Data frame. Plot or condition-level table with
#' aggregated tree domain attributes represented as proportion of total by
#' plot. }
#' \item{tdomdat.cov}{ Data frame. Plot or condition-level table with
#' aggregated tree domain attributes represented as percent cover, multipying
#' cover attribute by tdom proportion by plot. }
#'
#' If savedata=TRUE\cr - tdomdat will be saved to the outfolder
#' ('tdomprefix'_DAT.csv). \cr - a text file of input parameters is saved to
#' outfolder ('outfn'_parameters_'date'.txt). \cr - if presence=TRUE,
#' tdomdat.prop is saved to outfolder ('tdomprefix'_PRESDAT.csv) - if
#' proportion=TRUE, tdomdat.prop is saved to outfolder
#' ('tdomprefix'_PROPDAT.csv) - if cover=TRUE, tdomdat.prop is saved to
#' outfolder ('tdomprefix'_COVDAT.csv)
#' @note This function can be used to get tree domain data. This data can be
#' used for mapping tree domain distributions.
#' @author Tracey S. Frescino
#' @keywords data
#' @examples
#' \donttest{
#' # Sum of Live Basal Area Per Acre by Species
#' datSumTreeDom(tree = FIESTA::WYtree,
#' cond = FIESTA::WYcond,
#' plt = FIESTA::WYplt,
#' puniqueid = "CN",
#' bycond = FALSE,
#' tsumvar = "BA",
#' TPA = TRUE,
#' tdomtot = TRUE,
#' tdomtotnm = "BA_LIVE",
#' tdomprefix = "BA_LIVE",
#' tround = 2,
#' tfilter = "STATUSCD==1")
#'
#' # Sum of Number of Live Trees by Species
#' datSumTreeDom(tree = FIESTA::WYtree,
#' cond = FIESTA::WYcond,
#' plt = FIESTA::WYplt,
#' puniqueid = "CN",
#' bycond = FALSE,
#' tsumvar = "PLT_CN",
#' TPA = TRUE,
#' tdomtot = TRUE,
#' tdomprefix = "CNT",
#' tround = 0,
#' tfilter = "STATUSCD==1")
#'
#' # Sum of Number of Live Trees by Species, Including Seedlings
#' datSumTreeDom(cond = WYcond,
#' plt = WYplt,
#' seed = WYseed,
#' puniqueid = "CN",
#' bycond = FALSE,
#' tsumvar = "PLT_CN",
#' TPA = TRUE,
#' tdomtot = TRUE,
#' tdomprefix = "CNT",
#' tround = 0)
#' }
#' @export datSumTreeDom
datSumTreeDom <- function(tree = NULL,
seed = NULL,
cond = NULL,
plt = NULL,
subp_cond = NULL,
subplot = NULL,
datsource = "obj",
data_dsn = NULL,
tuniqueid = "PLT_CN",
cuniqueid = "PLT_CN",
puniqueid = "CN",
bycond = FALSE,
condid = "CONDID",
bysubp = FALSE,
subpid = "SUBP",
tsumvar = NULL,
addseed = FALSE,
seedonly = FALSE,
woodland = 'Y',
TPA = TRUE,
tfun = sum,
ACI = FALSE,
tfilter = NULL,
lbs2tons = TRUE,
metric = FALSE,
tdomvar = "SPCD",
tdomvarlst = NULL,
tdomvar2 = NULL,
tdomvar2lst = NULL,
tdomprefix = NULL,
tdombarplot = FALSE,
tdomtot = FALSE,
tdomtotnm =NULL,
FIAname = FALSE,
spcd_name = "COMMON",
pivot = TRUE,
presence = FALSE,
proportion = FALSE,
cover = FALSE,
getadjplot = FALSE,
adjtree = FALSE,
adjvar = "tadjfac",
NAto0 = FALSE,
adjTPA = 1,
tround = 5,
returnDT = TRUE,
savedata = FALSE,
savedata_opts = NULL,
dbconn = NULL,
dbconnopen = FALSE,
gui = FALSE){
####################################################################################
## DESCRIPTION: Aggregates tree domain data (ex. species) to condition or plot level
## for estimation, mapping, or exploratory data analyses.
##
## 1. Set biomass and carbon variables for converting from pounds to tons (0.0005)
## 2. Checks input tables (tree, cond, plt)
## 3. Check unique identifiers (tuniqueid, cuniqueid, and puniqueid) and make sure
## values and classes match
## Note: Condition table is needed if adjplot = TRUE, ACI = FALSE (COND_STATUS_CD)
########################################################################################
## IF NO ARGUMENTS SPECIFIED, ASSUME GUI=TRUE
gui <- ifelse(nargs() == 0, TRUE, FALSE)
## Set global variables
COND_STATUS_CD=COUNT=CONDPROP_UNADJ=V1=samenm=SUBP=NF_COND_STATUS_CD=
seedx=tunits=TREECOUNT_CALC=cond.nonsamp.filter=ref_spcd <- NULL
checkNApvars <- {}
checkNAcvars <- {}
checkNAtvars <- {}
seedclnm <- "<1"
parameters <- FALSE
ref_units <- FIESTAutils::ref_units
ref_estvar <- FIESTAutils::ref_estvar
twhereqry=swhereqry=tfromqry=sfromqry <- NULL
checkNA <- FALSE
## If gui.. set variables to NULL
if (gui) bycond=tuniqueid=puniqueid=cuniqueid=ACI=TPA=tfun=tdomvar=tdomlst=
tdombarplot=FIAname=addseed=proportion=presence=tdomtot=adjtree=tmp <- NULL
##################################################################
## SET VARIABLE LISTS
##################################################################
biovars <- c("DRYBIO_BOLE", "DRYBIO_STUMP", "DRYBIO_BG", "DRYBIO_SAWLOG",
"DRYBIO_AG", "DRYBIO_STEM", "DRYBIO_STEM_BARK", "DRYBIO_STUMP_BARK", "DRYBIO_BOLE_BARK", "DRYBIO_BRANCH", "DRYBIO_FOLIAGE", "DRYBIO_SAWLOG_BARK",
"DRYBIOT", "DRYBIOM", "DRYBIOTB", "JBIOTOT")
carbvars <- c("CARBON_BG", "CARBON_AG")
## SET VARIABLES TO CONVERT (from pounds to short tons.. * 0.0005)
vars2convert <- c(biovars, carbvars, paste(biovars, "TPA", sep="_"),
paste(carbvars, "TPA", sep="_"))
growvars <- c("TPAGROW_UNADJ", "GROWCFGS", "GROWBFSL", "GROWCFAL", "FGROWCFGS",
"FGROWBFSL", "FGROWCFAL")
mortvars <- c("TPAMORT_UNADJ", "MORTCFGS", "MORTBFSL", "MORTCFAL", "FMORTCFGS",
"FMORTBFSL", "FMORTCFAL")
remvars <- c("TPAREMV_UNADJ", "REMVCFGS", "REMVBFSL", "REMVCFAL", "FREMVCFGS",
"FREMVBFSL", "FREMVCFAL")
tpavars <- c("TPA_UNADJ", "TPAMORT_UNADJ", "TPAGROW_UNADJ", "TPAREMV_UNADJ")
propvar <- "CONDPROP_UNADJ"
tsumvar.not <- c(condid)
##################################################################
## CHECK PARAMETER NAMES
##################################################################
## Check input parameters
input.params <- names(as.list(match.call()))[-1]
formallst <- names(formals(datSumTreeDom))
if (!all(input.params %in% formallst)) {
miss <- input.params[!input.params %in% formallst]
stop("invalid parameter: ", toString(miss))
}
## Check parameter lists
pcheck.params(input.params, savedata_opts=savedata_opts)
## Set savedata defaults
savedata_defaults_list <- formals(savedata_options)[-length(formals(savedata_options))]
for (i in 1:length(savedata_defaults_list)) {
assign(names(savedata_defaults_list)[[i]], savedata_defaults_list[[i]])
}
## Set user-supplied savedata values
if (length(savedata_opts) > 0) {
if (!savedata) {
message("savedata=FALSE with savedata parameters... no data are saved")
}
for (i in 1:length(savedata_opts)) {
if (names(savedata_opts)[[i]] %in% names(savedata_defaults_list)) {
assign(names(savedata_opts)[[i]], savedata_opts[[i]])
} else {
stop(paste("Invalid parameter: ", names(savedata_opts)[[i]]))
}
}
}
##################################################################
## CHECK PARAMETER INPUTS
##################################################################
noplt=nocond <- TRUE
pltsp <- FALSE
## Set datsource
########################################################
datsourcelst <- c("obj", "csv", "sqlite", "gdb")
datsource <- pcheck.varchar(var2check=datsource, varnm="datsource",
checklst=datsourcelst, gui=gui, caption="Data source?")
if (is.null(datsource)) {
if (!is.null(data_dsn) && file.exists(data_dsn)) {
dsn.ext <- getext(data_dsn)
if (!is.na(dsn.ext) && dsn.ext != "") {
datsource <- ifelse(dsn.ext == "gdb", "gdb",
ifelse(dsn.ext %in% c("db", "db3", "sqlite", "sqlite3"), "sqlite",
ifelse(dsn.ext == "csv", "csv",
ifelse(dsn.ext == "shp", "shp", "datamart"))))
}
} else {
stop("datsource is invalid")
}
}
## Check bycond
###########################################################################
bycond <- pcheck.logical(bycond, varnm="bycond", title="By condition?",
first="YES", gui=gui, stopifnull=TRUE)
## Check bysubp
###########################################################################
bysubp <- pcheck.logical(bysubp, varnm="bysubp", title="By subplot?",
first="YES", gui=gui, stopifnull=TRUE)
## Check addseed
addseed <- pcheck.logical(addseed, varnm="addseed", title="Add seeds?",
first="NO", gui=gui)
## Check seedonly
seedonly <- pcheck.logical(seedonly, varnm="seedonly", title="Seed only?",
first="NO", gui=gui)
## Check woodland
woodlandlst <- c("Y", "N", "only")
woodland <- pcheck.varchar(var2check=woodland, varnm="woodland",
checklst=woodlandlst, gui=gui, caption="Woodland?")
## Check tree, seed tables
###########################################################################
treenm=seednm=dbname=ref_sppnm=woodlandnm <- NULL
if (datsource %in% c("obj", "csv")) {
treex <- pcheck.table(tree, gui=gui, tabnm="tree", caption="Tree table?")
if (!is.null(treex)) {
treex <- setDT(int64tochar(treex))
treenames <- names(treex)
treenm <- "treex"
}
seedx <- pcheck.table(seed, gui=gui, tabnm="seed", caption="Seed table?")
if (!is.null(seedx)) {
seedx <- setDT(int64tochar(seedx))
seednames <- names(seedx)
seednm <- "seedx"
}
if (woodland %in% c("N", "only")) {
woodlandnm <- findnm("WOODLAND", treenames, returnNULL=TRUE)
if (is.null(woodlandnm)) {
woodlandref <- TRUE
ref_sppnm <- "ref_species"
woodlandnm <- "WOODLAND"
refspcdnm <- "SPCD"
spcdnm <- findnm("SPCD", treenames)
}
}
} else {
dbname <- data_dsn
dbconn <- DBtestSQLite(data_dsn, dbconnopen=TRUE)
dbtablst <- DBI::dbListTables(dbconn)
treex <- chkdbtab(dbtablst, tree)
if (!is.null(treex)) {
treenames <- DBI::dbListFields(dbconn, treex)
treenm <- treex
}
seedx <- chkdbtab(dbtablst, seed)
if (!is.null(seedx)) {
seednames <- DBI::dbListFields(dbconn, seedx)
seednm <- seedx
}
if (woodland %in% c("N", "only")) {
woodlandnm <- findnm("WOODLAND", treenames, returnNULL=TRUE)
if (is.null(woodlandnm)) {
woodlandref <- TRUE
ref_sppnm <- chkdbtab(dbtablst, "REF_SPECIES")
if (!is.null(ref_sppnm)) {
refflds <- DBI::dbListFields(dbconn, ref_sppnm)
woodlandnm <- findnm("WOODLAND", refflds, returnNULL=TRUE)
refspcdnm <- findnm("SPCD", refflds)
spcdnm <- findnm("SPCD", treenames)
if (is.null(woodlandnm)) {
warning("WOODLAND attribute not in ref_species table... returning NULL")
return(NULL)
}
} else {
warning("ref_species table not in database... returning NULL")
return(NULL)
}
}
}
DBI::dbDisconnect(dbconn)
}
if (is.null(treex) && is.null(seedx)) {
stop("must include tree and/or seed table")
}
if (addseed && is.null(seedx)) {
stop("if addseed=TRUE, must include seed table")
}
if (is.null(treex) && !is.null(seedx)) {
addseed <- FALSE
seedonly <- TRUE
treex <- seedx
treenm <- seednm
treenames <- seednames
}
if (!addseed && !seedonly && !is.null(seedx)) {
seedx <- NULL
}
## Check unique identifiers and set unique keys for R objects
###########################################################################
## Check tuniqueid
if (!is.null(treex)) {
tuniqueid <- pcheck.varchar(var2check=tuniqueid, varnm="tuniqueid",
checklst=treenames, caption="UniqueID variable - tree",
warn=paste(tuniqueid, "not in tree table"), stopifnull=TRUE)
tsumuniqueid <- tuniqueid
if (addseed) {
if (!tuniqueid %in% seednames) {
stop(tuniqueid, " not in seedx")
}
}
if (bysubp) {
if (!subpid %in% treenames) {
stop(subpid, " not in tree")
}
if (addseed) {
if (!subpid %in% seednames) {
stop("bysubp=TRUE but ", subpid, " is not in seed table")
}
}
tsumuniqueid <- c(tsumuniqueid, subpid)
}
if (bycond) {
if (!condid %in% treenames) {
message(condid, " not in tree... assuming only 1 condition")
treex[[condid]] <- 1
}
if (addseed) {
if (!condid %in% seednames) {
message(condid, " not in seed table")
seedx[[condid]] <- 1
}
}
tsumuniqueid <- c(tsumuniqueid, condid)
}
}
if (seedonly) {
tuniqueid <- pcheck.varchar(var2check=tuniqueid, varnm="tuniqueid",
checklst=seednames, caption="UniqueID variable - seed",
warn=paste(tuniqueid, "not in seed table", stopifnull=TRUE))
tsumuniqueid <- tuniqueid
if (bysubp) {
if (!subpid %in% seednames) {
stop("bycond=TRUE but ", subpid, " is not in seed table")
}
tsumuniqueid <- c(tsumuniqueid, subpid)
}
if (bycond) {
if (!condid %in% seednames) {
message(condid, " not in seed... assuming only 1 condition")
seedx[[condid]] <- 1
}
tsumuniqueid <- c(tsumuniqueid, condid)
}
}
## Build query parts for tree table
##################################################
tfromqry <- paste("FROM", treenm)
if (addseed || seedonly) {
sfromqry <- paste("FROM", seednm)
}
if (woodland %in% c("N", "only") && woodlandref) {
tfromqry <- paste0(tfromqry,
"\n JOIN ", ref_sppnm, " ref ON(", treenm, ".", spcdnm, " = ref.", refspcdnm, ")")
}
selectvars <- tsumuniqueid
if (!is.null(tfilter)) {
if (!seedonly) {
if (is.null(twhereqry)) {
twhereqry <- paste("WHERE", RtoSQL(tfilter, x=treenames))
} else {
twhereqry <- paste(twhereqry, "AND", RtoSQL(tfilter, x=treenames))
}
}
if (addseed || seedonly) {
sfilter <- check.logic(seednames, statement=tfilter, stopifinvalid=FALSE)
if (!is.null(sfilter)) {
swhereqry <- paste("WHERE", RtoSQL(tfilter))
}
}
if (woodland %in% c("N", "only")) {
if (is.null(twhereqry)) {
if (woodland == "N") {
twhereqry <- paste("WHERE", woodlandnm, "== 'N'")
} else {
twhereqry <- paste("WHERE", woodlandnm, "== 'Y'")
}
} else {
if (woodland == "N") {
twhereqry <- paste(twhereqry, "AND", woodlandnm, "== 'N'")
} else {
twhereqry <- paste(twhereqry, "AND", woodlandnm, "== 'Y'")
}
}
}
}
### Check tsumvar
###########################################################
notdomdat <- ifelse(is.null(tsumvar) && presence, TRUE, FALSE)
if (is.null(tsumvar)) {
if (presence) {
#tsumvar <- "BA"
tsumvar <- tuniqueid
} else {
tsumvar <- select.list(treenames, title="Aggregate variable", multiple=FALSE)
if (tsumvar == "") stop("")
}
} else if (tsumvar %in% tsumvar.not) {
stop("tsumvar is invalid")
} else if (!tsumvar %in% treenames) {
warning("check tsumvar: tree aggregation variable not in tree table")
tsumvar <- select.list(treenames, title="Tree aggregate variable", multiple=FALSE)
if (tsumvar == "") stop("")
} else if (tsumvar == "PLT_CN") {
tsumvar <- "TPA_UNADJ"
}
## Check seed
if (seedonly || addseed) {
if (!tsumvar %in% c("TPA_UNADJ", "PLT_CN")) {
stop("tsumvar must be TPA_UNADJ or PLT_CN for seedonly")
} else {
tsumvar <- "TPA_UNADJ"
}
}
## Check tdomvar and tdomvar2
###########################################################
tdomvar <- pcheck.varchar(var2check=tdomvar, varnm="tdomvar", gui=gui,
checklst=treenames, caption="Tree domain name?",
warn=paste(tdomvar, "not in tree table"), stopifnull=TRUE)
tdomvar2 <- pcheck.varchar(var2check=tdomvar2, varnm="tdomvar2", gui=gui,
checklst=treenames, caption="Tree domain2 name?",
warn=paste(tdomvar2, "not in tree table"))
tselectvars <- unique(c(selectvars, tsumvar, tdomvar, tdomvar2))
## check seed table
if (addseed || seedonly) {
if (!tdomvar %in% seednames) {
message(tdomvar, "not in seed... no seeds included")
if (seedonly) {
stop()
} else {
addseed <- FALSE
}
}
if (!is.null(tdomvar2) && !tdomvar2 %in% seednames) {
message(tdomvar2, "not in seed... no seeds included")
if (seedonly) {
stop()
} else {
addseed <- FALSE
}
}
sselectvars <- unique(c(selectvars, tsumvar, tdomvar, tdomvar2))
}
## CHECK TPA and tsumvars
###########################################################
TPA <- pcheck.logical(TPA, varnm="TPA", title="Calculate TPA?", first="NO",
stopifnull=TRUE, gui=gui)
if (TPA) {
if (tsumvar %in% mortvars) {
if (!"TPAMORT_UNADJ" %in% treenames) {
stop("must have TPAMORT_UNADJ variable in tree table to calculate trees per acre")
}
tpavar <- "TPAMORT_UNADJ"
} else if (any(tsumvar %in% growvars)) {
if (!"TPAGROW_UNADJ" %in% treenames) {
stop("must have TPAGROW_UNADJ variable in tree table to calculate trees per acre")
}
tpavar <- "TPAGROW_UNADJ"
} else if (tsumvar %in% remvars) {
if (!"TPAREMV_UNADJ" %in% treenames) {
stop("must have TPAREMV_UNADJ variable in tree table to calculate trees per acre")
}
tpavar <- "TPAREMV_UNADJ"
} else {
if (!"TPA_UNADJ" %in% treenames) {
stop("must have TPA_UNADJ variable in tree table to calculate trees per acre")
}
tpavar <- "TPA_UNADJ"
}
tselectvars <- unique(c(tselectvars, tpavar))
if (addseed || seedonly) {
sselectvars <- unique(c(sselectvars, "TPA_UNADJ"))
}
}
## CHECK getadjplot and adjtree
###########################################################
getadjplot <- pcheck.logical(getadjplot, varnm="getadjplot",
title="Get plot adjustment?", first="NO", gui=gui)
## Check adjtree
adjtree <- pcheck.logical(adjtree, varnm="adjtree", title="Adjust trees",
first="NO", gui=gui)
if (is.null(adjtree)) adjtree <- FALSE
if (getadjplot && !adjtree) {
message("getadjplot=TRUE, and adjtree=FALSE... setting adjtree=TRUE")
adjtree <- TRUE
}
if (adjtree && !getadjplot) {
if (!adjvar %in% treenames) {
message(adjvar, " variable not in tree table... setting getadjplot=TRUE")
getadjplot <- TRUE
} else {
tselectvars <- unique(c(tselectvars, adjvar))
}
if (addseed || seedonly) {
if (!adjvar %in% seednames) {
message(adjvar, " variable not in seed table... setting getadjplot=TRUE")
if (seedonly) getadjplot <- TRUE
} else {
sselectvars <- unique(c(sselectvars, adjvar))
}
}
}
#####################################################################
## Get tree data
#####################################################################
tree.qry <- paste("SELECT", toString(tselectvars),
tfromqry)
if (!is.null(twhereqry)) {
tree.qry <- paste(tree.qry, twhereqry)
}
#message(tree.qry)
treex <- setDT(sqldf::sqldf(tree.qry, dbname=dbname))
setkeyv(treex, tsumuniqueid)
if (addseed) {
seed.qry <- paste("SELECT", toString(sselectvars),
sfromqry)
if (!is.null(swhereqry)) {
seed.qry <- paste(seed.qry, swhereqry)
}
#message(seed.qry)
seedx <- setDT(sqldf::sqldf(seed.qry, dbname=dbname))
setkeyv(seedx, tsumuniqueid)
}
## Check cond and plot tables
########################################################################
condx <- pcheck.table(cond, gui=gui, tab_dsn=data_dsn, tabnm="cond",
caption="Condition table?")
if (!is.null(condx)) {
condnames <- names(condx)
nocond <- FALSE
}
pltx <- pcheck.table(plt, gui=gui, tab_dsn=data_dsn, tabnm="plt",
caption="Plot table?")
if (!is.null(pltx)) {
pltnames <- names(pltx)
}
## Check subplot tables
if (bysubp) {
subpcondx <- pcheck.table(subp_cond, tab_dsn=data_dsn, tabnm="subp_cond",
gui=gui, caption="Subpcond table?")
if (!is.null(subpcondx)) {
subpcnames <- names(subpcondx)
}
subplotx <- pcheck.table(subplot, tab_dsn=data_dsn, tabnm="subplot",
gui=gui, caption="Subplot table?")
if (!is.null(subplotx)) {
subpnames <- names(subplotx)
}
}
## Check if have correct data for adjusting plots
##########################################################################
if (getadjplot) {
if (bysubp) {
if (sum(is.null(subpcondx), is.null(condx)) < 3) {
if (sum(is.null(subpcondx), is.null(condx)) == 2) {
stop("must include subp_cond and cond to adjust to plot")
} else if (is.null(condx)) {
stop("must include cond to adjust to plot")
} else if (is.null(subpcondx)) {
stop("must include subp_cond to adjust to plot")
}
}
} else {
if (is.null(condx)) {
stop("must include cond to adjust to plot")
}
}
}
## Check uniqueids
##########################################################################
if (!is.null(condx)) {
if (!cuniqueid %in% condnames) {
stop(cuniqueid, " not in cond")
}
if (bycond) {
if (!condid %in% condnames) {
if (!nocond) {
condx[[condid]] <- 1
} else {
stop("bycond=TRUE but ", condid, " is not in cond")
}
}
tjoinid <- c(tuniqueid, condid)
cjoinid <- c(cuniqueid, condid)
} else {
tjoinid <- tuniqueid
cjoinid <- cuniqueid
}
## Check if class of tuniqueid matches class of cuniqueid
tabs <- check.matchclass(treex, condx, tjoinid, cjoinid)
treex <- tabs$tab1
condx <- tabs$tab2
## Check that values of uniqueids in treex are all in uniqueids in condx
treex <- check.matchval(treex, condx, tjoinid, cjoinid,
tab1txt="tree", tab2txt="cond")
if (addseed) {
## Check if class of tuniqueid matches class of cuniqueid
tabs <- check.matchclass(seedx, condx, tjoinid, cjoinid)
seedx <- tabs$tab1
condx <- tabs$tab2
## Check that values of tuniqueid in seedx are all in puniqueid in condx
seedx <- check.matchval(seedx, condx, tjoinid, cjoinid)
}
}
if (bysubp) {
subpuniqueid <- cuniqueid
subpids <- c(subpuniqueid, subpid)
## Check subpids
if (!is.null(subpcondx)) {
if (!all(subpids %in% subpcnames)) {
stop("uniqueids not in subp_cond: ", toString(subpids))
}
setkeyv(subpcondx, subpids)
}
if (!is.null(subplotx)) {
if (!all(subpids %in% subpnames)) {
stop("uniqueids not in subplot: ", toString(subpids))
}
setkeyv(subplotx, subpids)
}
## Set pltx to NULL
pltx <- NULL
}
if (!bycond && !is.null(pltx)) {
noplt <- FALSE
## Remove totally nonsampled plots
if ("sf" %in% class(pltx)) {
pltsp <- TRUE
}
## Check for unique plot records
if (nrow(pltx) > length(unique(pltx[[puniqueid]]))) {
message("plt table has > 1 record per uniqueid... will not be merged to plt.")
noplt <- TRUE
}
## Check if class of tuniqueid matches class of puniqueid
tabs <- check.matchclass(treex, pltx, tuniqueid, puniqueid)
treex <- tabs$tab1
pltx <- tabs$tab2
## Check that the values of tuniqueid in treex are all in puniqueid in pltx
treex <- check.matchval(treex, pltx, tuniqueid, puniqueid)
if (addseed) {
## Check if class of tuniqueid matches class of puniqueid
tabs <- check.matchclass(seedx, pltx, tuniqueid, puniqueid)
seedx <- tabs$tab1
pltx <- tabs$tab2
## Check that the values of tuniqueid in seedx are all in puniqueid in pltx
check.matchval(seedx, pltx, tuniqueid, puniqueid)
}
}
## Check FIAname
##########################################################################
FIAname <- pcheck.logical(FIAname, varnm="FIAname", title="FIA name?",
first="NO", gui=gui, stopifnull=TRUE)
if (!any(c(tdomvar, tdomvar2) %in% c("SPCD", "SPGRPCD")) && FIAname) {
message("FIAname is only available for tdomains in(SPCD, SPGRPCD)")
FIAname <- FALSE
}
## Check spcd_name
##########################################################################
if (FIAname && any(c(tdomvar, tdomvar2) == "SPCD")) {
spcd_namelst <- c("COMMON", "SCIENTIFIC", "SYMBOL")
spcd_name <- pcheck.varchar(var2check=spcd_name, varnm="spcd_name",
checklst=spcd_namelst, gui=gui, caption="SPCD name type?")
}
## Check lbs2tons
##########################################################################
if (!addseed) {
lbs2tons <- pcheck.logical(lbs2tons, varnm="lbs2tons", title="Pounds to tons?",
first="YES", gui=gui, stopifnull=TRUE)
}
## Check metric
##########################################################################
metric <- pcheck.logical(metric, varnm="metric", title="Metric?",
first="NO", gui=gui, stopifnull=TRUE)
## Check checkNA
##########################################################################
NAto0 <- pcheck.logical(NAto0, varnm="NAto0", title="Convert NA to 0?",
first="YES", gui=gui)
if (is.null(NAto0)) NAto0 <- FALSE
## Check checkNA
##########################################################################
checkNA <- pcheck.logical(checkNA, varnm="checkNA", title="Check NA values?",
first="YES", gui=gui)
if (is.null(checkNA)) checkNA <- FALSE
## Check ACI. If TRUE, include all trees, If FALSE, filter for forested plots only
## (COND_STATUS_CD = 1)
######################################################################################
ACI <- pcheck.logical(ACI, varnm="ACI", title="Include ACI tree data?",
first="NO", gui=gui)
if (!ACI) {
if (is.null(condx) || (!"COND_STATUS_CD" %in% condnames)) {
message("COND_STATUS_CD not in table, assuming forested plots with no ACI plots")
} else {
cond.ids <- na.omit(condx[COND_STATUS_CD == 1,
do.call(paste, .SD), .SDcols = cjoinid])
if (bycond) {
treex <- treex[paste(get(eval(tuniqueid)), get(eval(condid))) %in% cond.ids]
} else {
treex <- treex[get(eval(tuniqueid)) %in% cond.ids]
}
}
}
## Check for NA values in necessary variables in all tables
###########################################################################
if (checkNA && !seedonly) {
treex.na <- sapply(checkNAtvars,
function(x, treex){ sum(is.na(treex[,x, with=FALSE])) }, treex)
if (any(treex.na) > 0) {
stop(treex.na[treex.na > 0], " NA values in tree variable: ",
paste(names(treex.na[treex.na > 0]), collapse=", "))
}
condx.na <- sapply(checkNAcvars,
function(x, condx){ sum(is.na(condx[,x, with=FALSE])) }, condx)
if (any(condx.na) > 0) {
stop(condx.na[condx.na > 0], " NA values in cond variable: ",
paste(names(condx.na[condx.na > 0]), collapse=", "))
}
pltx.na <- sapply(checkNApvars,
function(x, pltx){ sum(is.na(pltx[,x, with=FALSE])) }, pltx)
if (any(pltx.na) > 0) {
stop(pltx.na[pltx.na > 0], " NA values in plt variable: ",
paste(names(pltx.na[condx.na > 0]), collapse=", "))
}
}
## If tsumvar is a TPA* variable, add a variable, COUNT=1 to tree table
###########################################################################
if (tsumvar %in% tpavars) {
tpavar <- tsumvar
tsumvar <- "COUNT"
treex[, COUNT := 1]
if (addseed || seedonly) {
seedx[, COUNT := 1]
}
}
## Convert variables from pound to tons if lbs2tons=TRUE
###########################################################################
if (lbs2tons && tsumvar %in% vars2convert) {
convfac <- ifelse(metric, 0.00045359237, 0.0005)
message("converting from pounds to tons")
treex[[tsumvar]] <- treex[[tsumvar]] * convfac
}
## Convert to metric
###########################################################################
if (tsumvar != "COUNT") {
if (tsumvar %in% ref_estvar$ESTVAR) {
tunits <- unique(ref_estvar$ESTUNITS[ref_estvar$ESTVAR == tsumvar])
} else {
if (metric) {
message(tsumvar, " not in ref_estvar... no metric conversion")
metric <- FALSE
} else {
message(tsumvar, " not in ref_estvar... no units found")
}
}
if (metric) {
metricunits <- ref_units$METRICUNITS[ref_units$ESTVAR == tsumvar]
if (tunits != metricunits) {
convfac <- ref_conversion$CONVERSION[ref_conversion$METRIC ==
metricunits]
tsumvarm <- paste0(tsumvar, "_m")
treex[, (tsumvarm) := get(eval(tsumvar)) * convfac]
tunits <- metricunits
tsumvar <- tsumvarm
}
}
}
## CHECK adjTPA
###########################################################################
if (TPA) {
## Check adjTPA and adjust TPA (default = 1)
## (e.g., if adjTPA=4 (only 1 subplot measured), multiply TPA* by 4)
if (is.null(adjTPA)) {
message("adjTPA is invalid, assuming no adjustments")
adjTPA <- 1
} else if (!is.numeric(adjTPA)) {
stop("adjTPA must be a numeric number from 1 to 4")
} else if (!adjTPA %in% 1:4) {
stop("adjTPA must be between 1 and 4")
} else if (adjTPA > 1) {
if ("SUBP" %in% treenames) {
if (adjTPA == 2 && any(treex[, unique(SUBP), by=tuniqueid][[2]] > 3)) {
stop("more than 3 SUBP in dataset")
} else if (adjTPA == 3 && any(treex[, unique(SUBP), by=tuniqueid][[2]] > 2)) {
stop("more than 2 SUBP in dataset")
} else if (adjTPA == 4 && any(treex[, unique(SUBP), by=tuniqueid][[2]] > 1)) {
stop("more than 1 SUBP in dataset")
}
} else {
message("assuming less than 3 SUBP in dataset")
}
}
## If metric, convert tpavar to trees per hectare
if (metric) {
tpa.m <- paste0(tpavar, "_m")
treex[, (tpa.m) := get(eval(tpavar)) * 1 / 0.40468564]
tpavar <- tpa.m
}
}
### Get tfun used for aggregation
###########################################################################
tfunlst <- c("sum", "mean", "max", "min", "length", "median")
if (tsumvar == tuniqueid) tfun <- length
if (is.null(tfun)) {
if (gui) {
tfunstr <- select.list(tfunlst, title="Aggregate function", multiple=FALSE)
if (tfunstr == "") stop("")
tfun <- get(tfunstr)
} else {
tfun <- sum
}
}
if (!is.function(tfun)) {
stop("tfun is not a function")
} else {
if(tuniqueid %in% tsumvar & !identical(tfun, sum))
stop("use sum with PLT_CN for getting number of trees.")
if (length(grep("mean", deparse(tfun))) > 0) {
tfunstr <- "mean"
} else {
tfunnm <- noquote(strsplit(deparse(tfun), ".Primitive")[[1]][2])
if (is.na(tfunnm))
tfunnm <- noquote(strsplit(deparse(tfun), "UseMethod"))[[2]][2]
if (is.na(tfunnm)) {
warning("unknown function")
tfunstr <- "fun"
} else {
tfunstr <- substr(tfunnm, 3, nchar(tfunnm)-2)
}
}
}
## Get tdomvarlst and/or check if all tdomvarlst are in tdomvar values.
###########################################################################
if (is.factor(treex[[tdomvar]])) {
tdoms <- levels(treex[[tdomvar]])[levels(treex[[tdomvar]]) %in% unique(treex[[tdomvar]])]
} else {
tdoms <- sort(unique(treex[[tdomvar]]))
}
## check seed table
if (addseed) {
if (tdomvar == "DIACL") {
if ("DIACL" %in% seednames) {
seedx$DIACL <- seedclnm
}
}
}
nbrtdoms <- length(tdoms)
if (is.null(tdomvarlst)) {
## get tdomvarlst
if (gui) {
tdomvarlst <- select.list(as.character(tdoms), title="Tree domains?", multiple=TRUE)
if (length(tdomvarlst) == 0) stop("")
if (is.numeric(tdoms)) tdomvarlst <- as.numeric(tdomvarlst)
} else {
tdomvarlst <- tdoms
}
} else {
if (any(!tdomvarlst %in% unique(treex[[tdomvar]]))) {
tdom.miss <- tdomvarlst[which(!tdomvarlst %in% unique(treex[,get(tdomvar)]))]
tdom.miss <- tdomvarlst[!tdomvarlst %in% unique(treex[[tdomvar]])]
if (length(tdom.miss) == 1 && addseed && tdom.miss == seedclnm) {
tdom.miss <- NULL
}
if (!is.null(tdom.miss) || length(tdom.miss) > 0) {
message("tdomvarlst domain values not in tree table: ", toString(tdom.miss))
}
if (gui) {
tdomvarlst <- select.list(as.character(tdoms), title="Tree domain(s)",
multiple=TRUE)
}
if (length(tdomvarlst) == 0) {
stop("")
}
if (is.numeric(tdoms)) {
tdomvarlst <- as.numeric(tdomvarlst)
}
}
treex <- treex[treex[[tdomvar]] %in% tdomvarlst,]
if (addseed) {
if (tdomvar == "DIACL") {
seedx <- seedx[seedx[[tdomvar]] %in% seedclnm,]
} else {
seedx <- seedx[seedx[[tdomvar]] %in% tdomvarlst,]
}
}
}
## Check if want to include totals (tdomtot) and check for a totals name
## Check tdomtot
tdomtot <- pcheck.logical(tdomtot, varnm="tdomtot", "Total for domains?",
first="NO", gui=gui)
## Check tdomtotnm
if (tdomtot) {
if (!is.null(tdomtotnm) & !is.character(tdomtotnm)) {
warning("tdomtotnm is not valid... using default")
}
}
## GETS name for tdomvar
#####################################################################
## If tdomvar2 exists, concatenate the columns to one column (if pivot=TRUE)
## treex is the tree table after filtered tree domains
flag <- ifelse(NAto0, "0", "")
if (FIAname) {
if (tdomvar == "SPCD") {
tdomdata <- datLUTspp(x=treex, spcdname=spcd_name)
ref_spcd <- tdomdata$ref_spcd
} else {
tdomdata <- datLUTnm(treex, xvar=tdomvar, LUTvar="VALUE", FIAname=TRUE)
}
treex <- tdomdata$xLUT
tdomvarnm <- tdomdata$xLUTnm
setkeyv(treex, tsumuniqueid)
tdomvarlut <- unique(treex[,c(tdomvar, tdomvarnm), with=FALSE])
if (addseed || seedonly) {
sdomdata <- datLUTnm(seedx, xvar=tdomvar, LUTvar="VALUE", FIAname=TRUE)
seedx <- sdomdata$xLUT
}
tdomvarlst2 <- tdomvarlut[match(tdomvarlst, tdomvarlut[[tdomvar]]),
tdomvarnm, with=FALSE][[1]]
} else if (is.numeric(treex[[tdomvar]]) && !is.null(tdomprefix)) {
tdomvarnm <- paste0(tdomvar, "NM")
maxchar <- max(sapply(tdomvarlst, function(x) {nchar(x)}))
treex[, (tdomvarnm):= paste0(tdomprefix, formatC(get(eval(tdomvar)),
width=maxchar, flag=flag))]
tdomvarlst2 <- paste0(tdomprefix, formatC(tdomvarlst, width=maxchar, flag=flag))
#treex[, (tdomvarnm) := paste0(tdomprefix, get(eval(tdomvar)))]
#tdomvarlst2 <- paste0(tdomprefix, tdomvarlst)
if (addseed) {
seedx[, (tdomvarnm):= paste0(tdomprefix, formatC(get(eval(tdomvar)),
width=maxchar, flag=flag))]
}
#tdomvarlut <- data.frame(tdomvarlst, tdomvarlst2, stringsAsFactors=FALSE)
#names(tdomvarlut) <- c(tdomvar, tdomvarnm)
} else {
tdomvarnm <- tdomvar
#tdomvarlut <- data.frame(tdomvarlst, stringsAsFactors=FALSE)
#names(tdomvarlut) <- tdomvarnm
tdomvarlst2 <- as.character(tdomvarlst)
}
## GET tdomvarlst2 or CHECK IF ALL tree domains IN tdomvar2lst ARE INCLUDED IN tdomvar2.
if (!is.null(tdomvar2)) {
tdoms2 <- sort(unique(treex[[tdomvar2]]))
## check seed table
if (addseed) {
if (tdomvar2 == "DIACL") {
if ("DIACL" %in% seednames) {
seedx$DIACL <- seedclnm
}
}
}
if (is.null(tdomvar2lst)) {
## GET tdomvar2lst
if (gui) {
tdomvar2lst <- select.list(as.character(tdoms2), title="Tree domains?", multiple=TRUE)
if (length(tdomvar2lst) == 0) stop("")
if (is.numeric(tdoms2)) tdomvar2lst <- as.numeric(tdomvar2lst)
}else{
tdomvar2lst <- tdoms2
}
} else {
if (any(!tdomvar2lst %in% unique(treex[[tdomvar2]]))) {
tdom.miss <- tdomvar2lst[!tdomvar2lst %in% unique(treex[[tdomvar2]])]
if (length(tdom.miss) == 1 && addseed && tdom.miss == seedclnm) {
tdom.miss <- NULL
}
if (!is.null(tdom.miss) || length(tdom.miss) > 0) {
message("tdomvar2lst domain values not in tree table: ", toString(tdom.miss))
}
if (gui) {
tdomvar2lst <- select.list(as.character(tdoms2), title="Tree domain(s)",
multiple=TRUE)
}
if (length(tdomvar2lst) == 0) {
stop("")
}
if (is.numeric(tdoms2)) {
tdomvar2lst <- as.numeric(tdomvar2lst)
}
}
}
if (!is.null(tdomvar2)) {
treex <- treex[treex[[tdomvar2]] %in% tdomvar2lst,]
if (FIAname) {
if (tdomvar2 == "SPCD") {
tdomdata <- datLUTspp(x=treex, spcdname=spcd_name)
ref_spcd <- tdomdata$ref_spcd
} else {
tdomdata <- datLUTnm(treex, xvar=tdomvar2, LUTvar="VALUE", FIAname=TRUE)
}
treex <- tdomdata$xLUT
tdomvar2nm <- tdomdata$xLUTnm
if (addseed) {
sdomdata <- datLUTnm(seedx, xvar=tdomvar2, LUTvar="VALUE", FIAname=TRUE)
seedx <- sdomdata$xLUT
}
}
if (is.numeric(treex[[tdomvar2]])) {
maxchar2 <- max(sapply(tdomvar2lst, function(x) {nchar(x)}))
treex[, (tdomvarnm) := paste0(treex[[tdomvarnm]], "#",
formatC(treex[[tdomvar2]], width=maxchar2, flag=flag))]
if (addseed) {
seedx[, (tdomvarnm) := paste0(seedx[[tdomvarnm]], "#",
formatC(seedx[[tdomvar2]], width=maxchar2, flag=flag))]
}
} else {
treex[, (tdomvarnm) := paste0(treex[[tdomvarnm]], "#", treex[[tdomvar2]])]
if (addseed) {
seedx[, (tdomvarnm) := paste0(seedx[[tdomvarnm]], "#", seedx[[tdomvar2]])]
}
}
tdomvarlst2 <- sort(unique(treex[[tdomvarnm]]))
}
#tdomvarlut <- data.frame(unique(treex[, c(tdomvar, tdomvar2, tdomvarnm), with=FALSE]) )
#tdomvarlut <- tdomvarlut[order(tdomvarlut[[tdomvar]], tdomvarlut[[tdomvar2]]), ]
}
## Check pivot
pivot <- pcheck.logical(pivot, varnm="pivot", title="Pivot columns?",
first="NO", gui=gui)
if (!pivot) {
presence=proportion=cover <- FALSE
} else {
## Check presence
presence <- pcheck.logical(presence, varnm="presence", title="Presence only?",
first="NO", gui=gui)
## Check proportion (proportion of all tree domains, values 0-1)
proportion <- pcheck.logical(proportion, varnm="proportion", title="Proportions?",
first="NO", gui=gui)
## Check cover (proportion of LIVE_CANOPY_CVR_PCT per tree domain)
## Note: total of all tree domains will equal LIVE_CANOPY_CVR_PCT for plot/condition
cover <- pcheck.logical(cover, varnm="cover", title="As Cover?",
first="NO", gui=gui)
}
if (cover) {
covervar <- ifelse(bycond, "LIVE_CANOPY_CVR_PCT", "CCLIVEPLT")
if (bycond) {
if (is.null(condx) || !covervar %in% names(condx)) {
warning (paste(covervar, "must be in cond.. not included in output"))
cover <- FALSE
}
} else {
if (is.null(pltx) || !covervar %in% names(pltx)) {
warning (paste(covervar, "must be in plt.. not included in output"))
cover <- FALSE
}
}
proportion <- TRUE
}
## Check tdombarplot
tdombarplot <- pcheck.logical(tdombarplot, varnm="tdombarplot",
title="Barplot of tdomains?", first="NO", gui=gui)
## Check tround
if (is.null(tround) | !is.numeric(tround)) {
warning("tround is invalid.. rounding to 6 digits")
tround <- 4
}
## Check savedata
savedata <- pcheck.logical(savedata, varnm="savedata", title="Save data table?",
first="NO", gui=gui)
## Check output parameters
if (savedata) {
outlst <- pcheck.output(outfolder=outfolder, out_dsn=out_dsn,
out_fmt=out_fmt, outfn.pre=outfn.pre, outfn.date=outfn.date,
overwrite_dsn=overwrite_dsn, overwrite_layer=overwrite_layer,
add_layer=add_layer, append_layer=append_layer, out_conn=dbconn,
dbconnopen=TRUE, gui=gui)
outfolder <- outlst$outfolder
out_dsn <- outlst$out_dsn
out_fmt <- outlst$out_fmt
overwrite_layer <- outlst$overwrite_layer
append_layer <- outlst$append_layer
outfn.date <- outlst$outfn.date
outfn.pre <- outlst$outfn.pre
if (is.null(out_layer)) {
out_layer <- "tdomsum"
}
out_conn = outlst$out_conn
}
################################################################################
################################################################################
### DO WORK
################################################################################
################################################################################
if (getadjplot) {
if (bysubp) {
## Remove nonsampled conditions by subplot and summarize to condition-level
subpcx <- subpsamp(cond = condx,
subp_cond = subpcondx,
subplot = subplotx,
subpuniqueid = subpuniqueid,
subpid = subpid)
## Check if class of tuniqueid matches class of cuniqueid
tabs <- check.matchclass(treex, subpcx, c(tuniqueid, subpid), c(subpuniqueid, subpid))
treex <- tabs$tab1
subpcx <- tabs$tab2
adjfacdata <- getadjfactorPLOT(treex = treex,
seedx = seedx,
condx = subpcx,
tuniqueid = c(tuniqueid, subpid),
cuniqueid = c(subpuniqueid, subpid),
areawt = "CONDPROP_UNADJ")
condx <- adjfacdata$condx
cuniqueid <- c(subpuniqueid, subpid)
varadjlst <- c("ADJ_FACTOR_COND", "ADJ_FACTOR_SUBP", "ADJ_FACTOR_MICR", "ADJ_FACTOR_MACR")
if (any(varadjlst %in% names(condx))) {
varadjlst <- varadjlst[varadjlst %in% names(condx)]
condx[, (varadjlst) := NULL]
}
} else {
## Remove nonsampled plots
if ("COND_STATUS_CD" %in% names(condx)) {
cond.nonsamp.filter <- "COND_STATUS_CD != 5"
nonsampn <- sum(condx$COND_STATUS_CD == 5, na.rm=TRUE)
if (length(nonsampn) > 0) {
message("removing ", nonsampn, " nonsampled forest conditions")
} else {
message("assuming all sampled conditions in cond")
}
} else {
message("assuming all sampled conditions in cond")
}
if (ACI && "NF_COND_STATUS_CD" %in% names(condx)) {
cond.nonsamp.filter.ACI <- "(is.na(NF_COND_STATUS_CD) | NF_COND_STATUS_CD != 5)"
message("removing ", sum(is.na(NF_COND_STATUS_CD) & NF_COND_STATUS_CD == 5, na.rm=TRUE),
" nonsampled nonforest conditions")
if (!is.null(cond.nonsamp.filter))
cond.nonsamp.filter <- paste(cond.nonsamp.filter, "&", cond.nonsamp.filter.ACI)
}
condx <- datFilter(x=condx, xfilter=cond.nonsamp.filter,
title.filter="cond.nonsamp.filter")$xf
adjfacdata <- getadjfactorVOL(treex = treex,
seedx = seedx,
condx = condx,
tuniqueid = tuniqueid,
cuniqueid = cuniqueid,
adj = TRUE)
condx <- adjfacdata$condx
varadjlst <- c("ADJ_FACTOR_COND", "ADJ_FACTOR_SUBP",
"ADJ_FACTOR_MICR", "ADJ_FACTOR_MACR")
if (any(varadjlst %in% names(condx))) {
varadjlst <- varadjlst[varadjlst %in% names(condx)]
condx[, (varadjlst) := NULL]
}
}
treex <- adjfacdata$treex
if (addseed) {
seedx <- adjfacdata$seedx
}
adjtree <- TRUE
}
if (adjtree && !adjvar %in% names(treex)) {
message(adjvar, " variable not in tree table... no adjustment was added")
adjtree <- FALSE
}
if (nrow(treex) == 0) {
stop("no tree exists for your dataset")
return(NULL)
}
## AGGREGATE THE TREE SUM VARIABLE TO PLOT LEVEL USING THE SPECIFIED FUNCTION
if (adjtree) {
newname <- ifelse(TPA, paste0(tsumvar, "_TPA_ADJ"), paste0(tsumvar, "_ADJ"))
if (TPA) {
treex[, (newname) := get(eval(tsumvar)) * get(eval(tpavar)) * get(eval(adjvar))]
} else {
treex[, (newname) := get(eval(tsumvar)) * get(eval(adjvar))]
}
if (!is.null(seedx) && tsumvar == "COUNT") {
seed_newname <- paste0("SEED_", newname)
if (TPA) {
seedx[, (seed_newname) := get(eval(tsumvar)) * get(eval(tpavar)) * get(eval(adjvar))]
} else {
seedx[, (seed_newname) := get(eval(tsumvar)) * get(eval(adjvar))]
}
}
} else {
newname <- ifelse(TPA, paste0(tsumvar, "_TPA"), tsumvar)
if (TPA) {
treex[, (newname) := get(eval(tsumvar)) * get(eval(tpavar))]
} else {
treex[, (newname) := get(eval(tsumvar))]
}
if (!is.null(seedx) && tsumvar == "COUNT") {
seed_newname <- paste0("SEED_", newname)
if (TPA) {
seedx[, (seed_newname) := get(eval(tsumvar)) * get(eval(tpavar))]
} else {
seedx[, (seed_newname) := get(eval(tsumvar)) * TREECOUNT_CALC]
}
}
}
treex <- treex[, unique(c(key(treex), tdomvar, tdomvarnm, newname)), with=FALSE]
## GET NAME FOR SUMMED TREE VARIABLE FOR FILTERED TREE DOMAINS
if (is.null(tdomtotnm) && pivot) {
if (is.null(tdomprefix)) {
tdomtotnm <- paste0(newname, "TOT")
} else {
tdomtotnm <- paste0(tdomprefix, "TOT")
}
}
## GET NAME FOR SUMMED TREE VARIABLE FOR ALL TREE DOMAINS (IF PROPORTION = TRUE)
if (proportion) denomvar <- paste0(newname, "_ALL")
## Sum tree (and seed) by tdomvarnm
#####################################################################
byvars <- unique(c(tsumuniqueid, tdomvar, tdomvarnm))
if (seedonly) {
tdomtreef <- treex[, tfun(.SD, na.rm=TRUE), by=byvars, .SDcols=newname]
setnames(tdomtreef, "V1", newname)
setkeyv(tdomtreef, byvars)
} else {
tdomtreef <- treex[, tfun(.SD, na.rm=TRUE), by=byvars, .SDcols=newname]
setnames(tdomtreef, "V1", newname)
setkeyv(tdomtreef, byvars)
if (addseed) {
seedname <- ifelse(TPA, seed_newname, "TREECOUNT_CALC")
tdomseedf <- seedx[, tfun(.SD, na.rm=TRUE), by=byvars, .SDcols=seed_newname]
setnames(tdomseedf, "V1", seedname)
setkeyv(tdomseedf, byvars)
tdomtreef <- merge(tdomtreef, tdomseedf, by=byvars, all.x=TRUE, all.y=TRUE)
tdomtreef[, (paste0("TREE_", newname)) := get(newname)]
tdomtreef[, (newname) := rowSums(.SD, na.rm=TRUE), .SDcols=c(newname, seedname)]
#tdomtreef[, c(newname, seedname) := NULL]
#setnames(tdomtreef, "tmp", newname)
## Set 0 to NA values
tdomtreef[is.na(tdomtreef)] <- 0
}
}
setkeyv(tdomtreef, tsumuniqueid)
########################################################################
## If pivot=FALSE
########################################################################
if (!pivot) {
tdoms <- tdomtreef
tdomscolstot <- newname
tdomscols <- sort(unique(tdomtreef[[tdomvarnm]]))
tdomtotnm <- newname
if (!is.null(tdomvar2)) {
tdoms <- tdoms[, c(tdomvar, tdomvar2) := tstrsplit(get(tdomvarnm), "#")]
tdomvarnm <- c(tdomvar, tdomvar2)
}
} else {
########################################################################
## If pivot=TRUE, aggregate tree domain data
########################################################################
tdoms <- datPivot(tdomtreef, pvar=newname, xvar=tsumuniqueid,
yvar=tdomvarnm, pvar.round=tround, returnDT=TRUE)
tdoms <- setDT(tdoms)
## check if tree domain in tdomlst.. if not, create column with all 0 values
tdomscols <- colnames(tdoms)[!colnames(tdoms) %in% tsumuniqueid]
UNMATCH <- tdomvarlst2[is.na(match(tdomvarlst2, tdomscols))]
if (length(UNMATCH) > 0) {
tdoms[, (UNMATCH) := 0]
tdomvarlst2 <- c(tdomvarlst2, UNMATCH)
}
## ADD TOTAL OF TREE DOMAINS IN tdomvarlst
if ((tdomtot || proportion || cover)) {
tdomtotnm <- newname
## Sum the total tree domains in tdomvarlst after any filtering by plot
tdoms[, (tdomtotnm) := round(rowSums(.SD, na.rm=TRUE), tround), .SDcols=tdomvarlst2]
tdomscolstot <- c(tdomvarlst2, tdomtotnm)
} else {
tdomscolstot <- tdomvarlst2
}
## Create a table of proportions for each tdom by total by plot
if (proportion) {
tdoms.prop <- tdoms[, lapply(.SD, function(x, tdomtotnm) round(x / get(eval(tdomtotnm))),
tdomtotnm), by=key(tdoms), .SDcols=tdomscolstot]
setcolorder(tdoms.prop, c(key(tdoms.prop), tdomscolstot))
}
## Create a table of presence/absence (1/0) by plot
if (presence) {
tdoms.pres <- tdoms[, lapply(.SD, function(x) x / x), by=key(tdoms),
.SDcols=tdomscolstot]
tdoms.pres[is.na(tdoms.pres)] <- 0
setcolorder(tdoms.pres, c(key(tdoms.pres), tdomscolstot))
}
## GENERATE TREE DOMAIN LOOK-UP TABLE (tdomvarlut)
## get total tsumvar and number of conditions by tdom and add to tdomvarlut
# nvar <- ifelse(bycond, "NBRCONDS", "NBRPLOTS")
# sumnm <- ifelse(is.null(tdomprefix) || tdomprefix=="", paste(tsumvar, "SUM", sep="_"),
# paste(tdomprefix, "SUM", sep = "_"))
#
# sumtdomvar <- sapply(tdoms[, tdomvarlst2, with=FALSE], tfun)
# tdomvarlut[[sumnm]] <- sumtdomvar[match(tdomvarlut[[tdomvarnm]], names(sumtdomvar))]
# tdomvarlut[[nvar]] <- sapply(tdoms[, tdomvarlst2, with=FALSE],
# function(x) sum(x > 0))
}
## Generate tree domain look-up table (tdomvarlut)
nvar <- ifelse(bycond, "NBRCONDS", "NBRPLOTS")
byvars <- unique(c(tdomvar, tdomvarnm))
tdomvarlut <- tdomtreef[, list(sum(get(newname), na.rm=TRUE), .N), by=byvars]
names(tdomvarlut) <- c(byvars, newname, nvar)
if (tdomvar == "SPCD") {
refcol <- ifelse(spcd_name == "COMMON", "COMMON_NAME",
ifelse(spcd_name == "SYMBOL", "SPECIES_SYMBOL",
ifelse(spcd_name == "SCIENTIFIC", "SCIENTIFIC_NAME")))
tdomvarlut <- merge(FIESTAutils::ref_species[, c("SPCD", refcol)],
tdomvarlut, by="SPCD")
} else if (tdomvar == "SPGRPCD") {
ref_spgrpcd <- FIESTAutils::ref_codes[FIESTAutils::ref_codes$VARIABLE == "SPGRPCD", c("VALUE", "MEANING")]
tdomvarlut <- merge(ref_spgrpcd, tdomvarlut, by.x="VALUE", by.y="SPGRPCD")
names(tdomvarlut)[names(tdomvarlut) %in% c("VALUE", "MEANING")] <- c("SPGRPCD", "SPGRPNM")
}
## Generate barplot
if (tdombarplot) {
## Frequency
ylabel <- ifelse(bycond, "Number of Conditions", "Number of Plots")
datBarplot(x=tdomvarlut, xvar=tdomvarnm, yvar=newname, savedata=savedata,
outfolder=outfolder, ylabel=newname)
## Summed variable
datBarplot(x=tdomvarlut, xvar=tdomvarnm, yvar=newname, savedata=savedata,
outfolder=outfolder, ylabel=newname)
}
## Merge to cond or plot
###################################
if (bycond && !nocond) {
## Check for duplicate names
matchnames <- sapply(tdomscolstot, checknm, condnames)
setnames(tdoms, tdomscolstot, matchnames)
## Check if class of cuniqueid matches class of cuniqueid
tabs <- check.matchclass(condx, tdoms, c(cuniqueid, condid))
condx <- tabs$tab1
tdoms <- tabs$tab2
## Merge summed data to cond table
sumtreef <- merge(condx, tdoms, all.x=TRUE, by=c(cuniqueid, condid))
if (NAto0) {
for (col in tdomscolstot) set(sumtreef, which(is.na(sumtreef[[col]])), col, 0)
#sumtreef[is.na(sumtreef)] <- 0
}
## Merge proportion table to cond table
if (proportion) {
sumtreef.prop <- merge(condx, tdoms.prop, all.x=TRUE)
if (NAto0) {
for (col in tdomscolstot) set(sumtreef.prop, which(is.na(sumtreef.prop[[col]])), col, 0)
}
}
## Merge presence table to cond table
if (presence) {
sumtreef.pres <- merge(condx, tdoms.pres, all.x=TRUE)
if (NAto0) {
for (col in tdomscolstot) set(sumtreef.pres, which(is.na(sumtreef.pres[[col]])), col, 0)
}
}
## Create a table of cover (absolute) based on proportion table and live canopy cover for cond
if (cover) {
sumtreef.cov <- copy(sumtreef.prop)
if (NAto0) {
for (col in tdomscolstot) {set(sumtreef.cov, i=NULL, j=col,
value=round(sumtreef.cov[[col]] * sumtreef.cov[[covervar]])) }
}
}
} else if (!noplt) { ## Plot-level
## Check for duplicate names
matchnames <- sapply(tdomscolstot, checknm, names(pltx))
setnames(tdoms, tdomscolstot, matchnames)
## Check if class of cuniqueid matches class of cuniqueid
tabs <- check.matchclass(pltx, tdoms, puniqueid, cuniqueid)
pltx <- tabs$tab1
tdoms <- tabs$tab2
## Merge summed data to plt table
setkeyv(tdoms, tuniqueid)
sumtreef <- merge(pltx, tdoms, by.x=puniqueid, by.y=tuniqueid, all.x=TRUE)
if (NAto0) {
for (col in tdomscolstot) set(sumtreef, which(is.na(sumtreef[[col]])), col, 0)
}
## Merge proportion table to plt table
if (proportion) {
setkeyv(tdoms.prop, tuniqueid)
sumtreef.prop <- merge(pltx, tdoms.prop, by.x=puniqueid, by.y=tuniqueid, all.x=TRUE)
if (NAto0) {
for (col in tdomscolstot) set(sumtreef.prop, which(is.na(sumtreef.prop[[col]])), col, 0)
}
}
## Merge presence table to plt table
if (presence) {
setkeyv(tdoms.pres, tuniqueid)
sumtreef.pres <- merge(pltx, tdoms.pres, by.x=puniqueid, by.y=tuniqueid, all.x=TRUE)
if (NAto0) {
for (col in tdomscolstot) set(sumtreef.pres, which(is.na(sumtreef.pres[[col]])), col, 0)
}
}
## Create a table of cover (absolute) based on proportion table and live canopy cover for plot
if (cover) {
sumtreef.cov <- copy(sumtreef.prop)
if (NAto0) {
for (col in tdomscolstot) {set(sumtreef.cov, i=NULL, j=col,
value=sumtreef.cov[[col]] * sumtreef.cov[[covervar]]) }
}
}
} else {
sumtreef <- tdoms
if (proportion) sumtreef.prop <- tdoms.prop
if (presence) sumtreef.pres <- tdoms.pres
}
if (savedata) {
if (pltsp) {
spExportSpatial(sumtreef,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=out_layer,
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
} else {
datExportData(sumtreef, dbconn = out_conn, dbconnopen = TRUE,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=out_layer,
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
}
if (proportion) {
if (pltsp) {
spExportSpatial(sumtreef.prop,
savedata_opts=list(outfolder=outfolder,
out_fmt=outsp_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_prop"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
} else {
datExportData(sumtreef.prop, dbconn = out_conn, dbconnopen = TRUE,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_prop"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
}
}
if (presence) {
if (pltsp) {
spExportSpatial(sumtreef.pres,
savedata_opts=list(outfolder=outfolder,
out_fmt=outsp_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_pres"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
} else {
datExportData(sumtreef.pres, dbconn = out_conn, dbconnopen = TRUE,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_pres"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
}
}
if (cover) {
if (pltsp) {
spExportSpatial(sumtreef.cov,
savedata_opts=list(outfolder=outfolder,
out_fmt=outsp_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_cov"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
} else {
datExportData(sumtreef.cov, dbconn = out_conn, dbconnopen = TRUE,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_cov"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
}
}
datExportData(tdomvarlut, dbconn = out_conn, dbconnopen = FALSE,
savedata_opts=list(outfolder=outfolder,
out_fmt=out_fmt,
out_dsn=out_dsn,
out_layer=paste0(out_layer, "_lut"),
outfn.pre=outfn.pre,
outfn.date=outfn.date,
overwrite_layer=overwrite_layer,
append_layer=append_layer,
add_layer=TRUE))
# if (parameters) {
# ## OUTPUTS A TEXTFILE OF INPUT PARAMETERS TO OUTFOLDER
# ###########################################################
# outfn.param <- paste(out_layer, "parameters", sep="_")
# outparamfnbase <- paste(outfn.param, format(Sys.time(), "%Y%m%d"), sep="_")
# outparamfn <- fileexistsnm(outfolder, outparamfnbase, "txt")
#
# tdomvarlstout <- addcommas(sapply(tdomvarlst, function(x) paste0("'", x, "'") ))
# tdomvarlst2out <- addcommas(sapply(tdomvar2lst, function(x) paste0("'", x, "'") ))
# strunitvars <- addcommas(sapply(strunitvars, function(x) paste0("'", x, "'") ))
#
# outfile <- file(paste0(outfolder, "/", outparamfn, ".txt"), "w")
# cat( "tree = ", as.character(bquote(tree)), "\n",
# "seed = ", as.character(bquote(seed)), "\n",
# "cond = ", as.character(bquote(cond)), "\n",
# "plt = ", as.character(bquote(plt)), "\n",
# "plt_dsn = \"", plt_dsn, "\"", "\n",
# "tuniqueid = \"", tuniqueid, "\"", "\n",
# "cuniqueid = \"", cuniqueid, "\"", "\n",
# "puniqueid = \"", puniqueid, "\"", "\n",
# "bycond = ", bycond, "\n",
# "condid = \"", condid, "\"", "\n",
# "bysubp = ", bysubp, "\n",
# "subpid = \"", subpid, "\"", "\n",
# "tsumvar = \"", tsumvar, "\"", "\n",
# "TPA = ", TPA, "\n",
# "tfun = ", noquote(tfunstr), "\n",
# "ACI = ", ACI, "\n",
# "tfilter = \"", tfilter, "\"", "\n",
# "lbs2tons = ", lbs2tons, "\n",
# "tdomvar = \"", tdomvar, "\"", "\n",
# "tdomvarlst = c(", tdomvarlstout, ")", "\n",
# "tdomvar2 = \"", tdomvar2, "\"", "\n",
# "tdomvar2lst = c(", tdomvarlst2out, ")", "\n",
# "tdomprefix = \"", tdomprefix, "\"", "\n",
# "tdombarplot = ", tdombarplot, "\n",
# "tdomtot = ", tdomtot, "\n",
# "tdomtotnm = \"", tdomtotnm, "\"", "\n",
# "FIAname = ", FIAname, "\n",
# "addseed = ", addseed, "\n",
# "presence = ", presence, "\n",
# "proportion = ", proportion, "\n",
# "cover = ", cover, "\n",
# "getadjplot = ", getadjplot, "\n",
# "adjtree = ", adjtree, "\n",
# "NAto0 = ", NAto0, "\n",
# "adjTPA = ", adjTPA, "\n",
# "savedata = ", savedata, "\n",
# "outfolder = \"", outfolder, "\"", "\n",
# "out_layer = ", out_layer, "\n",
# "outfn.date = ", outfn.date, "\n",
# "overwrite_dsn = ", overwrite_dsn, "\n",
# "tround = \"", tround, "\"", "\n", "\n",
# file = outfile, sep="")
#
# cat( "tdomdat <- datSumTreeDom(tree=tree, seed=seed, cond=cond, plt=plt,
# plt_dsn=plt_dsn, tuniqueid=tuniqueid, cuniqueid=cuniqueid, puniqueid=puniqueid,
# bycond=bycond, condid=condid, bysubp=bysubp, subpid=subpid, tsumvar=tsumvar,
# TPA=TPA, tfun=tfun, ACI=ACI, tfilter=tfilter, lbs2tons=lbs2tons, tdomvar=tdomvar,
# tdomvarlst=tdomvarlst, tdomvar2=tdomvar2, tdomvar2lst=tdomvar2lst,
# tdomprefix=tdomprefix, tdombarplot=tdombarplot, tdomtot=tdomtot,
# tdomtotnm=tdomtotnm, FIAname=FIAname, addseed=addseed, presence=presence,
# proportion=proportion, cover=cover, getadjplot=getadjplot, adjtree=adjtree,
# NAto0=NAto0, adjTPA=adjTPA, savedata=savedata, outfolder=outfolder,
# out_layer=out_layer, outfn.date=outfn.date, overwrite_dsn=overwrite_dsn, tround=tround)",
# file = outfile, sep="")
# close(outfile)
# }
}
tdomdata <- list()
if (!notdomdat) {
if (returnDT) {
sumtreef <- setDF(sumtreef)
}
tdomdata$tdomdat <- sumtreef
}
if (length(tunits) > 0) {
tdomdata$tunits <- tunits
}
if (proportion) {
if (returnDT) {
sumtreef.prop <- setDF(sumtreef.prop)
}
tdomdata$tdomdat.prop <- sumtreef.prop
}
if (presence) {
if (returnDT) {
sumtreef.pres <- setDF(sumtreef.pres)
}
tdomdata$tdomdat.pres <- setDF(sumtreef.pres)
}
if (cover) {
if (returnDT) {
sumtreef.cov <- setDF(sumtreef.cov)
}
tdomdata$tdomdat.cov <- setDF(sumtreef.cov)
}
if (!notdomdat) tdomdata$tdomvarlut <- tdomvarlut
tdomdata$tdomlst <- tdomscols
if (!is.null(tdomtotnm)) {
tdomdata$tdomtotnm <- tdomtotnm
}
if (any(c(tdomvar, tdomvar2) == "SPCD")) {
tdomdata$ref_spcd <- ref_spcd
}
return(tdomdata)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.