tests/testthat/test_penaltymat.R

In smurf: Sparse Multi-Type Regularized Feature Modeling

context("Penalty matrices")


test_that("Penalty matrix for Lasso", {
  expect_equal(.pen.mat.lasso(5), 
               diag(5))
})


test_that("Penalty matrix for Group Lasso", {
  expect_equal(.pen.mat.grouplasso(6), 
               diag(6))
})


test_that("Penalty matrix for Fused Lasso", {
  expect_equal(.pen.mat.flasso(4), 
               rbind(c(1, 0, 0, 0), c(-1, 1, 0, 0), c(0, -1, 1, 0), c(0, 0, -1, 1)))
  
  # With changed reference category
  expect_equal(.pen.mat.flasso(4, refcat = 3), 
               rbind(c(-1, 1, 0, 0), c(0, -1, 0, 0), c(0, 0, 1, 0), c(0, 0, -1, 1)))
})


test_that("Penalty matrix for Generalized Fused Lasso", {
  # With reference category
  a <- .pen.mat.gflasso(4)
  # Remove dimension names
  dimnames(a) <- NULL
  expect_equal(a, 
               rbind(c(1, 0, 0, 0), c(-1, 1, 0, 0), c(0, -1, 1, 0), c(0, 0, -1, 1),
                     c(0, 1, 0, 0), c(-1, 0, 1, 0), c(0, -1, 0, 1),
                     c(0, 0, 1, 0), c(-1, 0, 0, 1), c(0, 0, 0, 1)))
  
  # Without reference category
  b <- .pen.mat.gflasso(4, refcat = FALSE)
  # Remove dimension names
  dimnames(b) <- NULL
  expect_equal(b, 
               rbind(c(-1, 1, 0, 0), c(0, -1, 1, 0), c(0, 0, -1, 1),
                     c(-1, 0, 1, 0), c(0, -1, 0, 1), c(-1, 0, 0, 1)))
})


test_that("Penalty matrix for 2D Fused Lasso", {
  expect_equal(.pen.mat.2dflasso(3, 2),
               rbind(c(1, 0, 0, 0, 0, 0), c(-1, 1, 0, 0, 0, 0), 
                     c(-1, 0, 0, 1, 0, 0), c(0, 1, 0, 0, 0, 0),
                     c(0, -1, 1, 0, 0, 0), c(0, -1, 0, 0, 1, 0),
                     c(0, 0, 1, 0, 0, 0), c(0, 0, -1, 0, 0, 1), 
                     c(0, 0, 0, 1, 0, 0), c(0, 0, 0, -1, 1, 0), c(0, 0, 0, 0, -1, 1)))
})


test_that("Penalty matrix for Graph-Guided Fused Lasso", {

  # Adjacency matrix
  adj <- matrix(0, 10, 10)
  adj[1, 2] <- adj[2, 1] <- 1
  adj[2, 3] <- adj[3, 2] <- 1 
  adj[2, 5] <- adj[5, 2] <- 1 
  adj[1, 3] <- adj[3, 1] <- 1
  adj[6, 7] <- adj[7, 6] <- 1
  
  # Expected penalty matrix
  pen.exp <- matrix(0, 5, 9)
  pen.exp[1, 1] <- 1
  pen.exp[2, 2] <- 1
  pen.exp[3, 1] <- -1; pen.exp[3, 2] <- 1
  pen.exp[4, 1] <- -1; pen.exp[4, 4] <- 1
  pen.exp[5, 5] <- -1; pen.exp[5, 6] <- 1
  
  expect_equal(.pen.mat.ggflasso(adj), 
               pen.exp)
  
  
  # Now with different reference category
  pen.exp2 <- matrix(0, 5, 9)
  pen.exp2[1, 2] <- 1
  pen.exp2[2, 1] <- -1; pen.exp2[2, 2] <- 1
  pen.exp2[3, 1] <- -1; pen.exp2[3, 3] <- 1
  pen.exp2[4, 2] <- -1; pen.exp2[4, 3] <- 1
  pen.exp2[5, 5] <- -1; pen.exp2[5, 6] <- 1
  
  expect_equal(.pen.mat.ggflasso(adj, refcat = 5), 
               pen.exp2)
})