tests/testthat/test-parallel-p1-plumbing.R

In LUCIDus: LUCID with Multiple Omics Data

# Regression tests for parallel-model parameter plumbing

test_that("parallel model records and runs requested init_par", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z <- list(matrix(rnorm(400), nrow = 40), matrix(rnorm(400), nrow = 40))
  Y <- rnorm(40)

  suppressWarnings(invisible(capture.output(
    fit_random <- est_lucid(
      lucid_model = "parallel",
      G = G, Z = Z, Y = Y,
      family = "normal",
      K = c(2, 2),
      init_par = "random",
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  suppressWarnings(invisible(capture.output(
    fit_mclust <- est_lucid(
      lucid_model = "parallel",
      G = G, Z = Z, Y = Y,
      family = "normal",
      K = c(2, 2),
      init_par = "mclust",
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  expect_equal(fit_random$init_par, "random")
  expect_equal(fit_mclust$init_par, "mclust")
})

test_that("parallel model stores EM control settings for bootstrap reuse", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z <- list(matrix(rnorm(400), nrow = 40), matrix(rnorm(400), nrow = 40))
  Y <- rnorm(40)

  suppressWarnings(invisible(capture.output(
    fit <- est_lucid(
      lucid_model = "parallel",
      G = G, Z = Z, Y = Y,
      family = "normal",
      K = c(2, 2),
      tol = 1e-2,
      max_itr = 7,
      max_tot.itr = 25,
      seed = 1008
    )
  )))

  expect_true(is.list(fit$em_control))
  expect_equal(fit$em_control$tol, 1e-2)
  expect_equal(fit$em_control$max_itr, 7)
  expect_equal(fit$em_control$max_tot.itr, 25)
})

test_that("parallel Z penalties are plumbed into fit metadata and select structure", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(400), nrow = 40)
  Z2 <- matrix(rnorm(400), nrow = 40)
  Z <- list(Z1, Z2)
  Y <- rnorm(40)

  suppressWarnings(invisible(capture.output(
    fit <- est_lucid(
      lucid_model = "parallel",
      G = G, Z = Z, Y = Y,
      family = "normal",
      K = c(2, 2),
      Rho_Z_Mu = 0.2,
      Rho_Z_Cov = 0.05,
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  expect_equal(fit$Rho$Rho_Z_Mu, 0.2)
  expect_equal(fit$Rho$Rho_Z_Cov, 0.05)
  expect_true(is.list(fit$select$selectZ))
  expect_equal(length(fit$select$selectZ), 2)
  expect_true(all(sapply(fit$select$selectZ, is.matrix)))
  expect_equal(dim(fit$select$selectZ[[1]]), c(2, ncol(Z1)))
  expect_equal(dim(fit$select$selectZ[[2]]), c(2, ncol(Z2)))
})

test_that("parallel G penalties return overall and per-layer selectG objects", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z <- list(matrix(rnorm(400), nrow = 40), matrix(rnorm(400), nrow = 40))
  Y <- rnorm(40)

  suppressWarnings(invisible(capture.output(
    fit <- est_lucid(
      lucid_model = "parallel",
      G = G, Z = Z, Y = Y,
      family = "normal",
      K = c(2, 2),
      Rho_G = 0.1,
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  expect_type(fit$select$selectG, "logical")
  expect_equal(length(fit$select$selectG), ncol(G))
  expect_true(is.list(fit$select$selectG_layer))
  expect_equal(length(fit$select$selectG_layer), 2)
  expect_true(all(sapply(fit$select$selectG_layer, is.logical)))
  expect_equal(length(fit$select$selectG_layer[[1]]), ncol(G))
  expect_equal(length(fit$select$selectG_layer[[2]]), ncol(G))
  expect_equal(fit$select$selectG,
               fit$select$selectG_layer[[1]] | fit$select$selectG_layer[[2]])
})