R/simulate_fc_data.R

In autoFC: Automatic Toolkit for Construction, Optimization, Scoring and Simulation of Forced-Choice Tests

#' Simulate Observed Forced-Choice Responses from Latent Utilities
#'
#' @description Simulates observed forced-choice responses (either complete rankings,
#' Most/Least partial rankings, or binary pairwise comparisons) from a matrix of
#' continuous latent utilities and a specified block design.
#' This is used in conjunction with \code{get_simulation_matrices()}, taking
#' use of the utility values it produces.
#'
#' @param utility_data A data frame or matrix of simulated latent utilities (e.g., the
#'        \code{Utility} output from \code{get_simulation_matrices()}).
#' @param blocks A matrix of block designs where each row represents a block of
#'        item IDs (e.g., output of \code{optimize_blocks()}).
#' @param format Character. The desired output format: \code{"RANK"} for block-grouped
#'        rankings, \code{"MOLE"} for relative block position choice, or
#'        \code{"PAIRWISE"} for binary comparisons.
#' @return A data frame of the simulated observed responses.
#'         For \code{"RANK"}, columns represent the assigned rank of each item in the block
#'         (e.g., "b1_i1_rank", "b1_i2_rank").
#'         For \code{"MOLE"}, columns indicate which item slot in the block was selected as
#'         most/least (e.g., "b1_most", "b1_least" with values from 1 to block_size).
#'         For \code{"PAIRWISE"}, columns correspond to pair combinations (e.g., "i1i2").
#' @export
simulate_fc_data <- function(utility_data, blocks, format = c("RANK", "MOLE", "PAIRWISE")) {

  format <- match.arg(toupper(format), choices = c("RANK", "MOLE", "PAIRWISE"))

  utility_data <- as.matrix(utility_data)
  N <- nrow(utility_data)
  n_blocks <- nrow(blocks)
  block_size <- ncol(blocks)
  n_items <- n_blocks * block_size

  # ==========================================
  # 1. BLOCK-GROUPED RANKING FORMAT ("RANK")
  # ==========================================
  if (format == "RANK") {
    rank_df <- as.data.frame(matrix(NA, nrow = N, ncol = n_items))

    # Generate standardized, block-grouped column names (e.g., b1_i1_rank, b1_i2_rank)
    col_names <- character(n_items)
    col_idx <- 1
    for (b in 1:n_blocks) {
      for (i in 1:block_size) {
        col_names[col_idx] <- paste0("b", b, "_i", i, "_rank")
        col_idx <- col_idx + 1
      }
    }
    colnames(rank_df) <- col_names

    for (b in 1:n_blocks) {
      item_idx <- blocks[b, ] # Global item IDs in this block
      sub_util <- utility_data[, item_idx, drop = FALSE]

      # Rank row-by-row (smaller rank = higher utility/preference)
      block_ranks <- t(apply(sub_util, 1, function(x) rank(-x)))

      # Map directly to the block's designated sequential columns
      target_cols <- ((b - 1) * block_size + 1):(b * block_size)
      rank_df[, target_cols] <- block_ranks
    }
    return(rank_df)
  }

  # ==========================================
  # 2. MOST/LEAST POSITION FORMAT ("MOLE")
  # ==========================================
  if (format == "MOLE") {
    n_out_cols <- n_blocks * 2
    mole_df <- as.data.frame(matrix(NA, nrow = N, ncol = n_out_cols))

    col_names <- character(n_out_cols)
    out_idx <- 1

    for (b in 1:n_blocks) {
      item_idx <- blocks[b, ]
      sub_util <- utility_data[, item_idx, drop = FALSE]

      # Vectorized search for the local column index of max/min utility
      # This returns a number from 1 to block_size, representing the selected item slot!
      most_local_idx  <- max.col(sub_util, ties.method = "first")
      least_local_idx <- max.col(-sub_util, ties.method = "first")

      # Column 1: Which item in the block was selected as Most (1, 2, ..., block_size)
      col_names[out_idx] <- paste0("b", b, "_most")
      mole_df[, out_idx] <- most_local_idx

      # Column 2: Which item in the block was selected as Least (1, 2, ..., block_size)
      col_names[out_idx + 1] <- paste0("b", b, "_least")
      mole_df[, out_idx + 1] <- least_local_idx

      out_idx <- out_idx + 2
    }

    colnames(mole_df) <- col_names
    return(mole_df)
  }

  # ==========================================
  # 3. BINARY PAIRWISE FORMAT ("PAIRWISE")
  # ==========================================
  if (format == "PAIRWISE") {
    n_pairs <- n_blocks * (block_size * (block_size - 1) / 2)
    pairwise_df <- as.data.frame(matrix(NA, nrow = N, ncol = n_pairs))

    pair_names <- character(n_pairs)
    pair_idx <- 1

    for (b in 1:n_blocks) {
      for (i in 1:(block_size - 1)) {
        item_i_id <- blocks[b, i]
        seq_i <- (b - 1) * block_size + i
        for (k in (i + 1):block_size) {
          item_k_id <- blocks[b, k]
          seq_k <- (b - 1) * block_size + k
          pair_names[pair_idx] <- paste0("i", seq_i, "i", seq_k)
          pairwise_df[, pair_idx] <- as.numeric(utility_data[, item_i_id] > utility_data[, item_k_id])
          pair_idx <- pair_idx + 1
        }
      }
    }
    colnames(pairwise_df) <- pair_names
    return(pairwise_df)
  }
}