tests/testthat/test-l1penalty.R

In sparsegl: Sparse Group Lasso

test_that("Test if function throws error as expected or automatically perform
  adjustment to the given data", {
  n <- 100
  beta <- c(5, 5, 5, -5, -5, -5, 1, 0, 1, 0, 0, 0, 0, 2, 0)
  gr <- rep(1:5, each = 3)
  X <- matrix(rnorm(n * length(beta)), n)
  y <- X %*% beta + rnorm(n)

  # length of pfl1 is not the same as the number of predictors.
  pfl1 <- rep(1, 10)
  expect_error(sparsegl(X, y, group = gr, pf_sparse = pfl1))


  # any entry of plf1 is negative
  index <- sample(seq(15), size = 1)
  pfl1[index] <- -1
  expect_error(sparsegl(X, y, group = gr, pf_sparse = pfl1))


  # function will rescale each entry such that the sum will be constant
  pfl1_1 <- rep(1, 15)
  pfl1_2 <- rep(2, 15)
  out1 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_1)
  out2 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_2)
  expect_equal(out1$b0, out2$b0)
  expect_equal(out1$beta, out2$beta)
  expect_equal(out1$lambda, out2$lambda)

  # test if logistic model works fine
  n <- 100
  beta <- c(5, 5, 5, -5, -5, -5, 1, 0, 1, 0, 0, 0, 0, 2, 0)
  gr <- rep(1:5, each = 3)
  X <- matrix(rnorm(n * length(beta)), n)
  pr <- 1 / (1 + exp(-X %*% beta))
  y0 <- rbinom(n, 1, pr)

  out1 <- sparsegl(X, y0, group = gr, family = "binomial")
  out2 <- sparsegl(X, y0, group = gr, family = "binomial", pf_sparse = rep(2, 15))
  expect_equal(out1$beta, out2$beta)
})

test_that("function behaviors changed by pfl1", {
  n <- 100
  beta <- c(5, 5, 5, -5, -5, -5)
  gr <- rep(1:2, each = 3)
  X <- matrix(rnorm(n * length(beta)), n)
  y <- X %*% beta + rnorm(n)
  pfl1_1 <- c(rep(0, 3), rep(10, 3))
  pfl1_2 <- c(rep(0, 3), rep(20, 3))
  out1 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_1)
  out2 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_2)

  # out1 and out2 are the same models.
  expect_equal(out1$b0, out2$b0)
  expect_equal(out1$beta, out2$beta)
  expect_equal(out1$lambda, out2$lambda)

  # will ignore group sparse penalty from this point.

  pfl1_2 <- c(rep(1, 5), 10)
  out1 <- sparsegl(X, y, group = gr, asparse = 1)
  out2 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_2, asparse = 1)


  # lambda is larger when the coefficient of predictor6 turns nonzero in out1.
  expect_true(out1$lambda[which(out1$beta[6, ] != 0)[1]] >=
    out2$lambda[which(out2$beta[6, ] != 0)[1]])


  # coefficient of predictor6 in out1 is larger than out1 with same lambdas.

  out2 <- sparsegl(X, y, group = gr, pf_sparse = pfl1_2, lambda = out1$lambda, asparse = 1)
  expect_equal(
    as.numeric(abs(as.numeric(out1$beta[6, ])) >= abs(as.numeric(out2$beta[6, ]))),
    rep(1, 100)
  )


  # compare in a single model.

  n <- 100
  beta <- rep(5, 6)
  gr <- rep(1:2, each = 3)
  X <- matrix(rnorm(n * length(beta)), n)
  y <- X %*% beta + rnorm(n)

  # assign increasing l1-penalty along the predictors
  out <- sparsegl(X, y, group = gr, pf_sparse = seq(1, 60, by = 10), asparse = 1)
  expect_true(out$lambda[which(out$beta[1, ] != 0)[1]] >=
    out$lambda[which(out$beta[6, ] != 0)[1]])
})