R/compare_waves_batch.R

In wavecov: Overlap-Aware Workforce Wave Comparisons

#' Batch comparisons of multiple waves and metrics
#'
#' @param data ...
#' @param wave_pairs ...
#' @param id_col ...
#' @param wave_col ...
#' @param metric_col ...
#' @param metric_id_col ...
#' @param group_cols ...
#' @param method ...
#' @param reliability ...
#' @param sigma2 ...
#' @param sigma2S ...
#' @param level ...
#' @param ... ...
#'
#' @return ...
#' @export
compare_waves_batch <- function(
    data,
    wave_pairs,
    id_col,
    wave_col,
    metric_col,
    metric_id_col = NULL,
    group_cols = NULL,
    method = c("linked", "reliability", "bounds", "auto", "ols"),
    reliability = NULL,
    sigma2 = NULL,
    sigma2S = NULL,
    level = 0.95,
    ...
) {
  method <- match.arg(method)
  
  if (!is.data.frame(data)) {
    stop("`data` must be a data.frame.")
  }
  
  if (!is.matrix(wave_pairs) && !is.data.frame(wave_pairs)) {
    stop("`wave_pairs` must be a two-column matrix or data.frame.")
  }
  if (ncol(wave_pairs) != 2L) {
    stop("`wave_pairs` must have exactly two columns: wave_0 and wave_1.")
  }
  
  # Standardize wave_pairs as data.frame with names wave_0, wave_1
  wave_pairs <- as.data.frame(wave_pairs, stringsAsFactors = FALSE)
  colnames(wave_pairs) <- c("wave_0", "wave_1")
  
  # Build grouping specification
  all_group_cols <- c(group_cols, metric_id_col)
  all_group_cols <- all_group_cols[!is.null(all_group_cols)]
  
  if (length(all_group_cols) > 0L) {
    split_keys   <- data[all_group_cols]
    groups       <- base::split(data, split_keys, drop = TRUE)
  } else {
    groups       <- list(data)
  }
  
  results <- list()
  idx <- 1L
  
  for (g in seq_along(groups)) {
    group_data <- groups[[g]]
    
    if (length(all_group_cols) > 0L) {
      group_vals <- unique(group_data[all_group_cols])
      if (nrow(group_vals) != 1L) {
        stop("Each group defined by group_cols/metric_id_col must yield exactly one row of grouping values.")
      }
      group_vals_list <- as.list(group_vals[1, , drop = FALSE])
    } else {
      group_vals_list <- list()
    }
    
    for (p in seq_len(nrow(wave_pairs))) {
      w0 <- wave_pairs$wave_0[p]
      w1 <- wave_pairs$wave_1[p]
      
      row_id <- idx
      idx <- idx + 1L
      
      # Base fields always present
      base_row <- c(
        list(
          wave_0 = w0,
          wave_1 = w1,
          status = "ok",
          method = NA_character_,
          error  = NA_character_
        ),
        group_vals_list
      )
      
      # Try scalar compare_waves on this subset
      out <- try(
        compare_waves(
          data        = group_data,
          wave_0      = w0,
          wave_1      = w1,
          id_col      = id_col,
          wave_col    = wave_col,
          metric_col  = metric_col,
          method      = method,
          reliability = reliability,
          sigma2      = sigma2,
          sigma2S     = sigma2S,
          level       = level,
          ...
        ),
        silent = TRUE
      )
      
      if (inherits(out, "try-error")) {
        base_row$status <- "error"
        base_row$error  <- as.character(out)
        results[[row_id]] <- base_row
        next
      }
      
      # Successful scalar compare_waves() call: build a single summary row
      res_list <- list(
        estimate   = out$estimate,
        se         = out$se,
        ci_lower   = if (!is.null(out$ci)) out$ci[1] else NA_real_,
        ci_upper   = if (!is.null(out$ci)) out$ci[2] else NA_real_,
        level      = out$level,
        N0         = out$N0,
        N1         = out$N1,
        nS         = out$nS,
        overlap    = out$overlap,
        V0_bar     = out$V0_bar,
        V1_bar     = out$V1_bar,
        C01_bar    = out$C01_bar,
        V0_ind     = out$V0_ind,
        V1_ind     = out$V1_ind,
        C01_ind    = out$C01_ind,
        sigma2     = out$sigma2,
        reliability = out$reliability
      )
      
      base_row$method <- out$method %||% method  # or just out$method if always present
      
      full_row <- c(base_row, res_list)
      results[[row_id]] <- full_row
    }
  }
  
  if (length(results) == 0L) {
    return(data.frame())
  }
  
  # Robust normalization and binding: fixed schema, fixed order
  all_cols <- unique(unlist(lapply(results, names)))
  
  results_df_list <- lapply(results, function(r) {
    row_list <- vector("list", length(all_cols))
    names(row_list) <- all_cols
    
    for (nm in all_cols) {
      val <- r[[nm]]
      if (is.null(val)) val <- NA
      row_list[[nm]] <- val
    }
    
    as.data.frame(row_list, stringsAsFactors = FALSE)
  })
  
  out_df <- base::do.call(base::rbind, results_df_list)
  base::rownames(out_df) <- NULL
  
  # Drop exact duplicate rows (e.g., if a combination was added twice)
  out_df <- unique(out_df)
  
  out_df
}