tests/testthat/test-slope.R

In sgs: Sparse-Group SLOPE: Adaptive Bi-Level Selection with FDR Control

test_that("solution reduces to slope when alpha=1, with no intercept or standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    0, 0, 6.35351249775198, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.924615812626428,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.593341879455522, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0.0574674799067196, 0, 0, 0, 0, 0, 0, 0, 0
  )

  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=FALSE,standardise="none")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with intercept but no standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    -0.591904300904075, 0, 0, 6.15570369828865, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    -0.855516332321258, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.597393440042509,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0.147583863629151, 0, 0, 0, 0, 0, 0,
    0, 0
  )

  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=TRUE,standardise="none")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with no intercept but sd standardisation", { # again, sd off by a small amount
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    0, 0, 6.62193929302955, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.794831421813014,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.446180314946519, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0.000446641410816172, 0, 0, 0, 0, 0, 0, 0, 0
  )

  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=FALSE,standardise="sd")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with no intercept but l1 standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    0, 0, 7.08023698435155, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1.32172932399327, 
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.72816894344401, 0, 0, 0, 0, 
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
    0.281886263999637, 0, 0, 0, 0.421166293233546, 0, 0, 0, 0, 0, 
    0, 0, 0
  )

  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=FALSE,standardise="l1")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with no intercept but l2 standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  slope = SLOPE::SLOPE(X, y, family = "gaussian", alpha = lambda, q=0.1,intercept=FALSE,scale="l2",center=TRUE)

  coef_ref <- c(
    0, 0, 6.62199573208823, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.794796341616357,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.446206778892696, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0.000340786752155744, 0, 0, 0, 0, 0, 0, 0, 0
  )
 
  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=FALSE,standardise="l2")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=FALSE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with intercept and sd standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    -0.443697677962616, 0, 0, 6.621939698726, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.794830608447868,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.446179964202237, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0.000444025886934943, 0, 0, 0, 0, 0, 0, 0, 0
  )
 
  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=TRUE,standardise="sd")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with intercept and l1 standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    -0.237185741459661, 0, 0, 7.08023698435156, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    -1.32172932399327, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.728168943444005,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0.281886263999636, 0, 0, 0, 0.421166293233551, 0,
    0, 0, 0, 0, 0, 0, 0
  )
  
  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=TRUE,standardise="l1")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})

test_that("solution reduces to slope when alpha=1, with intercept and l2 standardisation", {
  n = 50
  p = 100
  data= gen_toy_data(p=p,n=n,rho = 0,seed_id = 3,grouped = FALSE,var_sparsity=0.2,orthogonal = FALSE)
  X <- data$X
  y <- data$y
  lambda=0.8
  groups=1:p

  coef_ref <- c(
    -0.443672029601005, 0, 0, 6.62199573208823, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    -0.794796341616357, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -0.446206778892693,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0.00034078675215286, 0, 0, 0, 0, 0, 0,
    0, 0
  )
  
  sgs = fit_sgs(X=X,y=y, groups=groups, type="linear", lambda=lambda, alpha=1, vFDR=0.1, gFDR=0.1,intercept=TRUE,standardise="l2")
  
  slope_cost = sgs_convex_opt(X=X,y=y,beta=coef_ref,num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)
  sgs_cost = sgs_convex_opt(X=X,y=y,beta=as.matrix(sgs$beta),num_obs=n,gslope_seq=sgs$w_weights,slope_seq=sgs$v_weights,groups=groups, intercept=TRUE)

  expect_equivalent(coef_ref,
    as.matrix(sgs$beta),
    tol = 1e-3
  )

  expect_equivalent(slope_cost, sgs_cost, tol=1e-3)
})