tests/testthat/test-boot-lucid-parallel.R

In LUCIDus: LUCID with Multiple Omics Data

# Bootstrap smoke tests for parallel LUCID

test_that("boot_lucid parallel smoke test without covariates", {
  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(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  suppressWarnings(invisible(capture.output(
    out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 3,
      conf = 0.9
    )
  )))

  expect_true(all(c("beta", "mu", "gamma", "bootstrap") %in% names(out)))
  expect_true(is.list(out$beta))
  expect_true(is.list(out$mu))
  expect_equal(length(out$beta), 2)
  expect_equal(length(out$mu), 2)
  expect_equal(nrow(out$beta[[1]]), (fit$K[1] - 1) * (ncol(G) + 1))
  expect_equal(nrow(out$beta[[2]]), (fit$K[2] - 1) * (ncol(G) + 1))
  expect_equal(nrow(out$mu[[1]]), fit$K[1] * ncol(Z1))
  expect_equal(nrow(out$mu[[2]]), fit$K[2] * ncol(Z2))
  expect_equal(ncol(out$beta[[1]]), 5)
  expect_equal(ncol(out$mu[[1]]), 5)

  gamma_len <- if(!is.null(fit$res_Gamma$Gamma$mu)) {
    length(fit$res_Gamma$Gamma$mu)
  } else {
    length(fit$res_Gamma$fit$coefficients)
  }
  expect_equal(nrow(out$gamma), gamma_len)
  expect_equal(ncol(out$gamma), 5)
  expect_true(is.finite(out$beta[[1]][1, "estimate"]))
  expect_true(is.finite(out$mu[[1]][1, "estimate"]))
  expect_s3_class(out$bootstrap, "boot")
})

test_that("boot_lucid parallel handles CoG and CoY indexing", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)
  CoG <- matrix(rnorm(40), nrow = 40)
  CoY <- matrix(rnorm(40), nrow = 40)

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

  suppressWarnings(invisible(capture.output(
    out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      CoG = CoG, CoY = CoY,
      lucid_model = "parallel",
      model = fit,
      R = 3,
      conf = 0.9
    )
  )))

  expect_equal(nrow(out$beta[[1]]), (fit$K[1] - 1) * (ncol(G) + 1))
  expect_equal(nrow(out$beta[[2]]), (fit$K[2] - 1) * (ncol(G) + 1))
  expect_equal(nrow(out$mu[[1]]), fit$K[1] * ncol(Z1))
  expect_equal(nrow(out$mu[[2]]), fit$K[2] * ncol(Z2))
})

test_that("boot_lucid parallel keeps exposure names with single G and CoG present", {
  set.seed(2026)
  G <- matrix(rnorm(40), nrow = 40)
  colnames(G) <- "hs_child_age_yrs_None"
  Z1 <- matrix(rnorm(120), nrow = 40)
  Z2 <- matrix(rnorm(120), nrow = 40)
  Y <- rnorm(40)
  CoG <- matrix(rnorm(40), nrow = 40)
  CoY <- matrix(rnorm(40), nrow = 40)
  colnames(CoG) <- "sex_male"
  colnames(CoY) <- "sex_male"

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      CoG = CoG, CoY = CoY,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      max_itr = 5,
      max_tot.itr = 80,
      tol = 2e-1,
      seed = 2026
    )
  )))

  suppressWarnings(invisible(capture.output(
    out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      CoG = CoG, CoY = CoY,
      lucid_model = "parallel",
      model = fit,
      R = 2,
      conf = 0.9
    )
  )))

  expect_true(any(grepl("hs_child_age_yrs_None", rownames(out$beta[[1]]), fixed = TRUE)))
  expect_true(any(grepl("hs_child_age_yrs_None", rownames(out$beta[[2]]), fixed = TRUE)))
  expect_true(is.finite(out$beta[[1]][1, "estimate"]))
  expect_true(is.finite(out$beta[[2]][1, "estimate"]))
})

test_that("boot_lucid parallel rejects models with unrefit feature selection", {
  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(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  fit$select$selectG[1] <- FALSE

  expect_error(
    boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 2
    ),
    "Refit LUCID model with selected feature first"
  )
})

test_that("boot_lucid parallel integrates with summary_lucid and print", {
  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(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  suppressWarnings(invisible(capture.output(
    boot_out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 3,
      conf = 0.9
    )
  )))

  s <- summary_lucid(fit, boot.se = boot_out)
  expect_s3_class(s, "sumlucid_parallel")
  expect_true(is.list(s$boot.se))
  expect_true(all(c("beta", "mu", "gamma", "bootstrap") %in% names(s$boot.se)))

  txt <- capture.output(print(s))
  expect_true(any(grepl("Detailed parameter estimates", txt)))
  expect_true(any(grepl("norm_lower", txt)))
  expect_true(any(grepl(rownames(boot_out$mu[[1]])[1], txt, fixed = TRUE)))
  beta_row_print <- sub("^Layer[0-9]+\\.", "", rownames(boot_out$beta[[1]])[1])
  expect_true(any(grepl(beta_row_print, txt, fixed = TRUE)))
})

