tests/testthat/test-early-robustness.R

In LUCIDus: LUCID with Multiple Omics Data

# Additional robustness tests for early LUCID workflow

test_that("early missing data with LOD imputation returns finite posteriors", {
  G <- sim_data$G[1:180, ]
  Z <- sim_data$Z[1:180, ]
  Y <- sim_data$Y_normal[1:180, ]

  # Introduce sporadic missingness
  Z[1:30, 1] <- NA
  Z[31:60, 2] <- NA

  set.seed(1008)
  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      init_impute = "lod",
      useY = TRUE,
      seed = 1008
    )
  )))

  expect_s3_class(fit, "early_lucid")
  expect_true(all(is.finite(fit$inclusion.p)))
  expect_equal(nrow(fit$inclusion.p), nrow(G))
})

test_that("early missing data keeps all-missing rows as NA in stored Z", {
  G <- sim_data$G[1:120, ]
  Z <- sim_data$Z[1:120, ]
  Y <- sim_data$Y_normal[1:120, ]

  # Entire first row missing in omics
  Z[1, ] <- NA

  set.seed(1008)
  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      init_impute = "mix",
      seed = 1008
    )
  )))

  expect_s3_class(fit, "early_lucid")
  expect_true(all(is.na(fit$Z[1, ])))
})

test_that("tune_lucid early over K grid returns one row per K candidate", {
  G <- sim_data$G[1:160, ]
  Z <- sim_data$Z[1:160, ]
  Y <- sim_data$Y_normal[1:160, ]

  suppressWarnings(invisible(capture.output(
    tuned <- tune_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2:3,
      seed = 1008,
      useY = TRUE
    )
  )))

  expect_equal(nrow(tuned$tune_list), 2)
  expect_true("BIC" %in% colnames(tuned$tune_list))
  expect_s3_class(tuned$best_model, "early_lucid")
})

test_that("tune_lucid early over penalty grid returns full combinations", {
  G <- sim_data$G[1:140, ]
  Z <- sim_data$Z[1:140, ]
  Y <- sim_data$Y_normal[1:140, ]

  suppressWarnings(invisible(capture.output(
    tuned <- tune_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      Rho_G = c(0, 0.01),
      Rho_Z_Mu = c(0, 1),
      Rho_Z_Cov = 0,
      seed = 1008,
      useY = TRUE
    )
  )))

  expect_equal(nrow(tuned$tune_list), 4)
  expect_true("BIC" %in% colnames(tuned$tune_list))
  expect_type(tuned$res_model, "list")
})

test_that("lucid wrapper chooses one K from candidate vector", {
  G <- sim_data$G[1:180, ]
  Z <- sim_data$Z[1:180, ]
  Y <- sim_data$Y_normal[1:180, ]

  suppressWarnings(invisible(capture.output(
    fit <- lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2:3,
      seed = 1008
    )
  )))

  expect_s3_class(fit, "early_lucid")
  expect_true(fit$K %in% c(2, 3))
})

test_that("lucid wrapper with Rho_G vector returns logical selectG", {
  G <- sim_data$G[1:180, ]
  Z <- sim_data$Z[1:180, ]
  Y <- sim_data$Y_binary[1:180, ]
  cov <- sim_data$Covariate[1:180, ]

  suppressWarnings(invisible(capture.output(
    fit <- lucid(
      G = G, Z = Z, Y = Y,
      CoY = cov,
      lucid_model = "early",
      family = "binary",
      K = 2,
      Rho_G = c(0, 0.05),
      seed = 1008
    )
  )))

  expect_type(fit$select$selectG, "logical")
  expect_true(length(fit$select$selectG) >= 1)
  expect_true(length(fit$select$selectG) <= ncol(G))
})

test_that("lucid early preserves tuned Rho values in refit model metadata", {
  G <- sim_data$G[1:160, ]
  Z <- sim_data$Z[1:160, ]
  Y <- sim_data$Y_normal[1:160, ]

  suppressWarnings(invisible(capture.output(
    fit <- lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      Rho_G = 0.01,
      Rho_Z_Mu = 0.1,
      Rho_Z_Cov = 0.01,
      max_itr = 8,
      max_tot.itr = 20,
      tol = 1e-2,
      seed = 1008
    )
  )))

  expect_equal(fit$Rho$Rho_G, 0.01)
  expect_equal(fit$Rho$Rho_Z_Mu, 0.1)
  expect_equal(fit$Rho$Rho_Z_Cov, 0.01)
})

