Merge branch 'master' of https://github.com/USDAForestService/FIESTA

USDAForestService · May 24, 2024 · b4f022a · b4f022a
2 parents 614ce0e + 3af481b
commit b4f022a
Show file tree

Hide file tree

Showing 4 changed files with 65 additions and 24 deletions.
diff --git a/R/modSAarea.R b/R/modSAarea.R
@@ -512,7 +512,7 @@ modSAarea <- function(SApopdatlst = NULL,
   }
 
 
-  largebnd.unique2 <- largebnd.unique
+  #largebnd.unique2 <- largebnd.unique
 
   ## Loop through SApopdatlst
   for (i in 1:length(SApopdatlst)) {
@@ -544,6 +544,8 @@ modSAarea <- function(SApopdatlst = NULL,
     dunitvar2 <- SApopdat$dunitvar2
     dunitlut <- data.table(SApopdat$dunitlut)
     plotsampcnt <- SApopdat$plotsampcnt
+    pltassgnx <- SApopdat$pltassgnx
+    pltassgnid <- SApopdat$pltassgnid
     condsampcnt <- SApopdat$condsampcnt
     states <- SApopdat$states
     invyrs <- SApopdat$invyrs
@@ -553,7 +555,6 @@ modSAarea <- function(SApopdatlst = NULL,
     pop_fmt <- SApopdat$pop_fmt
     pop_dsn <- SApopdat$pop_dsn
 
-
     ## check smallbnd.dom
     ########################################################
     smallbnd.dom <- dunitvar
@@ -700,41 +701,68 @@ modSAarea <- function(SApopdatlst = NULL,
 
     ## check largebnd.unique
     ########################################################
-    if (!is.null(largebnd.unique2) && !is.null(SAdomsdf)) {
-      cdomdat <- merge(cdomdat, 
-		        unique(setDT(SAdomsdf)[, c(smallbnd.dom, largebnd.unique), with=FALSE]),
- 		        by=smallbnd.dom)
-      #addSAdomsdf <- TRUE
-      #SAdomvars <- unique(c(SAdomvars, largebnd.unique))
-      largebnd.unique <- largebnd.unique2
+
+    vars2keep <- NULL
+    if (!is.null(largebnd.unique)) {
+      if (largebnd.unique %in% names(cdomdat) && largebnd.unique %in% names(pltassgnx)) {
+        cdomdat <- merge(pltassgnx, cdomdat, 
+                         by.x = c(largebnd.unique, pltassgnid, "DOMAIN"), 
+                         by.y = c(largebnd.unique, cuniqueid, "DOMAIN"), , all.x=TRUE)
+      } else if (largebnd.unique %in% names(pltassgnx)) {
+        cdomdat <- merge(pltassgnx, cdomdat, 
+                         by.x = c(pltassgnid, "DOMAIN"), 
+                         by.y = c(cuniqueid, "DOMAIN"), all.x=TRUE)
+      } else if (!is.null(SAdomsdf)) {
+        cdomdat <- merge(cdomdat, 
+                         unique(setDT(SAdomsdf)[, c(smallbnd.dom, largebnd.unique), with=FALSE]),
+                         by=smallbnd.dom)
+      } else {
+        cdomdat$LARGEBND <- 1
+        largebnd.unique <- "LARGEBND"
+      }
     } else {
       cdomdat$LARGEBND <- 1
       largebnd.unique <- "LARGEBND"
-      cdomdat$LARGEBND <- 1
+      cdomdat <- merge(pltassgnx, cdomdat, 
+                       by.x=c(pltassgnid, "DOMAIN"), 
+                       by.y=c(cuniqueid, "DOMAIN"), all.x=TRUE)
+    }
+    if (pltassgnid != cuniqueid) {
+      setnames(cdomdat, pltassgnid, cuniqueid)
     }
-
-    ## get unique largebnd values
-    largebnd.vals <- sort(unique(cdomdat[[largebnd.unique]]))
-    largebnd.vals <- largebnd.vals[table(cdomdat[[largebnd.unique]]) > 30]
 
     ## Add AOI if not in data
     ######################################
     if (!"AOI" %in% names(cdomdat)) {
       cdomdat$AOI <- 1
       dunitlut$AOI <- 1
     }
-
+    # hardcode for now
+    bayes <- FALSE
+    if (bayes) {
+      vars2keep <- largebnd.unique
+      tdomdat$LARGEBND <- 1
+      largebnd.unique <- "LARGEBND"
+      largebnd.vals <- 1
+    }
+
+    byvars <- unique(c(vars2keep, largebnd.unique, dunitvar, "AOI", cuniqueid, "TOTAL", prednames))
+    if (all(c("X", "Y") %in% names(pltassgnx))) {
+      byvars <- c(byvars, "X","Y")
+    }
     ## Get estimate for total
     ######################################
     ## Sum estvar.name by dunitvar (DOMAIN), plot, domain
-    tdomdattot <- setDT(cdomdat)[, lapply(.SD, sum, na.rm=TRUE), 
-                      by=c(largebnd.unique, dunitvar, "AOI", cuniqueid, "TOTAL", prednames), 
-                      .SDcols=estvar.name]
-
+    tdomdattot <- cdomdat[, lapply(.SD, sum, na.rm=TRUE), by=byvars, .SDcols=estvar.name]
+
+    ## get unique largebnd values
+    largebnd.vals <- sort(unique(cdomdat[[largebnd.unique]]))
+    largebnd.vals <- largebnd.vals[table(cdomdat[[largebnd.unique]]) > 30]
+
+
     ## get estimate by domain, by largebnd value
     #message("generating JoSAE unit-level estimates for ", response, " using ", SApackage, "...")
-
-
+
     if (!"DOMAIN" %in% names(tdomdattot)) {
       tdomdattot$DOMAIN <- tdomdattot[[dunitvar]]
       tdomdattot[[dunitvar]] <- NULL
@@ -749,7 +777,6 @@ modSAarea <- function(SApopdatlst = NULL,
 #largebnd.val=largebnd.vals
 #domain="TOTAL"
 #largebnd.unique=largebnd.unique
-
     dunit_totestlst <- 
 	tryCatch(
 		lapply(largebnd.vals, SAest.large, 

diff --git a/R/modSApop.R b/R/modSApop.R
@@ -55,6 +55,9 @@
 #' @param SAdoms sf object. SA domains with attributes for joining.
 #' @param smallbnd sf object. small bound.
 #' @param smallbnd.domain String. Name of attribute defining domain attribute.
+#' @param largebnd.unique String. Name of the large boundary unique identifer
+#' to define plots within a model extent. If NULL, all plots are used for model
+#' extent.
 #' @param pltassgn DF/DT, comma-separated values (CSV) file(*.csv), or layer in
 #' dsn, Can also be a shapefile(*.shp) with one record per plot, a spatial
 #' layer in dsn, or a sf R object. Plot-level assignment of estimation unit

diff --git a/R/modSAtree.R b/R/modSAtree.R
@@ -360,7 +360,7 @@ modSAtree <- function(SApopdatlst = NULL,
   ##################################################################
 
   ## Check SApackage 
-  SApackagelst <- c("JoSAE", "sae", "hbsae")
+  SApackagelst <- c("JoSAE", "sae", "hbsae", "spAbundance")
   SApackage <- pcheck.varchar(var2check=SApackage, varnm="SApackage", gui=gui, 
 		checklst=SApackagelst, caption="SApackage", multiple=FALSE, stopifnull=TRUE)
 
@@ -793,7 +793,11 @@ modSAtree <- function(SApopdatlst = NULL,
     if (pltassgnid != cuniqueid) {
       setnames(tdomdat, pltassgnid, cuniqueid)
     }
-
+    if (SApackage == "spAbundance") {
+      bayes <- TRUE
+    } else {
+      bayes <- FALSE
+    }
     if (bayes) {
       vars2keep <- largebnd.unique
       tdomdat$LARGEBND <- 1
@@ -1095,6 +1099,9 @@ modSAtree <- function(SApopdatlst = NULL,
     } else if (SApackage == "JoSAE") {
       nhat <- "JU.EBLUP"
       nhat.se <- "JU.EBLUP.se.1"
+    } else if (SApackage == "spAbundance") {
+      nhat <- "bayes"
+      nhat.se <- "bayes.se"
     }
   } else if (SAmethod == "area") {
     if (SApackage == "JoSAE") {

diff --git a/man/modSApop.Rd b/man/modSApop.Rd