context("soil depth estimation")
## sample data
d <-
rbind(
data.frame(
id = c(1, 1, 1),
top = c(0, 20, 35),
bottom = c(20, 35, 110),
name = c('A', 'Bt', 'C')
),
data.frame(
id = c(2, 2, 2),
top = c(0, 20, 55),
bottom = c(20, 55, 80),
name = c('A', 'Bt', 'Cr')
),
data.frame(
id = c(3, 3, 3),
top = c(0, 20, 48),
bottom = c(20, 48, 130),
name = c('A', 'Bt', 'Cd')
),
data.frame(
id = c(4, 4),
top = c(0, 20),
bottom = c(20, 180),
name = c('A', 'R')
))
depths(d) <- id ~ top + bottom
hzdesgnname(d) <- "name"
## tests
test_that("error conditions", {
# function will only accept a single profile
expect_error(estimateSoilDepth(d, name='name'))
hzdesgnname(d) <- ""
# not specified -> error
expect_error(profileApply(d, estimateSoilDepth))
# not in horizonNames() -> error
expect_error(profileApply(d, estimateSoilDepth, name='goo'))
})
test_that("basic soil depth evaluation, based on pattern matching of hz designation", {
# setting hz desgn by argument works
res <- profileApply(d, estimateSoilDepth, name = 'name')
expect_equivalent(res, c(110, 55, 48, 20))
# use hzdesgnname(x)
hzdesgnname(d) <- "name"
res <- estimateSoilDepth(d[1,])
expect_equivalent(res, 110)
})
test_that("application of reasonable depth assumption of 150, given threshold of 100", {
res <- profileApply(d, estimateSoilDepth, name = 'name', no.contact.depth=100, no.contact.assigned=150)
expect_equivalent(res, c(150, 55, 48, 20))
})
test_that("depth to feature using REGEX on hzname: [Bt]", {
# example from manual page, NA used when there is no 'Bt' found
res <- profileApply(d, estimateSoilDepth, name = 'name', p = 'Bt', no.contact.depth=0, no.contact.assigned=NA)
expect_equivalent(res, c(20, 20, 20, NA))
})
test_that("depthOf - simple match", {
expect_equal(depthOf(d[1,], "Cr|R|Cd"), NA_real_)
expect_equal(depthOf(d[2,], "Cr|R|Cd"), 55)
expect_equal(minDepthOf(d[2,], "Cr|R|Cd"), 55)
expect_equal(maxDepthOf(d[2,], "Cr|R|Cd"), 55)
expect_equal(maxDepthOf(d[2,], "Cr|R|Cd", top = FALSE), 80)
})
test_that("depthOf - multiple match", {
expect_equal(depthOf(d[1,], "A|B|C"), c(0,20,35))
expect_equal(depthOf(d[1,], "A|B|C", top = FALSE), c(20,35,110))
expect_equal(minDepthOf(d[1,], "A|B|C"), 0)
expect_equal(maxDepthOf(d[1,], "A|B|C"), 35)
expect_equal(minDepthOf(d[1,], "A|B|C", top = FALSE), 20)
expect_equal(maxDepthOf(d[1,], "A|B|C", top = FALSE), 110)
})
test_that("depthOf - no match", {
expect_equal(depthOf(d[1,], "X"), NA_real_)
expect_equal(depthOf(d[2,], "Cr|R|Cd", no.contact.depth = 50), NA_real_)
# multiple SPC return data.frame
expect_true(inherits(depthOf(d, "X"), 'data.frame'))
# one match -- other pedons no match
d$name[1] <- "X"
expect_equal(maxDepthOf(d, "X")$top, c(0, NA_real_, NA_real_, NA_real_))
# two matches, more than one NA depth
d$name[2] <- "X"
d$top[1:2] <- NA
# first profile has two matches; all NA
expect_equal(depthOf(d, "X")$top, c(NA_real_, NA_real_, NA_real_, NA_real_, NA_real_))
# using functional (1 value per profile)
expect_equal(maxDepthOf(d, "X")$top, c(NA_real_, NA_real_, NA_real_, NA_real_))
d2 <- d
d2$name <- NULL
expect_error(depthOf(d2[1,], "A|B|C"))
})
test_that("soil depth class assignment, using USDA-NRCS class breaks", {
res <- getSoilDepthClass(d, name = 'name')
# result should be a data.frame with as many rows as profiles in input
expect_true(inherits(res, 'data.frame'))
expect_equal(nrow(res), length(d))
# depths, should be the same as prior tests using estimateSoilDepth
expect_equivalent(res$depth, c(110, 55, 48, 20))
# depth classes are returned as a factor sorted from shallow -> deep
dc <- factor(c('deep', 'mod.deep', 'shallow', 'very.shallow'), levels=c('very.shallow', 'shallow', 'mod.deep', 'deep', 'very.deep'))
expect_equivalent(res$depth.class, dc)
})
test_that("data.table safety", {
d <-
rbind(
data.frame(
id = c(1, 1, 1),
top = c(0, 20, 35),
bottom = c(20, 35, 110),
name = c('A', 'Bt', 'C')
),
data.frame(
id = c(2, 2, 2),
top = c(0, 20, 55),
bottom = c(20, 55, 80),
name = c('A', 'Bt', 'Cr')
),
data.frame(
id = c(3, 3, 3),
top = c(0, 20, 48),
bottom = c(20, 48, 130),
name = c('A', 'Bt', 'Cd')
),
data.frame(
id = c(4, 4),
top = c(0, 20),
bottom = c(20, 180),
name = c('A', 'R')
))
d <- data.table(d)
depths(d) <- id ~ top + bottom
res <- profileApply(d, estimateSoilDepth, name = 'name', no.contact.depth=100, no.contact.assigned=150)
expect_equivalent(res, c(150, 55, 48, 20))
sdc <- getSoilDepthClass(d, name = 'name', no.contact.depth=100, no.contact.assigned=150)
expect_equivalent(sdc$depth, c(150, 55, 48, 20))
})
test_that("really deep", {
d <-
rbind(
data.frame(
id = c(1, 1, 1),
top = c(0, 20, 35),
bottom = c(20, 35, 2000),
name = c('A', 'Bt', 'C')
))
depths(d) <- id ~ top + bottom
res <- profileApply(d, estimateSoilDepth, name = 'name')
expect_equivalent(res, 2000)
sdc <- getSoilDepthClass(d, name = 'name')
expect_equivalent(sdc$depth, 2000)
expect_equivalent(as.character(sdc$depth.class), 'very.deep')
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.