test_that("lucid early penalty refit uses tuned scalar K (not candidate grid)", {
  G <- sim_data$G[1:160, ]
  Z <- sim_data$Z[1:160, ]
  Y <- sim_data$Y_normal[1:160, ]

  suppressWarnings(invisible(capture.output(
    fit <- lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2:3,
      Rho_G = c(0, 0.01),
      Rho_Z_Mu = 0,
      Rho_Z_Cov = 0,
      max_itr = 8,
      max_tot.itr = 20,
      tol = 1e-2,
      seed = 1008
    )
  )))

  expect_s3_class(fit, "early_lucid")
  expect_true(is.numeric(fit$K))
  expect_equal(length(fit$K), 1)
  expect_true(fit$K %in% c(2, 3))
})

test_that("lucid wrapper rejects negative penalties", {
  G <- sim_data$G[1:120, ]
  Z <- sim_data$Z[1:120, ]
  Y <- sim_data$Y_normal[1:120, ]

  expect_error(
    lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      Rho_G = -0.01
    ),
    "greater than or equal to 0"
  )
})

test_that("estimate_lucid binary rejects non 0-1 outcomes", {
  G <- sim_data$G[1:120, ]
  Z <- sim_data$Z[1:120, ]
  Y <- sim_data$Y_binary[1:120, ] + 1

  expect_error(
    estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "binary",
      K = 2
    ),
    "coded as 0 and 1|contain only 0s and 1s"
  )
})

test_that("early g-computation returns pred.z and normalized inclusion probabilities", {
  G <- sim_data$G[1:150, ]
  Z <- sim_data$Z[1:150, ]
  Y <- sim_data$Y_binary[1:150, ]
  cov <- sim_data$Covariate[1:150, ]

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      CoY = cov,
      lucid_model = "early",
      family = "binary",
      K = 2,
      seed = 1008
    )
  )))

  pred <- predict_lucid(
    model = fit,
    lucid_model = "early",
    G = G,
    Z = Z,
    Y = NULL,
    CoY = cov,
    g_computation = TRUE
  )

  expect_true("pred.z" %in% names(pred))
  expect_equal(nrow(pred$pred.z), nrow(G))
  expect_equal(rowSums(pred$inclusion.p), rep(1, nrow(G)), tolerance = 1e-6)
})

test_that("summary_lucid early exposes top-level and nested BIC consistently", {
  G <- sim_data$G[1:140, ]
  Z <- sim_data$Z[1:140, ]
  Y <- sim_data$Y_normal[1:140, ]

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      seed = 1008
    )
  )))

  s <- summary_lucid(fit)
  expect_s3_class(s, "sumlucid_early")
  expect_true(is.numeric(s$BIC))
  expect_equal(s$BIC, s$model_fit$BIC, tolerance = 1e-8)
})

test_that("summary_lucid early reports listwise and sporadic missing-data profile", {
  G <- sim_data$G[1:120, ]
  Z <- sim_data$Z[1:120, ]
  Y <- sim_data$Y_normal[1:120, ]
  Z[1, ] <- NA
  Z[2:4, 1] <- NA

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      seed = 1008
    )
  )))

  s <- summary_lucid(fit)
  expect_s3_class(s, "sumlucid_early")
  expect_false(is.null(s$missing_data))
  expect_equal(s$missing_data$listwise_rows, 1)
  expect_equal(s$missing_data$sporadic_rows, 3)
  out <- capture.output(print(s))
  expect_true(any(grepl("Missing-data profile", out)))
})

test_that("estimate_lucid early stores EM control settings for bootstrap reuse", {
  G <- sim_data$G[1:120, ]
  Z <- sim_data$Z[1:120, ]
  Y <- sim_data$Y_normal[1:120, ]

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      lucid_model = "early",
      family = "normal",
      K = 2,
      tol = 1e-2,
      max_itr = 9,
      max_tot.itr = 30,
      seed = 1008
    )
  )))

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

test_that("summary_lucid early prints intercept (not forced cluster1=0) when CoY is included", {
  G <- sim_data$G[1:140, ]
  Z <- sim_data$Z[1:140, ]
  Y <- sim_data$Y_normal[1:140, ]
  CoY <- sim_data$Covariate[1:140, , drop = FALSE]

  suppressWarnings(invisible(capture.output(
    fit <- estimate_lucid(
      G = G, Z = Z, Y = Y,
      CoY = CoY,
      lucid_model = "early",
      family = "normal",
      K = 2,
      seed = 1008
    )
  )))

  s <- summary_lucid(fit)
  out <- capture.output(print(s))
  expect_true(any(grepl("^\\(Intercept\\)\\s", out)))
  expect_false(any(grepl("^cluster1\\s+0", out)))
})