tests/testthat/test-WPstepwise.R

In ericdunipace/limbs: Linear p-Wasserstein Projections

test_that("stepwise works", {
  require(WpProj)
  set.seed(111)
  
  ##### Testing R Functions ####
  n <- 128
  p <- 10
  s <- 100
  
  x <- matrix( rnorm( p * n ), nrow = n, ncol = p )
  x_ <- t(x)
  beta <- (1:10)/10
  y <- x %*% beta + rnorm(n)
  post_beta <- matrix(beta, nrow=p, ncol=s) + rnorm(p*s, 0, 0.1)
  post_mu <- x %*% post_beta
  
  xtx <- crossprod(x)/n #* wt + diag(1,p,p) * (1 - wt)
  xty <- crossprod(x, post_mu)/n #* wt + post_beta * (1 - wt)
  
  OTopts <- list(same = TRUE,
                 method = "selection.variable",
                 transport.method = "exact",
                 epsilon = 0.05,
                 niter = 100)
  
  suffStat_star <- sufficientStatistics(x, post_mu, t(post_beta), OTopts)
  xtx_star <- suffStat_star$XtX #* wt + diag(post_beta_norm) * (1-wt)
  xty_star <- suffStat_star$XtY #* wt + post_beta_norm * (1-wt)
  
  active.idx <- seq(2,10,2)
  
  out <- WPSW(x, post_mu, t(post_beta), force = 1, power = 2,
              direction = c("backward"), 
              method=c("selection.variable"))
  out1 <- WPSW(x, post_mu, t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("selection.variable"))
  
  testthat::expect_true(all(out$beta %in% c(0,1)))
  testthat::expect_true(all(out1$beta %in% c(0,1)))
  
  #check model size truncation
  out <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
              direction = c("backward"), 
              method=c("selection.variable"), model.size = 8)
  out1 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("selection.variable"), model.size = 3)
  
  testthat::expect_true(all(which(apply(out$beta, 2, function(i) all(!is.na(i)))) %in% 1:3))
  testthat::expect_true(all(which(apply(out1$beta, 2, function(i) all(!is.na(i)))) %in% c(1,2,3)))
  testthat::expect_true(all(out$beta %in% c(NA,0,1)))
  testthat::expect_true(all(out1$beta %in% c(NA, 0,1)))
  
  #check projection
  out2 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("backward"), 
               method=c("projection"))
  out3 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("projection"))
  testthat::expect_true(all((colSums(out2$beta!=0)/s) %in% 1:10))
  testthat::expect_true(all((colSums(out3$beta!=0)/s) %in% 1:10))
  
  #check modelsize truncation
  out4 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("backward"), 
               method=c("projection"), model.size = 8)
  out5 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("projection"), model.size = 3)

  testthat::expect_true(all(which(apply(out4$beta, 2, function(i) all(!is.na(i)))) %in% 1:3))
  testthat::expect_true(all(which(apply(out5$beta, 2, function(i) all(!is.na(i)))) %in% 1:3))
})

testthat::test_that("model size works when force is null", {
  require(WpProj)
  set.seed(1234807)
  
  ##### Testing R Functions ####
  n <- 128
  p <- 10
  s <- 100
  
  x <- matrix( rnorm( p * n ), nrow = n, ncol = p )
  x_ <- t(x)
  beta <- (1:10)/10
  y <- x %*% beta + rnorm(n)
  post_beta <- matrix(beta, nrow=p, ncol=s) + rnorm(p*s, 0, 0.1)
  post_mu <- x %*% post_beta
  
  xtx <- crossprod(x)/n #* wt + diag(1,p,p) * (1 - wt)
  xty <- crossprod(x, post_mu)/n #* wt + post_beta * (1 - wt)
  
  OTopts <- list(same = TRUE,
                 method = "selection.variable",
                 transport.method = "exact",
                 epsilon = 0.05,
                 niter = 100)
  
  suffStat_star <- sufficientStatistics(x, post_mu, t(post_beta), OTopts)
  xtx_star <- suffStat_star$XtX #* wt + diag(post_beta_norm) * (1-wt)
  xty_star <- suffStat_star$XtY #* wt + post_beta_norm * (1-wt)
  
  active.idx <- seq(2,10,2)
  
  testthat::expect_invisible( out <- WPSW(x, t(post_mu), t(post_beta), power = 2,
               direction = c("backward"), 
               method=c("projection"), model.size = 8))
  testthat::expect_invisible(out1 <- WPSW(x, t(post_mu), t(post_beta), power = 2,
               direction = c("forward"), 
               method=c("projection"), model.size = 3))
  testthat::expect_invisible( out2 <- WPSW(x, t(post_mu), t(post_beta), power = 2,
                                           direction = c("backward"), 
                                           method=c("projection")))
  
})
  
