Nothing
context("dice (update to slice)")
data(sp4, package = 'aqp')
depths(sp4) <- id ~ top + bottom
test_that("basic functionality", {
# SPC
s <- dice(sp4)
# as a data.frame
s.d <- dice(sp4, SPC = FALSE)
# did it work?
expect_true(inherits(s, 'SoilProfileCollection'))
expect_true(inherits(s.d, 'data.frame'))
# new metadata columns
expect_true(all(c('sliceID', '.oldTop', '.oldBottom') %in% horizonNames(s)))
expect_true(all(c('sliceID', '.oldTop', '.oldBottom') %in% names(s.d)))
# there should be as many slices as original profiles are deep
# names should be identical
expect_equal(
profileApply(sp4, max),
profileApply(s, nrow)
)
})
test_that("data integrity, default arguments", {
# SPC
s <- dice(sp4, SPC = FALSE)
# values match
# reference horizons
.ref <- horizons(sp4)
# inner join on original hz ID
x <- merge(.ref[, c('hzID', 'Mg')], s[, c('hzID', 'Mg')], by = 'hzID', sort = FALSE, all.x = FALSE)
# sliced == original
expect_equal(x$Mg.x, x$Mg.y)
})
test_that("formula interface", {
# reference
s <- dice(sp4)
# equivalent to `fm = NULL`
s1 <- dice(sp4, fm = ~ .)
expect_equivalent(s, s1)
# LHS
s2 <- dice(sp4, fm = 0:20 ~ .)
# all should be <= 21 slices
expect_true(all(profileApply(s2, nrow) <= 21))
# RHS
s3 <- dice(sp4, fm = ~ Ca)
# all other hz attr should be missing
hz.diff <- setdiff(horizonNames(sp4), horizonNames(s3))
expect_false(
all(
horizonNames(s3) %in% c("name", "K", "Mg", "CEC_7", "ex_Ca_to_Mg", "sand", "silt", "clay", "CF")
)
)
# LHS + RHS
s4 <- dice(sp4, fm = 0:30 ~ Ca + K)
# hz names
expect_false(
all(
horizonNames(s4) %in% c("name", "Mg", "CEC_7", "ex_Ca_to_Mg", "sand", "silt", "clay", "CF")
)
)
expect_true(all(profileApply(s4, nrow) <= 31))
})
.slices <<- 0:30
test_that("formula interface (with non-standard evaluation)", {
d5 <- dice(sp4, .slices ~ Ca + K)
expect_true(inherits(d5, 'SoilProfileCollection'))
})
test_that("discrete slices entirely within SPC", {
# single slice
s <- dice(sp4, fm = 5 ~ Mg, SPC = FALSE)
# NA should be returned for slices within gaps / below profile bottoms
expect_true(nrow(s) == length(sp4))
# reference horizons
.ref <- horizons(sp4)
# inner join on original hz ID
x <- merge(.ref[, c('hzID', 'Mg')], s[, c('hzID', 'Mg')], by = 'hzID', sort = FALSE, all.x = FALSE)
# sliced == original
expect_equal(x$Mg.x, x$Mg.y)
# multiple slices, all within SPC depth interval
.slices <- c(5, 10, 15)
s <- dice(sp4, fm = c(5, 10, 15) ~ Mg, SPC = FALSE)
# NA should be returned for slices within gaps / below profile bottoms
expect_true(nrow(s) == length(sp4) * length(.slices))
# reference horizons
.ref <- horizons(sp4)
# inner join on original hz ID
x <- merge(.ref[, c('hzID', 'Mg')], s[, c('hzID', 'Mg')], by = 'hzID', sort = FALSE, all.x = FALSE)
# sliced == original
expect_equal(x$Mg.x, x$Mg.y)
})
test_that("slices below bottom of profiles or entire collection", {
# single slice, deeper than some profiles
s <- dice(sp4, fm = 25 ~ Mg, SPC = FALSE)
# NA should be returned for slices within gaps / below profile bottoms
# filled horizons will create hzID beyond original sequence
expect_true(nrow(s) == length(sp4))
# there should be 3 NA
expect_true(length(which(is.na(s$Mg))) == 3)
# reference horizons
.ref <- horizons(sp4)
# inner join on original hz ID
x <- merge(s[, c('hzID', 'Mg')], .ref[, c('hzID', 'Mg')], by = 'hzID', sort = FALSE, all.x = TRUE)
# after NA-removal
x <- na.omit(x)
# sliced == original
expect_equal(x$Mg.x, x$Mg.y)
# single slice, deeper than all profiles
s <- dice(sp4, fm = 75 ~ Mg, SPC = FALSE)
# NA should be returned for slices within gaps / below profile bottoms
expect_true(nrow(s) == length(sp4))
# there should be as many NA as profiles in sp4
expect_true(length(which(is.na(s$Mg))) == length(sp4))
# multiple slices, some beyond profile depths
.slices <- c(5, 10, 15, 50, 100)
s <- dice(sp4, fm = c(5, 10, 15, 50, 100) ~ Mg, SPC = FALSE)
# NA should be returned for slices within gaps / below profile bottoms
expect_true(nrow(s) == length(sp4) * length(.slices))
# reference horizons
.ref <- horizons(sp4)
# inner join on original hz ID
x <- merge(s[, c('hzID', 'Mg')], .ref[, c('hzID', 'Mg')], by = 'hzID', sort = FALSE, all.x = TRUE)
# after NA-removal
x <- na.omit(x)
# sliced == original
expect_equal(x$Mg.x, x$Mg.y)
})
test_that("percent missing calculation", {
sp4$K[c(1, 5, 10, 30)] <- NA
sp4$Ca[c(1, 5, 20, 30)] <- NA
sp4$CEC_7[c(30)] <- NA
s <- dice(sp4, fm = ~ Ca + K + CEC_7, pctMissing = TRUE)
# visual check
plotSPC(s, color = 'Ca')
plotSPC(s, color = 'K')
plotSPC(s, color = '.pctMissing')
# new column
expect_true('.pctMissing' %in% horizonNames(s))
# some should be non-zero
expect_true(any(s$.pctMissing > 0) & !all(s$.pctMissing > 0))
# check exact values
# 1st horizon, 2/3 missing
expect_true(all(s[1, ]$.pctMissing[1:3] == 2/3))
# all horizons, 1/3 missing
expect_true(all(s[7, ]$.pctMissing == 1/3))
# last horizon, 100% missing
expect_true(all(s[10, ]$.pctMissing[8:16] == 1))
})
test_that("padding with NA, backwards-compatible with slice", {
# fill = TRUE is implied with formula interface
s <- dice(sp4, fm = 0:80 ~ .)
# all profiles should be the same "depth", including empty (NA) horizons
expect_true(all(profileApply(s, max) == 81))
})
test_that("testing exact values", {
# typical soil profile, no problem horizons
x <- data.frame(
id = 'A',
top = c(0, 10, 15, 20, 40, 50, 100),
bottom = c(10, 15, 20, 40, 50, 100, 165),
p = 1:7
)
# init SPC
depths(x) <- id ~ top + bottom
# dice with defaults
s <- dice(x)
# horizon thickness
thick <- x$bottom - x$top
# check no. contiguous sliced values = horizon thickness
expect_true(all(rle(s$p)$lengths == thick))
# check values within chunks
expect_true(all(rle(s$p)$values == x$p))
# do it again with a formula
s <- dice(x, fm = 0:106 ~ .)
# the last horizon is truncated to 107cm
expect_true(rle(s$p)$lengths[7] == 7)
})
test_that("overlapping horizons", {
# overlapping horizons results in increased number of slices (according to overlapping thickness)
x1 <- horizons(dice(sp4, ~ .))
# create overlap
sp4@horizons[2,]$bottom <- sp4@horizons[2,]$bottom + 12
x2 <- horizons(dice(sp4, ~ .))
# evaluate logic by profile, not horizon
expect_message({ x3 <- horizons(dice(sp4, ~ ., byhz = FALSE)) })
# default case--nothing removed, nothing added
expect_equal(nrow(x1), 331)
# 12cm of overlap
expect_equal(nrow(x2), 331 + 12)
# 1 profile removed due to overlap
expect_equal(nrow(x3), 289)
})
test_that("perfectly overlapping horizons", {
# two overlapping horizons
z <- data.frame(
id = 'SPC',
top = c(0, 25, 25, 50, 75, 100, 100),
bottom = c(25, 50, 50, 75, 100, 125, 125),
property = 1:7
)
depths(z) <- id ~ top + bottom
# formula specified
# single slice within zone of overlapping horizons
d <- dice(z, fm = 30 ~ property , SPC = FALSE)
# two rows, one for each overlapping horizon
expect_equal(nrow(d), 2)
# slices within and beyond zone of overlap
d <- dice(z, fm = 40:54 ~ property , SPC = FALSE)
# 10 slices of hzID 2/3
# 5 slices of hzID 4
tab <- table(d$hzID)
expect_equal(as.vector(tab), c(10, 10, 5))
})
test_that("dropped profile IDs", {
# corrupt depth
sp4$top[5] <- sp4$bottom[5]
# offending horizons removed
expect_message(s <- dice(sp4, byhz = TRUE))
expect_equal(
setdiff(profile_id(sp4), profile_id(s)),
character(0)
)
# offending profiles removed
expect_message(s <- dice(sp4, byhz = FALSE))
# single dropped ID should be present in metadata
expect_equal(
setdiff(profile_id(sp4), profile_id(s)),
metadata(s)$removed.profiles
)
})
test_that("safely handle hzdesgnname", {
# hzdesgnname is not set
d <- dice(sp4, ~ K)
expect_equal(hzdesgnname(d), '')
# init hzname
hzdesgnname(sp4) <- 'name'
# hzdesgnname is not set
d <- dice(sp4, ~ K)
expect_equal(hzdesgnname(d), 'name')
# hzdesgnname retained
d <- dice(sp4, ~ .)
expect_equal(hzdesgnname(d), 'name')
# hzdesgnname retained
d <- dice(sp4, ~ name + K)
expect_equal(hzdesgnname(d), 'name')
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.