tests/testthat/test-parallel-robustness-extra.R

In LUCIDus: LUCID with Multiple Omics Data

# Additional robustness tests for parallel LUCID

test_that("check_na for parallel classifies row-level missing patterns correctly", {
  Z1 <- matrix(rnorm(40), nrow = 10)
  Z2 <- matrix(rnorm(40), nrow = 10)

  Z1[1, ] <- NA      # all missing
  Z1[2, 1] <- NA     # partial missing
  Z2[3, ] <- NA      # all missing
  Z2[4, 2] <- NA     # partial missing

  na_pat <- check_na(list(Z1, Z2), lucid_model = "parallel")

  expect_equal(na_pat$indicator_na[[1]][1], 3)
  expect_equal(na_pat$indicator_na[[1]][2], 2)
  expect_equal(na_pat$indicator_na[[1]][5], 1)
  expect_equal(na_pat$indicator_na[[2]][3], 3)
  expect_equal(na_pat$indicator_na[[2]][4], 2)
  expect_true(all(na_pat$impute_flag == c(TRUE, TRUE)))
})

test_that("parallel LOD imputation fills missing entries in both all-missing and partial rows", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)

  Z1[1, ] <- NA
  Z1[2, 1:2] <- NA

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      lucid_model = "parallel",
      G = G,
      Z = list(Z1, Z2),
      Y = Y,
      K = c(2, 2),
      family = "normal",
      init_impute = "lod",
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  expect_true(all(is.finite(fit$Z[[1]][1, ])))
  expect_true(all(is.finite(fit$Z[[1]][2, ])))
})

test_that("parallel tune_lucid carries penalty grid and returns model with tuned Rho", {
  set.seed(1008)
  G <- matrix(rnorm(120), nrow = 30)
  Z1 <- matrix(rnorm(180), nrow = 30)
  Z2 <- matrix(rnorm(180), nrow = 30)
  Y <- rnorm(30)

  suppressWarnings(invisible(capture.output(
    tuned <- tune_lucid(
      G = G,
      Z = list(Z1, Z2),
      Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = list(2:3, 2),
      Rho_G = c(0, 0.05),
      Rho_Z_Mu = c(0, 0.1),
      Rho_Z_Cov = 0,
      max_itr = 6,
      tol = 1e-1,
      seed = 1008,
      useY = TRUE
    )
  )))

  expect_equal(nrow(tuned$tune_K), 8)
  expect_true(all(c("Rho_G", "Rho_Z_Mu", "Rho_Z_Cov", "BIC") %in% colnames(tuned$tune_K)))
  expect_s3_class(tuned$model_opt, "lucid_parallel")
  expect_true(tuned$model_opt$Rho$Rho_G %in% c(0, 0.05))
  expect_true(tuned$model_opt$Rho$Rho_Z_Mu %in% c(0, 0.1))
})

test_that("parallel lucid wrapper tunes K and penalty vectors together", {
  set.seed(1008)
  G <- matrix(rnorm(120), nrow = 30)
  Z1 <- matrix(rnorm(180), nrow = 30)
  Z2 <- matrix(rnorm(180), nrow = 30)
  Y <- rnorm(30)

  suppressWarnings(invisible(capture.output(
    fit <- lucid(
      G = G,
      Z = list(Z1, Z2),
      Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = list(2:3, 2),
      Rho_G = c(0, 0.05),
      Rho_Z_Mu = 0,
      Rho_Z_Cov = 0,
      max_itr = 6,
      tol = 1e-1,
      seed = 1008,
      useY = TRUE
    )
  )))

  expect_s3_class(fit, "lucid_parallel")
  expect_true(fit$K[1] %in% c(2, 3))
  expect_equal(fit$K[2], 2)
  expect_true(fit$Rho$Rho_G %in% c(0, 0.05))
})

test_that("parallel selection objects are consistent with feature dimensions", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)

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

  expect_type(fit$select$selectG, "logical")
  expect_true(is.list(fit$select$selectZ))
  expect_true(is.list(fit$select$selectG_layer))
  expect_equal(length(fit$select$selectG_layer), 2)
  expect_equal(length(fit$select$selectZ), 2)
  expect_equal(length(fit$select$selectG), ncol(G))
  expect_equal(length(fit$select$selectG_layer[[1]]), ncol(G))
  expect_equal(length(fit$select$selectG_layer[[2]]), ncol(G))
  expect_equal(dim(fit$select$selectZ[[1]]), c(fit$K[1], ncol(Z1)))
  expect_equal(dim(fit$select$selectZ[[2]]), c(fit$K[2], ncol(Z2)))
})

test_that("parallel summary reports selected-feature tables with valid bounds", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)

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

  s <- summary_lucid(fit)
  expect_s3_class(s, "sumlucid_parallel")
  expect_equal(length(s$feature_selection$Z), 2)
  expect_equal(nrow(s$feature_selection$Z[[1]]), ncol(Z1))
  expect_equal(nrow(s$feature_selection$Z[[2]]), ncol(Z2))
  expect_true(all(s$feature_selection$Z[[1]]$Selected_in_clusters >= 0))
  expect_true(all(s$feature_selection$Z[[1]]$Selected_in_clusters <= fit$K[1]))
  expect_true(all(s$feature_selection$Z[[2]]$Selected_in_clusters >= 0))
  expect_true(all(s$feature_selection$Z[[2]]$Selected_in_clusters <= fit$K[2]))
})

test_that("parallel summary reports per-layer listwise and sporadic missing profile", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)

  Z1[1, ] <- NA
  Z1[2, 1:2] <- NA
  Z2[3, ] <- NA
  Z2[4:5, 1] <- NA

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      lucid_model = "parallel",
      G = G,
      Z = list(Z1, Z2),
      Y = Y,
      K = c(2, 2),
      family = "normal",
      init_impute = "mix",
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  s <- summary_lucid(fit)
  expect_s3_class(s, "sumlucid_parallel")
  expect_false(is.null(s$missing_data))
  expect_true("layer_summary" %in% names(s$missing_data))
  expect_equal(s$missing_data$layer_summary$listwise_rows[1], 1)
  expect_equal(s$missing_data$layer_summary$sporadic_rows[1], 1)
  expect_equal(s$missing_data$layer_summary$listwise_rows[2], 1)
  expect_equal(s$missing_data$layer_summary$sporadic_rows[2], 2)
  out <- capture.output(print(s))
  expect_true(any(grepl("Missing-data profile by layer", out)))
})