tests/testthat/test.R

In transreg: Penalised Regression with Multiple Sets of Prior Effects ('Transfer Learning')

set.seed(1)
n <- 100; p <- 1000
X <- matrix(stats::rnorm(n*p),nrow=n,ncol=p)
beta <- stats::rnorm(p)
y <- X %*% beta

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#- - - slow and fast isotonic scaling- - - - - - - - - - - - - - - - - - - - - -
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

prior1 <- beta + stats::rnorm(p,sd=0.1)
prior2 <- beta + stats::rnorm(p,sd=0.1)

fast <- .iso.fast.single(y=y,X=X,prior=matrix(prior1,ncol=1),family="gaussian")$beta
  
testthat::test_that("expected signs (fast)",{
  cond1 <- all(fast[prior1==0]==0)
  cond2 <- all(fast[prior1<0]<=0)
  cond3 <- all(fast[prior1>0]>=0)
  testthat::expect_true(cond1&cond2&cond3)
})

if(require("CVXR")){
  
  slow <- .iso.slow.single(y=y,X=X,prior=matrix(prior1,ncol=1),family="gaussian")$beta

  testthat::test_that("expected signs (slow)",{
    cond1 <- all(slow[prior1==0]==0)
    cond2 <- all(slow[prior1<0]<=0)
    cond3 <- all(slow[prior1>0]>=0)
    testthat::expect_true(cond1&cond2&cond3)
  })
  
  testthat::test_that("correlation (slow, fast)",{
    cond1 <- abs(mean(slow)-mean(fast))<0.01
    cond2 <- stats::cor(slow,fast)>0.99
    testthat::expect_true(cond1&cond2)
  })
  
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#- - - equivalence predicted values- - - - - - - - - - - - - - - - - - - - - - -
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

for(scale in c("exp","iso")){
  for(stack in c("sta","sim")){
    
    family <- "gaussian"
    
    prior <- cbind(prior1,prior2)
    object <- transreg(y=y,X=X,prior=prior,family=family,scale=scale,stack=stack)
    
    y_hat1 <- predict(object,newx=X)
    coef <- coef(object=object)
    y_hat2 <- joinet:::.mean.function(coef$alpha + X %*% coef$beta,family=family)
    
    testthat::test_that("correlation (pred, coef)",{
      cond1 <- mean(y_hat1)-mean(y_hat2) < 0.01
      cond2 <- stats::cor(y_hat1,y_hat2) > 0.99
      testthat::expect_true(cond1&cond2)
    })
  
  }
}

#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#- - - prior re-scaling- - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

family <- "gaussian"
prior <- object <- pred <- list()
prior$original <- prior1
prior$modified <- -stats::runif(1)*prior1

for(scale in c("exp","iso")){
  for(stack in c("sta","sim")){
    
    for(i in seq_along(prior)){
      set.seed(2)
      object[[i]] <- transreg(y=y,X=X,prior=prior[[i]],family=family,scale=scale,stack=stack,switch=TRUE)
      pred[[i]] <- predict(object[[i]],newx=X)
    }
    
    testthat::test_that("prior re-scaling",{
      cond1 <- mean(pred[[1]])-mean(pred[[2]])<0.01
      cond2 <- stats::cor(pred[[1]],pred[[2]])>0.99
      testthat::expect_true(cond1&cond2)
    })
    
  }
}