R/summarize_trait_pairs.R

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

#' Summarize Trait and Keying Pairs in a Constructed Forced-Choice Test
#'
#' @description Analyzes a constructed forced-choice block design and tallies the 
#' number of equally-keyed and mixed-keyed pairs for every trait combination.
#'
#' @param blocks Either an n-by-k matrix of item IDs (where rows are blocks), 
#'        or a flat vector of ordered item IDs.
#' @param item_chars Data frame containing the item characteristics.
#' @param trait_col Character string. Name of the column in \code{item_chars} containing traits.
#' @param key_col Character string. Name of the column in \code{item_chars} containing keying directions.
#' @param block_size Integer. Required only if \code{blocks} is a flat vector. 
#'        Number of items per block.
#' @param output_format Character. Either "wide" (default, cross-tabulated summary) 
#'        or "long" (matches the exact data frame format of `build_target_dist()`).
#'
#' @return A data frame of the tallied pairs.
#' @export
summarize_trait_pairs <- function(blocks, item_chars, trait_col, key_col, block_size = NULL, 
                                  output_format = c("wide", "long")) {
  
  output_format <- match.arg(output_format)
  
  # 1. Format Input
  if (!is.matrix(blocks)) {
    if (is.null(block_size)) {
      stop("If 'blocks' is provided as a vector, 'block_size' must be specified.")
    }
    if (length(blocks) %% block_size != 0) {
      stop("The length of the items vector is not a multiple of block_size.")
    }
    blocks <- matrix(blocks, ncol = block_size, byrow = TRUE)
  } else {
    block_size <- ncol(blocks)
  }
  
  # 2. Extract traits and keys
  traits <- as.character(item_chars[[trait_col]])
  keys <- as.character(item_chars[[key_col]])
  n_blocks <- nrow(blocks)
  
  # 3. Iterate through blocks and tally pairs
  t1_list <- character()
  t2_list <- character()
  match_list <- character()
  
  for (b in 1:n_blocks) {
    for (i in 1:(block_size - 1)) {
      for (k in (i + 1):block_size) {
        
        item_i <- blocks[b, i]
        item_k <- blocks[b, k]
        
        tA <- traits[item_i]
        tB <- traits[item_k]
        kA <- keys[item_i]
        kB <- keys[item_k]
        
        # Alphabetize so "Openness-Conscientiousness" is identical to "Conscientiousness-Openness"
        t1 <- min(tA, tB)
        t2 <- max(tA, tB)
        
        t1_list <- c(t1_list, t1)
        t2_list <- c(t2_list, t2)
        
        # Check if keys match
        match_type <- ifelse(kA == kB, "equal", "mixed")
        match_list <- c(match_list, match_type)
      }
    }
  }
  
  # Base raw dataframe
  raw_pairs <- data.frame(
    trait1 = t1_list,
    trait2 = t2_list,
    match_type = match_list,
    stringsAsFactors = FALSE
  )
  
  # ---------------------------------------------------------------------------
  # 4. Format Output
  # ---------------------------------------------------------------------------
  
  if (output_format == "long") {
    # Match the `build_target_dist()` output exactly
    
    # Aggregate raw pairs into counts
    if (nrow(raw_pairs) > 0) {
      long_df <- as.data.frame(table(raw_pairs$trait1, raw_pairs$trait2, raw_pairs$match_type), stringsAsFactors = FALSE)
      colnames(long_df) <- c("trait1", "trait2", "match_type", "target")
      
      # Filter out empty zero-counts generated by table() for impossible A-B and B-A reversals
      long_df <- long_df[long_df$target > 0 | (long_df$trait1 <= long_df$trait2), ]
    } else {
      # Fallback for empty
      long_df <- data.frame(trait1 = character(), trait2 = character(), match_type = character(), target = numeric())
    }
    
    # Sort nicely (Equal first, then Mixed, ordered by trait1)
    long_df <- long_df[order(long_df$match_type, long_df$trait1, long_df$trait2), ]
    rownames(long_df) <- NULL
    long_df <- long_df[long_df$target > 0,]
    return(long_df)
    
  } else {
    # Default "wide" cross-tabulated format
    raw_pairs$trait_pair <- paste(raw_pairs$trait1, raw_pairs$trait2, sep = "-")
    
    pair_table <- table(raw_pairs$trait_pair, raw_pairs$match_type)
    summary_df <- as.data.frame.matrix(pair_table)
    
    # Ensure both 'equal' and 'mixed' columns exist
    if (!"equal" %in% colnames(summary_df)) summary_df$equal <- 0
    if (!"mixed" %in% colnames(summary_df)) summary_df$mixed <- 0
    
    # Clean up and add totals
    summary_df$total <- summary_df$equal + summary_df$mixed
    summary_df <- cbind(trait_pair = rownames(summary_df), summary_df)
    rownames(summary_df) <- NULL
    
    # Return nicely sorted
    summary_df <- summary_df[order(summary_df$trait_pair), c("trait_pair", "equal", "mixed", "total")]
    return(summary_df)
  }
}