From 489d2a815c7c49c56453f965da15a20c7358b8e1 Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Fri, 11 Oct 2024 13:11:32 -0700 Subject: [PATCH] fix issue with aggregated colums always returning character + test --- R/collapseHz.R | 77 ++++++++++++++++---------------- tests/testthat/test-collapseHz.R | 11 ++++- 2 files changed, 49 insertions(+), 39 deletions(-) diff --git a/R/collapseHz.R b/R/collapseHz.R index 9492bfc8..868712f9 100644 --- a/R/collapseHz.R +++ b/R/collapseHz.R @@ -192,43 +192,44 @@ collapseHz <- function(x, # 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]] + function(n, top, bottom) { + v <- .SD[[n]] + if (length(v) > 1) { + if (!n %in% ignore_numerics && is.numeric(v)) { + + # weighted average by thickness (numerics not in exclusion list) + v <- 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) + v <- cond[[1]][which.max(cond[[2]])[1]] + } } - } else { - v - } - }, - top = .SD[[hzd[1]]], - bottom = .SD[[hzd[2]]]), + out <- data.frame(v) + colnames(out) <- n + out + }, + 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]]]))), + # 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 @@ -237,9 +238,9 @@ collapseHz <- function(x, } # 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] + test1.idx <- na.omit(match(colnames(res), paste0(colnames(h), ".", colnames(h)))) + test2.idx <- na.omit(match(paste0(colnames(h), ".", colnames(h)), colnames(res))) + colnames(res)[test2.idx] <- colnames(h)[test1.idx] # determine matches that are only a single layer (no aggregation applied) res2 <- h[hidx & l, ] diff --git a/tests/testthat/test-collapseHz.R b/tests/testthat/test-collapseHz.R index 9ec84361..f0ada978 100644 --- a/tests/testthat/test-collapseHz.R +++ b/tests/testthat/test-collapseHz.R @@ -11,15 +11,23 @@ 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)) + # collapses adjacent horizons with same label i <- collapseHz(jacobs2000_gen, by = "genhz") + + # no effect, horizon designations are unique within profiles + j <- collapseHz(jacobs2000_gen, by = "name") + expect_equal(length(jacobs2000), length(i)) expect_equal(nrow(i), 26) + expect_equal(nrow(j), 46) expect_equal(i[7, , .BOTTOM], c(15, 41, 61, 132, 140, 152)) + expect_equal(j[7, , .BOTTOM], jacobs2000[7, , .BOTTOM]) + expect_true(is.numeric(i$clay)) + expect_true(is.numeric(j$clay)) a_pattern <- c(`A` = "^A", `E` = "E", @@ -29,6 +37,7 @@ test_that("collapseHz works", { x <- collapseHz(jacobs2000, a_pattern) expect_equal(length(jacobs2000), length(x)) expect_equal(nrow(x), 29) + expect_true(is.numeric(x$clay)) m <- collapseHz(jacobs2000, pattern = a_pattern,