--- a +++ b/tests/testthat/test-projection.R @@ -0,0 +1,208 @@ +test_that("projsel for a model with no penalized predictors", +{ + SW({ + sel.base.00 <- projsel(hs.base, max.iters=0) + sel.base.02 <- projsel(hs.base, max.iters=0, start.from="X2") + sel.base.1 <- projsel(hs.base) + sel.base.2 <- projsel(hs.base, start.from="X2") + }) + + expect_equal(nrow(sel.base.00), + 1) + expect_true(is.na(sel.base.00$rel.kl)) + expect_equal(sel.base.00$rel.kl.null, + 0) + + expect_equal(nrow(sel.base.02), + 2) + expect_equal(sel.base.02$rel.kl[2], + 0) + expect_equal(sel.base.02$rel.kl.null[1], + 0) + expect_equal(sel.base.02$rel.kl.null[2], + 0.38193515, tolerance=tol) + + expect_equal(nrow(sel.base.1), + length(hs.base$betas$unpenalized)) + expect_equal(attr(sel.base.1, "start.from"), + character(0)) + + expect_equal(nrow(sel.base.2), + length(hs.base$betas$unpenalized)) + expect_equal(sel.base.2$var[2], + "Initial submodel") + expect_equal(attr(sel.base.2, "start.from"), + "X2") +}) + +test_that("projsel for gaussian family", +{ + SW({ + sel.gauss <- projsel(hs.gauss, out.csv="out.csv") + }) + + expect_s3_class(sel.gauss, + "projsel") + expect_equal(colnames(sel.gauss), + c("var", "kl", "rel.kl.null", "rel.kl", "elpd", "delta.elpd")) + expect_equal(nrow(sel.gauss), + length(pen) + 2) + expect_equal(attr(sel.gauss, "start.from"), + hs.gauss$model.terms$unpenalized) + expect_equal(sel.gauss$var[1:2], + c("Intercept only", "Initial submodel")) + expect_equal(sel.gauss$var[-c(1:2)], + paste0("X", c(9, 4, 8, 7, 5, 6, 10))) + expect_equal(sel.gauss$kl[2], + 0.02948656, tolerance=tol) + expect_equal(tail(sel.gauss$kl, n=1), + 0) + expect_equal(sel.gauss$rel.kl.null[1], + 0) + expect_equal(tail(sel.gauss$rel.kl.null, n=1), + 1) + expect_true(is.na(sel.gauss$rel.kl[1])) + expect_equal(sel.gauss$rel.kl[2], + 0) + expect_equal(tail(sel.gauss$rel.kl, n=1), + 1) + expect_equal(sel.gauss$elpd[2], + -111.370949, tolerance=tol) + expect_equal(tail(sel.gauss$elpd, n=1), + -109.695740, tolerance=tol) + expect_equal(sel.gauss$delta.elpd[2], + -1.67520810, tolerance=tol) + expect_true(all(diff(sel.gauss$kl) < 0)) + expect_true(file.exists("out.csv")) + unlink("out.csv") + + expect_s3_class(plot(sel.gauss, from.covariates=FALSE, max.points=3), + "ggplot") + expect_silent(print(plot(sel.gauss, title="Test", max.labels=3))) + unlink("Rplots.pdf") +}) + +test_that("projsel for binomial family", +{ + num.sel <- 4 + SW({ + sel.binom <- projsel(hs.binom, max.iters=num.sel) + }) + + expect_equal(nrow(sel.binom), + num.sel + 2) + expect_equal(sel.binom$var[-c(1:2)], + paste0("X", c(6, 9, 5, 8))) + expect_equal(sel.binom$kl[2], + 0.03245156, tolerance=tol) + expect_equal(tail(sel.binom$kl, n=1), + 0.00478297, tolerance=tol) + expect_equal(sel.binom$rel.kl.null[1], + 0) + expect_true(is.na(sel.binom$rel.kl[1])) + expect_lt(tail(sel.binom$rel.kl, n=1), + 1) + expect_lt(tail(sel.binom$rel.kl.null, n=1), + 1) + expect_equal(sel.binom$elpd[2], + -35.3793754, tolerance=tol) + expect_equal(tail(sel.binom$elpd, n=1), + -34.0411588, tolerance=tol) + expect_equal(sel.binom$delta.elpd[2], + -1.39197661, tolerance=tol) + expect_true(all(diff(sel.binom$kl) < 0)) +}) + +test_that("projsel for a model with interaction terms", +{ + SW({ + sel.inter <- projsel(hs.inter, start.from="X1:X3") + }) + expect_equal(attr(sel.inter, "start.from"), + c("X1", "X3", "X1:X3")) +}) + +test_that("projsel from the intercept-only model", +{ + SW({ + sel.gauss.1 <- projsel(hs.gauss, start.from=character(0)) + sel.gauss.2 <- projsel(hs.gauss, start.from="X2") + }) + + expect_equal(sel.gauss.1$var[1:2], + c("Intercept only", "X2")) + expect_equal(sel.gauss.2$var[1:2], + c("Intercept only", "Initial submodel")) + expect_equivalent(sel.gauss.1[-2, ], + sel.gauss.2[-2, ]) + expect_equal(nrow(sel.gauss.1), + length(c(hs.gauss$betas$unpenalized, hs.gauss$betas$penalized))) + expect_equal(attr(sel.gauss.1, "start.from"), + character(0)) + expect_equal(attr(sel.gauss.2, "start.from"), + "X2") +}) + +test_that("projsel from a non-default starting submodel", +{ + SW({ + sel.gauss <- projsel(hs.gauss, start.from="X1") + }) + + expect_equal(nrow(sel.gauss), + length(c(grep("X1", names(hs.gauss$beta$unpenalized), inv=TRUE), + hs.gauss$betas$penalized)) + 1) +}) + +test_that("projsel from a submodel that includes all variables", +{ + SW({ + sel.gauss <- projsel(hs.gauss, start.from=paste0("X", 1:P)) + }) + + expect_equal(sel.gauss$var, + c("Intercept only", "Initial submodel")) + expect_equal(sel.gauss$rel.kl.null, + c(0, 1)) + expect_equal(sel.gauss$rel.kl, + c(NA, 1)) + expect_equal(sel.gauss$delta.elpd[2], + 0) + expect_equal(attr(sel.gauss, "row.names"), + 1:2) + expect_equal(attr(sel.gauss, "start.from"), + paste0("X", 1:P)) +}) + +test_that("projsel for a model with few observations", +{ + SW({ + hs.small <- hsstan(df[1:5, ], y.gauss ~ X2 + X3, pen, + iter=iters, chains=chains, refresh=0) + expect_message(sel <- projsel(hs.small), + "Fully saturated model reached") + }) + expect_equal(tail(sel$kl, 1), + 0) +}) + +test_that("projsel for a cross-validated object", +{ + SW({ + sel.gauss <- projsel(cv.gauss$fits[[1]]) + }) + + expect_equal(tail(sel.gauss$elpd, n=1), + sum(colMeans(log_lik(cv.gauss$fits[[1]], + newdata=df[folds == 2, ])))) +}) + +test_that("projsel with invalid inputs", +{ + expect_error(projsel(hs.gauss, max.iters=-1), + "must be a non-negative integer") + expect_error(projsel(hs.gauss, max.iters=2.3), + "must be a non-negative integer") + expect_error(projsel(hs.gauss, max.iters=iris), + "must be a non-negative integer") +})