Switch to side-by-side view

--- a
+++ b/tests/testthat/test-hsstan.R
@@ -0,0 +1,169 @@
+test_that("hsstan",
+{
+    expect_s3_class(hs.gauss,
+                    "hsstan")
+    expect_s4_class(hs.gauss$stanfit,
+                    "stanfit")
+    expect_named(hs.gauss,
+                 c("stanfit", "betas", "call", "data", "model.terms", "family",
+                   "hsstan.settings"))
+    expect_false("lambda[1]" %in% names(hs.gauss$stanfit))
+    expect_equal(hs.gauss$family,
+                 gaussian())
+    expect_named(hs.gauss$betas$unpenalized,
+                 c("(Intercept)", "X1b", "X1c", "X2", "X3"))
+    expect_named(hs.gauss$betas$penalized,
+                 hs.gauss$model.terms$penalized)
+    expect_length(hs.gauss$betas, 2)
+    expect_named(hs.gauss$hsstan.settings,
+                 c("adapt.delta", "qr", "seed", "scale.u", "regularized", "nu",
+                   "par.ratio", "global.scale", "global.df", "slab.scale",
+                   "slab.df"))
+    expect_equal(hs.gauss$hsstan.settings$global.scale,
+                 0.007071068)
+    expect_equal(hs.gauss$hsstan.settings$adapt.delta,
+                 0.99)
+})
+
+test_that("hsstan with no penalized predictors",
+{
+    expect_null(hs.base$betas$penalized)
+    expect_length(hs.base$penalized,
+                  0)
+    expect_named(hs.base$hsstan.settings,
+                 c("adapt.delta", "qr", "seed", "scale.u"))
+    expect_equal(hs.base$hsstan.settings$adapt.delta,
+                 0.95)
+})
+
+test_that("hsstan handles categorical variables in the penalized predictors",
+{
+    SW({
+        hs.1 <- hsstan(df, y.gauss ~ X2 + X3, "X1", iter=250,
+                       keep.hs.pars=TRUE, refresh=0)
+    })
+    expect_named(hs.1$betas$unpenalized,
+                 c("(Intercept)", "X2", "X3"))
+    expect_named(hs.1$betas$penalized,
+                 c("X1b", "X1c"))
+})
+
+test_that("hsstan handles penalized predictors appearing in the formula",
+{
+    SW({
+        hs.1 <- hsstan(df, y.gauss ~ X1 + X2 + X3, "X2", iter=250,
+                       keep.hs.pars=TRUE, refresh=0)
+        hs.2 <- hsstan(df, y.gauss ~ X1 + X3, "X2", iter=250,
+                       keep.hs.pars=TRUE, refresh=0)
+    })
+    for (val in c("beta", "data", "model.terms"))
+        expect_equal(hs.1[[val]],
+                     hs.2[[val]])
+})
+
+test_that("hsstan handles interaction terms correctly",
+{
+    SW({
+        hs.int.2 <- hs(y.gauss ~ X1 + X3 + X2 + X1b_X3 + X1c_X3 + X3_X2, gaussian)
+    })
+    expect_equal(names(hs.inter$betas$unpenalized),
+                 gsub("_", ":", names(hs.int.2$betas$unpenalized)))
+    expect_equivalent(hs.inter$betas$unpenalized,
+                      hs.int.2$betas$unpenalized)
+    expect_equal(hs.inter$betas$penalized,
+                 hs.int.2$betas$penalized)
+})
+
+test_that("hsstan handles interaction term without main effects",
+{
+    SW({
+        hs.int.0 <- hsstan(df, y.gauss ~ X1:X3, iter=200, refresh=0)
+    })
+    expect_named(hs.int.0$betas$unpenalized,
+                 c("(Intercept)", "X1a:X3", "X1b:X3", "X1c:X3"))
+})
+
+test_that("hsstan doesn't use the QR decomposition if P > N",
+{
+    SW({
+        hs.noqr <- hsstan(df[1:5, ], mod.gauss, pen, iter=100, qr=TRUE,
+                          keep.hs.pars=TRUE, refresh=0)
+    })
+    expect_false(hs.noqr$hsstan.settings$qr)
+    expect_match(names(hs.noqr$stanfit),
+                 "lambda", all=FALSE)
+    expect_match(names(hs.noqr$stanfit),
+                 "tau", all=FALSE)
+})
+
+test_that("kfold",
+{
+    expect_s3_class(cv.gauss,
+                    c("kfold", "loo"))
+    expect_output(print(cv.gauss),
+                  "Based on 2-fold cross-validation")
+    expect_named(cv.gauss,
+                 c("estimates", "pointwise", "fits", "data"))
+    expect_equal(rownames(cv.gauss$estimates),
+                 c("elpd_kfold", "p_kfold", "kfoldic"))
+    expect_equal(colnames(cv.gauss$estimates),
+                 c("Estimate", "SE"))
+    expect_equal(nrow(cv.gauss$pointwise),
+                 N)
+    expect_equal(colnames(cv.gauss$pointwise),
+                 c("elpd_kfold", "p_kfold", "kfoldic"))
+    expect_true(all(is.na(cv.gauss$pointwise[, "p_kfold"])))
+    expect_length(cv.gauss$fits[[1]]$stanfit@stan_args,
+                  2)
+
+    expect_named(cv.binom,
+                 c("estimates", "pointwise", "fits", "data"))
+    for (i in 1:max(folds))
+        expect_s3_class(cv.binom$fits[[i]],
+                        "hsstan")
+    expect_silent(validate.samples(cv.binom$fits[[1]]))
+    expect_equal(nrow(cv.binom$fits),
+                 2)
+    expect_length(cv.binom$fits[[1]]$stanfit@stan_args,
+                  1)
+    expect_length(cv.binom$fits,
+                  max(folds) * 2)
+    expect_equal(cv.binom$fits[[max(folds) + 1]],
+                 which(folds == 1))
+})
+
+test_that("kfold with store.fits=FALSE",
+{
+    expect_named(cv.nofit,
+                 c("estimates", "pointwise"))
+})
+
+test_that("hsstan with invalid inputs",
+{
+    expect_error(hsstan(df, mod.gauss, adapt.delta=1),
+                 "'adapt.delta' must be less than 1")
+
+    expect_error(hsstan(df, mod.gauss, iter=0),
+                 "'iter' must be a positive integer")
+    expect_error(hsstan(df, mod.gauss, iter=-1),
+                 "'iter' must be a positive integer")
+
+    expect_error(hsstan(df, mod.gauss, warmup=0),
+                 "'warmup' must be a positive integer")
+    expect_error(hsstan(df, mod.gauss, warmup=-1),
+                 "'warmup' must be a positive integer")
+
+    expect_error(hsstan(df, mod.gauss, iter=1000, warmup=1000),
+                 "'warmup' must be smaller than 'iter'")
+
+    expect_error(hsstan(df, mod.gauss, chains=0),
+                 "rstan::sampling failed")
+})
+
+test_that("kfold with invalid inputs",
+{
+    expect_error(kfold(hs.gauss, folds, chains=0),
+                 "'chains' must be a positive integer")
+    expect_error(kfold(hs.gauss, folds, chains=4.4),
+                 "'chains' must be a positive integer")
+})