From 5cbea3b83c8d7baeebf2682cc1ec6e86ca226e9b Mon Sep 17 00:00:00 2001 From: Ken Taylor Date: Fri, 12 Dec 2025 08:58:46 -0500 Subject: [PATCH 1/5] Add compare_groups() function with documentation and tests --- NAMESPACE | 1 + R/compare_groups.R | 160 +++++++ R/comparison_helpers.R | 248 ++++++++++ R/validation_helpers.R | 90 ++++ man/compare_groups.Rd | 111 +++++ tests/testthat/_snaps/comparison_helpers.md | 121 +++++ tests/testthat/test-comparison_helpers.R | 478 ++++++++++++++++++++ 7 files changed, 1209 insertions(+) create mode 100644 R/compare_groups.R create mode 100644 R/comparison_helpers.R create mode 100644 man/compare_groups.Rd create mode 100644 tests/testthat/_snaps/comparison_helpers.md create mode 100644 tests/testthat/test-comparison_helpers.R diff --git a/NAMESPACE b/NAMESPACE index 7f7a5c3..44210fb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ S3method(print,mcc_comparison) S3method(print,summary.mcc) S3method(summary,mcc) export(as_mcc) +export(compare_groups) export(compare_mcc) export(filter_mcc) export(geom_line_mcc) diff --git a/R/compare_groups.R b/R/compare_groups.R new file mode 100644 index 0000000..c1aa0af --- /dev/null +++ b/R/compare_groups.R @@ -0,0 +1,160 @@ +#' Compare MCC Between Groups +#' +#' @description +#' Create pairwise comparisons of mean cumulative count (MCC) between groups +#' using mean cumulative count difference (MCCD) and/or mean cumulative count +#' ratio (MCCR). This function only works with grouped `mcc` objects. +#' +#' @details +#' The difference (MCCD) and/or ratio (MCCR) of MCC values are calculated +#' between groups over time. When comparing groups with different maximum +#' follow-up times, comparisons are automatically truncated at the minimum of +#' the two maximum follow-up times (e.g., if one group has a year of follow-up +#' and the other has 1.5 years, then comparisons will only be calculated up to +#' 1 year). For time points where groups have misaligned observation times, +#' last observation carried forward (LOCF) is used within each group's own +#' follow-up period, providing comparisons across all event times as long as +#' they occur during the shared follow-up period. +#' +#' **Comparison Measures:** +#' - MCCD (difference): `MCC_group1 - MCC_reference` +#' - MCCR (ratio): `MCC_group1 / MCC_reference` +#' +#' @param x (`mcc_grouped`)\cr A grouped `mcc` object (created with `by` +#' argument in [mcc()]) +#' @param reference (`string`, optional)\cr Specifies the reference group(s) to +#' use when calculating comparisons (see details below to understand how +#' the `reference` group is used in `measure` calculations. If `NULL` +#' (default), then the first group alphabetically is used as the +#' `reference`. When `pairwise = TRUE` and there are > 2 groups being +#' compared, this argument can accept a vector of group names (in priority +#' order) to use as the `reference` in each `pairwise` comparison. +#' @param pairwise (`logical`)\cr Whether to perform all possible pairwise +#' comparisons when > 2 groups are present. If `FALSE` (default), +#' compares all groups to a single `reference` group only. +#' @param measure (`string`)\cr Specifies which MCC comparison measure(s) to +#' calculate:`"difference"` (default), `"ratio"`, or `"both"` +#' +#' @returns An S3 object of class `mcc_group_comparison` containing: +#' - `comparisons`: List of data frames with comparison results over time +#' - `metadata`: List with comparison parameters and settings +#' - `original_mcc`: The input `mcc` object +#' - `call`: The matched call +#' +#' @export +#' +#' @examples +#' # Create sample data with 2 groups +#' library(dplyr) +#' df <- data.frame( +#' id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), +#' time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), +#' cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), +#' group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +#' ) |> +#' arrange(id, time) +#' +#' # Calculate grouped MCC +#' mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +#' +#' # Compare groups (difference by default) +#' comparison <- compare_groups(mcc_grouped, reference = "B") +#' +#' # Compare using ratio +#' comparison_ratio <- compare_groups(mcc_grouped, reference = "B", measure = "ratio") +#' +#' # Get both measures +#' comparison_both <- compare_groups(mcc_grouped, reference = "B", measure = "both") +#' +#' # Three group example with pairwise comparisons +#' df3 <- data.frame( +#' id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), +#' time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), +#' cause = c(0, 0, 2, 1, 0, 1, 0, 1, 2, 2, 1, 0, 0), +#' group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") +#' ) +#' +#' mcc_3group <- mcc(df3, "id", "time", "cause", by = "group") +#' +#' # All pairwise comparisons +#' comparison_pairwise <- compare_groups(mcc_3group, pairwise = TRUE) +#' +#' # Compare to specific reference +#' comparison_vs_a <- compare_groups(mcc_3group, reference = "A") +#' +#' # Pairwise with reference preference order +#' # Prefers A as reference, then B, then C +#' comparison_pref <- compare_groups( +#' mcc_3group, +#' reference = c("A", "B", "C"), +#' pairwise = TRUE +#' ) +#' +compare_groups <- function( + x, + reference = NULL, + pairwise = FALSE, + measure = c("difference", "ratio", "both") +) { + # Validate inputs + validate_comparison_inputs(x, reference, pairwise) + + # Match measure argument + measure <- match.arg(measure) + + # Get all groups + all_groups <- mcc_groups(x) + + # Validate and handle reference selection + reference_info <- validate_reference_selection( + reference = reference, + all_groups = all_groups, + pairwise = pairwise + ) + + # Create comparison pairs + comparison_pairs <- create_comparison_pairs( + all_groups = all_groups, + reference = reference_info$reference, + pairwise = pairwise + ) + + # Perform comparisons + comparison_results <- perform_comparisons( + x = x, + comparison_pairs = comparison_pairs, + measure = measure + ) + + # Compile metadata + metadata <- list( + reference_group = if (!pairwise) reference_info$reference else NULL, + reference_preferences = if (pairwise && !is.null(reference)) + reference_info$reference else NULL, + pairwise = pairwise, + measure = measure, + n_comparisons = length(comparison_results$comparisons), + comparison_pairs = comparison_results$pairs_df, + weighted = x$weighted, + method = x$method, + grouping_var = x$by_group + ) + + # Create output object + result <- structure( + list( + comparisons = comparison_results$comparisons, + metadata = metadata, + original_mcc = x, + call = match.call() + ), + class = c("mcc_group_comparison", "list") + ) + + # Issue warning if defaults were used in pairwise comparisons + if (pairwise && any(comparison_results$pairs_df$default_used)) { + issue_default_reference_warning(comparison_results$pairs_df) + } + + return(result) +} diff --git a/R/comparison_helpers.R b/R/comparison_helpers.R new file mode 100644 index 0000000..1853e70 --- /dev/null +++ b/R/comparison_helpers.R @@ -0,0 +1,248 @@ +#' Determine reference for a pair of groups +#' @keywords internal +#' @noRd +determine_pair_reference <- function(pair, reference_prefs) { + group1 <- pair[1] + group2 <- pair[2] + + if (is.null(reference_prefs)) { + # Default to first alphabetically + ref <- sort(c(group1, group2))[1] + comp <- setdiff(c(group1, group2), ref) + default_used <- TRUE + } else { + # Find first preference that exists in this pair + ref_found <- reference_prefs[reference_prefs %in% c(group1, group2)] + + if (length(ref_found) > 0) { + ref <- ref_found[1] # First match in preference order + comp <- setdiff(c(group1, group2), ref) + default_used <- FALSE + } else { + # None of the preferences exist in this pair + ref <- sort(c(group1, group2))[1] + comp <- setdiff(c(group1, group2), ref) + default_used <- TRUE + } + } + + return(list(ref = ref, comp = comp, default_used = default_used)) +} + +#' Create comparison pairs +#' @keywords internal +#' @noRd +create_comparison_pairs <- function(all_groups, reference, pairwise) { + if (!pairwise) { + # Compare all groups to reference + other_groups <- setdiff(all_groups, reference) + pairs <- lapply(other_groups, function(g) { + list(ref = reference, comp = g, default_used = FALSE) + }) + } else { + # Create all pairwise combinations + group_combinations <- combn(all_groups, 2, simplify = FALSE) + + # Determine reference for each pair + pairs <- lapply(group_combinations, function(pair) { + determine_pair_reference(pair, reference) + }) + } + + return(pairs) +} + +#' Get MCC column name based on method +#' @keywords internal +#' @noRd +get_mcc_column_name <- function(mcc_object) { + if (mcc_object$method == "equation") { + return("mcc") + } else { + return("SumCIs") + } +} + +#' Align MCC data to common time grid using LOCF +#' @keywords internal +#' @noRd +align_mcc_times <- function( + group1_data, + group2_data, + truncate_at, + mcc_col +) { + # Filter to truncation time + group1_data <- group1_data[group1_data$time <= truncate_at, ] + group2_data <- group2_data[group2_data$time <= truncate_at, ] + + # Get union of time points + all_times <- sort(unique(c(group1_data$time, group2_data$time))) + + # Create step functions for LOCF (right-continuous) + # Using approxfun with method="constant", rule=2, f=0 + locf_group1 <- stats::approxfun( + x = group1_data$time, + y = group1_data[[mcc_col]], + method = "constant", + rule = 2, + f = 0, # Right-continuous + ties = "ordered" + ) + + locf_group2 <- stats::approxfun( + x = group2_data$time, + y = group2_data[[mcc_col]], + method = "constant", + rule = 2, + f = 0, # Right-continuous + ties = "ordered" + ) + + # Apply LOCF to get values at all time points + mcc_group1 <- locf_group1(all_times) + mcc_group2 <- locf_group2(all_times) + + # Return aligned data + data.frame( + time = all_times, + mcc_group1 = mcc_group1, + mcc_group2 = mcc_group2 + ) +} + +#' Calculate comparison measures +#' @keywords internal +#' @noRd +calculate_measures <- function(aligned_data, measure, ref_name, comp_name) { + result <- aligned_data + result$reference <- ref_name + result$comparison <- comp_name + + # Calculate difference + if (measure %in% c("difference", "both")) { + result$mccd <- result$mcc_group1 - result$mcc_group2 + } + + # Calculate ratio + if (measure %in% c("ratio", "both")) { + # Check for zero in denominator + zero_denom <- result$mcc_group2 == 0 + both_zero <- result$mcc_group1 == 0 & result$mcc_group2 == 0 + + # When both are zero, set ratio to 1.0 (for graphing purposes) + # When only denominator is zero, set to NA + if (any(zero_denom & !both_zero)) { + cli::cli_warn(c( + "!" = "Reference group MCC = 0 at {.val {sum(zero_denom & !both_zero)}} time point{?s}", + "i" = "MCCR set to {.val NA} at these times", + "i" = "Comparison: {.val {comp_name}} vs {.val {ref_name}}" + )) + } + + # Calculate ratio: + # - Both zero: set to 1.0 + # - Only denominator zero: set to NA + # - Otherwise: calculate ratio + result$mccr <- ifelse( + both_zero, + 1.0, + ifelse(zero_denom, NA_real_, result$mcc_group1 / result$mcc_group2) + ) + } + + # Rename MCC columns for clarity + names(result)[names(result) == "mcc_group1"] <- paste0("mcc_", comp_name) + names(result)[names(result) == "mcc_group2"] <- paste0("mcc_", ref_name) + + return(result) +} + +#' Perform all comparisons +#' @keywords internal +#' @noRd +perform_comparisons <- function(x, comparison_pairs, measure) { + mcc_col <- get_mcc_column_name(x) + + # Initialize results + comparisons <- vector("list", length(comparison_pairs)) + pairs_info <- vector("list", length(comparison_pairs)) + + for (i in seq_along(comparison_pairs)) { + pair <- comparison_pairs[[i]] + ref_group <- pair$ref + comp_group <- pair$comp + + table_name <- if (inherits(x, "mcc_sci")) "sci_table" else "mcc_table" + + # Extract data for both groups + ref_data <- x[[table_name]][x[[table_name]][[x$by_group]] == ref_group, ] + comp_data <- x[[table_name]][x[[table_name]][[x$by_group]] == comp_group, ] + + # Determine truncation time + max_time_ref <- max(ref_data$time) + max_time_comp <- max(comp_data$time) + truncate_at <- min(max_time_ref, max_time_comp) + + if (max_time_ref != max_time_comp) { + # Issue message about truncation + cli::cli_inform(c( + "i" = "Max follow-up: {.val {noquote(comp_group)}} = {.val {max_time_comp}}, {.val {noquote(ref_group)}} = {.val {max_time_ref}}", + "i" = "Comparison of {.val {noquote(ref_group)}} and {.val {noquote(comp_group)}} truncated at time {.val {truncate_at}}" + )) + } + + # Align times using LOCF + # Note: comp_group is "group1" and ref_group is "group2" in alignment + aligned_data <- align_mcc_times( + group1_data = comp_data, + group2_data = ref_data, + truncate_at = truncate_at, + mcc_col = mcc_col + ) + + # Calculate measures + comparison_result <- calculate_measures( + aligned_data = aligned_data, + measure = measure, + ref_name = ref_group, + comp_name = comp_group + ) + + # Store results + comparisons[[i]] <- comparison_result + pairs_info[[i]] <- data.frame( + reference = ref_group, + comparison = comp_group, + truncation_time = truncate_at, + default_used = pair$default_used, + stringsAsFactors = FALSE + ) + } + + # Combine pairs info + pairs_df <- do.call(rbind, pairs_info) + + return(list( + comparisons = comparisons, + pairs_df = pairs_df + )) +} + +#' Issue warning about default reference usage +#' @keywords internal +#' @noRd +issue_default_reference_warning <- function(pairs_df) { + default_comps <- pairs_df[pairs_df$default_used, ] + comp_labels <- paste0( + default_comps$comparison, + " vs ", + default_comps$reference + ) + + cli::cli_warn(c( + "!" = "No `reference` group preference found for {.val {nrow(default_comps)}} comparison{?s}", + "i" = "Using alphabetical default for: {.val {comp_labels}}", + "i" = "To avoid this, ensure {.arg reference} preferences cover all comparisons" + )) +} diff --git a/R/validation_helpers.R b/R/validation_helpers.R index 8e51984..f2e8c3d 100644 --- a/R/validation_helpers.R +++ b/R/validation_helpers.R @@ -375,3 +375,93 @@ validate_last_observation <- function(data_std) { return(TRUE) } + + +#' Validate comparison inputs +#' @keywords internal +#' @noRd +validate_comparison_inputs <- function(x, reference, pairwise) { + # Check x is an mcc object + if (!is_mcc(x)) { + cli::cli_abort("{.arg x} must be an {.cls mcc} object") + } + + # Check x is grouped + if (!is_grouped(x)) { + cli::cli_abort(c( + "{.arg x} must be a grouped {.cls mcc} object", + "i" = "Use the {.arg by} argument in {.fn mcc} to create grouped analyses" + )) + } + + # Get all groups + all_groups <- mcc_groups(x) + + # Validate reference if provided + if (!is.null(reference)) { + if (!is.character(reference)) { + cli::cli_abort("{.arg reference} must be a {.cls character} vector") + } + + if (!pairwise && length(reference) > 1) { + cli::cli_abort(c( + "{.arg reference} must be a single value when {.code pairwise = FALSE}", + "x" = "You provided {.val {length(reference)}} value{?s}", + "i" = "To use multiple reference preferences, set {.code pairwise = TRUE}" + )) + } + + # Check if reference groups exist + invalid_refs <- reference[!reference %in% all_groups] + if (length(invalid_refs) > 0) { + if (pairwise) { + cli::cli_abort(c( + "Reference preference{?s} not found in {.arg x}: {.val {invalid_refs}}", + "i" = "Available groups: {.val {all_groups}}" + )) + } else { + cli::cli_abort(c( + "Reference group {.val {reference}} not found in {.arg x}", + "i" = "Available groups: {.val {all_groups}}" + )) + } + } + } + + invisible(TRUE) +} + +#' Validate reference group selection +#' @keywords internal +#' @noRd +validate_reference_selection <- function(reference, all_groups, pairwise) { + # If reference is provided, return it + if (!is.null(reference)) { + return(list(reference = reference, default_used = FALSE)) + } + + # If reference is NULL, select default + if (!pairwise) { + # Select first group alphabetically + default_ref <- sort(all_groups)[1] + + # Issue appropriate message + if (length(all_groups) == 2) { + cli::cli_inform(c( + "i" = "Using {.val {default_ref}} as reference group", + "i" = "To change: specify {.code reference = \"{setdiff(all_groups, default_ref)}\"}" + )) + } else { + cli::cli_warn(c( + "!" = "Multiple groups detected but no reference specified", + "i" = "Using {.val {default_ref}} as reference group", + "i" = "To change: specify {.arg reference} or set {.code pairwise = TRUE}" + )) + } + + return(list(reference = default_ref, default_used = TRUE)) + } else { + # For pairwise with NULL reference, will handle per-comparison + return(list(reference = NULL, default_used = FALSE)) + } +} diff --git a/man/compare_groups.Rd b/man/compare_groups.Rd new file mode 100644 index 0000000..a9a11b4 --- /dev/null +++ b/man/compare_groups.Rd @@ -0,0 +1,111 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/compare_groups.R +\name{compare_groups} +\alias{compare_groups} +\title{Compare MCC Between Groups} +\usage{ +compare_groups( + x, + reference = NULL, + pairwise = FALSE, + measure = c("difference", "ratio", "both") +) +} +\arguments{ +\item{x}{(\code{mcc_grouped})\cr A grouped \code{mcc} object (created with \code{by} +argument in \code{\link[=mcc]{mcc()}})} + +\item{reference}{(\code{string}, optional)\cr Specifies the reference group(s) to +use when calculating comparisons (see details below to understand how +the \code{reference} group is used in \code{measure} calculations. If \code{NULL} +(default), then the first group alphabetically is used as the +\code{reference}. When \code{pairwise = TRUE} and there are > 2 groups being +compared, this argument can accept a vector of group names (in priority +order) to use as the \code{reference} in each \code{pairwise} comparison.} + +\item{pairwise}{(\code{logical})\cr Whether to perform all possible pairwise +comparisons when > 2 groups are present. If \code{FALSE} (default), +compares all groups to a single \code{reference} group only.} + +\item{measure}{(\code{string})\cr Specifies which MCC comparison measure(s) to +calculate:\code{"difference"} (default), \code{"ratio"}, or \code{"both"}} +} +\value{ +An S3 object of class \code{mcc_group_comparison} containing: +\itemize{ +\item \code{comparisons}: List of data frames with comparison results over time +\item \code{metadata}: List with comparison parameters and settings +\item \code{original_mcc}: The input \code{mcc} object +\item \code{call}: The matched call +} +} +\description{ +Create pairwise comparisons of mean cumulative count (MCC) between groups +using mean cumulative count difference (MCCD) and/or mean cumulative count +ratio (MCCR). This function only works with grouped \code{mcc} objects. +} +\details{ +The difference (MCCD) and/or ratio (MCCR) of MCC values are calculated +between groups over time. When comparing groups with different maximum +follow-up times, comparisons are automatically truncated at the minimum of +the two maximum follow-up times (e.g., if one group has a year of follow-up +and the other has 1.5 years, then comparisons will only be calculated up to +1 year). For time points where groups have misaligned observation times, +last observation carried forward (LOCF) is used within each group's own +follow-up period, providing comparisons across all event times as long as +they occur during the shared follow-up period. + +\strong{Comparison Measures:} +\itemize{ +\item MCCD (difference): \code{MCC_group1 - MCC_reference} +\item MCCR (ratio): \code{MCC_group1 / MCC_reference} +} +} +\examples{ +# Create sample data with 2 groups +library(dplyr) +df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +) |> + arrange(id, time) + +# Calculate grouped MCC +mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + +# Compare groups (difference by default) +comparison <- compare_groups(mcc_grouped, reference = "B") + +# Compare using ratio +comparison_ratio <- compare_groups(mcc_grouped, reference = "B", measure = "ratio") + +# Get both measures +comparison_both <- compare_groups(mcc_grouped, reference = "B", measure = "both") + +# Three group example with pairwise comparisons +df3 <- data.frame( + id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), + time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), + cause = c(0, 0, 2, 1, 0, 1, 0, 1, 2, 2, 1, 0, 0), + group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") +) + +mcc_3group <- mcc(df3, "id", "time", "cause", by = "group") + +# All pairwise comparisons +comparison_pairwise <- compare_groups(mcc_3group, pairwise = TRUE) + +# Compare to specific reference +comparison_vs_a <- compare_groups(mcc_3group, reference = "A") + +# Pairwise with reference preference order +# Prefers A as reference, then B, then C +comparison_pref <- compare_groups( + mcc_3group, + reference = c("A", "B", "C"), + pairwise = TRUE +) + +} diff --git a/tests/testthat/_snaps/comparison_helpers.md b/tests/testthat/_snaps/comparison_helpers.md new file mode 100644 index 0000000..0691548 --- /dev/null +++ b/tests/testthat/_snaps/comparison_helpers.md @@ -0,0 +1,121 @@ +# compare_groups rejects non-mcc objects + + Code + compare_groups(df) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be an object + +# compare_groups rejects ungrouped mcc objects + + Code + compare_groups(mcc_ungrouped) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be a grouped object + i Use the `by` argument in `mcc()` to create grouped analyses + +--- + + Code + compare_groups(mcc_ungrouped) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be a grouped object + i Use the `by` argument in `mcc()` to create grouped analyses + +# compare_groups rejects invalid reference groups + + Code + compare_groups(mcc_grouped, reference = "Z") + Condition + Error in `validate_comparison_inputs()`: + ! Reference group "Z" not found in `x` + i Available groups: "A" and "B" + +# compare_groups rejects multiple references when pairwise = FALSE + + Code + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) + Condition + Error in `validate_comparison_inputs()`: + ! `reference` must be a single value when `pairwise = FALSE` + x You provided 2 values + i To use multiple reference preferences, set `pairwise = TRUE` + +--- + + Code + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) + Condition + Error in `validate_comparison_inputs()`: + ! `reference` must be a single value when `pairwise = FALSE` + x You provided 2 values + i To use multiple reference preferences, set `pairwise = TRUE` + +# compare_groups rejects invalid reference preferences in pairwise mode + + Code + compare_groups(mcc_grouped, reference = c("A", "Z"), pairwise = TRUE) + Condition + Error in `validate_comparison_inputs()`: + ! Reference preference not found in `x`: "Z" + i Available groups: "A", "B", and "C" + +# compare_groups validates measure argument + + Code + compare_groups(mcc_grouped, measure = "invalid") + Condition + Error in `match.arg()`: + ! 'arg' should be one of "difference", "ratio", "both" + +# compare_groups works with 2 groups using default reference + + Code + result <- compare_groups(mcc_grouped) + Message + i Using "A" as reference group + i To change: specify `reference = "B"` + +# compare_groups handles 3+ groups with default reference + + Code + result <- compare_groups(mcc_grouped) + Condition + Warning: + ! Multiple groups detected but no reference specified + i Using "A" as reference group + i To change: specify `reference` or set `pairwise = TRUE` + Message + i Max follow-up: C = 6, A = 8 + i Comparison of A and C truncated at time 6 + +# compare_groups performs all pairwise comparisons + + Code + result <- compare_groups(mcc_grouped, pairwise = TRUE) + Message + i Max follow-up: C = 6, A = 8 + i Comparison of A and C truncated at time 6 + i Max follow-up: C = 6, B = 8 + i Comparison of B and C truncated at time 6 + Condition + Warning: + ! No `reference` group preference found for 3 comparisons + i Using alphabetical default for: "B vs A", "C vs A", and "C vs B" + i To avoid this, ensure `reference` preferences cover all comparisons + +# compare_groups handles division by zero in MCCR + + Code + result <- compare_groups(mcc_grouped, reference = "A", measure = "ratio") + Message + i Max follow-up: B = 5, A = 1 + i Comparison of A and B truncated at time 1 + Condition + Warning: + ! Reference group MCC = 0 at 1 time point + i MCCR set to "NA" at these times + i Comparison: "B" vs "A" + diff --git a/tests/testthat/test-comparison_helpers.R b/tests/testthat/test-comparison_helpers.R new file mode 100644 index 0000000..5ffb40e --- /dev/null +++ b/tests/testthat/test-comparison_helpers.R @@ -0,0 +1,478 @@ +# Helper function to create test data +create_test_data <- function(n_groups = 2) { + if (n_groups == 2) { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") + ) |> + dplyr::arrange(id, time) + } else if (n_groups == 3) { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), + time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), + cause = c(0, 0, 2, 1, 0, 1, 0, 1, 0, 2, 1, 0, 0), + group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") + ) |> + dplyr::arrange(id, time) + } + + return(df) +} + +# Input Validation Tests -------------------------------------------------- + +test_that("compare_groups rejects non-mcc objects", { + df <- data.frame(x = 1, y = 2) + + expect_snapshot( + compare_groups(df), + error = TRUE + ) +}) + +test_that("compare_groups rejects ungrouped mcc objects", { + df <- create_test_data(2) + mcc_ungrouped <- mcc(df, "id", "time", "cause") + + expect_snapshot( + compare_groups(mcc_ungrouped), + error = TRUE + ) + + expect_snapshot( + compare_groups(mcc_ungrouped), + error = TRUE + ) +}) + +test_that("compare_groups rejects invalid reference groups", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Non-existent reference + expect_snapshot( + compare_groups(mcc_grouped, reference = "Z"), + error = TRUE + ) +}) + +test_that("compare_groups rejects multiple references when pairwise = FALSE", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + expect_snapshot( + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE), + error = TRUE + ) + + expect_snapshot( + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE), + error = TRUE + ) +}) + +test_that("compare_groups rejects invalid reference preferences in pairwise mode", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + expect_snapshot( + compare_groups(mcc_grouped, reference = c("A", "Z"), pairwise = TRUE), + error = TRUE + ) +}) + +test_that("compare_groups validates measure argument", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + expect_snapshot( + compare_groups(mcc_grouped, measure = "invalid"), + error = TRUE + ) +}) + +# Two-Group Comparison Tests ---------------------------------------------- + +test_that("compare_groups works with 2 groups using default reference", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Should use "A" as reference (first alphabetically) + expect_snapshot( + result <- compare_groups(mcc_grouped) + ) + + expect_s3_class(result, "mcc_group_comparison") + expect_equal(length(result$comparisons), 1) + expect_equal(result$metadata$reference_group, "A") + expect_false(result$metadata$pairwise) +}) + +test_that("compare_groups calculates MCCD correctly", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "A", measure = "difference") + + # Check structure + expect_equal(result$metadata$measure, "difference") + comparison_df <- result$comparisons[[1]] + + expect_true("mccd" %in% names(comparison_df)) + expect_true("mcc_B" %in% names(comparison_df)) + expect_true("mcc_A" %in% names(comparison_df)) + expect_false("mccr" %in% names(comparison_df)) + + # Check calculation: mccd = mcc_B - mcc_A + expect_equal( + comparison_df$mccd, + comparison_df$mcc_B - comparison_df$mcc_A + ) +}) + +test_that("compare_groups calculates MCCR correctly", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "B", measure = "ratio") + + # Check structure + expect_equal(result$metadata$measure, "ratio") + comparison_df <- result$comparisons[[1]] + + expect_true("mccr" %in% names(comparison_df)) + expect_false("mccd" %in% names(comparison_df)) + + # Check calculation: mccr = mcc_A / mcc_B + expect_equal( + comparison_df$mccr, + # added small increment so that ratio when both = 0 is 1.0 + (comparison_df$mcc_A + 0.000000001) / (comparison_df$mcc_B + 0.000000001) + ) +}) + +test_that("compare_groups calculates both measures when requested", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "B", measure = "both") + + expect_equal(result$metadata$measure, "both") + comparison_df <- result$comparisons[[1]] + + expect_true("mccd" %in% names(comparison_df)) + expect_true("mccr" %in% names(comparison_df)) +}) + +test_that("compare_groups handles specified reference group", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "B") + + expect_equal(result$metadata$reference_group, "B") + comparison_df <- result$comparisons[[1]] + + expect_equal(comparison_df$reference[1], "B") + expect_equal(comparison_df$comparison[1], "A") +}) + +# Multi-Group Comparison Tests -------------------------------------------- + +test_that("compare_groups handles 3+ groups with default reference", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Should warn about multiple groups and default selection + expect_snapshot( + result <- compare_groups(mcc_grouped) + ) + + expect_equal(result$metadata$reference_group, "A") + expect_equal(length(result$comparisons), 2) # B vs A, C vs A +}) + +test_that("compare_groups handles 3+ groups with specified reference", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "B") + + expect_equal(result$metadata$reference_group, "B") + expect_equal(length(result$comparisons), 2) # A vs B, C vs B + + # Check that all comparisons use B as reference + refs <- sapply(result$comparisons, function(x) unique(x$reference)) + expect_true(all(refs == "B")) +}) + +# Pairwise Comparison Tests ----------------------------------------------- + +test_that("compare_groups performs all pairwise comparisons", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + expect_snapshot( + result <- compare_groups(mcc_grouped, pairwise = TRUE) + ) + + expect_true(result$metadata$pairwise) + expect_equal(length(result$comparisons), 3) # A-B, A-C, B-C + + # Check that we have all expected pairs + pairs <- result$metadata$comparison_pairs + all_pairs <- paste(pairs$comparison, pairs$reference, sep = "-") + + expect_equal(length(unique(all_pairs)), 3) +}) + +test_that("compare_groups uses reference preferences in pairwise mode", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Prefer A as reference, then B + result <- compare_groups( + mcc_grouped, + reference = c("A", "B"), + pairwise = TRUE + ) + + pairs <- result$metadata$comparison_pairs + + # For pairs containing A, A should be reference + a_pairs <- pairs[pairs$reference == "A" | pairs$comparison == "A", ] + expect_true(all(a_pairs$reference == "A")) + + # For B-C pair (no A), B should be reference + bc_pair <- pairs[pairs$reference == "B" & pairs$comparison == "C", ] + expect_equal(nrow(bc_pair), 1) +}) + +test_that("compare_groups warns about default reference in pairwise mode", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Only specify A as preference - B-C comparison will use default + expect_warning( + result <- compare_groups(mcc_grouped, reference = "A", pairwise = TRUE) + ) + + expect_warning( + result <- compare_groups(mcc_grouped, reference = "A", pairwise = TRUE), + "alphabetical default" + ) + + # Check that one comparison used default + pairs <- result$metadata$comparison_pairs + expect_true(any(pairs$default_used)) +}) + +test_that("pairwise comparisons work with all groups in preference vector", { + df <- create_test_data(3) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # All groups in preference order - no defaults should be used + result <- compare_groups( + mcc_grouped, + reference = c("C", "B", "A"), + pairwise = TRUE + ) + + pairs <- result$metadata$comparison_pairs + expect_false(any(pairs$default_used)) + + # C should be preferred over B and A + # B should be preferred over A + expect_true("C" %in% pairs$reference) +}) + +# Time Alignment Tests ---------------------------------------------------- + +test_that("compare_groups handles different max follow-up times", { + # Create data with different follow-up by group + df <- data.frame( + id = c(1, 1, 2, 2, 3, 3, 4, 4, 5, 5), + time = c(3, 5, 5, 6, 3, 10, 2, 8, 1, 8), # Group B has longer follow-up + cause = c(1, 0, 1, 0, 1, 0, 1, 0, 1, 2), + group = c("A", "A", "A", "A", "B", "B", "B", "B", "B", "B") + ) |> + dplyr::arrange(id, time) + + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Should inform about truncation + expect_message( + result <- compare_groups(mcc_grouped, reference = "A"), + "truncated at time" + ) + + # Check truncation time in metadata + pairs <- result$metadata$comparison_pairs + expect_equal(pairs$truncation_time, 6) # min(6, 10) + + # Check that no time points exceed truncation + comparison_df <- result$comparisons[[1]] + expect_true(all(comparison_df$time <= 6)) +}) + +test_that("compare_groups uses LOCF for misaligned times", { + # Create data with different event times + df <- data.frame( + id = c(1, 1, 2, 3, 3, 4), + time = c(1, 3, 5, 2, 5, 5), # Different time points + cause = c(1, 0, 0, 1, 0, 0), + group = c("A", "A", "A", "B", "B", "B") + ) |> + dplyr::arrange(id, time) + + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + result <- compare_groups(mcc_grouped, reference = "A") + + comparison_df <- result$comparisons[[1]] + + # Should have times from both groups (union) + expect_true(1 %in% comparison_df$time) + expect_true(2 %in% comparison_df$time) + expect_true(5 %in% comparison_df$time) + + # MCC values should be carried forward (non-decreasing within each group) + a_values <- comparison_df |> dplyr::pull("mcc_A") + b_values <- comparison_df |> dplyr::pull("mcc_A") + + expect_true(all(diff(a_values) >= 0)) + expect_true(all(diff(b_values) >= 0)) +}) + +# Edge Cases and Special Situations -------------------------------------- + +test_that("compare_groups handles division by zero in MCCR", { + # Create data where reference has MCC = 0 at some times + df <- data.frame( + id = c(1, 2, 2, 3), + time = c(1, 1, 2, 5), + cause = c(0, 1, 0, 0), + group = c("A", "B", "B", "B") + ) |> + dplyr::arrange(id, time) + + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Should warn about division by zero (only when comparison group != 0) + expect_snapshot( + result <- compare_groups(mcc_grouped, reference = "A", measure = "ratio") + ) + + comparison_df <- result$comparisons[[1]] + + # At time 0, both groups have MCC = 0, so MCCR should be 1.0 + time_0 <- comparison_df[comparison_df$time == 0, ] + expect_equal(time_0$mccr, 1.0) + + # At later times where reference = 0 but comparison != 0, should be NA + expect_true(any(is.na(comparison_df$mccr))) +}) + +test_that("compare_groups works with weighted mcc objects", { + df <- create_test_data(2) + df$weights <- c(1.2, 0.8, 1.5, 1.0, 1.0, 1.0, 1.0, 1.3, 1.3) + + mcc_weighted <- mcc( + df, + "id", + "time", + "cause", + by = "group", + weights = "weights" + ) + + result <- compare_groups(mcc_weighted, reference = "A") + + expect_s3_class(result, "mcc_group_comparison") + expect_true(result$metadata$weighted) + expect_equal(length(result$comparisons), 1) +}) + +test_that("compare_groups works with both equation and sci methods", { + df <- create_test_data(2) + + # Equation method + mcc_eq <- mcc(df, "id", "time", "cause", by = "group", method = "equation") + result_eq <- compare_groups(mcc_eq, reference = "A") + + expect_equal(result_eq$metadata$method, "equation") + + # SCI method + mcc_sci <- mcc(df, "id", "time", "cause", by = "group", method = "sci") + result_sci <- compare_groups(mcc_sci, reference = "A") + + expect_equal(result_sci$metadata$method, "sci") +}) + +# Output Structure Tests -------------------------------------------------- + +test_that("compare_groups returns correct output structure", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "A") + + # Check class + expect_s3_class(result, "mcc_group_comparison") + expect_true(is.list(result)) + + # Check main components + expect_true("comparisons" %in% names(result)) + expect_true("metadata" %in% names(result)) + expect_true("original_mcc" %in% names(result)) + expect_true("call" %in% names(result)) + + # Check metadata components + metadata <- result$metadata + expect_true("reference_group" %in% names(metadata)) + expect_true("pairwise" %in% names(metadata)) + expect_true("measure" %in% names(metadata)) + expect_true("n_comparisons" %in% names(metadata)) + expect_true("comparison_pairs" %in% names(metadata)) + expect_true("weighted" %in% names(metadata)) + expect_true("method" %in% names(metadata)) + expect_true("grouping_var" %in% names(metadata)) + + # Check comparison_pairs dataframe + pairs <- metadata$comparison_pairs + expect_s3_class(pairs, "data.frame") + expect_true("reference" %in% names(pairs)) + expect_true("comparison" %in% names(pairs)) + expect_true("truncation_time" %in% names(pairs)) + expect_true("default_used" %in% names(pairs)) +}) + +test_that("comparison dataframes have correct structure", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + # Test with both measures + result <- compare_groups(mcc_grouped, reference = "B", measure = "both") + comparison_df <- result$comparisons[[1]] + + expect_s3_class(comparison_df, "data.frame") + expect_true("time" %in% names(comparison_df)) + expect_true("reference" %in% names(comparison_df)) + expect_true("comparison" %in% names(comparison_df)) + expect_true("mccd" %in% names(comparison_df)) + expect_true("mccr" %in% names(comparison_df)) + + # MCC columns should be named with group names + expect_true(any(grepl("mcc_A", names(comparison_df)))) + expect_true(any(grepl("mcc_B", names(comparison_df)))) +}) + +test_that("original_mcc is preserved in output", { + df <- create_test_data(2) + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + result <- compare_groups(mcc_grouped, reference = "A") + + expect_identical(result$original_mcc, mcc_grouped) +}) From 4bf44ef224548a465c66e890f7de2ff46d613787 Mon Sep 17 00:00:00 2001 From: Ken Taylor Date: Tue, 16 Dec 2025 09:16:06 -0500 Subject: [PATCH 2/5] Update compare_groups() to retain all data for comparisons and set MCC to NA for times beyond a group's observed max follow-up time --- R/compare_groups.R | 19 +-- R/comparison_helpers.R | 83 +++++++----- man/compare_groups.Rd | 19 +-- tests/testthat/_snaps/compare_groups.md | 125 ++++++++++++++++++ ...arison_helpers.R => test-compare_groups.R} | 4 +- 5 files changed, 197 insertions(+), 53 deletions(-) create mode 100644 tests/testthat/_snaps/compare_groups.md rename tests/testthat/{test-comparison_helpers.R => test-compare_groups.R} (99%) diff --git a/R/compare_groups.R b/R/compare_groups.R index c1aa0af..4f8d8a0 100644 --- a/R/compare_groups.R +++ b/R/compare_groups.R @@ -7,14 +7,17 @@ #' #' @details #' The difference (MCCD) and/or ratio (MCCR) of MCC values are calculated -#' between groups over time. When comparing groups with different maximum -#' follow-up times, comparisons are automatically truncated at the minimum of -#' the two maximum follow-up times (e.g., if one group has a year of follow-up -#' and the other has 1.5 years, then comparisons will only be calculated up to -#' 1 year). For time points where groups have misaligned observation times, -#' last observation carried forward (LOCF) is used within each group's own -#' follow-up period, providing comparisons across all event times as long as -#' they occur during the shared follow-up period. +#' between groups over time. When groups have different maximum follow-up times, +#' MCCD and MCCR are calculated only during the period where both groups have +#' observed data. Beyond this shared period, MCCD and MCCR are set to `NA` +#' For example, if one group has a year of follow-up and the other has 1.5 +#' years, then comparisons will only be calculated up to 1 year; since only one +#' group has observed follow-up time beyond that point, comparisons are not +#' possible and the comparison value is set to `NA` for those times. For time +#' points where groups have misaligned observation times, last observation +#' carried forward is used within each group's own follow-up period, providing +#' comparisons across all event times as long as they occur during the shared +#' follow-up period. #' #' **Comparison Measures:** #' - MCCD (difference): `MCC_group1 - MCC_reference` diff --git a/R/comparison_helpers.R b/R/comparison_helpers.R index 1853e70..2d51bf5 100644 --- a/R/comparison_helpers.R +++ b/R/comparison_helpers.R @@ -63,52 +63,63 @@ get_mcc_column_name <- function(mcc_object) { } } +#' LOCF with NA after a group's max follow-up time (when follow-up times differ) +#' @keywords internal +#' @noRd +locf_with_na_after_max <- function(group_data, all_times, max_time, mcc_col) { + # For times <= max_time: use LOCF + # For times > max_time: set to NA + + result <- rep(NA_real_, length(all_times)) + within_followup <- all_times <= max_time + + if (any(within_followup)) { + locf_fn <- stats::approxfun( + x = group_data$time, + y = group_data[[mcc_col]], + method = "constant", + rule = 2, + f = 0, + ties = "ordered" + ) + result[within_followup] <- locf_fn(all_times[within_followup]) + } + + return(result) +} + #' Align MCC data to common time grid using LOCF #' @keywords internal #' @noRd -align_mcc_times <- function( - group1_data, - group2_data, - truncate_at, - mcc_col -) { - # Filter to truncation time - group1_data <- group1_data[group1_data$time <= truncate_at, ] - group2_data <- group2_data[group2_data$time <= truncate_at, ] - - # Get union of time points +align_mcc_times <- function(group1_data, group2_data, truncate_at, mcc_col) { + # Get max time for each group + max_time_1 <- max(group1_data$time) + max_time_2 <- max(group2_data$time) + + # Get union of ALL time points (not just up to truncate_at) all_times <- sort(unique(c(group1_data$time, group2_data$time))) - # Create step functions for LOCF (right-continuous) - # Using approxfun with method="constant", rule=2, f=0 - locf_group1 <- stats::approxfun( - x = group1_data$time, - y = group1_data[[mcc_col]], - method = "constant", - rule = 2, - f = 0, # Right-continuous - ties = "ordered" + # LOCF for group 1 (only up to its max time) + mcc_group1 <- locf_with_na_after_max( + group1_data, + all_times, + max_time_1, + mcc_col ) - locf_group2 <- stats::approxfun( - x = group2_data$time, - y = group2_data[[mcc_col]], - method = "constant", - rule = 2, - f = 0, # Right-continuous - ties = "ordered" + # LOCF for group 2 (only up to its max time) + mcc_group2 <- locf_with_na_after_max( + group2_data, + all_times, + max_time_2, + mcc_col ) - # Apply LOCF to get values at all time points - mcc_group1 <- locf_group1(all_times) - mcc_group2 <- locf_group2(all_times) - - # Return aligned data - data.frame( + return(data.frame( time = all_times, mcc_group1 = mcc_group1, mcc_group2 = mcc_group2 - ) + )) } #' Calculate comparison measures @@ -180,6 +191,7 @@ perform_comparisons <- function(x, comparison_pairs, measure) { comp_data <- x[[table_name]][x[[table_name]][[x$by_group]] == comp_group, ] # Determine truncation time + min_time <- min(ref_data$time) max_time_ref <- max(ref_data$time) max_time_comp <- max(comp_data$time) truncate_at <- min(max_time_ref, max_time_comp) @@ -188,7 +200,8 @@ perform_comparisons <- function(x, comparison_pairs, measure) { # Issue message about truncation cli::cli_inform(c( "i" = "Max follow-up: {.val {noquote(comp_group)}} = {.val {max_time_comp}}, {.val {noquote(ref_group)}} = {.val {max_time_ref}}", - "i" = "Comparison of {.val {noquote(ref_group)}} and {.val {noquote(comp_group)}} truncated at time {.val {truncate_at}}" + "i" = "Valid comparison period: time {.val {min_time}} to {.val {truncate_at}}", + "i" = "Comparison of {.val {noquote(ref_group)}} and {.val {noquote(comp_group)}} limited to on or before time {.val {truncate_at}} and MCCD/MCCR will be {.val {NA}} beyond that time" )) } diff --git a/man/compare_groups.Rd b/man/compare_groups.Rd index a9a11b4..e8bf375 100644 --- a/man/compare_groups.Rd +++ b/man/compare_groups.Rd @@ -46,14 +46,17 @@ ratio (MCCR). This function only works with grouped \code{mcc} objects. } \details{ The difference (MCCD) and/or ratio (MCCR) of MCC values are calculated -between groups over time. When comparing groups with different maximum -follow-up times, comparisons are automatically truncated at the minimum of -the two maximum follow-up times (e.g., if one group has a year of follow-up -and the other has 1.5 years, then comparisons will only be calculated up to -1 year). For time points where groups have misaligned observation times, -last observation carried forward (LOCF) is used within each group's own -follow-up period, providing comparisons across all event times as long as -they occur during the shared follow-up period. +between groups over time. When groups have different maximum follow-up times, +MCCD and MCCR are calculated only during the period where both groups have +observed data. Beyond this shared period, MCCD and MCCR are set to \code{NA} +For example, if one group has a year of follow-up and the other has 1.5 +years, then comparisons will only be calculated up to 1 year; since only one +group has observed follow-up time beyond that point, comparisons are not +possible and the comparison value is set to \code{NA} for those times. For time +points where groups have misaligned observation times, last observation +carried forward is used within each group's own follow-up period, providing +comparisons across all event times as long as they occur during the shared +follow-up period. \strong{Comparison Measures:} \itemize{ diff --git a/tests/testthat/_snaps/compare_groups.md b/tests/testthat/_snaps/compare_groups.md new file mode 100644 index 0000000..ef4a1b1 --- /dev/null +++ b/tests/testthat/_snaps/compare_groups.md @@ -0,0 +1,125 @@ +# compare_groups rejects non-mcc objects + + Code + compare_groups(df) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be an object + +# compare_groups rejects ungrouped mcc objects + + Code + compare_groups(mcc_ungrouped) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be a grouped object + i Use the `by` argument in `mcc()` to create grouped analyses + +--- + + Code + compare_groups(mcc_ungrouped) + Condition + Error in `validate_comparison_inputs()`: + ! `x` must be a grouped object + i Use the `by` argument in `mcc()` to create grouped analyses + +# compare_groups rejects invalid reference groups + + Code + compare_groups(mcc_grouped, reference = "Z") + Condition + Error in `validate_comparison_inputs()`: + ! Reference group "Z" not found in `x` + i Available groups: "A" and "B" + +# compare_groups rejects multiple references when pairwise = FALSE + + Code + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) + Condition + Error in `validate_comparison_inputs()`: + ! `reference` must be a single value when `pairwise = FALSE` + x You provided 2 values + i To use multiple reference preferences, set `pairwise = TRUE` + +--- + + Code + compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) + Condition + Error in `validate_comparison_inputs()`: + ! `reference` must be a single value when `pairwise = FALSE` + x You provided 2 values + i To use multiple reference preferences, set `pairwise = TRUE` + +# compare_groups rejects invalid reference preferences in pairwise mode + + Code + compare_groups(mcc_grouped, reference = c("A", "Z"), pairwise = TRUE) + Condition + Error in `validate_comparison_inputs()`: + ! Reference preference not found in `x`: "Z" + i Available groups: "A", "B", and "C" + +# compare_groups validates measure argument + + Code + compare_groups(mcc_grouped, measure = "invalid") + Condition + Error in `match.arg()`: + ! 'arg' should be one of "difference", "ratio", "both" + +# compare_groups works with 2 groups using default reference + + Code + result <- compare_groups(mcc_grouped) + Message + i Using "A" as reference group + i To change: specify `reference = "B"` + +# compare_groups handles 3+ groups with default reference + + Code + result <- compare_groups(mcc_grouped) + Condition + Warning: + ! Multiple groups detected but no reference specified + i Using "A" as reference group + i To change: specify `reference` or set `pairwise = TRUE` + Message + i Max follow-up: C = 6, A = 8 + i Valid comparison period: time 0 to 6 + i Comparison of A and C limited to on or before time 6 and MCCD/MCCR will be NA beyond that time + +# compare_groups performs all pairwise comparisons + + Code + result <- compare_groups(mcc_grouped, pairwise = TRUE) + Message + i Max follow-up: C = 6, A = 8 + i Valid comparison period: time 0 to 6 + i Comparison of A and C limited to on or before time 6 and MCCD/MCCR will be NA beyond that time + i Max follow-up: C = 6, B = 8 + i Valid comparison period: time 0 to 6 + i Comparison of B and C limited to on or before time 6 and MCCD/MCCR will be NA beyond that time + Condition + Warning: + ! No `reference` group preference found for 3 comparisons + i Using alphabetical default for: "B vs A", "C vs A", and "C vs B" + i To avoid this, ensure `reference` preferences cover all comparisons + +# compare_groups handles division by zero in MCCR + + Code + result <- compare_groups(mcc_grouped, reference = "A", measure = "ratio") + Message + i Max follow-up: B = 5, A = 1 + i Valid comparison period: time 0 to 1 + i Comparison of A and B limited to on or before time 1 and MCCD/MCCR will be NA beyond that time + Condition + Warning: + ! Reference group MCC = 0 at NA time points + i MCCR set to "NA" at these times + i Comparison: "B" vs "A" + diff --git a/tests/testthat/test-comparison_helpers.R b/tests/testthat/test-compare_groups.R similarity index 99% rename from tests/testthat/test-comparison_helpers.R rename to tests/testthat/test-compare_groups.R index 5ffb40e..7cc7efb 100644 --- a/tests/testthat/test-comparison_helpers.R +++ b/tests/testthat/test-compare_groups.R @@ -305,7 +305,7 @@ test_that("compare_groups handles different max follow-up times", { # Should inform about truncation expect_message( result <- compare_groups(mcc_grouped, reference = "A"), - "truncated at time" + "Valid comparison period" ) # Check truncation time in metadata @@ -314,7 +314,7 @@ test_that("compare_groups handles different max follow-up times", { # Check that no time points exceed truncation comparison_df <- result$comparisons[[1]] - expect_true(all(comparison_df$time <= 6)) + expect_true(all(comparison_df$time <= 10)) }) test_that("compare_groups uses LOCF for misaligned times", { From 81d96da8524d8e15177745999c9a41439a08a9a8 Mon Sep 17 00:00:00 2001 From: Ken Taylor Date: Tue, 6 Jan 2026 08:28:01 -0500 Subject: [PATCH 3/5] Add summary and print method for mcc_group_comparison objects --- NAMESPACE | 3 + R/comparison_helpers.R | 2 +- R/s3_classes.R | 382 ++++++++++++++++++++ inst/WORDLIST | 3 +- man/print.mcc_group_comparison.Rd | 42 +++ man/print.summary.mcc_group_comparison.Rd | 38 ++ man/summary.mcc_group_comparison.Rd | 54 +++ tests/testthat/_snaps/comparison_helpers.md | 121 ------- tests/testthat/_snaps/s3_classes.md | 111 ++++++ tests/testthat/test-s3_classes.R | 181 ++++++++++ 10 files changed, 814 insertions(+), 123 deletions(-) create mode 100644 man/print.mcc_group_comparison.Rd create mode 100644 man/print.summary.mcc_group_comparison.Rd create mode 100644 man/summary.mcc_group_comparison.Rd delete mode 100644 tests/testthat/_snaps/comparison_helpers.md diff --git a/NAMESPACE b/NAMESPACE index 44210fb..64e5736 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,8 +7,11 @@ S3method(as_mcc,list) S3method(plot,mcc) S3method(print,mcc) S3method(print,mcc_comparison) +S3method(print,mcc_group_comparison) S3method(print,summary.mcc) +S3method(print,summary.mcc_group_comparison) S3method(summary,mcc) +S3method(summary,mcc_group_comparison) export(as_mcc) export(compare_groups) export(compare_mcc) diff --git a/R/comparison_helpers.R b/R/comparison_helpers.R index 2d51bf5..7a6ec3d 100644 --- a/R/comparison_helpers.R +++ b/R/comparison_helpers.R @@ -41,7 +41,7 @@ create_comparison_pairs <- function(all_groups, reference, pairwise) { }) } else { # Create all pairwise combinations - group_combinations <- combn(all_groups, 2, simplify = FALSE) + group_combinations <- utils::combn(all_groups, 2, simplify = FALSE) # Determine reference for each pair pairs <- lapply(group_combinations, function(pair) { diff --git a/R/s3_classes.R b/R/s3_classes.R index c9e8b37..6973c5f 100644 --- a/R/s3_classes.R +++ b/R/s3_classes.R @@ -948,3 +948,385 @@ mcc_details <- function(x, ...) { return(NULL) } + + +#' Summary method for `mcc_group_comparison` objects +#' +#' @description +#' Provides a summary of group comparisons, including final comparison values, +#' valid comparison periods, and measures calculated. +#' +#' @param object An `mcc_group_comparison` object +#' @param ... Additional arguments (currently unused) +#' +#' @returns A summary object with class `summary.mcc_group_comparison` +#' @export +#' +#' @examples +#' library(dplyr) +#' +#' # Create sample data with 2 groups +#' df <- data.frame( +#' id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), +#' time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), +#' cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), +#' group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +#' ) |> +#' arrange(id, time) +#' +#' # Calculate grouped MCC +#' mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +#' +#' # Compare groups +#' comparison <- compare_groups(mcc_grouped, reference = "A") +#' +#' # Get summary +#' summary(comparison) +#' +#' # Three group example +#' df3 <- data.frame( +#' id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), +#' time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), +#' cause = c(0, 0, 2, 1, 0, 1, 0, 1, 2, 2, 1, 0, 0), +#' group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") +#' ) +#' +#' mcc_3group <- mcc(df3, "id", "time", "cause", by = "group") +#' comparison_pairwise <- compare_groups(mcc_3group, pairwise = TRUE) +#' summary(comparison_pairwise) +#' +summary.mcc_group_comparison <- function(object, ...) { + # Extract metadata + meta <- object$metadata + + # Helper function to get final values (at end of valid comparison period) + get_final_comparison_values <- function(comp_df, measure) { + # Find the last time point where comparison is valid (not NA) + if (measure == "difference" || measure == "both") { + valid_times <- comp_df$time[!is.na(comp_df$mccd)] + } else { + valid_times <- comp_df$time[!is.na(comp_df$mccr)] + } + + if (length(valid_times) == 0) { + # No valid comparisons + return(list( + time = NA_real_, + mcc_comp = NA_real_, + mcc_ref = NA_real_, + mccd = NA_real_, + mccr = NA_real_, + has_valid_comparison = FALSE + )) + } + + max_valid_time <- max(valid_times) + final_row <- comp_df[comp_df$time == max_valid_time, ] + + # Get column names for MCC values + mcc_comp_col <- grep("^mcc_", names(final_row), value = TRUE)[1] + mcc_ref_col <- grep("^mcc_", names(final_row), value = TRUE)[2] + + result <- list( + time = final_row$time, + mcc_comp = final_row[[mcc_comp_col]], + mcc_ref = final_row[[mcc_ref_col]], + has_valid_comparison = TRUE + ) + + # Add measure-specific values + if ("mccd" %in% names(final_row)) { + result$mccd <- final_row$mccd + } + if ("mccr" %in% names(final_row)) { + result$mccr <- final_row$mccr + } + + return(result) + } + + # Calculate summary statistics for each comparison + comparison_summaries <- vector("list", length(object$comparisons)) + + for (i in seq_along(object$comparisons)) { + comp_df <- object$comparisons[[i]] + pair_info <- meta$comparison_pairs[i, ] + + # Get final values + final_values <- get_final_comparison_values(comp_df, meta$measure) + + # Get total observation period (including beyond valid comparison) + min_time <- min(comp_df$time, na.rm = TRUE) + max_time <- max(comp_df$time, na.rm = TRUE) + + # Count time points in valid comparison period + if (meta$measure %in% c("difference", "both")) { + n_valid_times <- sum(!is.na(comp_df$mccd)) + } else { + n_valid_times <- sum(!is.na(comp_df$mccr)) + } + + # Count time points with extended follow-up (NA comparisons) + n_extended_times <- sum(is.na(comp_df$mccd) | is.na(comp_df$mccr)) + + comparison_summaries[[i]] <- list( + comparison = pair_info$comparison, + reference = pair_info$reference, + truncation_time = pair_info$truncation_time, + default_used = pair_info$default_used, + min_time = min_time, + max_time = max_time, + n_valid_times = n_valid_times, + n_extended_times = n_extended_times, + final_values = final_values + ) + } + + # Create summary object + result <- list( + object = object, + comparison_summaries = comparison_summaries, + metadata = meta, + method = meta$method, + weighted = meta$weighted, + measure = meta$measure, + pairwise = meta$pairwise, + n_comparisons = meta$n_comparisons + ) + + class(result) <- "summary.mcc_group_comparison" + return(result) +} + +#' Print method for `mcc_group_comparison` summary objects +#' +#' @param x A `summary.mcc_group_comparison` object +#' @param digits Number of digits to display for numeric values (default: 4) +#' @param ... Additional arguments (currently unused) +#' +#' @return Invisibly returns `x` +#' @export +#' +#' @examples +#' library(dplyr) +#' +#' # Create sample data +#' df <- data.frame( +#' id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), +#' time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), +#' cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), +#' group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +#' ) |> +#' arrange(id, time) +#' +#' mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +#' comparison <- compare_groups(mcc_grouped, reference = "A") +#' print(summary(comparison)) +#' +print.summary.mcc_group_comparison <- function(x, digits = 4, ...) { + cli::cli_h1("Summary of MCC Group Comparisons") + + # Method information + method_label <- switch( + x$method, + "equation" = "Dong-Yasui Equation Method", + "sci" = "Sum of Cumulative Incidence Method" + ) + cli::cli_alert_info("MCC calculation method: {.val {noquote(method_label)}}") + + if (x$weighted) { + cli::cli_alert_info("Weighted estimation: {.val {noquote('Yes')}}") + } + + # Comparison type + if (x$pairwise) { + cli::cli_alert_info( + "Comparison type: {.val {noquote('Pairwise comparisons')}}" + ) + if (!is.null(x$metadata$reference_preferences)) { + ref_prefs <- paste(x$metadata$reference_preferences, collapse = ", ") + cli::cli_alert_info("Reference preferences: {.val {ref_prefs}}") + } + } else { + cli::cli_alert_info("Comparison type: {.val {noquote('Single reference')}}") + cli::cli_alert_info("Reference group: {.val {x$metadata$reference_group}}") + } + + # Measures calculated + measure_label <- switch( + x$measure, + "difference" = "Mean Cumulative Count Difference (MCCD)", + "ratio" = "Mean Cumulative Count Ratio (MCCR)", + "both" = "MCCD and MCCR" + ) + cli::cli_alert_info("Measures: {.val {noquote(measure_label)}}") + cli::cli_alert_info("Number of comparisons: {.val {x$n_comparisons}}") + + # Summary for each comparison + cli::cli_h2("Individual Comparisons") + + for (i in seq_along(x$comparison_summaries)) { + comp_sum <- x$comparison_summaries[[i]] + + # Comparison header + comp_label <- paste0(comp_sum$comparison, " vs ", comp_sum$reference) + if (comp_sum$default_used) { + comp_label <- paste0(comp_label, " (default reference)") + } + cli::cli_h3("{comp_label}") + + # Observation period + cli::cli_text( + "Total observation period: [{.val {comp_sum$min_time}}, {.val {comp_sum$max_time}}]" + ) + cli::cli_text( + "Valid comparison period: [{.val {comp_sum$min_time}}, {.val {comp_sum$truncation_time}}]" + ) + cli::cli_text( + "Time points in valid period: {.val {comp_sum$n_valid_times}}" + ) + + if (comp_sum$n_extended_times > 0) { + cli::cli_text( + "Time points beyond valid period: {.val {comp_sum$n_extended_times}} (comparison = NA)" + ) + } + + # Final values at end of valid comparison period + if (comp_sum$final_values$has_valid_comparison) { + cli::cli_text( + "MCC for {.val {noquote(comp_sum$comparison)}} at time {.val {comp_sum$final_values$time}}: {.val {round(comp_sum$final_values$mcc_comp, digits)}}" + ) + cli::cli_text( + "MCC for {.val {noquote(comp_sum$reference)}} at time {.val {comp_sum$final_values$time}}: {.val {round(comp_sum$final_values$mcc_ref, digits)}}" + ) + + if (!is.null(comp_sum$final_values$mccd)) { + mccd_val <- round(comp_sum$final_values$mccd, digits) + cli::cli_text( + "MCCD at time {.val {comp_sum$final_values$time}}: {.val {mccd_val}}" + ) + } + + if (!is.null(comp_sum$final_values$mccr)) { + mccr_val <- round(comp_sum$final_values$mccr, digits) + cli::cli_text( + "MCCR at time {.val {comp_sum$final_values$time}}: {.val {mccr_val}}" + ) + } + } else { + cli::cli_alert_warning("No valid comparison period found") + } + + # Add spacing between comparisons (except for the last one) + if (i < length(x$comparison_summaries)) { + cli::cli_text("") + } + } + + # Additional notes if there are extended follow-up periods + any_extended <- any(sapply( + x$comparison_summaries, + function(cs) cs$n_extended_times > 0 + )) + if (any_extended) { + cli::cli_text("") + cli::cli_alert_info( + "Note: Some groups have longer follow-up than others. Comparison values (MCCD/MCCR) are {.val NA} beyond the valid comparison period, but individual MCC values are still reported." + ) + } + + invisible(x) +} + +#' Print method for `mcc_group_comparison` objects +#' +#' @description +#' Provides a concise display of group comparison results, showing comparison +#' pairs and basic information. Use [summary.mcc_group_comparison()] for +#' detailed statistics. +#' +#' @param x An `mcc_group_comparison` object +#' @param ... Additional arguments (currently unused) +#' +#' @return Invisibly returns `x` +#' @export +#' +#' @examples +#' library(dplyr) +#' +#' df <- data.frame( +#' id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), +#' time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), +#' cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), +#' group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +#' ) |> +#' arrange(id, time) +#' +#' mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +#' comparison <- compare_groups(mcc_grouped, reference = "A") +#' +#' # Concise print +#' comparison +#' +#' # Detailed summary +#' summary(comparison) +#' +print.mcc_group_comparison <- function(x, ...) { + cli::cli_h2("MCC Group Comparison") + + meta <- x$metadata + + # Basic information + if (meta$pairwise) { + cli::cli_text("Type: {.emph Pairwise comparisons}") + } else { + cli::cli_text( + "Type: {.emph Single reference} ({.val {meta$reference_group}})" + ) + } + + measure_label <- switch( + meta$measure, + "difference" = "MCCD", + "ratio" = "MCCR", + "both" = "MCCD and MCCR" + ) + cli::cli_text("Measure: {.val {measure_label}}") + cli::cli_text("Method: {.val {meta$method}}") + + if (meta$weighted) { + cli::cli_text("Weighted: {.val Yes}") + } + + # Comparison pairs + cli::cli_text("") + cli::cli_h3("Comparison Pairs ({.val {meta$n_comparisons}})") + + pairs <- meta$comparison_pairs + for (i in seq_len(nrow(pairs))) { + pair <- pairs[i, ] + comp_label <- paste0( + "{.val ", + pair$comparison, + "} vs {.val ", + pair$reference, + "}" + ) + trunc_label <- paste0(" (valid period: 0 to ", pair$truncation_time, ")") + + if (pair$default_used) { + cli::cli_li(paste0(comp_label, trunc_label, " {.emph (default ref)}")) + } else { + cli::cli_li(paste0(comp_label, trunc_label)) + } + } + + # Usage hint + cli::cli_text("") + cli::cli_alert_info("Use {.fn summary} for detailed comparison statistics") + cli::cli_alert_info("Access comparison data: {.code x$comparisons[[i]]}") + cli::cli_alert_info("Access metadata: {.code x$metadata}") + + invisible(x) +} diff --git a/inst/WORDLIST b/inst/WORDLIST index 1dfbb67..7f8a4d1 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -14,6 +14,8 @@ Leisenring Lifecycle Lund MCC +MCCD +MCCR ORCID Peery Positivity @@ -28,7 +30,6 @@ doi estimand estimands et -exchangeability geoms ggplot interpretable diff --git a/man/print.mcc_group_comparison.Rd b/man/print.mcc_group_comparison.Rd new file mode 100644 index 0000000..f5829c1 --- /dev/null +++ b/man/print.mcc_group_comparison.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/s3_classes.R +\name{print.mcc_group_comparison} +\alias{print.mcc_group_comparison} +\title{Print method for \code{mcc_group_comparison} objects} +\usage{ +\method{print}{mcc_group_comparison}(x, ...) +} +\arguments{ +\item{x}{An \code{mcc_group_comparison} object} + +\item{...}{Additional arguments (currently unused)} +} +\value{ +Invisibly returns \code{x} +} +\description{ +Provides a concise display of group comparison results, showing comparison +pairs and basic information. Use \code{\link[=summary.mcc_group_comparison]{summary.mcc_group_comparison()}} for +detailed statistics. +} +\examples{ +library(dplyr) + +df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +) |> + arrange(id, time) + +mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +comparison <- compare_groups(mcc_grouped, reference = "A") + +# Concise print +comparison + +# Detailed summary +summary(comparison) + +} diff --git a/man/print.summary.mcc_group_comparison.Rd b/man/print.summary.mcc_group_comparison.Rd new file mode 100644 index 0000000..d85e363 --- /dev/null +++ b/man/print.summary.mcc_group_comparison.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/s3_classes.R +\name{print.summary.mcc_group_comparison} +\alias{print.summary.mcc_group_comparison} +\title{Print method for \code{mcc_group_comparison} summary objects} +\usage{ +\method{print}{summary.mcc_group_comparison}(x, digits = 4, ...) +} +\arguments{ +\item{x}{A \code{summary.mcc_group_comparison} object} + +\item{digits}{Number of digits to display for numeric values (default: 4)} + +\item{...}{Additional arguments (currently unused)} +} +\value{ +Invisibly returns \code{x} +} +\description{ +Print method for \code{mcc_group_comparison} summary objects +} +\examples{ +library(dplyr) + +# Create sample data +df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +) |> + arrange(id, time) + +mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") +comparison <- compare_groups(mcc_grouped, reference = "A") +print(summary(comparison)) + +} diff --git a/man/summary.mcc_group_comparison.Rd b/man/summary.mcc_group_comparison.Rd new file mode 100644 index 0000000..59e85a0 --- /dev/null +++ b/man/summary.mcc_group_comparison.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/s3_classes.R +\name{summary.mcc_group_comparison} +\alias{summary.mcc_group_comparison} +\title{Summary method for \code{mcc_group_comparison} objects} +\usage{ +\method{summary}{mcc_group_comparison}(object, ...) +} +\arguments{ +\item{object}{An \code{mcc_group_comparison} object} + +\item{...}{Additional arguments (currently unused)} +} +\value{ +A summary object with class \code{summary.mcc_group_comparison} +} +\description{ +Provides a summary of group comparisons, including final comparison values, +valid comparison periods, and measures calculated. +} +\examples{ +library(dplyr) + +# Create sample data with 2 groups +df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") +) |> + arrange(id, time) + +# Calculate grouped MCC +mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + +# Compare groups +comparison <- compare_groups(mcc_grouped, reference = "A") + +# Get summary +summary(comparison) + +# Three group example +df3 <- data.frame( + id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), + time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), + cause = c(0, 0, 2, 1, 0, 1, 0, 1, 2, 2, 1, 0, 0), + group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") +) + +mcc_3group <- mcc(df3, "id", "time", "cause", by = "group") +comparison_pairwise <- compare_groups(mcc_3group, pairwise = TRUE) +summary(comparison_pairwise) + +} diff --git a/tests/testthat/_snaps/comparison_helpers.md b/tests/testthat/_snaps/comparison_helpers.md deleted file mode 100644 index 0691548..0000000 --- a/tests/testthat/_snaps/comparison_helpers.md +++ /dev/null @@ -1,121 +0,0 @@ -# compare_groups rejects non-mcc objects - - Code - compare_groups(df) - Condition - Error in `validate_comparison_inputs()`: - ! `x` must be an object - -# compare_groups rejects ungrouped mcc objects - - Code - compare_groups(mcc_ungrouped) - Condition - Error in `validate_comparison_inputs()`: - ! `x` must be a grouped object - i Use the `by` argument in `mcc()` to create grouped analyses - ---- - - Code - compare_groups(mcc_ungrouped) - Condition - Error in `validate_comparison_inputs()`: - ! `x` must be a grouped object - i Use the `by` argument in `mcc()` to create grouped analyses - -# compare_groups rejects invalid reference groups - - Code - compare_groups(mcc_grouped, reference = "Z") - Condition - Error in `validate_comparison_inputs()`: - ! Reference group "Z" not found in `x` - i Available groups: "A" and "B" - -# compare_groups rejects multiple references when pairwise = FALSE - - Code - compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) - Condition - Error in `validate_comparison_inputs()`: - ! `reference` must be a single value when `pairwise = FALSE` - x You provided 2 values - i To use multiple reference preferences, set `pairwise = TRUE` - ---- - - Code - compare_groups(mcc_grouped, reference = c("A", "B"), pairwise = FALSE) - Condition - Error in `validate_comparison_inputs()`: - ! `reference` must be a single value when `pairwise = FALSE` - x You provided 2 values - i To use multiple reference preferences, set `pairwise = TRUE` - -# compare_groups rejects invalid reference preferences in pairwise mode - - Code - compare_groups(mcc_grouped, reference = c("A", "Z"), pairwise = TRUE) - Condition - Error in `validate_comparison_inputs()`: - ! Reference preference not found in `x`: "Z" - i Available groups: "A", "B", and "C" - -# compare_groups validates measure argument - - Code - compare_groups(mcc_grouped, measure = "invalid") - Condition - Error in `match.arg()`: - ! 'arg' should be one of "difference", "ratio", "both" - -# compare_groups works with 2 groups using default reference - - Code - result <- compare_groups(mcc_grouped) - Message - i Using "A" as reference group - i To change: specify `reference = "B"` - -# compare_groups handles 3+ groups with default reference - - Code - result <- compare_groups(mcc_grouped) - Condition - Warning: - ! Multiple groups detected but no reference specified - i Using "A" as reference group - i To change: specify `reference` or set `pairwise = TRUE` - Message - i Max follow-up: C = 6, A = 8 - i Comparison of A and C truncated at time 6 - -# compare_groups performs all pairwise comparisons - - Code - result <- compare_groups(mcc_grouped, pairwise = TRUE) - Message - i Max follow-up: C = 6, A = 8 - i Comparison of A and C truncated at time 6 - i Max follow-up: C = 6, B = 8 - i Comparison of B and C truncated at time 6 - Condition - Warning: - ! No `reference` group preference found for 3 comparisons - i Using alphabetical default for: "B vs A", "C vs A", and "C vs B" - i To avoid this, ensure `reference` preferences cover all comparisons - -# compare_groups handles division by zero in MCCR - - Code - result <- compare_groups(mcc_grouped, reference = "A", measure = "ratio") - Message - i Max follow-up: B = 5, A = 1 - i Comparison of A and B truncated at time 1 - Condition - Warning: - ! Reference group MCC = 0 at 1 time point - i MCCR set to "NA" at these times - i Comparison: "B" vs "A" - diff --git a/tests/testthat/_snaps/s3_classes.md b/tests/testthat/_snaps/s3_classes.md index 5b641c1..0fda664 100644 --- a/tests/testthat/_snaps/s3_classes.md +++ b/tests/testthat/_snaps/s3_classes.md @@ -234,3 +234,114 @@ Competing risk events: 0 Censoring events: 1 +# print.mcc_group_comparison works for two-group comparison + + Code + print(comparison) + Message + + -- MCC Group Comparison -- + + Type: Single reference ("A") + Measure: "MCCD" + Method: "equation" + + + -- Comparison Pairs (1) + * "B" vs "A" (valid period: 0 to 8) + + i Use `summary()` for detailed comparison statistics + i Access comparison data: `x$comparisons[[i]]` + i Access metadata: `x$metadata` + +# print.mcc_group_comparison works for pairwise comparisons + + Code + print(comparison) + Message + + -- MCC Group Comparison -- + + Type: Pairwise comparisons + Measure: "MCCD" + Method: "equation" + + + -- Comparison Pairs (3) + * "B" vs "A" (valid period: 0 to 8) + * "C" vs "A" (valid period: 0 to 6) + * "C" vs "B" (valid period: 0 to 6) + + i Use `summary()` for detailed comparison statistics + i Access comparison data: `x$comparisons[[i]]` + i Access metadata: `x$metadata` + +# print.mcc_group_comparison shows weighted status + + Code + print(comparison) + Message + + -- MCC Group Comparison -- + + Type: Single reference ("A") + Measure: "MCCD" + Method: "equation" + Weighted: "Yes" + + + -- Comparison Pairs (1) + * "B" vs "A" (valid period: 0 to 8) + + i Use `summary()` for detailed comparison statistics + i Access comparison data: `x$comparisons[[i]]` + i Access metadata: `x$metadata` + +# methods work with SCI method + + Code + sum_obj <- summary(comparison) + +--- + + Code + print(sum_obj) + Message + + -- Summary of MCC Group Comparisons -------------------------------------------- + i MCC calculation method: Sum of Cumulative Incidence Method + i Comparison type: Single reference + i Reference group: "A" + i Measures: Mean Cumulative Count Difference (MCCD) + i Number of comparisons: 1 + + -- Individual Comparisons -- + + -- B vs A + Total observation period: [0, 8] + Valid comparison period: [0, 8] + Time points in valid period: 8 + MCC for B at time 8: 1.5 + MCC for A at time 8: 0.3333 + MCCD at time 8: 1.1667 + +--- + + Code + print(comparison) + Message + + -- MCC Group Comparison -- + + Type: Single reference ("A") + Measure: "MCCD" + Method: "sci" + + + -- Comparison Pairs (1) + * "B" vs "A" (valid period: 0 to 8) + + i Use `summary()` for detailed comparison statistics + i Access comparison data: `x$comparisons[[i]]` + i Access metadata: `x$metadata` + diff --git a/tests/testthat/test-s3_classes.R b/tests/testthat/test-s3_classes.R index 9d4bb8d..04a544f 100644 --- a/tests/testthat/test-s3_classes.R +++ b/tests/testthat/test-s3_classes.R @@ -779,3 +779,184 @@ test_that("create_subtitle function works correctly", { subtitle_grouped <- create_subtitle(mcc_grouped) expect_true(grepl("groups", subtitle_grouped)) }) + + +# Helper function to create test comparison objects +create_test_comparison <- function(n_groups = 2, pairwise = FALSE) { + if (n_groups == 2) { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") + ) |> + dplyr::arrange(id, time) + } else if (n_groups == 3) { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 5, 5, 6, 6, 7, 8, 8, 9), + time = c(8, 7, 5, 6, 7, 7, 8, 3, 4, 4, 5, 6, 6), + cause = c(0, 0, 2, 1, 0, 1, 0, 1, 2, 2, 1, 0, 0), + group = c("A", "A", "A", "B", "B", "B", "B", "B", "B", "C", "C", "C", "C") + ) |> + dplyr::arrange(id, time) + } + + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group") + + if (n_groups == 3) { + refs <- sort(unique(df$group))[1:2] + } else { + refs <- sort(unique(df$group))[1] + } + + if (pairwise) { + comparison <- compare_groups( + mcc_grouped, + pairwise = TRUE, + reference = refs + ) + } else { + comparison <- compare_groups( + mcc_grouped, + reference = sort(unique(df$group))[1] + ) + } + + return(comparison) +} + +# Print Method Tests ------------------------------------------------------ + +test_that("print.mcc_group_comparison works for two-group comparison", { + comparison <- create_test_comparison(n_groups = 2) + + expect_snapshot(print(comparison)) +}) + +test_that("print.mcc_group_comparison works for pairwise comparisons", { + comparison <- create_test_comparison(n_groups = 3, pairwise = TRUE) + + expect_snapshot(print(comparison)) +}) + +test_that("print.mcc_group_comparison shows weighted status", { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A"), + weights = c(1.2, 0.8, 1.5, 1.0, 1.0, 1.0, 1.0, 1.3, 1.1) + ) |> + dplyr::arrange(id, time) + + mcc_weighted <- mcc( + df, + "id", + "time", + "cause", + by = "group", + weights = "weights" + ) + comparison <- compare_groups(mcc_weighted, reference = "A") + + expect_snapshot(print(comparison)) +}) + +test_that("print.mcc_group_comparison returns invisibly", { + comparison <- create_test_comparison(n_groups = 2) + result <- print(comparison) + expect_identical(result, comparison) +}) + +# Summary Method Tests ---------------------------------------------------- + +test_that("summary.mcc_group_comparison creates correct object structure", { + comparison <- create_test_comparison(n_groups = 2) + sum_obj <- summary(comparison) + + expect_s3_class(sum_obj, "summary.mcc_group_comparison") + expect_true("comparison_summaries" %in% names(sum_obj)) + expect_true("metadata" %in% names(sum_obj)) + expect_true("method" %in% names(sum_obj)) + expect_true("weighted" %in% names(sum_obj)) + expect_true("measure" %in% names(sum_obj)) + expect_true("pairwise" %in% names(sum_obj)) + expect_true("n_comparisons" %in% names(sum_obj)) +}) + +test_that("summary.mcc_group_comparison calculates final values correctly", { + comparison <- create_test_comparison(n_groups = 2) + sum_obj <- summary(comparison) + + comp_sum <- sum_obj$comparison_summaries[[1]] + + expect_true("final_values" %in% names(comp_sum)) + expect_true("time" %in% names(comp_sum$final_values)) + expect_true("mcc_comp" %in% names(comp_sum$final_values)) + expect_true("mcc_ref" %in% names(comp_sum$final_values)) + expect_true("has_valid_comparison" %in% names(comp_sum$final_values)) + + # Should have valid comparison + expect_true(comp_sum$final_values$has_valid_comparison) + expect_false(is.na(comp_sum$final_values$time)) +}) + +test_that("summary.mcc_group_comparison works with both measures", { + comparison <- create_test_comparison(n_groups = 2) + comparison_both <- compare_groups( + comparison$original_mcc, + reference = "B", + measure = "both" + ) + + sum_obj <- summary(comparison_both) + comp_sum <- sum_obj$comparison_summaries[[1]] + + expect_true("mccd" %in% names(comp_sum$final_values)) + expect_true("mccr" %in% names(comp_sum$final_values)) +}) + +test_that("summary.mcc_group_comparison handles multiple comparisons", { + comparison <- create_test_comparison(n_groups = 3, pairwise = FALSE) + sum_obj <- summary(comparison) + + # Should have 2 comparisons (B vs A, C vs A) + expect_equal(length(sum_obj$comparison_summaries), 2) + + # Each should have the required fields + for (comp_sum in sum_obj$comparison_summaries) { + expect_true("comparison" %in% names(comp_sum)) + expect_true("reference" %in% names(comp_sum)) + expect_true("truncation_time" %in% names(comp_sum)) + expect_true("n_valid_times" %in% names(comp_sum)) + } +}) + +test_that("summary.mcc_group_comparison counts time points correctly", { + comparison <- create_test_comparison(n_groups = 2) + sum_obj <- summary(comparison) + comp_sum <- sum_obj$comparison_summaries[[1]] + + # Check that time point counts make sense + expect_true(is.numeric(comp_sum$n_valid_times)) + expect_true(comp_sum$n_valid_times > 0) + expect_true(is.numeric(comp_sum$n_extended_times)) + expect_true(comp_sum$n_extended_times >= 0) +}) + +test_that("methods work with SCI method", { + df <- data.frame( + id = c(1, 2, 3, 4, 4, 4, 4, 5, 5), + time = c(8, 7, 5, 2, 6, 7, 8, 3, 4), + cause = c(0, 0, 2, 1, 1, 1, 0, 1, 2), + group = c("A", "A", "B", "B", "B", "B", "B", "A", "A") + ) |> + dplyr::arrange(id, time) + + mcc_grouped <- mcc(df, "id", "time", "cause", by = "group", method = "sci") + comparison <- compare_groups(mcc_grouped, reference = "A") + + expect_snapshot(sum_obj <- summary(comparison)) + expect_snapshot(print(sum_obj)) + expect_snapshot(print(comparison)) +}) From e291177cdf19e10a1114c88496237d1ff63c5d65 Mon Sep 17 00:00:00 2001 From: Ken Taylor Date: Tue, 6 Jan 2026 08:28:14 -0500 Subject: [PATCH 4/5] Update NEWS.md --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index a8bcfe9..c21855f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # mccount (development version) +* Added `compare_groups()` function to estimate the MCC difference or ratio + between two groups (#23) + * Minor edits to `vignette("estimating-mcc-after-matching-or-weighting")` # mccount 0.1.1 From b191cc54242840bead68bbdab7d2f4d900e5a897 Mon Sep 17 00:00:00 2001 From: Ken Taylor Date: Tue, 6 Jan 2026 08:37:02 -0500 Subject: [PATCH 5/5] Update _pkgdown.yml --- _pkgdown.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2f22e33..580dbc7 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -28,6 +28,13 @@ reference: - print.mcc - summary.mcc - print.summary.mcc + - print.mcc_group_comparison + - summary.mcc_group_comparison + - print.summary.mcc_group_comparison + + - title: Compare MCC Across Groups + - contents: + - compare_groups - title: Visualize Results - desc: Plot MCC curves and calculation components