R/Scoring_TTE.R

In winratiosim: Simulate Power for Hierarchical Win Ratio Endpoints

#' Score Time-to-Event Pairwise Comparisons
#'
#' Assigns win, loss, or unresolved scores to subject pairs based on a
#' time-to-event endpoint. This function is typically used for the first,
#' highest-priority layer in a hierarchical win ratio analysis.
#'
#' @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 var1 Character. Name of the time-to-event column for subject 1.
#' @param var2 Character. Name of the time-to-event column for subject 2.
#' @param censor1 Character. Name of the event indicator column for subject 1,
#'   coded as 1 for event and 0 for censored.
#' @param censor2 Character. Name of the event indicator column for subject 2,
#'   coded as 1 for event and 0 for censored.
#'
#' @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, and \code{NA} when the comparison remains tied or
#'   unresolved because of censoring.
#'
#' @examples
#' pairs <- data.frame(
#'   usubjid1 = c(1, 1),
#'   usubjid2 = c(2, 3),
#'   deathdays1 = c(360, 120),
#'   deathdays2 = c(100, 200),
#'   death1 = c(0, 1),
#'   death2 = c(1, 1),
#'   score = NA_real_,
#'   WR_cat = ""
#' )
#'
#' Scoring_TTE(pairs, "deathdays1", "deathdays2", "death1", "death2")
#'
#' @export
Scoring_TTE <- function(dataset, var1, var2, censor1, censor2) {
  required <- c("score", "WR_cat", "usubjid1", "usubjid2",
                var1, var2, censor1, censor2)
  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]]
  c1 <- temp[[censor1]]
  c2 <- temp[[censor2]]

  temp$score[v1 - v2 > tol] <- 1
  temp$score[v2 - v1 > tol] <- -1

  temp$score[c1 == 1 & c2 == 0 & v1 > v2] <- NA_real_
  temp$score[c1 == 0 & c2 == 1 & v1 < v2] <- NA_real_
  temp$score[c1 == 0 & c2 == 0] <- NA_real_

  label <- gsub("[[:digit:]]+", "", var1)
  temp$WR_cat[!is.na(temp$score) & temp$score == 1] <- paste(label, "winner")
  temp$WR_cat[!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)
}