tests/testthat/test_mpspline.R
In obrl-soil/mpspline2: Mass-Preserving Spline Functions for Soil Data
context('mpspline tests')
test_that("mpspline_conv works for numeric matrices",
c(
obj <- matrix(c( 1, 1, 1, 1, 2, 2, 2, 2,
NA, 20, 40, 60, -1, 45, 15, 80,
10, 30, 50, 70, 5, 60, 30, NA,
6, 4, 3, 10, 0.1, 0.9, 2.5, 6),
ncol = 4, byrow = FALSE),
fixed <- mpspline_conv(obj),
expect_is(fixed, 'data.frame'),
expect_equal(nrow(fixed), 8),
# whoops, site IDs aren't numeric!
obj <- matrix(c("a", "a", "a", 0, 10, 20, 10, 20, 30, 4.5, 6, 7.8),
ncol = 4, byrow = FALSE),
fx <- mpspline_conv(obj),
expect_is(fx, 'data.frame'),
expect_equal(nrow(fx), 3),
expect_is(fx[[2]], 'numeric')
)
)
test_that("mpspline_conv works for data frames",
c(
obj <- data.frame("SID" = c( 1, 1, 1, 1, 2, 2, 2, 2),
"UD" = c(NA, 20, 40, 60, -1, 45, 15, 80),
"LD" = c(10, 30, 50, 70, 5, 60, 30, NA),
"VAL" = c( 6, 4, 3, 10, 0.1, 0.9, 2.5, 6),
stringsAsFactors = FALSE),
fixed <- mpspline_conv(obj),
expect_is(fixed, 'data.frame'),
expect_equal(obj, fixed)
)
)
test_that("mpspline_datchk does what it oughta",
c(
obj <- data.frame("SID" = 1,
"UD" = c(NA, 20, 40, 60),
"LD" = c(10, 30, 50, NA),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
chkd <- mpspline_datchk(obj, 'VAL'),
expect_is(chkd, 'data.frame'),
expect_equal(nrow(chkd), 4),
expect_equal(chkd[[2]][1], 0), # surface fixed
expect_equal(chkd[[3]][4], 70), # last fixed
obj2 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c(-5, 20, 40, 60),
"LD" = c(10, 30, 50, 90),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
chkd2 <- mpspline_datchk(obj2, 'VAL'),
expect_equal(nrow(chkd2), 3), # -ve hor dropped
# some na
onena <- data.frame("SID" = "A",
"UD" = c(0, 30, 60, 90),
"LD" = c(30, 60, 90, NA),
"VAL" = c( 6, 4, 3, NA),
stringsAsFactors = FALSE),
expect_message({res <- mpspline_datchk(onena, 'VAL')}),
expect_equal(nrow(res), nrow(onena) - 1),
expect_equal(mpspline_datchk(onena, 'VAL'), data.frame("SID" = "A",
"UD" = c(0, 30, 60),
"LD" = c(30, 60, 90),
"VAL" = c( 6, 4, 3),
stringsAsFactors = FALSE)),
# all na
allna <- data.frame("SID" = "A",
"UD" = c(0, 30, 60, 90),
"LD" = c(30, 60, 90 ,120),
"VAL" = NA_real_,
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(allna, 'VAL')),
expect_equal(mpspline_datchk(allna, 'VAL'), NA),
# overlap
ols <- data.frame("SID" = "A",
"UD" = c(0, 30, 50, 90),
"LD" = c(30, 60, 100 ,120),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(ols, 'VAL')),
expect_equal(mpspline_datchk(ols, 'VAL'), NA),
# 0-thickness horizon
zthk <- data.frame("SID" = "A",
"UD" = c(0, 30, 50, 90),
"LD" = c(30, 30, 80 ,120),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(zthk, 'VAL')),
expect_equal(mpspline_datchk(zthk, 'VAL'),
data.frame("SID" = "A",
"UD" = c(0, 50, 90),
"LD" = c(30, 80 ,120),
"VAL" = c(1,3,4),
stringsAsFactors = FALSE)),
# bkwrds
bkw <- data.frame("SID" = "A",
"UD" = c(0, 20, 50, 120),
"LD" = c(10, 30, 80 ,90),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(bkw, 'VAL')),
expect_equal(mpspline_datchk(bkw, 'VAL'),
data.frame("SID" = "A",
"UD" = c(0, 20, 50),
"LD" = c(10, 30, 80),
"VAL" = c(1,2,3),
stringsAsFactors = FALSE)),
# single horizon unharmed
sh <- data.frame("SID" = "A",
"UD" = 0,
"LD" = 10,
"VAL" = 4,
stringsAsFactors = FALSE),
chkd <- mpspline_datchk(sh, 'VAL'),
expect_identical(sh, chkd)
)
)
test_that("mpspline_est1 does the thing",
c(
# normal
s <- data.frame("SID" = "A",
"UD" = c(0,10,20,30),
"LD" = c(10,20,30,40),
"VAL" = c(5.4, 5.3, 5.6, 7.0),
stringsAsFactors = FALSE),
spar <- mpspline_est1(s, 'VAL', lam = 0.1),
# lock this down
expect_is(spar, 'list'),
expect_equal(length(spar), 6),
expect_equal(names(spar), c("s_bar", "b0", "b1", "gamma", "alfa", "Z")),
expect_is(spar[[1]], 'numeric'),
expect_equal(length(spar[[1]]), 4),
expect_equivalent(spar[[1]][1], 5.3938765799840498),
expect_is(spar[[2]], 'numeric'),
expect_equal(length(spar[[2]]), 4),
expect_equivalent(spar[[2]][1], 0),
expect_is(spar[[3]], 'numeric'),
expect_equal(length(spar[[3]]), 4),
expect_equivalent(spar[[3]][1], -0.015308550039877671),
expect_is(spar[[4]], 'numeric'),
expect_equal(length(spar[[4]]), 4),
expect_equivalent(spar[[4]][1], -0.00076542750199388358),
expect_is(spar[[5]], 'numeric'),
expect_equal(length(spar[[5]]), 4),
expect_equivalent(spar[[5]][1], 5.4193908300505127),
expect_is(spar[[6]], 'matrix'),
expect_equal(nrow(spar[[6]]), 4),
expect_equivalent(spar[[6]][1], 1.064285714),
# one horizon
s <- data.frame("SID" = "A", "UD" = 0, "LD" = 10, "VAL" = 5.4,
stringsAsFactors = FALSE),
spar <- mpspline_est1(s, 'VAL', lam = 0.1),
expect_equal(spar, NA_real_)
)
)
test_that("mpspline_fit1 does the thing",
c(
# single horizon
s1 <- data.frame("SID" = "A", "UD" = 0, "LD" = 10, "VAL" = 5.4),
p1 <- mpspline_est1(s1, 'VAL', lam = 0.1),
expect_message(mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
f1 <- mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(f1, 'list'),
expect_equal(length(f1), 2),
expect_equal(f1[[1]][1], s1[[4]]),
expect_equal(f1[[1]][11], NA_real_),
expect_equal(f1[[2]][1], s1[[4]]),
expect_equal(f1[[2]][3], NA_real_),
# normal no gaps
s2 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c( 0, 20, 30, 50),
"LD" = c(20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
p2 <- mpspline_est1(s2, 'VAL', lam = 0.1),
f2 <- mpspline_fit1(s = s2, p = p2, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(f2, 'list'),
expect_is(f2[[1]], 'numeric'),
expect_is(f2[[2]], 'numeric'),
expect_equal(length(f2), 2),
expect_equal(length(f2[[1]]), 200),
expect_true(sum(is.na(f2[[1]])) == 130),
expect_true(max(f2[[1]], na.rm = TRUE) <= 14),
expect_true(min(f2[[1]], na.rm = TRUE) >= 0),
expect_equal(length(f2[[2]]), 6),
expect_true(sum(is.na(f2[[2]])) == 1),
# gaps
s3 <- data.frame("SID" = c( 1, 1, 1),
"UD" = c( 0, 30, 50),
"LD" = c(20, 50, 70),
"VAL" = c( 6, 3, 10),
stringsAsFactors = FALSE),
p3 <- mpspline_est1(s3, 'VAL', lam = 0.1),
f3 <- mpspline_fit1(s = s3, p = p3, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
# still getting predictions in the same depth range as s1:
expect_true(sum(is.na(f3[[1]])) == 130),
expect_true(max(f3[[1]], na.rm = TRUE) <= 14),
expect_true(min(f3[[1]], na.rm = TRUE) >= 0),
expect_equal(length(f3[[2]]), 6),
expect_true(sum(is.na(f3[[2]])) == 1),
# deeper than max d - should just truncate
f4 <- mpspline_fit1(s = s2, p = p2, var_name = 'VAL',
d = c(0, 5, 15, 30),
vhigh = 14, vlow = 0),
expect_equal(length(f4[[1]]), 30),
expect_true(sum(is.na(f4[[1]])) == 0),
expect_equal(length(f4[[2]]), 3),
expect_true(sum(is.na(f4[[2]])) == 0),
expect_equal(f2[[2]][1:3], f4[[2]]),
# starts below surface
s4 <- data.frame("SID" = c( 1, 1, 1),
"UD" = c(20, 30, 50),
"LD" = c(30, 50, 70),
"VAL" = c( 4, 3, 10),
stringsAsFactors = FALSE),
p4 <- mpspline_est1(s4, 'VAL', lam = 0.1),
f5 <- mpspline_fit1(s = s4, p = p4, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100),
vhigh = 14, vlow = 0),
# no extrapolation, only interpolation!!
expect_true(all(is.na(f5[[1]][1:20]))),
expect_true(all(is.na(f5[[1]][71:100]))) # x[70] == 69-70cm
))
test_that("mpspline_rmse1 does the thing",
c( s1 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c( 0, 20, 30, 50),
"LD" = c(20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
p1 <- mpspline_est1(s1, 'VAL', lam = 0.1),
f1 <- mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
t1 <- mpspline_rmse1(s1, p1, var_name = 'VAL'),
expect_equal(length(t1), 2),
expect_equal(t1[[1]], 0.19001524938836459),
expect_equal(t1[[2]], 0.058466230581035256),
expect_equal(names(t1), c('RMSE', 'RMSE_IQR')),
p <- list("s_bar" = NA, "b0" = NA, "b1" = NA, "gamma" = NA,
"alfa" = NA, "Z" = NA),
expect_equal(mpspline_rmse1(s1, p, var_name = 'VAL'),
c("RMSE" = NA_real_, "RMSE_IQR" = NA_real_))
)
)
test_that("mpspline_one returns correctly",
c(
s1 <-
data.frame("SID" = c("A"),
"UD" = c( 0, 20, 30, 50),
"LD" = c( 20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 100),
stringsAsFactors = FALSE),
m1 <- mpspline_one(s1, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(m1, 'list'),
expect_equal(length(m1), 5),
expect_is(m1[[1]], 'character'),
expect_is(m1[[2]], 'numeric'),
expect_is(m1[[3]], 'numeric'),
expect_is(m1[[4]], 'numeric'),
expect_is(m1[[5]], 'numeric'),
expect_length(m1[[1]], 1),
expect_length(m1[[2]], 4),
expect_length(m1[[3]], 200),
expect_length(m1[[4]], 6),
expect_length(m1[[5]], 2),
# var name skipped
expect_message(
mpspline_one(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
m2 <- mpspline_one(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1, m2),
# test non df input
s1$SID <- 1,
s2 <- as.matrix(s1),
m3 <- mpspline_one(s2, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1[[3]], m3[[3]]),
# fctr SID
s3 <- s1,
s3[[1]] <- as.factor(s3[[1]]),
m4 <- mpspline_one(s3, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1[[3]], m4[[3]]),
expect_is(m4[[1]], 'character'),
# single row input
s4 <- s1[1, ],
m5 <- mpspline_one(s4, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_message(mpspline_one(s4, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0))
))
test_that("mpspline works with default output",
c( s1 <-
data.frame("SID" = c( "A", "A", "A", "A", "B", "B", "B", "B", "C", "D", "E", 5),
"UD" = c( 0, 20, 30, 50, -1, 45, 15, 80, 0, 30, 0, 30),
"LD" = c(20, 30, 50, 70, 5, 60, 30, NA, 10, 50, 10, 50),
"VAL" = c( 6, 4, 3, 100, 0.1, 0.9, 2.5, 6, 3.5, 10.4, NA, NA),
stringsAsFactors = FALSE),
m1 <- mpspline(s1, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(m1, 'list'),
expect_equal(length(m1), 4),
expect_is(m1[[1]], 'list'),
expect_equal(length(m1[[1]]), 5),
expect_is(m1[[1]][[1]], 'character'),
expect_is(m1[[1]][[2]], 'numeric'),
expect_is(m1[[1]][[3]], 'numeric'),
expect_is(m1[[1]][[4]], 'numeric'),
expect_is(m1[[1]][[5]], 'numeric'),
expect_length(m1[[1]][[1]], 1),
expect_length(m1[[1]][[2]], 4),
expect_length(m1[[1]][[3]], 200),
expect_length(m1[[1]][[4]], 6),
expect_length(m1[[1]][[5]], 2),
expect_equivalent(m1[[3]][[2]], 3.5),
# var name skipped
expect_message(mpspline(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
m2 <- mpspline(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1, m2)
)
)
obrl-soil/mpspline2 documentation built on Feb. 1, 2024, 7:55 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context('mpspline tests')
test_that("mpspline_conv works for numeric matrices",
c(
obj <- matrix(c( 1, 1, 1, 1, 2, 2, 2, 2,
NA, 20, 40, 60, -1, 45, 15, 80,
10, 30, 50, 70, 5, 60, 30, NA,
6, 4, 3, 10, 0.1, 0.9, 2.5, 6),
ncol = 4, byrow = FALSE),
fixed <- mpspline_conv(obj),
expect_is(fixed, 'data.frame'),
expect_equal(nrow(fixed), 8),
# whoops, site IDs aren't numeric!
obj <- matrix(c("a", "a", "a", 0, 10, 20, 10, 20, 30, 4.5, 6, 7.8),
ncol = 4, byrow = FALSE),
fx <- mpspline_conv(obj),
expect_is(fx, 'data.frame'),
expect_equal(nrow(fx), 3),
expect_is(fx[[2]], 'numeric')
)
)
test_that("mpspline_conv works for data frames",
c(
obj <- data.frame("SID" = c( 1, 1, 1, 1, 2, 2, 2, 2),
"UD" = c(NA, 20, 40, 60, -1, 45, 15, 80),
"LD" = c(10, 30, 50, 70, 5, 60, 30, NA),
"VAL" = c( 6, 4, 3, 10, 0.1, 0.9, 2.5, 6),
stringsAsFactors = FALSE),
fixed <- mpspline_conv(obj),
expect_is(fixed, 'data.frame'),
expect_equal(obj, fixed)
)
)
test_that("mpspline_datchk does what it oughta",
c(
obj <- data.frame("SID" = 1,
"UD" = c(NA, 20, 40, 60),
"LD" = c(10, 30, 50, NA),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
chkd <- mpspline_datchk(obj, 'VAL'),
expect_is(chkd, 'data.frame'),
expect_equal(nrow(chkd), 4),
expect_equal(chkd[[2]][1], 0), # surface fixed
expect_equal(chkd[[3]][4], 70), # last fixed
obj2 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c(-5, 20, 40, 60),
"LD" = c(10, 30, 50, 90),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
chkd2 <- mpspline_datchk(obj2, 'VAL'),
expect_equal(nrow(chkd2), 3), # -ve hor dropped
# some na
onena <- data.frame("SID" = "A",
"UD" = c(0, 30, 60, 90),
"LD" = c(30, 60, 90, NA),
"VAL" = c( 6, 4, 3, NA),
stringsAsFactors = FALSE),
expect_message({res <- mpspline_datchk(onena, 'VAL')}),
expect_equal(nrow(res), nrow(onena) - 1),
expect_equal(mpspline_datchk(onena, 'VAL'), data.frame("SID" = "A",
"UD" = c(0, 30, 60),
"LD" = c(30, 60, 90),
"VAL" = c( 6, 4, 3),
stringsAsFactors = FALSE)),
# all na
allna <- data.frame("SID" = "A",
"UD" = c(0, 30, 60, 90),
"LD" = c(30, 60, 90 ,120),
"VAL" = NA_real_,
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(allna, 'VAL')),
expect_equal(mpspline_datchk(allna, 'VAL'), NA),
# overlap
ols <- data.frame("SID" = "A",
"UD" = c(0, 30, 50, 90),
"LD" = c(30, 60, 100 ,120),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(ols, 'VAL')),
expect_equal(mpspline_datchk(ols, 'VAL'), NA),
# 0-thickness horizon
zthk <- data.frame("SID" = "A",
"UD" = c(0, 30, 50, 90),
"LD" = c(30, 30, 80 ,120),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(zthk, 'VAL')),
expect_equal(mpspline_datchk(zthk, 'VAL'),
data.frame("SID" = "A",
"UD" = c(0, 50, 90),
"LD" = c(30, 80 ,120),
"VAL" = c(1,3,4),
stringsAsFactors = FALSE)),
# bkwrds
bkw <- data.frame("SID" = "A",
"UD" = c(0, 20, 50, 120),
"LD" = c(10, 30, 80 ,90),
"VAL" = c(1,2,3,4),
stringsAsFactors = FALSE),
expect_message(mpspline_datchk(bkw, 'VAL')),
expect_equal(mpspline_datchk(bkw, 'VAL'),
data.frame("SID" = "A",
"UD" = c(0, 20, 50),
"LD" = c(10, 30, 80),
"VAL" = c(1,2,3),
stringsAsFactors = FALSE)),
# single horizon unharmed
sh <- data.frame("SID" = "A",
"UD" = 0,
"LD" = 10,
"VAL" = 4,
stringsAsFactors = FALSE),
chkd <- mpspline_datchk(sh, 'VAL'),
expect_identical(sh, chkd)
)
)
test_that("mpspline_est1 does the thing",
c(
# normal
s <- data.frame("SID" = "A",
"UD" = c(0,10,20,30),
"LD" = c(10,20,30,40),
"VAL" = c(5.4, 5.3, 5.6, 7.0),
stringsAsFactors = FALSE),
spar <- mpspline_est1(s, 'VAL', lam = 0.1),
# lock this down
expect_is(spar, 'list'),
expect_equal(length(spar), 6),
expect_equal(names(spar), c("s_bar", "b0", "b1", "gamma", "alfa", "Z")),
expect_is(spar[[1]], 'numeric'),
expect_equal(length(spar[[1]]), 4),
expect_equivalent(spar[[1]][1], 5.3938765799840498),
expect_is(spar[[2]], 'numeric'),
expect_equal(length(spar[[2]]), 4),
expect_equivalent(spar[[2]][1], 0),
expect_is(spar[[3]], 'numeric'),
expect_equal(length(spar[[3]]), 4),
expect_equivalent(spar[[3]][1], -0.015308550039877671),
expect_is(spar[[4]], 'numeric'),
expect_equal(length(spar[[4]]), 4),
expect_equivalent(spar[[4]][1], -0.00076542750199388358),
expect_is(spar[[5]], 'numeric'),
expect_equal(length(spar[[5]]), 4),
expect_equivalent(spar[[5]][1], 5.4193908300505127),
expect_is(spar[[6]], 'matrix'),
expect_equal(nrow(spar[[6]]), 4),
expect_equivalent(spar[[6]][1], 1.064285714),
# one horizon
s <- data.frame("SID" = "A", "UD" = 0, "LD" = 10, "VAL" = 5.4,
stringsAsFactors = FALSE),
spar <- mpspline_est1(s, 'VAL', lam = 0.1),
expect_equal(spar, NA_real_)
)
)
test_that("mpspline_fit1 does the thing",
c(
# single horizon
s1 <- data.frame("SID" = "A", "UD" = 0, "LD" = 10, "VAL" = 5.4),
p1 <- mpspline_est1(s1, 'VAL', lam = 0.1),
expect_message(mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
f1 <- mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(f1, 'list'),
expect_equal(length(f1), 2),
expect_equal(f1[[1]][1], s1[[4]]),
expect_equal(f1[[1]][11], NA_real_),
expect_equal(f1[[2]][1], s1[[4]]),
expect_equal(f1[[2]][3], NA_real_),
# normal no gaps
s2 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c( 0, 20, 30, 50),
"LD" = c(20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
p2 <- mpspline_est1(s2, 'VAL', lam = 0.1),
f2 <- mpspline_fit1(s = s2, p = p2, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(f2, 'list'),
expect_is(f2[[1]], 'numeric'),
expect_is(f2[[2]], 'numeric'),
expect_equal(length(f2), 2),
expect_equal(length(f2[[1]]), 200),
expect_true(sum(is.na(f2[[1]])) == 130),
expect_true(max(f2[[1]], na.rm = TRUE) <= 14),
expect_true(min(f2[[1]], na.rm = TRUE) >= 0),
expect_equal(length(f2[[2]]), 6),
expect_true(sum(is.na(f2[[2]])) == 1),
# gaps
s3 <- data.frame("SID" = c( 1, 1, 1),
"UD" = c( 0, 30, 50),
"LD" = c(20, 50, 70),
"VAL" = c( 6, 3, 10),
stringsAsFactors = FALSE),
p3 <- mpspline_est1(s3, 'VAL', lam = 0.1),
f3 <- mpspline_fit1(s = s3, p = p3, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
# still getting predictions in the same depth range as s1:
expect_true(sum(is.na(f3[[1]])) == 130),
expect_true(max(f3[[1]], na.rm = TRUE) <= 14),
expect_true(min(f3[[1]], na.rm = TRUE) >= 0),
expect_equal(length(f3[[2]]), 6),
expect_true(sum(is.na(f3[[2]])) == 1),
# deeper than max d - should just truncate
f4 <- mpspline_fit1(s = s2, p = p2, var_name = 'VAL',
d = c(0, 5, 15, 30),
vhigh = 14, vlow = 0),
expect_equal(length(f4[[1]]), 30),
expect_true(sum(is.na(f4[[1]])) == 0),
expect_equal(length(f4[[2]]), 3),
expect_true(sum(is.na(f4[[2]])) == 0),
expect_equal(f2[[2]][1:3], f4[[2]]),
# starts below surface
s4 <- data.frame("SID" = c( 1, 1, 1),
"UD" = c(20, 30, 50),
"LD" = c(30, 50, 70),
"VAL" = c( 4, 3, 10),
stringsAsFactors = FALSE),
p4 <- mpspline_est1(s4, 'VAL', lam = 0.1),
f5 <- mpspline_fit1(s = s4, p = p4, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100),
vhigh = 14, vlow = 0),
# no extrapolation, only interpolation!!
expect_true(all(is.na(f5[[1]][1:20]))),
expect_true(all(is.na(f5[[1]][71:100]))) # x[70] == 69-70cm
))
test_that("mpspline_rmse1 does the thing",
c( s1 <- data.frame("SID" = c( 1, 1, 1, 1),
"UD" = c( 0, 20, 30, 50),
"LD" = c(20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 10),
stringsAsFactors = FALSE),
p1 <- mpspline_est1(s1, 'VAL', lam = 0.1),
f1 <- mpspline_fit1(s = s1, p = p1, var_name = 'VAL',
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
t1 <- mpspline_rmse1(s1, p1, var_name = 'VAL'),
expect_equal(length(t1), 2),
expect_equal(t1[[1]], 0.19001524938836459),
expect_equal(t1[[2]], 0.058466230581035256),
expect_equal(names(t1), c('RMSE', 'RMSE_IQR')),
p <- list("s_bar" = NA, "b0" = NA, "b1" = NA, "gamma" = NA,
"alfa" = NA, "Z" = NA),
expect_equal(mpspline_rmse1(s1, p, var_name = 'VAL'),
c("RMSE" = NA_real_, "RMSE_IQR" = NA_real_))
)
)
test_that("mpspline_one returns correctly",
c(
s1 <-
data.frame("SID" = c("A"),
"UD" = c( 0, 20, 30, 50),
"LD" = c( 20, 30, 50, 70),
"VAL" = c( 6, 4, 3, 100),
stringsAsFactors = FALSE),
m1 <- mpspline_one(s1, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(m1, 'list'),
expect_equal(length(m1), 5),
expect_is(m1[[1]], 'character'),
expect_is(m1[[2]], 'numeric'),
expect_is(m1[[3]], 'numeric'),
expect_is(m1[[4]], 'numeric'),
expect_is(m1[[5]], 'numeric'),
expect_length(m1[[1]], 1),
expect_length(m1[[2]], 4),
expect_length(m1[[3]], 200),
expect_length(m1[[4]], 6),
expect_length(m1[[5]], 2),
# var name skipped
expect_message(
mpspline_one(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
m2 <- mpspline_one(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1, m2),
# test non df input
s1$SID <- 1,
s2 <- as.matrix(s1),
m3 <- mpspline_one(s2, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1[[3]], m3[[3]]),
# fctr SID
s3 <- s1,
s3[[1]] <- as.factor(s3[[1]]),
m4 <- mpspline_one(s3, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1[[3]], m4[[3]]),
expect_is(m4[[1]], 'character'),
# single row input
s4 <- s1[1, ],
m5 <- mpspline_one(s4, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_message(mpspline_one(s4, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0))
))
test_that("mpspline works with default output",
c( s1 <-
data.frame("SID" = c( "A", "A", "A", "A", "B", "B", "B", "B", "C", "D", "E", 5),
"UD" = c( 0, 20, 30, 50, -1, 45, 15, 80, 0, 30, 0, 30),
"LD" = c(20, 30, 50, 70, 5, 60, 30, NA, 10, 50, 10, 50),
"VAL" = c( 6, 4, 3, 100, 0.1, 0.9, 2.5, 6, 3.5, 10.4, NA, NA),
stringsAsFactors = FALSE),
m1 <- mpspline(s1, var_name = 'VAL', lam = 0.1,
d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_is(m1, 'list'),
expect_equal(length(m1), 4),
expect_is(m1[[1]], 'list'),
expect_equal(length(m1[[1]]), 5),
expect_is(m1[[1]][[1]], 'character'),
expect_is(m1[[1]][[2]], 'numeric'),
expect_is(m1[[1]][[3]], 'numeric'),
expect_is(m1[[1]][[4]], 'numeric'),
expect_is(m1[[1]][[5]], 'numeric'),
expect_length(m1[[1]][[1]], 1),
expect_length(m1[[1]][[2]], 4),
expect_length(m1[[1]][[3]], 200),
expect_length(m1[[1]][[4]], 6),
expect_length(m1[[1]][[5]], 2),
expect_equivalent(m1[[3]][[2]], 3.5),
# var name skipped
expect_message(mpspline(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0)),
m2 <- mpspline(s1, d = c(0, 5, 15, 30, 60, 100, 200),
vhigh = 14, vlow = 0),
expect_identical(m1, m2)
)
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.