testthat::test_that("nzero gives right number", {
  require(WpProj)
  set.seed(9786)
  
  ##### Testing R Functions ####
  n <- 128
  p <- 10
  s <- 100
  
  x <- matrix( rnorm( p * n ), nrow = n, ncol = p )
  x_ <- t(x)
  beta <- (1:10)/10
  y <- x %*% beta + rnorm(n)
  post_beta <- matrix(beta, nrow=p, ncol=s) + rnorm(p*s, 0, 0.1)
  post_mu <- x %*% post_beta
  
  xtx <- crossprod(x)/n #* wt + diag(1,p,p) * (1 - wt)
  xty <- crossprod(x, post_mu)/n #* wt + post_beta * (1 - wt)
  
  OTopts <- list(same = TRUE,
                 method = "selection.variable",
                 transport.method = "exact",
                 epsilon = 0.05,
                 niter = 100)
  
  suffStat_star <- sufficientStatistics(x, post_mu, t(post_beta), OTopts)
  xtx_star <- suffStat_star$XtX #* wt + diag(post_beta_norm) * (1-wt)
  xty_star <- suffStat_star$XtY #* wt + post_beta_norm * (1-wt)
  
  active.idx <- seq(2,10,2)
  
  out <- WPSW(x, post_mu, t(post_beta), force = 1, power = 2,
              direction = c("backward"), 
              method=c("selection.variable"))
  out1 <- WPSW(x, post_mu, t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("selection.variable"))
  
  testthat::expect_true(all(out$nzero %in% 1:p))
  testthat::expect_true(all(out1$nzero %in% 1:p))
  
  #check model size truncation
  out <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
              direction = c("backward"), 
              method=c("selection.variable"), model.size = 8)
  out1 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("selection.variable"), model.size = 3)
  
  testthat::expect_true(all(out$nzero %in% 8:p))
  testthat::expect_true(all(out1$nzero %in% 1:3))
  testthat::expect_true(all(out$beta %in% c(NA,0,1)))
  testthat::expect_true(all(out1$beta %in% c(NA, 0,1)))
  
  #check projection
  out2 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("backward"), 
               method=c("projection"))
  out3 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("projection"))
  testthat::expect_true(all(out2$nzero %in% 1:p))
  testthat::expect_true(all(out3$nzero %in% 1:p))
  testthat::expect_true(all((colSums(out2$beta!=0)/s) %in% 1:p))
  testthat::expect_true(all((colSums(out3$beta!=0)/s) %in% 1:p))
  
  #check modelsize truncation
  out4 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("backward"), 
               method=c("projection"), model.size = 8)
  out5 <- WPSW(x, t(post_mu), t(post_beta), force = 1, power = 2,
               direction = c("forward"), 
               method=c("projection"), model.size = 3)
  testthat::expect_true(all(out4$nzero %in% 1:p))
  testthat::expect_true(all(out5$nzero %in% 1:p))
  testthat::expect_true(all((colSums(out4$beta!=0)/s) %in% 1:p))
  testthat::expect_true(all((colSums(out5$beta!=0)/s) %in% 1:p))
})