test.R 1.35 KB
Newer Older
Armin Rauschenberger's avatar
Armin Rauschenberger committed
1
2

# data simulation
Armin Rauschenberger's avatar
Armin Rauschenberger committed
3
list <- colasso:::.simulate(n=100,p=200)
Armin Rauschenberger's avatar
Armin Rauschenberger committed
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
y <- list$y; X <- list$X

# penalised regression
cutoff <- 1
foldid <- palasso:::.folds(y=y>cutoff,nfolds=10)
fit <- colasso::bilasso(y=y,cutoff=cutoff,X=X,foldid=foldid)
net <- list()
net$gaussian <- glmnet::cv.glmnet(y=y,x=X,family="gaussian",foldid=foldid)
net$binomial <- glmnet::cv.glmnet(y=y>cutoff,x=X,family="binomial",foldid=foldid)

for(dist in c("gaussian","binomial")){
  
  testthat::test_that("cross-validated loss",{
    a <- fit[[dist]]$sigma.cvm
    b <- net[[dist]]$cvm
    diff <- abs(a[seq_along(b)]-b)
    testthat::expect_true(all(diff<1e-06))
  })
  
  testthat::test_that("optimal lambda",{
    a <- fit[[dist]]$lambda.min
    b <- net[[dist]]$lambda.min
    testthat::expect_true(a==b)
  })
  
  testthat::test_that("lambda sequence",{
    a <- fit[[dist]]$lambda
    b <- net[[dist]]$lambda
    testthat::expect_true(all(a[seq_along(b)]==b))
  })
  
  testthat::test_that("predicted values",{
    a <- stats::predict(object=fit[[dist]],newx=X)
    b <- stats::predict(object=net[[dist]]$glmnet.fit,newx=X)
    testthat::expect_true(all(a==b))
  })
  
}

testthat::test_that("predicted values (logistic)",{
Armin Rauschenberger's avatar
Armin Rauschenberger committed
44
  a <- colasso:::predict.bilasso(object=fit,newx=X)$binomial
Armin Rauschenberger's avatar
Armin Rauschenberger committed
45
46
47
48
49
  b <- as.numeric(stats::predict(object=net$binomial,newx=X,s="lambda.min",type="response"))
  testthat::expect_true(all(a==b))
})