tests/testthat/test-irwls_comparisons.R

In sparsegl: Sparse Group Lasso

set.seed(1)
nobs <- 100L
beta_star <- c(5, 5, 5, -5, -5, -5, 1, 0, 1, 0, 0, 0, 0, 2, 0)
nvars <- length(beta_star)

group <- rep(1:5, each = 3)
x <- matrix(rnorm(nobs * length(beta_star)), nobs)
x[abs(x) < 0.2] <- 0
xsp <- as(x, "sparseMatrix")

eps <- rnorm(nobs)
y <- x %*% beta_star + eps

pr <- 1 / (1 + exp(-x %*% beta_star))
ybin <- rbinom(nobs, 1, pr)


test_that("wls provides the same result as sparsegl, Gaussian family", {
  res1 <- sparsegl(x, y, group, lambda = .1)
  res2 <- sparsegl(x, y, group, family = gaussian(), lambda = .1)

  expect_lt(max(abs(coef(res1) - coef(res2))), 1e-4)

  res1 <- sparsegl(x, y, group, lambda = .025)
  res2 <- sparsegl(x, y, group, family = gaussian(), lambda = .025)

  expect_lt(max(abs(coef(res1) - coef(res2))), 1e-4)

  res1_lam <- sparsegl(x, y, group)
  res2_lam <- sparsegl(x, y, group, family = gaussian())
  nlam <- length(res2_lam$lambda)
  expect_lt(max(abs(res1_lam$lambda[1:nlam] - res2_lam$lambda)), 1e-10)

  expect_lt(mean(abs(coef(res1_lam)[, 1:nlam] - coef(res2_lam))), 1e-4)

  ## sparse case
  res1 <- sparsegl(xsp, y, group, lambda = .1)
  res2 <- sparsegl(xsp, y, group, family = gaussian(), lambda = .1)
  expect_lt(max(abs(coef(res1) - coef(res2))), 1e-4)

  res1 <- sparsegl(xsp, y, group, lambda = .025)
  res2 <- sparsegl(xsp, y, group, family = gaussian(), lambda = .025)
  expect_lt(max(abs(coef(res1) - coef(res2))), 1e-4)

  res1_lam <- sparsegl(xsp, y, group)
  res2_lam <- sparsegl(xsp, y, group, family = gaussian())
  nlam <- seq_along(res2_lam$lambda)
  expect_lt(max(abs(res1_lam$lambda[nlam] - res2_lam$lambda)), 1e-10)

  tt <- abs(coef(res1_lam)[, nlam] - coef(res2_lam)) /
    (1 + abs(coef(res1_lam)[, nlam]))
  expect_lt(max(tt), 1e-3)
})

test_that("wls provides the same result as sparsegl, binomial family", {
  res1 <- sparsegl(x, ybin, group, family = "binomial", lambda = .01)
  res2 <- sparsegl(x, ybin, group, family = binomial(), lambda = .01, eps = 1e-10)
  tt <- abs(coef(res1)[-1] - coef(res2)[-1]) / (1 + abs(coef(res1)[-1]))
  expect_true(all(tt < 1e-3))

  res1 <- sparsegl(x, ybin, group, family = "binomial", lambda = .0025)
  res2 <- sparsegl(x, ybin, group, family = binomial(), lambda = .0025, eps = 1e-10)
  tt <- abs(coef(res1) - coef(res2)) / (1 + abs(coef(res1)))
  expect_true(mean(tt) < 3e-3)

  nlam <- 35
  res1_lam <- sparsegl(x, ybin, group,
    family = "binomial", nlambda = nlam,
    lambda.factor = 0.01
  )
  res2_lam <- sparsegl(x, ybin, group,
    family = binomial(), eps = 1e-10,
    nlambda = nlam, lambda.factor = 0.01
  )
  expect_lt(max(abs(res1_lam$lambda - res2_lam$lambda)), 1e-8)
  tt <- abs(coef(res1_lam) - coef(res2_lam)) / (1 + abs(coef(res1_lam)))
  expect_true(all(colMeans(tt) < 0.1))


  ## sparse case
  res1 <- sparsegl(xsp, ybin, group, family = "binomial", lambda = .01)
  res2 <- sparsegl(xsp, ybin, group, family = binomial(), lambda = .01, eps = 1e-9)
  tt <- abs(coef(res1)[-1] - coef(res2)[-1]) / (1 + abs(coef(res1)[-1]))
  expect_true(max(tt) < 1e-3)

  res1 <- sparsegl(x, ybin, group, family = "binomial", lambda = .0025)
  res2 <- sparsegl(x, ybin, group, family = binomial(), lambda = .0025, eps = 1e-10)
  tt <- abs(coef(res1) - coef(res2)) / (1 + abs(coef(res1)))
  expect_true(mean(tt) < 3e-3)

  nlam <- 35
  res1_lam <- sparsegl(x, ybin, group,
    family = "binomial", nlambda = nlam,
    lambda.factor = 0.01, eps = 1e-10
  )
  res2_lam <- sparsegl(x, ybin, group,
    family = binomial(), nlambda = nlam,
    eps = 1e-10, lambda.factor = 0.01
  )
  expect_lt(max(abs(res1_lam$lambda - res2_lam$lambda)), 1e-8)
  tt <- abs(coef(res1_lam) - coef(res2_lam)) /
    (1 + abs(coef(res1_lam)))
  expect_true(all(colMeans(tt) < 0.1))
})

test_that("wls sparse and dense cases give the same results, Gaussian", {
  res1 <- sparsegl(x, y, group, family = gaussian())
  res2 <- sparsegl(xsp, y, group, family = gaussian())

  tt <- abs(coef(res1) - coef(res2)) / (1 + abs(coef(res1)))
  expect_lt(max(tt), 1e-7)

  res1 <- sparsegl(x, ybin, group,
    family = binomial(), nlambda = 10,
    lambda.factor = .01
  )
  res2 <- sparsegl(xsp, ybin, group,
    family = binomial(), nlambda = 10,
    lambda.factor = .01
  )
  tt <- abs(coef(res1) - coef(res2)) / (1 + abs(coef(res1)))
  expect_lt(max(tt), 1e-6)
})