R/Scoring_Conti.R

In winratiosim: Simulate Power for Hierarchical Win Ratio Endpoints

#' Score Continuous Pairwise Comparisons
#'
#' Assigns win, loss, tie, or unresolved scores to subject pairs based on a
#' continuous endpoint. This function is typically used after higher-priority
#' layers have left a pair unresolved.
#'
#' @param dataset A data frame containing pairwise subject comparisons.
#'   The data frame must contain columns named \code{score}, \code{WR_cat},
#'   \code{usubjid1}, and \code{usubjid2}.
#' @param higher_better Character. Use \code{"Yes"} when higher values are
#'   better and \code{"No"} when lower values are better.
#' @param var1 Character. Name of the continuous endpoint column for subject 1.
#' @param var2 Character. Name of the continuous endpoint column for subject 2.
#'
#' @return A data frame matching \code{dataset}, with updated \code{score}
#'   and \code{WR_cat} columns. Scores are 1 when subject 1 wins, -1 when
#'   subject 2 wins, 0 for exact or near-exact ties, and \code{NA} when either
#'   value is missing.
#'
#' @examples
#' pairs <- data.frame(
#'   usubjid1 = c(1, 1, 2),
#'   usubjid2 = c(3, 4, 4),
#'   kccq1 = c(15, 10, NA),
#'   kccq2 = c(10, 10, 12),
#'   score = NA_real_,
#'   WR_cat = ""
#' )
#'
#' Scoring_Conti(pairs, higher_better = "Yes", var1 = "kccq1", var2 = "kccq2")
#'
#' @export
Scoring_Conti <- function(dataset, higher_better, var1, var2) {
  if (!higher_better %in% c("Yes", "No")) {
    stop('higher_better must be either "Yes" or "No".', call. = FALSE)
  }

  required <- c("score", "WR_cat", "usubjid1", "usubjid2", var1, var2)
  missing_cols <- setdiff(required, names(dataset))
  if (length(missing_cols) > 0L) {
    stop("dataset is missing required columns: ",
         paste(missing_cols, collapse = ", "), call. = FALSE)
  }

  unresolved <- is.na(dataset$score) | dataset$score == 0
  temp <- dataset[unresolved, , drop = FALSE]
  rest <- dataset[!unresolved, , drop = FALSE]

  tol <- 1e-10
  v1 <- temp[[var1]]
  v2 <- temp[[var2]]
  diff <- v1 - v2

  if (higher_better == "Yes") {
    temp$score[diff >= tol] <- 1
    temp$score[abs(diff) < tol] <- 0
    temp$score[-diff >= tol] <- -1
  } else {
    temp$score[-diff >= tol] <- 1
    temp$score[abs(diff) < tol] <- 0
    temp$score[diff >= tol] <- -1
  }

  temp$score[is.na(v1) | is.na(v2)] <- NA_real_

  label <- gsub("[[:digit:]]+", "", var1)
  unresolved_label <- is.na(temp$WR_cat) | temp$WR_cat == ""
  temp$WR_cat[unresolved_label & !is.na(temp$score) & temp$score == 1] <-
    paste(label, "winner")
  temp$WR_cat[unresolved_label & !is.na(temp$score) & temp$score == -1] <-
    paste(label, "loser")

  out <- rbind(temp, rest)
  out <- out[order(out$usubjid1, out$usubjid2), , drop = FALSE]
  as.data.frame(out)
}