R/00_BiclusterUtils.R

In exametrika: Test Data Engineering

#' @title Initialize field membership profile probabilities
#' @description
#' Calculates initial probabilities for the field membership profile matrix
#' in biclustering analysis. This function generates probability distributions
#' based on class and field effects to initialize the profile matrix.
#' @param Q Number of categories
#' @param class_effect Class effect parameter (numeric value influencing class-based probabilities)
#' @param field_effect Field effect parameter (numeric value influencing field-based probabilities)
#' @return A normalized probability vector of length Q for initializing the field membership profile matrix
#' @noRd
init_field_membership_probs <- function(Q, class_effect, field_effect) {
  q_vals <- 1:Q / Q
  high_influence <- q_vals * class_effect
  low_influence <- q_vals[order(q_vals, decreasing = TRUE)] * field_effect
  probs <- high_influence + low_influence
  return(probs / sum(probs))
}

#' @title Check for empty fields in Biclustering
#' @description
#' Checks if any fields have no items assigned after Biclustering estimation.
#' This can occur when the specified number of fields is too large for the data,
#' causing some fields to be empty. Emits a warning message if empty fields are detected.
#' @param fld Vector of field assignments for each item
#' @param nfld Number of specified fields
#' @noRd
check_empty_fields <- function(fld, nfld) {
  empty_fields <- setdiff(1:nfld, unique(fld))
  if (length(empty_fields) > 0) {
    n_effective <- nfld - length(empty_fields)
    warning(
      sprintf(
        "Only %d of %d specified fields have items assigned. Fields %s are empty. Consider reducing nfld.",
        n_effective, nfld, paste(empty_fields, collapse = ", ")
      ),
      call. = FALSE
    )
  }
}

#' @title Create filter matrix for clustering
#' @description
#' Generates a filter matrix used in clustering algorithms. The matrix is constructed
#' with diagonal elements based on the number of classes, and off-diagonal elements
#' that create a tridiagonal structure. The first and last columns are normalized.
#' @param ncls Number of classes (integer value determining the matrix dimensions)
#' @return A square filter matrix of size ncls x ncls with normalized first and last columns
#' @noRd
create_filter_matrix <- function(ncls) {
  f0 <- ifelse(ncls < 5, 1.05 - 0.05 * ncls,
    ifelse(ncls < 10, 1.00 - 0.04 * ncls,
      0.80 - 0.02 * ncls
    )
  )
  f1 <- diag(0, ncls)
  f1[row(f1) == col(f1) - 1] <- (1 - f0) / 2
  Fil <- diag(rep(f0, ncls)) + t(f1) + f1
  Fil[, 1] <- Fil[, 1] / sum(Fil[, 1])
  Fil[, ncls] <- Fil[, ncls] / sum(Fil[, ncls])

  return(Fil)
}

#' @title Remap polytomous category codes to contiguous 1-based indices
#' @description
#' Response matrices produced by dataFormat() preserve the caller's raw
#' category codes (e.g. 0-indexed 0..3, or codes with gaps), with missing
#' cells marked as -1. Biclustering/Biclustering_IRM's one-hot encoding
#' indexes an array directly by these raw codes, so a raw code of 0 is
#' silently dropped (R's array-index semantics treat 0 as "select nothing")
#' and any non-contiguous coding misaligns with the array's category
#' dimension. This remaps each item's own observed codes to `1..ncat[j]`,
#' leaving -1 (missing) untouched, mirroring the equivalent remap already
#' done in GRM().
#' @param Q Response matrix (nobs x nitems) with -1 marking missing cells
#' @return Q with each column's non-missing values remapped to `1..ncat[j]`
#' @noRd
remap_category_codes <- function(Q) {
  for (j in seq_len(NCOL(Q))) {
    valid_j <- Q[, j] != -1
    Q[valid_j, j] <- match(Q[valid_j, j], sort(unique(Q[valid_j, j])))
  }
  Q
}