tests/testthat/test-screen_experimental.R

In hal9001: The Scalable Highly Adaptive Lasso

# 06 April 2020 - test is failing, corresponding code needs review/re-haul
if (FALSE) {
  context("Unit test for HAL screening procedure")
  library(glmnet)
  set.seed(749125)

  n <- 100
  p <- 5
  x <- xmat <- matrix(rnorm(n * p), n, p)
  y <- 10 * x[, 1] + 5 * x[, 2] + 6 * x[, 1] * x[, 2] +
    rnorm(n, mean = 0, sd = 0.2)

  testn <- 10000
  testx <- xmat <- matrix(rnorm(testn * p), testn, p)
  testy <- 10 * testx[, 1] + 5 * testx[, 2] + 6 * testx[, 1] * testx[, 2] +
    rnorm(n, mean = 0, sd = 0.2)

  select_list <- 2
  select_rank1 <- hal_screen_rank(x, y, k = 1, family = "gaussian")
  test_that("Rank function works properly with k(k!=NULL)", {
    expect_equal(select_list, select_rank1) # k=length(select_list), equal
  })

  select_list <- c(2, 3)
  select_rank2 <- hal_screen_rank(x, y, family = "gaussian")

  test_that("Rank function works properly without k", {
    expect_equal(select_list, select_rank2) # k=NULL, equal
  })

  # x_interaction_basis <- cbind(x, x[,1]*x[,2], x[,1]*x[,3], x[,2]*x[,3])# generate main terms and 2-way interaction
  # x_basis_lists <- list(1, 2, 3, c(1,2), c(1,3), c(2,3))#generate the column lists
  x_basis_lists <- list(1, 2, c(1, 2))
  goodbasis <- hal_screen_goodbasis(x, y,
    actual_max_degree = 2, k = NULL,
    family = "gaussian"
  )


  test_that("Goodbasis function works properly with interaction", {
    x_basis_str <- lapply(x_basis_lists, paste, collapse = ",")
    goodbasis_str <- lapply(goodbasis, paste, collapse = ",")
    # when k=6, they must be equal, all columns would be selected
    expect_setequal(x_basis_str, goodbasis_str)
  })
  #
  # x_basis<-matrix(nrow = n, ncol = 1)
  #
  # basis_list <- c()
  # for (i in seq_along(x_basis_lists)) {
  #   col_list <- x_basis_lists[[i]]
  #   basis_list <- c(basis_list,basis_list_cols(col_list, x))
  #
  # }
  #
  # x_basis <- make_design_matrix(x, basis_list)#generate k*n basis functions
  #
  # test_x_basis <- make_design_matrix(testx, basis_list)

  hal_with_screening <- fit_hal(x, y, screen_basis = TRUE)
  hal_without_screening <- fit_hal(x, y, screen_basis = FALSE)

  preds <- predict(hal_with_screening, new_data = testx)
  mse_w_screening <- mean((preds - testy)^2)
  preds <- predict(hal_without_screening, new_data = testx)
  mse_wo_screening <- mean((preds - testy)^2)

  hal_with_screening$times
  hal_without_screening$times


  test_that("screening makes things faster", {
    with_time <- hal_with_screening$times["total", "elapsed"]
    wo_time <- hal_without_screening$times["total", "elapsed"]
    expect_lt(with_time, wo_time)
  })

  test_that("screening doesn't hurt mse too much", {
    expect_lt(mse_w_screening, mse_wo_screening * 1.2)
  })
}