Skip to content

Commit

Permalink
add test of by argument and custom AGGFUN with data.frame results
Browse files Browse the repository at this point in the history
  • Loading branch information
@brownag
brownag committed Oct 11, 2024
1 parent 21c3ad8 commit 9c3b432
Show file tree
Hide file tree
Showing 2 changed files with 85 additions and 51 deletions.
98 changes: 52 additions & 46 deletions R/collapseHz.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -169,58 +169,61 @@ collapseHz <- function(x,
naf <- names(AGGFUN)

# iterate over sets of layers needing aggregation within each matching group
res <- h[gidx, c(list(hzdeptnew = suppressWarnings(min(.SD[[hzd[1]]], na.rm = na.rm)),
hzdepbnew = suppressWarnings(max(.SD[[hzd[2]]], na.rm = na.rm))),

# process numeric depth weighted averages w/ dominant condition otherwise
sapply(colnames(.SD)[!colnames(.SD) %in% c(hzd, naf)],
function(n, top, bottom) {
v <- .SD[[n]]
if (length(v) > 1) {
if (!n %in% ignore_numerics && is.numeric(x)) {

# weighted average by thickness (numerics not in exclusion list)
weighted.mean(v, bottom - top, na.rm = na.rm)

if (sum(gidx) > 0){
res <- h[gidx, c(list(hzdeptnew = suppressWarnings(min(.SD[[hzd[1]]], na.rm = na.rm)),
hzdepbnew = suppressWarnings(max(.SD[[hzd[2]]], na.rm = na.rm))),

# process numeric depth weighted averages w/ dominant condition otherwise
sapply(colnames(.SD)[!colnames(.SD) %in% c(hzd, naf)],
function(n, top, bottom) {
v <- .SD[[n]]
if (length(v) > 1) {
if (!n %in% ignore_numerics && is.numeric(x)) {

# weighted average by thickness (numerics not in exclusion list)
weighted.mean(v, bottom - top, na.rm = na.rm)

} else {
# take thickest value
# v[which.max(bottom - top)[1]]

# take dominant condition (based on sum of thickness)
cond <- aggregate(bottom - top, by = list(as.character(v)), sum, na.rm = na.rm)
cond[[1]][which.max(cond[[2]])[1]]
}
} else {
# take thickest value
# v[which.max(bottom - top)[1]]

# take dominant condition (based on sum of thickness)
cond <- aggregate(bottom - top, by = list(as.character(v)), sum, na.rm = na.rm)
cond[[1]][which.max(cond[[2]])[1]]
v
}
} else {
v
}
},
top = .SD[[hzd[1]]],
bottom = .SD[[hzd[2]]]),

# process custom aggregation functions (may return data.frames)
do.call('c', lapply(colnames(.SD)[colnames(.SD) %in% naf],
function(n, top, bottom) {
out <- AGGFUN[[n]](.SD[[n]], top, bottom)
if (!is.data.frame(out)) {
out <- data.frame(out)
colnames(out) <- n
} else {
colnames(out) <- paste0(n, ".", colnames(out))
}
out
},
top = .SD[[hzd[1]]],
bottom = .SD[[hzd[2]]]))),
by = g[gidx]]
},
top = .SD[[hzd[1]]],
bottom = .SD[[hzd[2]]]),

# process custom aggregation functions (may return data.frames)
do.call('c', lapply(colnames(.SD)[colnames(.SD) %in% naf],
function(n, top, bottom) {
out <- AGGFUN[[n]](.SD[[n]], top, bottom)
if (!is.data.frame(out)) {
out <- data.frame(out)
colnames(out) <- n
} else {
colnames(out) <- paste0(n, ".", colnames(out))
}
out
},
top = .SD[[hzd[1]]],
bottom = .SD[[hzd[2]]]))),
by = g[gidx]]
# remove grouping ID
res$g <- NULL
} else {
res <- h[0, ]
}

# allow for replacing values as well as adding new values with data.frame AGGFUN
test1.idx <- na.omit(match(colnames(res), paste0(naf, ".", naf)))
test2.idx <- na.omit(match(paste0(naf, ".", naf), colnames(res)))
colnames(res)[test2.idx] <- naf[test1.idx]

# remove grouping ID
res$g <- NULL

# determine matches that are only a single layer (no aggregation applied)
res2 <- h[hidx & l, ]
res2$hzdeptnew <- res2[[hzd[1]]]
Expand All @@ -230,12 +233,15 @@ collapseHz <- function(x,

# combine matches
res3 <- data.table::rbindlist(list(res, res2), fill = TRUE)
if (missing(by)){
if (missing(by) && nrow(res3) > 0){
res3[[hzdesgn]] <- labels[p]
}

# combine matches with horizons that did not match
h <- h[-which(g %in% unique(g[l]) | hidx),]
agg.idx <- which(g %in% unique(g[l]) | hidx)
if (length(agg.idx) > 0) {
h <- h[-agg.idx, ]
}
h <- data.table::rbindlist(list(h, res3), fill = TRUE)

# replace depths
Expand Down
38 changes: 33 additions & 5 deletions tests/testthat/test-collapseHz.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,15 +11,43 @@ test_that("collapseHz works", {

# collapse that SPC based on genhz
i <- collapseHz(jacobs2000_gen, hzdesgn = "genhz")

expect_equal(length(jacobs2000), length(i))
expect_equal(nrow(i), 26)
expect_equal(i[7, , .BOTTOM], c(15, 41, 61, 132, 140, 152))

x <- collapseHz(jacobs2000, c(`A` = "^A",
`E` = "E",
`Bt` = "[ABC]+t",
`C` = "^C",
`foo` = "bar"))
i <- collapseHz(jacobs2000_gen, by = "genhz")
expect_equal(length(jacobs2000), length(i))
expect_equal(nrow(i), 26)
expect_equal(i[7, , .BOTTOM], c(15, 41, 61, 132, 140, 152))

a_pattern <- c(`A` = "^A",
`E` = "E",
`Bt` = "[ABC]+t",
`C` = "^C",
`foo` = "bar")
x <- collapseHz(jacobs2000, a_pattern)
expect_equal(length(jacobs2000), length(x))
expect_equal(nrow(x), 29)

m <- collapseHz(jacobs2000,
pattern = a_pattern,
AGGFUN = list(
matrix_color_munsell = function(x, top, bottom) {
thk <- bottom - top
if (length(x) > 1) {
xord <- order(thk, decreasing = TRUE)
data.frame(matrix_color_munsell = paste0(x, collapse = ";"),
n_matrix_color = length(x))
} else {
data.frame(matrix_color_munsell = x,
n_matrix_color = length(x))
}
}
)
)
profile_id(m) <- paste0(profile_id(m), "_collapse_custom")

expect_true(all(c("matrix_color_munsell", "matrix_color_munsell.n_matrix_color") %in% names(m)))
expect_equal(nrow(m), 29)
})

0 comments on commit 9c3b432

Please sign in to comment.