Datasets
Models
Diff of
/tests/testthat/test-projection.R
[000000]
..
[ede2d4]
Switch to unified view
| a | b/tests/testthat/test-projection.R | ||
|---|---|---|---|
| 1 | test_that("projsel for a model with no penalized predictors", |
||
| 2 | { |
||
| 3 | SW({ |
||
| 4 | sel.base.00 <- projsel(hs.base, max.iters=0) |
||
| 5 | sel.base.02 <- projsel(hs.base, max.iters=0, start.from="X2") |
||
| 6 | sel.base.1 <- projsel(hs.base) |
||
| 7 | sel.base.2 <- projsel(hs.base, start.from="X2") |
||
| 8 | }) |
||
| 9 | |||
| 10 | expect_equal(nrow(sel.base.00), |
||
| 11 | 1) |
||
| 12 | expect_true(is.na(sel.base.00$rel.kl)) |
||
| 13 | expect_equal(sel.base.00$rel.kl.null, |
||
| 14 | 0) |
||
| 15 | |||
| 16 | expect_equal(nrow(sel.base.02), |
||
| 17 | 2) |
||
| 18 | expect_equal(sel.base.02$rel.kl[2], |
||
| 19 | 0) |
||
| 20 | expect_equal(sel.base.02$rel.kl.null[1], |
||
| 21 | 0) |
||
| 22 | expect_equal(sel.base.02$rel.kl.null[2], |
||
| 23 | 0.38193515, tolerance=tol) |
||
| 24 | |||
| 25 | expect_equal(nrow(sel.base.1), |
||
| 26 | length(hs.base$betas$unpenalized)) |
||
| 27 | expect_equal(attr(sel.base.1, "start.from"), |
||
| 28 | character(0)) |
||
| 29 | |||
| 30 | expect_equal(nrow(sel.base.2), |
||
| 31 | length(hs.base$betas$unpenalized)) |
||
| 32 | expect_equal(sel.base.2$var[2], |
||
| 33 | "Initial submodel") |
||
| 34 | expect_equal(attr(sel.base.2, "start.from"), |
||
| 35 | "X2") |
||
| 36 | }) |
||
| 37 | |||
| 38 | test_that("projsel for gaussian family", |
||
| 39 | { |
||
| 40 | SW({ |
||
| 41 | sel.gauss <- projsel(hs.gauss, out.csv="out.csv") |
||
| 42 | }) |
||
| 43 | |||
| 44 | expect_s3_class(sel.gauss, |
||
| 45 | "projsel") |
||
| 46 | expect_equal(colnames(sel.gauss), |
||
| 47 | c("var", "kl", "rel.kl.null", "rel.kl", "elpd", "delta.elpd")) |
||
| 48 | expect_equal(nrow(sel.gauss), |
||
| 49 | length(pen) + 2) |
||
| 50 | expect_equal(attr(sel.gauss, "start.from"), |
||
| 51 | hs.gauss$model.terms$unpenalized) |
||
| 52 | expect_equal(sel.gauss$var[1:2], |
||
| 53 | c("Intercept only", "Initial submodel")) |
||
| 54 | expect_equal(sel.gauss$var[-c(1:2)], |
||
| 55 | paste0("X", c(9, 4, 8, 7, 5, 6, 10))) |
||
| 56 | expect_equal(sel.gauss$kl[2], |
||
| 57 | 0.02948656, tolerance=tol) |
||
| 58 | expect_equal(tail(sel.gauss$kl, n=1), |
||
| 59 | 0) |
||
| 60 | expect_equal(sel.gauss$rel.kl.null[1], |
||
| 61 | 0) |
||
| 62 | expect_equal(tail(sel.gauss$rel.kl.null, n=1), |
||
| 63 | 1) |
||
| 64 | expect_true(is.na(sel.gauss$rel.kl[1])) |
||
| 65 | expect_equal(sel.gauss$rel.kl[2], |
||
| 66 | 0) |
||
| 67 | expect_equal(tail(sel.gauss$rel.kl, n=1), |
||
| 68 | 1) |
||
| 69 | expect_equal(sel.gauss$elpd[2], |
||
| 70 | -111.370949, tolerance=tol) |
||
| 71 | expect_equal(tail(sel.gauss$elpd, n=1), |
||
| 72 | -109.695740, tolerance=tol) |
||
| 73 | expect_equal(sel.gauss$delta.elpd[2], |
||
| 74 | -1.67520810, tolerance=tol) |
||
| 75 | expect_true(all(diff(sel.gauss$kl) < 0)) |
||
| 76 | expect_true(file.exists("out.csv")) |
||
| 77 | unlink("out.csv") |
||
| 78 | |||
| 79 | expect_s3_class(plot(sel.gauss, from.covariates=FALSE, max.points=3), |
||
| 80 | "ggplot") |
||
| 81 | expect_silent(print(plot(sel.gauss, title="Test", max.labels=3))) |
||
| 82 | unlink("Rplots.pdf") |
||
| 83 | }) |
||
| 84 | |||
| 85 | test_that("projsel for binomial family", |
||
| 86 | { |
||
| 87 | num.sel <- 4 |
||
| 88 | SW({ |
||
| 89 | sel.binom <- projsel(hs.binom, max.iters=num.sel) |
||
| 90 | }) |
||
| 91 | |||
| 92 | expect_equal(nrow(sel.binom), |
||
| 93 | num.sel + 2) |
||
| 94 | expect_equal(sel.binom$var[-c(1:2)], |
||
| 95 | paste0("X", c(6, 9, 5, 8))) |
||
| 96 | expect_equal(sel.binom$kl[2], |
||
| 97 | 0.03245156, tolerance=tol) |
||
| 98 | expect_equal(tail(sel.binom$kl, n=1), |
||
| 99 | 0.00478297, tolerance=tol) |
||
| 100 | expect_equal(sel.binom$rel.kl.null[1], |
||
| 101 | 0) |
||
| 102 | expect_true(is.na(sel.binom$rel.kl[1])) |
||
| 103 | expect_lt(tail(sel.binom$rel.kl, n=1), |
||
| 104 | 1) |
||
| 105 | expect_lt(tail(sel.binom$rel.kl.null, n=1), |
||
| 106 | 1) |
||
| 107 | expect_equal(sel.binom$elpd[2], |
||
| 108 | -35.3793754, tolerance=tol) |
||
| 109 | expect_equal(tail(sel.binom$elpd, n=1), |
||
| 110 | -34.0411588, tolerance=tol) |
||
| 111 | expect_equal(sel.binom$delta.elpd[2], |
||
| 112 | -1.39197661, tolerance=tol) |
||
| 113 | expect_true(all(diff(sel.binom$kl) < 0)) |
||
| 114 | }) |
||
| 115 | |||
| 116 | test_that("projsel for a model with interaction terms", |
||
| 117 | { |
||
| 118 | SW({ |
||
| 119 | sel.inter <- projsel(hs.inter, start.from="X1:X3") |
||
| 120 | }) |
||
| 121 | expect_equal(attr(sel.inter, "start.from"), |
||
| 122 | c("X1", "X3", "X1:X3")) |
||
| 123 | }) |
||
| 124 | |||
| 125 | test_that("projsel from the intercept-only model", |
||
| 126 | { |
||
| 127 | SW({ |
||
| 128 | sel.gauss.1 <- projsel(hs.gauss, start.from=character(0)) |
||
| 129 | sel.gauss.2 <- projsel(hs.gauss, start.from="X2") |
||
| 130 | }) |
||
| 131 | |||
| 132 | expect_equal(sel.gauss.1$var[1:2], |
||
| 133 | c("Intercept only", "X2")) |
||
| 134 | expect_equal(sel.gauss.2$var[1:2], |
||
| 135 | c("Intercept only", "Initial submodel")) |
||
| 136 | expect_equivalent(sel.gauss.1[-2, ], |
||
| 137 | sel.gauss.2[-2, ]) |
||
| 138 | expect_equal(nrow(sel.gauss.1), |
||
| 139 | length(c(hs.gauss$betas$unpenalized, hs.gauss$betas$penalized))) |
||
| 140 | expect_equal(attr(sel.gauss.1, "start.from"), |
||
| 141 | character(0)) |
||
| 142 | expect_equal(attr(sel.gauss.2, "start.from"), |
||
| 143 | "X2") |
||
| 144 | }) |
||
| 145 | |||
| 146 | test_that("projsel from a non-default starting submodel", |
||
| 147 | { |
||
| 148 | SW({ |
||
| 149 | sel.gauss <- projsel(hs.gauss, start.from="X1") |
||
| 150 | }) |
||
| 151 | |||
| 152 | expect_equal(nrow(sel.gauss), |
||
| 153 | length(c(grep("X1", names(hs.gauss$beta$unpenalized), inv=TRUE), |
||
| 154 | hs.gauss$betas$penalized)) + 1) |
||
| 155 | }) |
||
| 156 | |||
| 157 | test_that("projsel from a submodel that includes all variables", |
||
| 158 | { |
||
| 159 | SW({ |
||
| 160 | sel.gauss <- projsel(hs.gauss, start.from=paste0("X", 1:P)) |
||
| 161 | }) |
||
| 162 | |||
| 163 | expect_equal(sel.gauss$var, |
||
| 164 | c("Intercept only", "Initial submodel")) |
||
| 165 | expect_equal(sel.gauss$rel.kl.null, |
||
| 166 | c(0, 1)) |
||
| 167 | expect_equal(sel.gauss$rel.kl, |
||
| 168 | c(NA, 1)) |
||
| 169 | expect_equal(sel.gauss$delta.elpd[2], |
||
| 170 | 0) |
||
| 171 | expect_equal(attr(sel.gauss, "row.names"), |
||
| 172 | 1:2) |
||
| 173 | expect_equal(attr(sel.gauss, "start.from"), |
||
| 174 | paste0("X", 1:P)) |
||
| 175 | }) |
||
| 176 | |||
| 177 | test_that("projsel for a model with few observations", |
||
| 178 | { |
||
| 179 | SW({ |
||
| 180 | hs.small <- hsstan(df[1:5, ], y.gauss ~ X2 + X3, pen, |
||
| 181 | iter=iters, chains=chains, refresh=0) |
||
| 182 | expect_message(sel <- projsel(hs.small), |
||
| 183 | "Fully saturated model reached") |
||
| 184 | }) |
||
| 185 | expect_equal(tail(sel$kl, 1), |
||
| 186 | 0) |
||
| 187 | }) |
||
| 188 | |||
| 189 | test_that("projsel for a cross-validated object", |
||
| 190 | { |
||
| 191 | SW({ |
||
| 192 | sel.gauss <- projsel(cv.gauss$fits[[1]]) |
||
| 193 | }) |
||
| 194 | |||
| 195 | expect_equal(tail(sel.gauss$elpd, n=1), |
||
| 196 | sum(colMeans(log_lik(cv.gauss$fits[[1]], |
||
| 197 | newdata=df[folds == 2, ])))) |
||
| 198 | }) |
||
| 199 | |||
| 200 | test_that("projsel with invalid inputs", |
||
| 201 | { |
||
| 202 | expect_error(projsel(hs.gauss, max.iters=-1), |
||
| 203 | "must be a non-negative integer") |
||
| 204 | expect_error(projsel(hs.gauss, max.iters=2.3), |
||
| 205 | "must be a non-negative integer") |
||
| 206 | expect_error(projsel(hs.gauss, max.iters=iris), |
||
| 207 | "must be a non-negative integer") |
||
| 208 | }) |