test_that("parallel summary includes intercept in Y and E with and without bootstrap", {
  set.seed(1008)
  G <- matrix(rnorm(160), nrow = 40)
  colnames(G) <- paste0("g", 1:ncol(G))
  Z1 <- matrix(rnorm(320), nrow = 40)
  Z2 <- matrix(rnorm(320), nrow = 40)
  Y <- rnorm(40)

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

  s_plain <- summary_lucid(fit)
  txt_plain <- capture.output(print(s_plain))
  expect_true(any(grepl("^\\(Intercept\\)\\s", txt_plain)))
  expect_true(any(grepl("\\(Intercept\\)\\.cluster2", txt_plain)))

  suppressWarnings(invisible(capture.output(
    boot_out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 3,
      conf = 0.9
    )
  )))

  s_boot <- summary_lucid(fit, boot.se = boot_out)
  txt_boot <- capture.output(print(s_boot))
  expect_true(any(grepl("^\\(Intercept\\)\\s", txt_boot)))
  expect_true(any(grepl("\\(Intercept\\)\\.cluster2", txt_boot)))
  expect_true(any(grepl("norm_lower", txt_boot)))
})

test_that("boot_lucid parallel runs with mixed missingness under mix imputation", {
  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(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      init_impute = "mix",
      max_itr = 8,
      tol = 1e-1,
      seed = 1008
    )
  )))

  suppressWarnings(invisible(capture.output(
    out <- boot_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 2,
      conf = 0.9
    )
  )))

  expect_s3_class(out$bootstrap, "boot")
  expect_equal(length(out$beta), 2)
  expect_equal(length(out$mu), 2)
  expect_equal(ncol(out$gamma), 5)
})

test_that("boot_lucid parallel works for binary outcome", {
  i <- 1008
  set.seed(i)
  G <- matrix(rnorm(500), nrow = 100)
  Z1 <- matrix(rnorm(1000), nrow = 100)
  Z2 <- matrix(rnorm(1000), nrow = 100)
  Z3 <- matrix(rnorm(1000), nrow = 100)
  Y <- rbinom(n = 100, size = 1, prob = 0.25)

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G,
      Z = list(Z1, Z2, Z3),
      Y = Y,
      lucid_model = "parallel",
      family = "binary",
      K = c(2, 2, 2),
      seed = i,
      useY = TRUE
    )
  )))

  suppressWarnings(invisible(capture.output(
    out <- boot_lucid(
      G = G,
      Z = list(Z1, Z2, Z3),
      Y = Y,
      lucid_model = "parallel",
      model = fit,
      R = 2,
      conf = 0.9
    )
  )))

  expect_true(all(c("beta", "mu", "gamma", "bootstrap") %in% names(out)))
  expect_equal(length(out$beta), 3)
  expect_equal(length(out$mu), 3)
  expect_equal(ncol(out$gamma), 5)
  expect_s3_class(out$bootstrap, "boot")
  expect_true(any(is.finite(out$gamma[, "estimate"])))
})

test_that("boot_lucid parallel auto-refits zero-penalty fallback when model has nonzero penalty", {
  set.seed(2027)
  G <- matrix(rnorm(180), nrow = 45)
  Z1 <- matrix(rnorm(225), nrow = 45)
  Z2 <- matrix(rnorm(225), nrow = 45)
  Y <- rnorm(45)

  suppressWarnings(invisible(capture.output(
    fit_pen <- estimate_lucid(
      G = G, Z = list(Z1, Z2), Y = Y,
      lucid_model = "parallel",
      family = "normal",
      K = c(2, 2),
      Rho_G = 0.01,
      Rho_Z_Mu = 0.01,
      Rho_Z_Cov = 0.01,
      max_itr = 8,
      max_tot.itr = 40,
      tol = 1e-1,
      seed = 2027
    )
  )))

  out <- NULL
  expect_warning(
    invisible(capture.output(
      out <- withCallingHandlers(
        boot_lucid(
          G = G, Z = list(Z1, Z2), Y = Y,
          lucid_model = "parallel",
          model = fit_pen,
          R = 2,
          conf = 0.9
        ),
        warning = function(w) {
          if (!grepl("zero-penalty", conditionMessage(w), fixed = TRUE)) {
            invokeRestart("muffleWarning")
          }
        }
      )
    )),
    "zero-penalty"
  )

  expect_true(all(c("beta", "mu", "gamma", "bootstrap") %in% names(out)))
  expect_equal(length(out$beta), 2)
  expect_equal(length(out$mu), 2)
  expect_true(is.matrix(out$gamma))
})