R/reduce_design_global_only.R

In GPCMlasso: Regularized Explanatory Generalized Partial Credit Models

reduce_to_global_only_design <- function(design_list) {
  
  if (is.null(design_list$designX) || ncol(design_list$designX) == 0) {
    design_list$include.item.effects <- FALSE
    return(design_list)
  }
  
  m <- design_list$m
  n_design <- ncol(design_list$design)
  n_sigma <- design_list$n_sigma
  
  if (m <= 0) {
    design_list$include.item.effects <- FALSE
    return(design_list)
  }
  
  if (ncol(design_list$designX) < m) {
    stop("Global-only reduction failed: designX has fewer columns than m.")
  }
  
  ## keep only global covariate effects
  designX_new <- design_list$designX[, seq_len(m), drop = FALSE]
  
  ## new number of parameters
  px_new <- n_design + ncol(designX_new) + n_sigma
  
  ## build new penalty matrix:
  ## rows correspond to c(design parameters, global covariates, sigma)
  ## columns correspond to penalized global covariate effects
  acoefs_new <- matrix(0, nrow = px_new, ncol = m)
  acoefs_new[n_design + seq_len(m), seq_len(m)] <- diag(m)
  
  ## update sd.vec if present
  if (!is.null(design_list$sd.vec)) {
    keep_idx <- c(
      seq_len(n_design),
      n_design + seq_len(m),
      tail(seq_along(design_list$sd.vec), n_sigma)
    )
    design_list$sd.vec <- design_list$sd.vec[keep_idx]
  }
  
  design_list$designX <- designX_new
  design_list$acoefs <- acoefs_new
  design_list$px <- px_new
  design_list$include.item.effects <- FALSE
  
  design_list
}