# get_selected_G()/get_selected_Z() (from the package itself) already return a
# well-shaped, aligned logical mask straight from the fitted object -- no
# length mismatch is possible, since they derive it from the model's own
# recorded fields. The one thing left for a tutorial to decide is what to do
# if a penalty happened to deselect EVERY feature: refitting on zero columns
# would fail, so this keeps everything instead in that one edge case.
keep_or_all <- function(mask) if (any(mask, na.rm = TRUE)) mask else rep(TRUE, length(mask))
# Build selected-only inputs for early model.
prepare_early_selected_inputs <- function(fit_pen, G, Z) {
list(
G = as.matrix(G[, keep_or_all(get_selected_G(fit_pen)), drop = FALSE]),
Z = as.matrix(Z[, keep_or_all(get_selected_Z(fit_pen)), drop = FALSE])
)
}
# Build selected-only inputs for parallel model.
prepare_parallel_selected_inputs <- function(fit_pen, G, Z) {
keep_g <- keep_or_all(get_selected_G(fit_pen))
Z_sel <- lapply(seq_along(Z), function(i) {
zi <- as.matrix(Z[[i]])
zi[, keep_or_all(get_selected_Z(fit_pen, layer = i)), drop = FALSE]
})
names(Z_sel) <- names(Z)
list(
G = as.matrix(G[, keep_g, drop = FALSE]),
Z = Z_sel
)
}
# Serial stage>1 uses latent-cluster-derived "G" internally.
# We therefore subset stage-1 original G and each stage's Z where applicable.
prepare_serial_selected_inputs <- function(fit_pen, G, Z) {
G_refit <- as.matrix(G)
keep_g1 <- get_selected_G(fit_pen)
if (length(keep_g1) == ncol(G_refit)) {
G_refit <- G_refit[, keep_or_all(keep_g1), drop = FALSE]
}
selected_z <- get_selected_Z(fit_pen)
Z_refit <- Z
for (i in seq_along(fit_pen$submodel)) {
sm <- fit_pen$submodel[[i]]
if (inherits(sm, "early_lucid")) {
zi <- as.matrix(Z_refit[[i]])
Z_refit[[i]] <- zi[, keep_or_all(selected_z[[i]]), drop = FALSE]
} else if (inherits(sm, "lucid_parallel")) {
zi_list <- Z_refit[[i]]
for (j in seq_along(zi_list)) {
zij <- as.matrix(zi_list[[j]])
zi_list[[j]] <- zij[, keep_or_all(selected_z[[i]][[j]]), drop = FALSE]
}
Z_refit[[i]] <- zi_list
}
}
list(G = G_refit, Z = Z_refit)
}
# Zero-penalty refit, for any model type.
#
# The three model types previously had three byte-identical wrappers differing
# only in `lucid_model` and whether `useY` was forwarded; they are one function
# here. Everything about the model -- family, K, initialization, EM controls --
# is carried over from the screening fit, so the ONLY difference between the
# screening fit and this one is that the penalties are zero. That is what makes
# the refit estimates unshrunk and therefore suitable for bootstrap inference.
refit_selected <- function(model_type, fit_pen, inputs, Y,
CoG = NULL, CoY = NULL, seed = 1, verbose = FALSE) {
args <- list(
lucid_model = model_type,
G = inputs$G,
Z = inputs$Z,
Y = Y,
CoG = CoG,
CoY = CoY,
family = fit_pen$family,
K = fit_pen$K,
init_omic.data.model = fit_pen$init_omic.data.model,
init_impute = fit_pen$init_impute,
init_par = fit_pen$init_par,
Rho_G = 0,
Rho_Z_Mu = 0,
Rho_Z_Cov = 0,
max_itr = fit_pen$em_control$max_itr,
max_tot.itr = fit_pen$em_control$max_tot.itr,
tol = fit_pen$em_control$tol,
seed = seed,
verbose = verbose
)
# Every fitted class records useY, so it is carried over for all three model
# types. The original three wrappers omitted it on the early path, which meant
# an unsupervised screening fit would have been silently refitted supervised.
args$useY <- fit_pen$useY
do.call(estimate_lucid, args)
}
# Dispatcher for the three input-preparation helpers above.
prepare_selected_inputs <- function(model_type, fit_pen, G, Z) {
switch(model_type,
early = prepare_early_selected_inputs(fit_pen, G, Z),
parallel = prepare_parallel_selected_inputs(fit_pen, G, Z),
serial = prepare_serial_selected_inputs(fit_pen, G, Z),
stop("unknown model_type: ", model_type)
)
}
# Compact stage-wise feature-selection report for serial fits, built entirely
# from get_selected_G()/get_selected_Z() -- no per-stage dispatch of its own.
serial_selection_report <- function(fit_serial_pen) {
selected_z <- get_selected_Z(fit_serial_pen)
out <- vector("list", length(fit_serial_pen$submodel))
for (i in seq_along(fit_serial_pen$submodel)) {
sm <- fit_serial_pen$submodel[[i]]
if (inherits(sm, "early_lucid")) {
out[[i]] <- list(
stage = i,
model = "early",
selected_G = if (i == 1) sum(get_selected_G(fit_serial_pen)) else NA,
total_G = if (i == 1) length(get_selected_G(fit_serial_pen)) else NA,
selected_Z = sum(selected_z[[i]]),
total_Z = length(selected_z[[i]])
)
} else {
out[[i]] <- list(
stage = i,
model = "parallel",
selected_G = if (i == 1) sum(get_selected_G(fit_serial_pen)) else NA,
total_G = if (i == 1) length(get_selected_G(fit_serial_pen)) else NA,
selected_Z_by_layer = sapply(selected_z[[i]], sum),
total_Z_by_layer = sapply(selected_z[[i]], length)
)
}
}
out
}
