areaHelper1 <- function(x, plts, db, grpBy, byPlot){
## Selecting the plots for one county
db$PLOT <- plts[[x]]
## Carrying out filter across all tables
#db <- clipFIA(db, mostRecent = FALSE)
## Which grpByNames are in which table? Helps us subset below
grpP <- names(db$PLOT)[names(db$PLOT) %in% grpBy]
grpC <- names(db$COND)[names(db$COND) %in% grpBy & names(db$COND) %in% grpP == FALSE]
grpT <- names(db$TREE)[names(db$TREE) %in% grpBy & names(db$TREE) %in% c(grpP, grpC) == FALSE]
### Only joining tables necessary to produce plot level estimates, adjusted for non-response
data <- db$PLOT %>%
left_join(db$COND, by = c('PLT_CN')) %>%
left_join(db$TREE, by = c('PLT_CN', 'CONDID'))
## Comprehensive indicator function
data$aDI <- data$landD * data$aD_p * data$aD_c * data$sp
if (byPlot){
grpBy <- c('YEAR', grpBy, 'PLOT_STATUS_CD')
t <- data %>%
mutate(YEAR = INVYR) %>%
distinct(PLT_CN, CONDID, .keep_all = TRUE) %>%
group_by(.dots = grpBy, PLT_CN, CONDID) %>%
summarize(CONDPROP_UNADJ = first(CONDPROP_UNADJ),
aDI = first(aDI)) %>%
group_by(.dots = grpBy, PLT_CN) %>%
summarize(PERC_AREA = sum(CONDPROP_UNADJ * aDI, na.rm = TRUE),
nCond = sum(aDI > 0, na.rm = TRUE))
} else {
### Plot-level estimates
t <- data %>%
## Will be lots of trees here, so CONDPROP listed multiple times
## Adding PROP_BASIS so we can handle adjustment factors at strata level
distinct(PLT_CN, CONDID, .keep_all = TRUE) %>%
group_by(PLT_CN, PROP_BASIS, .dots = grpBy) %>%
summarize(fa = sum(CONDPROP_UNADJ * aDI, na.rm = TRUE),
plotIn = ifelse(sum(aDI > 0, na.rm = TRUE), 1,0))
}
pltOut <- list(t = t)
return(pltOut)
}
areaHelper2 <- function(x, popState, t, grpBy, method){
## DOES NOT MODIFY OUTSIDE ENVIRONMENT
if (str_to_upper(method) %in% c("SMA", 'EMA', 'LMA', 'ANNUAL')) {
grpBy <- c(grpBy, 'INVYR')
#aGrpBy <- c(aGrpBy, 'INVYR')
popState[[x]]$P2POINTCNT <- popState[[x]]$P2POINTCNT_INVYR
popState[[x]]$p2eu <- popState[[x]]$p2eu_INVYR
}
## Strata level estimates
tEst <- t %>%
## Rejoin with population tables
right_join(select(popState[[x]], -c(STATECD)), by = 'PLT_CN') %>%
mutate(
## AREA
aAdj = case_when(
## When NA, stay NA
is.na(PROP_BASIS) ~ NA_real_,
## If the proportion was measured for a macroplot,
## use the macroplot value
PROP_BASIS == 'MACR' ~ as.numeric(ADJ_FACTOR_MACR),
## Otherwise, use the subpplot value
PROP_BASIS == 'SUBP' ~ ADJ_FACTOR_SUBP),
fa = fa * aAdj) %>%
group_by(ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN, .dots = grpBy) %>%
summarize(a_t = length(unique(PLT_CN)) / first(P2POINTCNT),
aStrat = mean(fa * a_t, na.rm = TRUE),
plotIn_AREA = sum(plotIn, na.rm = TRUE),
n = n(),
## We don't want a vector of these values, since they are repeated
nh = first(P2POINTCNT),
a = first(AREA_USED),
w = first(P1POINTCNT) / first(P1PNTCNT_EU),
p2eu = first(p2eu),
ndif = nh - n,
# ## Strata level variances
av = stratVar(ESTN_METHOD, fa, aStrat, ndif, a, nh)) %>%
## Estimation unit
group_by(ESTN_UNIT_CN, .dots = grpBy) %>%
summarize(aEst = unitMean(ESTN_METHOD, a, nh, w, aStrat),
aVar = unitVarNew(method = 'var', ESTN_METHOD, a, nh, first(p2eu), w, av, aStrat, aEst),
N = first(p2eu),
plotIn_AREA = sum(plotIn_AREA, na.rm = TRUE))
out <- list(tEst = tEst)
return(out)
}
areaHelper <- function(x, combos, data, grpBy, totals, SE){
# Update domain indicator for each each column speficed in grpBy
td = 1 # Start both at 1, update as we iterate through
ad = 1
for (n in 1:ncol(combos[[x]])){
# Tree domain indicator for each column in
tObs <- as.character(combos[[x]][[grpBy[n]]]) == as.character(data[[grpBy[n]]])
if (length(which(is.na(tObs))) == length(tObs)) tObs <- 1
td <- data$aDI * tObs * td
}
if(SE){
data$aDI <- td
data$aDI[is.na(data$aDI)] <- 0
# Compute estimates
a <- data %>%
group_by(ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN, PLT_CN, CONDID) %>%
summarize(CONDPROP_UNADJ = first(CONDPROP_UNADJ),
aDI = ifelse(sum(aDI > 0, na.rm = TRUE), 1, 0),
a = first(AREA_USED),
p1EU = first(P1PNTCNT_EU),
p1 = first(P1POINTCNT),
p2 = first(P2POINTCNT),
aAdj = first(aAdj)) %>%
group_by(ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN, PLT_CN) %>%
summarize(fa = sum(CONDPROP_UNADJ * aDI * aAdj, na.rm = TRUE),
plotIn = ifelse(sum(aDI > 0, na.rm = TRUE), 1,0),
p1EU = first(p1EU),
a = first(a),
p1 = first(p1),
p2 = first(p2)) %>%
# Continue through totals
group_by(ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN) %>%
summarize(aStrat = mean(fa, na.rm = TRUE),
plotIn = sum(plotIn, na.rm = TRUE),
a = first(a),
w = first(p1) / first(p1EU), # Stratum weight
nh = first(p2), # Number plots in stratum
# Strata level variances
av = ifelse(first(ESTN_METHOD == 'simple'),
var(fa * first(a) / nh),
(sum(fa^2, na.rm = TRUE) - sum(nh * aStrat^2, na.rm = TRUE)) / (nh * (nh-1)))) %>% # Stratified and double cases) %>% # Stratified and double cases
group_by(ESTN_UNIT_CN) %>%
summarize(aEst = unitMean(ESTN_METHOD, a, nh, w, aStrat),
plotIn = sum(plotIn, na.rm = TRUE),
# Estimation of unit variance,
aVar = unitVar(method = 'var', ESTN_METHOD, a, nh, w, av, aStrat, aEst)) %>%
# Compute totals
summarize(AREA = sum(aEst, na.rm = TRUE),
nPlots = sum(plotIn, na.rm = TRUE),
areaVar = sum(aVar, na.rm = TRUE),
AREA_SE = ifelse(nPlots > 1, sqrt(areaVar) / AREA * 100,0)) %>%
select(AREA, AREA_SE, nPlots)
# Rejoin with some grpBy Names
a <- data.frame(combos[[x]], a)
} else { # No sampling errors
### BELOW DOES NOT PRODUCE SAMPLING ERRORS, use EXPNS instead (much quicker)
# Compute estimates
a <- data %>%
group_by(.dots = grpBy, ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN, EXPNS, PLT_CN, CONDID) %>%
summarize(CONDPROP_UNADJ = first(CONDPROP_UNADJ),
aDI = ifelse(sum(aDI > 0, na.rm = TRUE), 1, 0),
a = first(AREA_USED),
p1EU = first(P1PNTCNT_EU),
p1 = first(P1POINTCNT),
p2 = first(P2POINTCNT),
aAdj = first(aAdj)) %>%
group_by(.dots = grpBy, ESTN_UNIT_CN, ESTN_METHOD, STRATUM_CN, PLT_CN) %>%
summarize(fa = sum(CONDPROP_UNADJ * aDI * aAdj * EXPNS, na.rm = TRUE),
plotIn = ifelse(sum(aDI > 0, na.rm = TRUE), 1,0)) %>%
group_by(.dots = grpBy) %>%
summarize(AREA = sum(fa, na.rm = TRUE),
nPlots = sum(plotIn, na.rm = TRUE)) %>%
select(grpBy, AREA, nPlots)
} # End SE Conditional
# Some cleanup
#gc()
# Return t
a
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.