diff --git a/.gitignore b/.gitignore index 79f4fad..1d1bd20 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ scratch/ CLAUDE.md /.quarto/ +Rplots.pdf diff --git a/DESCRIPTION b/DESCRIPTION index f8c3ded..55d2f94 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,12 +38,13 @@ Suggests: mgcv, survey, testthat (>= 3.0.0), - vdiffr + vdiffr, + withr Config/testthat/edition: 3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 -Remotes: +Remotes: r-causal/tidysmd, r-causal/propensity diff --git a/NAMESPACE b/NAMESPACE index 068dc03..5afdeac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,8 +1,23 @@ # Generated by roxygen2: do not edit by hand -S3method(plot_calibration,data.frame) -S3method(plot_calibration,glm) -S3method(plot_calibration,lm) +S3method(autoplot,halfmoon_auc) +S3method(autoplot,halfmoon_balance) +S3method(autoplot,halfmoon_calibration) +S3method(autoplot,halfmoon_ess) +S3method(autoplot,halfmoon_qq) +S3method(autoplot,halfmoon_roc) +S3method(plot,halfmoon_auc) +S3method(plot,halfmoon_balance) +S3method(plot,halfmoon_calibration) +S3method(plot,halfmoon_ess) +S3method(plot,halfmoon_qq) +S3method(plot,halfmoon_roc) +S3method(plot_model_calibration,data.frame) +S3method(plot_model_calibration,glm) +S3method(plot_model_calibration,halfmoon_calibration) +S3method(plot_model_calibration,lm) +S3method(plot_qq,default) +S3method(plot_qq,halfmoon_qq) S3method(plot_stratified_residuals,data.frame) S3method(plot_stratified_residuals,glm) S3method(plot_stratified_residuals,lm) @@ -11,15 +26,21 @@ export(StatRoc) export(add_ess_header) export(bal_corr) export(bal_energy) +export(bal_ess) export(bal_ks) +export(bal_model_auc) +export(bal_model_roc_curve) export(bal_prognostic_score) +export(bal_qq) export(bal_smd) export(bal_vr) export(bind_matches) -export(check_auc) export(check_balance) -export(check_calibration) export(check_ess) +export(check_model_auc) +export(check_model_calibration) +export(check_model_roc_curve) +export(check_qq) export(contains) export(ends_with) export(ess) @@ -38,20 +59,19 @@ export(num_range) export(one_of) export(peek_vars) export(plot_balance) -export(plot_calibration) export(plot_ess) export(plot_mirror_distributions) +export(plot_model_auc) +export(plot_model_calibration) +export(plot_model_roc_curve) export(plot_qq) -export(plot_roc_auc) -export(plot_roc_curve) export(plot_stratified_residuals) -export(qq) -export(roc_curve) export(starts_with) export(stat_qq2) export(stat_roc) export(tidy_smd) export(weighted_quantile) +importFrom(ggplot2,autoplot) importFrom(rlang,"%||%") importFrom(rlang,.data) importFrom(rlang,.env) diff --git a/R/autoplot-methods.R b/R/autoplot-methods.R new file mode 100644 index 0000000..69eee04 --- /dev/null +++ b/R/autoplot-methods.R @@ -0,0 +1,104 @@ +#' Autoplot Methods for halfmoon Objects +#' +#' These methods provide automatic plot generation for halfmoon data objects +#' using ggplot2's autoplot interface. Each method dispatches to the appropriate +#' plot_*() function as follows: +#' +#' - `autoplot.halfmoon_balance` calls [plot_balance()] +#' - `autoplot.halfmoon_ess` calls [plot_ess()] +#' - `autoplot.halfmoon_calibration` calls [plot_model_calibration()] +#' - `autoplot.halfmoon_roc` calls [plot_model_roc_curve()] +#' - `autoplot.halfmoon_auc` calls [plot_model_auc()] +#' - `autoplot.halfmoon_qq` calls [plot_qq()] +#' +#' @param object A halfmoon data object with appropriate class +#' @param ... Additional arguments passed to the underlying plot_*() function +#' +#' @return A ggplot2 object +#' @name autoplot-halfmoon +NULL + +#' @rdname autoplot-halfmoon +#' @export +#' @importFrom ggplot2 autoplot +autoplot.halfmoon_balance <- function(object, ...) { + plot_balance(object, ...) +} + +#' @rdname autoplot-halfmoon +#' @export +autoplot.halfmoon_ess <- function(object, ...) { + plot_ess(object, ...) +} + +#' @rdname autoplot-halfmoon +#' @export +autoplot.halfmoon_calibration <- function(object, ...) { + plot_model_calibration(object, ...) +} + +#' @rdname autoplot-halfmoon +#' @export +autoplot.halfmoon_roc <- function(object, ...) { + plot_model_roc_curve(object, ...) +} + +#' @rdname autoplot-halfmoon +#' @export +autoplot.halfmoon_auc <- function(object, ...) { + plot_model_auc(object, ...) +} + +#' @rdname autoplot-halfmoon +#' @export +autoplot.halfmoon_qq <- function(object, ...) { + plot_qq(object, ...) +} + +#' Plot Methods for halfmoon Objects +#' +#' These methods provide standard plot generation for halfmoon data objects. +#' They create the plot using autoplot() and then print it. +#' +#' @param x A halfmoon data object with appropriate class +#' @param ... Additional arguments passed to autoplot() +#' +#' @return Invisibly returns the ggplot2 object after printing +#' @name plot-halfmoon +NULL + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_balance <- function(x, ...) { + autoplot(x, ...) +} + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_ess <- function(x, ...) { + autoplot(x, ...) +} + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_calibration <- function(x, ...) { + autoplot(x, ...) +} + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_roc <- function(x, ...) { + autoplot(x, ...) +} + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_auc <- function(x, ...) { + autoplot(x, ...) +} + +#' @rdname plot-halfmoon +#' @export +plot.halfmoon_qq <- function(x, ...) { + autoplot(x, ...) +} diff --git a/R/bal_ess.R b/R/bal_ess.R new file mode 100644 index 0000000..95fe85c --- /dev/null +++ b/R/bal_ess.R @@ -0,0 +1,49 @@ +#' Calculate Effective Sample Size for Single Weight Vector +#' +#' Computes the effective sample size (ESS) for a single weighting scheme. +#' This is a wrapper around [ess()] that follows the bal_*() naming convention +#' for API consistency. +#' +#' @details +#' The effective sample size (ESS) is calculated using the classical formula: +#' \eqn{ESS = (\sum w)^2 / \sum(w^2)}. +#' +#' ESS reflects how many observations you would have if all were equally weighted. +#' When weights vary substantially, the ESS can be much smaller than the actual +#' number of observations, indicating that a few observations carry +#' disproportionately large weights. +#' +#' **Diagnostic Value**: +#' * A large discrepancy between ESS and the actual sample size indicates that +#' a few observations carry disproportionately large weights +#' * A small ESS signals that weighted estimates are more sensitive to a handful +#' of observations, inflating the variance and standard errors +#' * If ESS is much lower than the total sample size, consider investigating +#' why some weights are extremely large or small +#' +#' @param .wts A numeric vector of weights or a single weight column from a data frame. +#' @inheritParams balance_params +#' +#' @return A single numeric value representing the effective sample size. +#' +#' @family balance functions +#' @seealso [ess()] for the underlying implementation, [check_ess()] for +#' computing ESS across multiple weighting schemes +#' +#' @examples +#' # ESS for ATE weights +#' bal_ess(nhefs_weights$w_ate) +#' +#' # ESS for ATT weights +#' bal_ess(nhefs_weights$w_att) +#' +#' # With missing values +#' weights_with_na <- nhefs_weights$w_ate +#' weights_with_na[1:5] <- NA +#' bal_ess(weights_with_na, na.rm = TRUE) +#' +#' @export +bal_ess <- function(.wts, na.rm = FALSE) { + # Simply call the existing ess() function + ess(.wts, na.rm = na.rm) +} diff --git a/R/bal_model_auc.R b/R/bal_model_auc.R new file mode 100644 index 0000000..54e3098 --- /dev/null +++ b/R/bal_model_auc.R @@ -0,0 +1,130 @@ +#' Calculate Single AUC for Model Balance Assessment +#' +#' Computes the Area Under the ROC Curve (AUC) for a single weighting scheme +#' or unweighted data. In causal inference, an AUC around 0.5 indicates good +#' balance between treatment groups. +#' +#' @details +#' The AUC provides a single metric for assessing propensity score balance. +#' When propensity scores achieve perfect balance, the weighted distribution +#' of scores should be identical between treatment groups, resulting in an +#' AUC of 0.5 (chance performance). +#' +#' AUC values significantly different from 0.5 indicate systematic differences +#' in propensity score distributions between groups, suggesting inadequate +#' balance. +#' +#' @param .data A data frame containing the variables. +#' @param .truth The treatment/outcome variable (unquoted). +#' @param .estimate The propensity score or fitted values (unquoted). +#' @param .wts Optional single weight variable (unquoted). If NULL, computes +#' unweighted AUC. +#' @inheritParams balance_params +#' @inheritParams treatment_param +#' +#' @return A numeric value representing the AUC. Values around 0.5 indicate +#' good balance, while values closer to 0 or 1 indicate poor balance. +#' +#' @family balance functions +#' @seealso [check_model_auc()] for computing AUC across multiple weights, +#' [bal_model_roc_curve()] for the full ROC curve +#' +#' @examples +#' # Unweighted AUC +#' bal_model_auc(nhefs_weights, qsmk, .fitted) +#' +#' # Weighted AUC +#' bal_model_auc(nhefs_weights, qsmk, .fitted, w_ate) +#' +#' @export +bal_model_auc <- function( + .data, + .truth, + .estimate, + .wts = NULL, + na.rm = TRUE, + treatment_level = NULL +) { + validate_data_frame(.data, call = rlang::caller_env()) + + truth_quo <- rlang::enquo(.truth) + estimate_quo <- rlang::enquo(.estimate) + wts_quo <- rlang::enquo(.wts) + + # Extract column names + truth_name <- names(tidyselect::eval_select(truth_quo, .data)) + estimate_name <- names(tidyselect::eval_select(estimate_quo, .data)) + + if (length(truth_name) != 1) { + abort( + "{.arg .truth} must select exactly one variable", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + if (length(estimate_name) != 1) { + abort( + "{.arg .estimate} must select exactly one variable", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + + # Extract data + truth <- .data[[truth_name]] + estimate <- .data[[estimate_name]] + + # Handle weights if provided + weights <- NULL + if (!rlang::quo_is_null(wts_quo)) { + weight_vars <- names(tidyselect::eval_select(wts_quo, .data)) + if (length(weight_vars) != 1) { + abort( + "{.arg .wts} must select exactly one variable or be NULL", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + weights <- extract_weight_data(.data[[weight_vars[1]]]) + } + + # Handle missing values + if (na.rm) { + if (is.null(weights)) { + complete_cases <- stats::complete.cases(truth, estimate) + } else { + complete_cases <- stats::complete.cases(truth, estimate, weights) + } + truth <- truth[complete_cases] + estimate <- estimate[complete_cases] + if (!is.null(weights)) { + weights <- weights[complete_cases] + } + } else { + if (is.null(weights)) { + na_present <- any(is.na(truth)) || any(is.na(estimate)) + } else { + na_present <- any(is.na(truth)) || + any(is.na(estimate)) || + any(is.na(weights)) + } + if (na_present) { + return(NA_real_) + } + } + + # Compute ROC curve + roc_data <- compute_roc_curve_imp( + truth, + estimate, + weights = weights, + treatment_level = treatment_level, + call = rlang::current_env() + ) + + # Calculate AUC using trapezoidal rule + fpr <- 1 - roc_data$specificity + tpr <- roc_data$sensitivity + + compute_auc(fpr, tpr) +} diff --git a/R/bal_model_roc_curve.R b/R/bal_model_roc_curve.R new file mode 100644 index 0000000..803a6b4 --- /dev/null +++ b/R/bal_model_roc_curve.R @@ -0,0 +1,131 @@ +#' Calculate Single ROC Curve for Model Balance Assessment +#' +#' Computes the Receiver Operating Characteristic (ROC) curve for a single +#' weighting scheme or unweighted data. In causal inference, an ROC curve +#' near the diagonal indicates good balance between treatment groups. +#' +#' @details +#' The ROC curve plots sensitivity (true positive rate) against 1-specificity +#' (false positive rate) across all possible threshold values. When propensity +#' scores achieve perfect balance, the ROC curve should lie close to the diagonal +#' line from (0,0) to (1,1), indicating that the propensity scores have no +#' discriminatory ability between treatment groups. +#' +#' ROC curves that bow significantly above the diagonal indicate that the +#' propensity scores can still distinguish between treatment groups, suggesting +#' inadequate balance. +#' +#' @param .data A data frame containing the variables. +#' @param .truth The treatment/outcome variable (unquoted). +#' @param .estimate The propensity score or fitted values (unquoted). +#' @param .wts Optional single weight variable (unquoted). If NULL, computes +#' unweighted ROC curve. +#' @inheritParams balance_params +#' @inheritParams treatment_param +#' +#' @return A tibble with columns: +#' \item{threshold}{Numeric. The decision threshold.} +#' \item{sensitivity}{Numeric. True positive rate at the threshold.} +#' \item{specificity}{Numeric. True negative rate at the threshold.} +#' +#' @family balance functions +#' @seealso [check_model_roc_curve()] for computing ROC curves across multiple weights, +#' [bal_model_auc()] for the area under the curve summary +#' +#' @examples +#' # Unweighted ROC curve +#' bal_model_roc_curve(nhefs_weights, qsmk, .fitted) +#' +#' # Weighted ROC curve +#' bal_model_roc_curve(nhefs_weights, qsmk, .fitted, w_ate) +#' +#' @export +bal_model_roc_curve <- function( + .data, + .truth, + .estimate, + .wts = NULL, + na.rm = TRUE, + treatment_level = NULL +) { + validate_data_frame(.data, call = rlang::caller_env()) + + truth_quo <- rlang::enquo(.truth) + estimate_quo <- rlang::enquo(.estimate) + wts_quo <- rlang::enquo(.wts) + + # Extract column names + truth_name <- names(tidyselect::eval_select(truth_quo, .data)) + estimate_name <- names(tidyselect::eval_select(estimate_quo, .data)) + + if (length(truth_name) != 1) { + abort( + "{.arg .truth} must select exactly one variable", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + if (length(estimate_name) != 1) { + abort( + "{.arg .estimate} must select exactly one variable", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + + # Extract data + truth <- .data[[truth_name]] + estimate <- .data[[estimate_name]] + + # Handle weights if provided + weights <- NULL + if (!rlang::quo_is_null(wts_quo)) { + weight_vars <- names(tidyselect::eval_select(wts_quo, .data)) + if (length(weight_vars) != 1) { + abort( + "{.arg .wts} must select exactly one variable or be NULL", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + weights <- extract_weight_data(.data[[weight_vars[1]]]) + } + + # Handle missing values + if (na.rm) { + if (is.null(weights)) { + complete_cases <- stats::complete.cases(truth, estimate) + } else { + complete_cases <- stats::complete.cases(truth, estimate, weights) + } + truth <- truth[complete_cases] + estimate <- estimate[complete_cases] + if (!is.null(weights)) { + weights <- weights[complete_cases] + } + } else { + if (is.null(weights)) { + na_present <- any(is.na(truth)) || any(is.na(estimate)) + } else { + na_present <- any(is.na(truth)) || + any(is.na(estimate)) || + any(is.na(weights)) + } + if (na_present) { + return(tibble::tibble( + threshold = NA_real_, + sensitivity = NA_real_, + specificity = NA_real_ + )) + } + } + + # Compute and return ROC curve + compute_roc_curve_imp( + truth, + estimate, + weights = weights, + treatment_level = treatment_level, + call = rlang::current_env() + ) +} diff --git a/R/bal_qq.R b/R/bal_qq.R new file mode 100644 index 0000000..64432db --- /dev/null +++ b/R/bal_qq.R @@ -0,0 +1,178 @@ +#' Compute QQ Data for Single Variable and Weight +#' +#' Calculate quantile-quantile data comparing the distribution of a variable +#' between treatment groups for a single weighting scheme (or unweighted). +#' This function computes the quantiles for both groups and returns a data frame +#' suitable for plotting or further analysis. +#' +#' @details +#' This function computes the data needed for quantile-quantile plots by calculating +#' corresponding quantiles from two distributions. The computation uses the inverse +#' of the empirical cumulative distribution function (ECDF). For weighted data, +#' it first computes the weighted ECDF and then inverts it to obtain quantiles. +#' +#' When the distributions of a variable are similar between treatment groups +#' (indicating good balance), the QQ plot points will lie close to the diagonal +#' line y = x. +#' +#' @param .data A data frame containing the variables. +#' @param .var Variable to compute quantiles for (unquoted). +#' @param .group Column name of treatment/group variable (unquoted). +#' @param .wts Optional single weight variable (unquoted). If NULL, computes +#' unweighted quantiles. +#' @param quantiles Numeric vector of quantiles to compute. Default is +#' `seq(0.01, 0.99, 0.01)` for 99 quantiles. +#' @inheritParams balance_params +#' @inheritParams treatment_param +#' +#' @return A tibble with columns: +#' \item{quantile}{Numeric. The quantile probability (0-1).} +#' \item{treated_quantiles}{Numeric. The quantile value for the treatment group.} +#' \item{untreated_quantiles}{Numeric. The quantile value for the control group.} +#' +#' @family balance functions +#' @seealso [check_qq()] for computing QQ data across multiple weights, +#' [plot_qq()] for visualization +#' +#' @examples +#' # Unweighted QQ data +#' bal_qq(nhefs_weights, age, qsmk) +#' +#' # Weighted QQ data +#' bal_qq(nhefs_weights, age, qsmk, .wts = w_ate) +#' +#' # Custom quantiles +#' bal_qq(nhefs_weights, age, qsmk, .wts = w_ate, +#' quantiles = seq(0.1, 0.9, 0.1)) +#' +#' @export +bal_qq <- function( + .data, + .var, + .group, + .wts = NULL, + quantiles = seq(0.01, 0.99, 0.01), + treatment_level = NULL, + na.rm = FALSE +) { + # Handle column names + var_quo <- rlang::enquo(.var) + group_quo <- rlang::enquo(.group) + wts_quo <- rlang::enquo(.wts) + + var_name <- get_column_name(var_quo, ".var") + group_name <- get_column_name(group_quo, ".group") + + # Validate inputs + validate_data_frame(.data, call = rlang::caller_env()) + validate_column_exists(.data, var_name, ".var", call = rlang::caller_env()) + validate_column_exists( + .data, + group_name, + ".group", + call = rlang::caller_env() + ) + + # Get weight column if provided + wt_name <- NULL + if (!rlang::quo_is_null(wts_quo)) { + wt_names <- names(tidyselect::eval_select(wts_quo, .data)) + if (length(wt_names) != 1) { + abort( + "{.arg .wts} must select exactly one variable or be NULL", + error_class = "halfmoon_arg_error", + call = rlang::current_env() + ) + } + wt_name <- wt_names[1] + } + + # Get group levels + group_var <- .data[[group_name]] + group_levels <- extract_group_levels(group_var) + + # Validate binary group + validate_binary_group(group_levels, group_name, call = rlang::caller_env()) + + # Check for missing values if na.rm = FALSE + if (!na.rm) { + var_data <- .data[[var_name]] + if (any(is.na(var_data))) { + abort( + "Variable {.code {var_name}} contains missing values and {.arg na.rm = FALSE}", + error_class = "halfmoon_na_error", + call = rlang::current_env() + ) + } + if (any(is.na(group_var))) { + abort( + "Group variable {.code {group_name}} contains missing values and {.arg na.rm = FALSE}", + error_class = "halfmoon_na_error", + call = rlang::current_env() + ) + } + } + + # Handle NULL treatment_level - use same logic as check_qq + if (is.null(treatment_level)) { + if (is.factor(group_var)) { + # For factors, use the last level + treatment_level <- group_levels[length(group_levels)] + } else { + # For numeric, use the maximum value + treatment_level <- max(group_levels) + } + } + + # Validate treatment_level exists + if (!treatment_level %in% group_levels) { + abort( + "{.arg treatment_level} '{treatment_level}' not found in {.arg .group} levels: {.val {group_levels}}", + error_class = "halfmoon_reference_error", + call = rlang::current_env() + ) + } + + # Use treatment_level as reference group (same as check_qq) + ref_group <- treatment_level + comp_group <- setdiff(group_levels, treatment_level) + + # Filter data by group + ref_data <- .data[group_var == ref_group, ] + comp_data <- .data[group_var == comp_group, ] + + if (na.rm) { + ref_data <- ref_data[!is.na(ref_data[[var_name]]), ] + comp_data <- comp_data[!is.na(comp_data[[var_name]]), ] + } + + # Get values + ref_vals <- ref_data[[var_name]] + comp_vals <- comp_data[[var_name]] + + # Compute quantiles + if (is.null(wt_name)) { + # Standard quantiles + ref_q <- stats::quantile(ref_vals, probs = quantiles, na.rm = FALSE) + comp_q <- stats::quantile(comp_vals, probs = quantiles, na.rm = FALSE) + } else { + # Weighted quantiles + ref_wts <- extract_weight_data(ref_data[[wt_name]]) + comp_wts <- extract_weight_data(comp_data[[wt_name]]) + + if (na.rm) { + ref_wts <- ref_wts[!is.na(ref_data[[var_name]])] + comp_wts <- comp_wts[!is.na(comp_data[[var_name]])] + } + + ref_q <- weighted_quantile(ref_vals, quantiles, .wts = ref_wts) + comp_q <- weighted_quantile(comp_vals, quantiles, .wts = comp_wts) + } + + # Return tibble + tibble::tibble( + quantile = quantiles, + treated_quantiles = ref_q, + untreated_quantiles = comp_q + ) +} diff --git a/R/check_balance.R b/R/check_balance.R index 9588f11..6302793 100644 --- a/R/check_balance.R +++ b/R/check_balance.R @@ -56,7 +56,8 @@ #' \item{metric}{Character. The balance metric computed ("smd", "vr", "ks").} #' \item{estimate}{Numeric. The computed balance statistic.} #' @family balance functions -#' @seealso [bal_smd()], [bal_vr()], [bal_ks()], [bal_corr()], [bal_energy()] for individual metric functions +#' @seealso [bal_smd()], [bal_vr()], [bal_ks()], [bal_corr()], [bal_energy()] for individual metric functions, +#' [plot_balance()] for visualization #' #' @examples #' # Basic usage with binary exposure @@ -379,6 +380,9 @@ check_balance <- function( results <- dplyr::arrange(results, variable, metric, method) } + # Add halfmoon_balance class + class(results) <- c("halfmoon_balance", class(results)) + return(results) } diff --git a/R/check_ess.R b/R/check_ess.R index 244c558..410ccd6 100644 --- a/R/check_ess.R +++ b/R/check_ess.R @@ -178,5 +178,8 @@ check_ess <- function( ess_data <- dplyr::select(ess_data, -.ess_group) } + # Add halfmoon_ess class + class(ess_data) <- c("halfmoon_ess", class(ess_data)) + ess_data } diff --git a/R/check_auc.R b/R/check_model_auc.R similarity index 93% rename from R/check_auc.R rename to R/check_model_auc.R index 8300024..7e177b5 100644 --- a/R/check_auc.R +++ b/R/check_model_auc.R @@ -30,17 +30,18 @@ #' \item{method}{Character. The weighting method ("observed" or weight variable name).} #' \item{auc}{Numeric. The ROC AUC value.} #' @family balance functions -#' @seealso [check_balance()] for other balance metrics, [geom_roc()] for plotting ROC curves +#' @seealso [bal_model_auc()] for single AUC values, [plot_model_auc()] for visualization, +#' [check_balance()] for other balance metrics #' #' @examples #' # Check balance for propensity scores -#' check_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)) +#' check_model_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)) #' #' # Without observed results -#' check_auc(nhefs_weights, qsmk, .fitted, w_ate, include_observed = FALSE) +#' check_model_auc(nhefs_weights, qsmk, .fitted, w_ate, include_observed = FALSE) #' #' @export -check_auc <- function( +check_model_auc <- function( .data, .truth, .estimate, @@ -51,7 +52,7 @@ check_auc <- function( ) { validate_data_frame(.data) - roc_data <- roc_curve( + roc_data <- check_model_roc_curve( .data, {{ .truth }}, {{ .estimate }}, @@ -69,6 +70,9 @@ check_auc <- function( roc_data = roc_data ) + # Add halfmoon_auc class + class(auc_results) <- c("halfmoon_auc", class(auc_results)) + auc_results } @@ -88,7 +92,7 @@ compute_method_auc <- function(method, roc_data) { } -#' ROC Curve for Causal Inference +#' Check ROC Curves for Multiple Weights #' #' Computes ROC curves (weighted or unweighted) for evaluating propensity score balance. #' In causal inference, an ROC curve near the diagonal (AUC around 0.5) @@ -103,9 +107,11 @@ compute_method_auc <- function(method, roc_data) { #' @param treatment_level The level of `.truth` to consider as the treatment/event. #' Default is NULL, which uses the second level. #' -#' @return A tibble with ROC curve data. +#' @return A tibble with class "halfmoon_roc" containing ROC curve data. +#' @family balance functions +#' @seealso [check_model_auc()] for AUC summaries, [bal_model_roc_curve()] for single ROC curves #' @export -roc_curve <- function( +check_model_roc_curve <- function( .data, .truth, .estimate, @@ -264,7 +270,12 @@ roc_curve <- function( ) } - dplyr::bind_rows(results) + result <- dplyr::bind_rows(results) + + # Add halfmoon_roc class + class(result) <- c("halfmoon_roc", class(result)) + + result } compute_roc_curve_imp <- function( diff --git a/R/compute_qq.R b/R/check_qq.R similarity index 94% rename from R/compute_qq.R rename to R/check_qq.R index 24ea4aa..383e249 100644 --- a/R/compute_qq.R +++ b/R/check_qq.R @@ -1,4 +1,4 @@ -#' Compute QQ plot data for weighted and unweighted samples +#' Check QQ Data for Multiple Weights #' #' Calculate quantile-quantile data comparing the distribution of a variable #' between treatment groups. This function computes the quantiles for both @@ -24,24 +24,26 @@ #' If `NULL` (default), uses the last level for factors or the maximum value for numeric variables. #' @param na.rm Logical; if TRUE, drop NA values before computation. #' -#' @return A tibble with columns: +#' @return A tibble with class "halfmoon_qq" containing columns: #' \item{method}{Character. The weighting method ("observed" or weight variable name).} #' \item{quantile}{Numeric. The quantile probability (0-1).} #' \item{treated_quantiles}{Numeric. The quantile value for the treatment group.} #' \item{untreated_quantiles}{Numeric. The quantile value for the control group.} #' +#' @family balance functions +#' @seealso [bal_qq()] for single weight QQ data, [plot_qq()] for visualization #' @examples #' # Basic QQ data (observed only) -#' qq(nhefs_weights, age, qsmk) +#' check_qq(nhefs_weights, age, qsmk) #' #' # With weighting -#' qq(nhefs_weights, age, qsmk, .wts = w_ate) +#' check_qq(nhefs_weights, age, qsmk, .wts = w_ate) #' #' # Compare multiple weighting schemes -#' qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) +#' check_qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) #' #' @export -qq <- function( +check_qq <- function( .data, .var, .group, @@ -161,6 +163,9 @@ qq <- function( # Format method labels qq_data$method <- factor(qq_data$method, levels = methods) + # Add halfmoon_qq class + class(qq_data) <- c("halfmoon_qq", class(qq_data)) + qq_data } diff --git a/R/geom_calibration.R b/R/geom_calibration.R index b72c9d6..1a832ce 100644 --- a/R/geom_calibration.R +++ b/R/geom_calibration.R @@ -1,6 +1,6 @@ #' Compute calibration data for binary outcomes #' -#' `check_calibration()` summarizes predicted probabilities and observed outcomes, +#' `check_model_calibration()` summarizes predicted probabilities and observed outcomes, #' computing mean prediction, observed rate, counts, and confidence intervals. #' Calibration represents the agreement between predicted probabilities and observed outcomes. #' Supports multiple methods for calibration assessment. @@ -37,17 +37,17 @@ #' @examples #' # Using the included `nhefs_weights` dataset #' # `.fitted` contains propensity scores, and `qsmk` is the treatment variable -#' check_calibration(nhefs_weights, .fitted, qsmk) +#' check_model_calibration(nhefs_weights, .fitted, qsmk) #' #' # Logistic method with smoothing -#' check_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") +#' check_model_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") #' #' # Windowed method -#' check_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") +#' check_model_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") #' #' @importFrom stats prop.test quantile glm binomial predict plogis qnorm #' @export -check_calibration <- function( +check_model_calibration <- function( data, .fitted, .group, @@ -113,6 +113,9 @@ check_calibration <- function( ) } + # Add halfmoon_calibration class + class(result) <- c("halfmoon_calibration", class(result)) + result } @@ -689,7 +692,7 @@ GeomCalibrationPoint <- ggplot2::ggproto( #' #' `geom_calibration()` creates calibration plots to assess the agreement between predicted #' probabilities and observed binary outcomes. It supports three methods: -#' binning ("breaks"), logistic regression ("logistic"), and windowed ("windowed"), all computed with [`check_calibration()`]. +#' binning ("breaks"), logistic regression ("logistic"), and windowed ("windowed"), all computed with [`check_model_calibration()`]. #' #' @details #' This geom provides a ggplot2 layer for creating calibration plots with confidence @@ -724,7 +727,7 @@ GeomCalibrationPoint <- ggplot2::ggproto( #' @inheritParams ggplot2_params #' @return A ggplot2 layer or list of layers #' @family ggplot2 functions -#' @seealso [check_calibration()] for computing calibration statistics +#' @seealso [check_model_calibration()] for computing calibration statistics #' @examples #' library(ggplot2) #' diff --git a/R/geom_qq2.R b/R/geom_qq2.R index 13cc30e..7ef5688 100644 --- a/R/geom_qq2.R +++ b/R/geom_qq2.R @@ -37,7 +37,7 @@ #' @seealso #' - [`geom_ecdf()`] for an alternative visualization of distributional differences #' - [`plot_qq()`] for a complete plotting function with reference line and labels -#' - [`qq()`] for the underlying data computation +#' - [`check_qq()`] for the underlying data computation #' #' @examples #' library(ggplot2) @@ -190,7 +190,7 @@ process_aesthetic_group <- function( wts_arg <- NULL } - qq_result <- qq( + qq_result <- check_qq( .data = temp_data, .var = .var, .group = .group, diff --git a/R/geom_roc.R b/R/geom_roc.R index 50f2666..bc277e2 100644 --- a/R/geom_roc.R +++ b/R/geom_roc.R @@ -14,7 +14,7 @@ #' #' @return A ggplot2 layer. #' @family ggplot2 functions -#' @seealso [check_auc()] for computing AUC values, [stat_roc()] for the underlying stat +#' @seealso [check_model_auc()] for computing AUC values, [stat_roc()] for the underlying stat #' #' @examples #' # Basic usage diff --git a/R/plot_calibration.R b/R/plot_calibration.R index fa8c6fb..281c01b 100644 --- a/R/plot_calibration.R +++ b/R/plot_calibration.R @@ -34,17 +34,17 @@ #' library(ggplot2) #' #' # Method 1: Using data frame -#' plot_calibration(nhefs_weights, .fitted, qsmk) +#' plot_model_calibration(nhefs_weights, .fitted, qsmk) #' #' # With rug plot -#' plot_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) +#' plot_model_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) #' #' # Different methods -#' plot_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") -#' plot_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") +#' plot_model_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") +#' plot_model_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") #' #' # Specify treatment level explicitly -#' plot_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") +#' plot_model_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") #' #' # Method 2: Using model objects #' # Fit a propensity score model @@ -53,21 +53,21 @@ #' family = binomial()) #' #' # Plot calibration from the model -#' plot_calibration(ps_model) +#' plot_model_calibration(ps_model) #' #' @seealso #' - [`geom_calibration()`] for the underlying geom -#' - [`check_calibration()`] for numerical calibration metrics +#' - [`check_model_calibration()`] for numerical calibration metrics #' - [`plot_stratified_residuals()`] for residual diagnostic plots -#' - [`plot_roc_curve()`] for ROC curves +#' - [`plot_model_roc_curve()`] for ROC curves #' - [`plot_qq()`] for QQ plots #' #' @export -plot_calibration <- function(x, ...) { - UseMethod("plot_calibration") +plot_model_calibration <- function(x, ...) { + UseMethod("plot_model_calibration") } -#' @rdname plot_calibration +#' @rdname plot_model_calibration #' @param .fitted Column name of predicted probabilities (propensity scores). #' Can be unquoted (e.g., `.fitted`) or quoted (e.g., `".fitted"`). #' @param .group Column name of treatment/group variable. @@ -86,7 +86,7 @@ plot_calibration <- function(x, ...) { #' @param include_points Logical; show points (only for "breaks" and "windowed" methods). #' @param na.rm Logical; if TRUE, drop NA values before computation. #' @export -plot_calibration.data.frame <- function( +plot_model_calibration.data.frame <- function( x, .fitted, .group, @@ -168,9 +168,9 @@ plot_calibration.data.frame <- function( p } -#' @rdname plot_calibration +#' @rdname plot_model_calibration #' @export -plot_calibration.glm <- function( +plot_model_calibration.glm <- function( x, treatment_level = NULL, method = "breaks", @@ -202,7 +202,7 @@ plot_calibration.glm <- function( ) # Call the data frame method - plot_calibration.data.frame( + plot_model_calibration.data.frame( plot_data, .fitted = .fitted, .group = .group, @@ -222,6 +222,91 @@ plot_calibration.glm <- function( ) } -#' @rdname plot_calibration +#' @rdname plot_model_calibration #' @export -plot_calibration.lm <- plot_calibration.glm +plot_model_calibration.lm <- plot_model_calibration.glm + +#' @rdname plot_model_calibration +#' @export +plot_model_calibration.halfmoon_calibration <- function( + x, + include_rug = FALSE, + include_ribbon = TRUE, + include_points = TRUE, + ... +) { + # Determine method from the data structure + method <- if (".bin" %in% names(x)) { + "breaks" + } else { + # Could be logistic or windowed - both have similar structure + # Default to logistic as it's more common + "logistic" + } + + # Create the base plot + p <- ggplot2::ggplot( + x, + ggplot2::aes(x = .data$predicted_rate, y = .data$observed_rate) + ) + + if (method == "breaks") { + # For breaks method, plot points with error bars + if (include_points) { + p <- p + ggplot2::geom_point(size = 3) + } + + if (include_ribbon) { + p <- p + + ggplot2::geom_errorbar( + ggplot2::aes(ymin = .data$lower, ymax = .data$upper), + width = 0.02, + alpha = 0.5 + ) + } + } else { + # For logistic/windowed methods, plot as line + p <- p + ggplot2::geom_line(color = "steelblue", linewidth = 1) + + if (include_ribbon) { + p <- p + + ggplot2::geom_ribbon( + ggplot2::aes(ymin = .data$lower, ymax = .data$upper), + alpha = 0.2, + fill = "steelblue" + ) + } + + if (include_points) { + p <- p + ggplot2::geom_point(alpha = 0.5, size = 1) + } + } + + # Add perfect calibration line + p <- p + + ggplot2::geom_abline( + intercept = 0, + slope = 1, + linetype = "dashed", + color = "gray50", + alpha = 0.8 + ) + + # Add labels and formatting + p <- p + + ggplot2::labs( + x = "predicted probability", + y = "observed rate" + ) + + ggplot2::xlim(0, 1) + + ggplot2::coord_cartesian(ylim = c(0, 1)) + + ggplot2::theme_minimal() + + # Add rug if requested and we have the original data + # Note: This won't work with pre-computed calibration data + if (include_rug) { + warning("Rug plot not available for pre-computed calibration data") + } + + p +} diff --git a/R/plot_mirror_distributions.R b/R/plot_mirror_distributions.R index 1968b65..2934c07 100644 --- a/R/plot_mirror_distributions.R +++ b/R/plot_mirror_distributions.R @@ -108,7 +108,7 @@ plot_mirror_distributions <- function( .wts = NULL, type = c("histogram", "density"), mirror_axis = "y", - bins = NULL, + bins = 30, binwidth = NULL, bw = "nrd0", adjust = 1, diff --git a/R/plot_qq.R b/R/plot_qq.R index 3f139e7..09de206 100644 --- a/R/plot_qq.R +++ b/R/plot_qq.R @@ -14,7 +14,8 @@ #' For an alternative visualization of the same information, see [`geom_ecdf()`], #' which shows the empirical cumulative distribution functions directly. #' -#' @param .data A data frame containing the variables. +#' @param .data A data frame containing the variables or a halfmoon_qq object. +#' @param ... Arguments passed to methods (see Methods section). #' @param .var Variable to plot. Can be unquoted (e.g., `age`) or quoted (e.g., `"age"`). #' @param .group Column name of treatment/group variable. Can be unquoted (e.g., `qsmk`) or quoted (e.g., `"qsmk"`). #' @param .wts Optional weighting variable(s). Can be unquoted variable names, @@ -30,10 +31,16 @@ #' #' @return A ggplot2 object. #' +#' @section Methods: +#' \describe{ +#' \item{`plot_qq.default`}{For data frames. Accepts all documented parameters.} +#' \item{`plot_qq.halfmoon_qq`}{For halfmoon_qq objects from `check_qq()`. Only uses `.data` and `...` parameters.} +#' } +#' #' @seealso #' - [`geom_ecdf()`] for ECDF plots, an alternative distributional visualization #' - [`geom_qq2()`] for the underlying geom used by this function -#' - [`qq()`] for computing QQ data without plotting +#' - [`check_qq()`] for computing QQ data without plotting #' #' @examples #' library(ggplot2) @@ -54,7 +61,13 @@ #' plot_qq(nhefs_weights, age, qsmk, .wts = w_ate, include_observed = FALSE) #' #' @export -plot_qq <- function( +plot_qq <- function(.data, ...) { + UseMethod("plot_qq") +} + +#' @rdname plot_qq +#' @export +plot_qq.default <- function( .data, .var, .group, @@ -62,7 +75,8 @@ plot_qq <- function( quantiles = seq(0.01, 0.99, 0.01), include_observed = TRUE, treatment_level = NULL, - na.rm = FALSE + na.rm = FALSE, + ... ) { # Basic validation var_quo <- rlang::enquo(.var) @@ -208,3 +222,47 @@ plot_qq <- function( y = paste0(var_name, " (", group_name, " = ", comp_group, ")") ) } + +#' @rdname plot_qq +#' @export +plot_qq.halfmoon_qq <- function(.data, ...) { + # Check if we have multiple methods + has_multiple_methods <- length(unique(.data$method)) > 1 + + # Create the base plot + if (has_multiple_methods) { + p <- ggplot2::ggplot( + .data, + ggplot2::aes( + x = .data$untreated_quantiles, + y = .data$treated_quantiles, + color = .data$method + ) + ) + + ggplot2::geom_line(linewidth = 1) + + ggplot2::geom_point(size = 0.5, alpha = 0.7) + } else { + p <- ggplot2::ggplot( + .data, + ggplot2::aes(x = .data$untreated_quantiles, y = .data$treated_quantiles) + ) + + ggplot2::geom_line(linewidth = 1) + + ggplot2::geom_point(size = 0.5, alpha = 0.7) + } + + # Add reference line and formatting + p + + ggplot2::geom_abline( + intercept = 0, + slope = 1, + linetype = "dashed", + color = "gray50", + alpha = 0.8 + ) + + ggplot2::labs( + x = "Control group quantiles", + y = "Treatment group quantiles" + ) + + ggplot2::theme_minimal() + + ggplot2::coord_equal() +} diff --git a/R/plot_roc.R b/R/plot_roc.R index 623f0ff..017c75b 100644 --- a/R/plot_roc.R +++ b/R/plot_roc.R @@ -15,7 +15,7 @@ #' residual imbalance. The closer the curve is to the diagonal, the better the #' balance achieved by the weighting scheme. #' -#' @param .data Output from [`roc_curve()`]. +#' @param .data Output from [`check_model_roc_curve()`] with class "halfmoon_roc". #' @param linewidth Width of the ROC curve lines. Default is 1. #' @param diagonal_color Color for the diagonal reference line. Default is "gray50". #' @param diagonal_linetype Line type for the diagonal. Default is "dashed". @@ -23,18 +23,18 @@ #' @return A ggplot2 object. #' #' @examples -#' roc_data <- roc_curve( +#' roc_data <- check_model_roc_curve( #' nhefs_weights, #' qsmk, #' .fitted, #' c(w_ate, w_att) #' ) #' -#' plot_roc_curve(roc_data) +#' plot_model_roc_curve(roc_data) #' #' #' @export -plot_roc_curve <- function( +plot_model_roc_curve <- function( .data, linewidth = 0.5, diagonal_color = "gray50", @@ -42,7 +42,7 @@ plot_roc_curve <- function( ) { if (!inherits(.data, "tbl_df") && !inherits(.data, "data.frame")) { abort( - "{.arg .data} must be a data frame or tibble from {.fn roc_curve}", + "{.arg .data} must be a data frame or tibble from {.fn check_model_roc_curve}", error_class = "halfmoon_type_error" ) } @@ -103,7 +103,7 @@ plot_roc_curve <- function( #' Creates a visualization of AUC values from weighted ROC analysis. #' Values near 0.5 indicate good balance. #' -#' @param .data Output from `check_auc()`. +#' @param .data Output from `check_model_auc()`. #' @param ref_line Show reference line at AUC = 0.5? Default is TRUE. #' @param ref_color Color for reference line. Default is "red". #' @param point_size Size of the points. Default is 3. @@ -113,7 +113,7 @@ plot_roc_curve <- function( #' #' @examples #' # Compute AUC values -#' auc_data <- check_auc( +#' auc_data <- check_model_auc( #' nhefs_weights, #' qsmk, #' .fitted, @@ -121,10 +121,10 @@ plot_roc_curve <- function( #' ) #' #' # Create plot -#' plot_roc_auc(auc_data) +#' plot_model_auc(auc_data) #' #' @export -plot_roc_auc <- function( +plot_model_auc <- function( .data, ref_line = TRUE, ref_color = "red", @@ -133,7 +133,7 @@ plot_roc_auc <- function( ) { if (!inherits(.data, "tbl_df") && !inherits(.data, "data.frame")) { abort( - "{.arg .data} must be a data frame or tibble from {.fn check_auc}", + "{.arg .data} must be a data frame or tibble from {.fn check_model_auc}", error_class = "halfmoon_type_error" ) } diff --git a/R/plot_stratified_residuals.R b/R/plot_stratified_residuals.R index 065291a..1236ffe 100644 --- a/R/plot_stratified_residuals.R +++ b/R/plot_stratified_residuals.R @@ -84,8 +84,8 @@ #' 9(1), 87-95. #' #' @seealso -#' - [`plot_calibration()`] for calibration plots -#' - [`plot_roc_curve()`] for ROC curves +#' - [`plot_model_calibration()`] for calibration plots +#' - [`plot_model_roc_curve()`] for ROC curves #' - [`plot_qq()`] for QQ plots #' #' @export diff --git a/README.Rmd b/README.Rmd index 543d598..c4ef5b9 100644 --- a/README.Rmd +++ b/README.Rmd @@ -78,17 +78,18 @@ ggplot( ylab("Proportion <= x") # weighted SMDs -plot_df <- tidy_smd( +plot_df <- check_balance( nhefs_weights, race:active, .group = qsmk, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato), + .metrics = "smd" ) ggplot( plot_df, aes( - x = abs(smd), + x = abs(estimate), y = variable, group = method, color = method @@ -107,25 +108,25 @@ Assess how well your propensity score model discriminates between treatment grou ```{r roc-example} # Check AUC across different weighting methods -roc_results <- roc_curve( +roc_results <- check_model_roc_curve( nhefs_weights, .truth = qsmk, .estimate = .fitted, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato) ) -auc_results <- check_auc( +auc_results <- check_model_auc( nhefs_weights, .truth = qsmk, .estimate = .fitted, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato) ) # Plot ROC curves -plot_roc_curve(roc_results) +plot_model_roc_curve(roc_results) # Display AUC values -plot_roc_auc(auc_results) +plot_model_auc(auc_results) ``` ### Calibration Assessment @@ -134,7 +135,7 @@ Evaluate whether predicted probabilities align with observed treatment frequenci ```{r calibration-example} #| warning: false -plot_calibration(nhefs_weights, .fitted, qsmk) +plot_model_calibration(nhefs_weights, .fitted, qsmk) ``` ### Comprehensive Balance Checking @@ -147,7 +148,7 @@ balance_results <- check_balance( nhefs_weights, .vars = race:active, .group = qsmk, - .wts = starts_with("w_"), + .wts = c(w_ate, w_att, w_atm, w_ato), .metrics = c("smd", "vr", "ks", "energy") ) @@ -189,13 +190,14 @@ One option is to just look at the matched dataset with halfmoon: ```{r} matched_data <- get_matches(m.out1) -match_smd <- tidy_smd( +match_smd <- check_balance( matched_data, - c(age, educ, race, nodegree, married, re74, re75), - .group = treat + c(age, educ, race, nodegree, married, re74, re75), + .group = treat, + .metrics = "smd" ) -love_plot(match_smd) +plot_balance(match_smd) ``` The downside here is that you can't compare multiple matching strategies to the observed dataset; the label on the plot is also wrong. halfmoon comes with a helper function, `bind_matches()`, that creates a dataset more appropriate for this task: @@ -208,14 +210,15 @@ head(matches) `matches` includes an binary variable for each `matchit` object which indicates if the row was included in the match or not. Since downweighting to 0 is equivalent to filtering the datasets to the matches, we can more easily compare multiple matched datasets with `.wts`: ```{r} -many_matched_smds <- tidy_smd( +many_matched_smds <- check_balance( matches, - c(age, educ, race, nodegree, married, re74, re75), - .group = treat, - .wts = c(m.out1, m.out2) -) + c(age, educ, race, nodegree, married, re74, re75), + .group = treat, + .wts = c(m.out1, m.out2), + .metrics = "smd" +) -love_plot(many_matched_smds) +plot_balance(many_matched_smds) ``` We can also extend the idea that matching indicators are weights to weighted mirrored histograms, giving us a good idea of the range of propensity scores that are being removed from the dataset. @@ -235,5 +238,3 @@ ggplot(matches, aes(ps)) + alpha = 0.5 ) + scale_y_continuous(labels = abs) ``` - - diff --git a/README.md b/README.md index 1a731c6..25f11f6 100644 --- a/README.md +++ b/README.md @@ -81,17 +81,18 @@ ggplot( ``` r # weighted SMDs -plot_df <- tidy_smd( +plot_df <- check_balance( nhefs_weights, race:active, .group = qsmk, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato), + .metrics = "smd" ) ggplot( plot_df, aes( - x = abs(smd), + x = abs(estimate), y = variable, group = method, color = method @@ -116,22 +117,22 @@ about 0.5 (what you would observe from a randomized experiment): ``` r # Check AUC across different weighting methods -roc_results <- roc_curve( +roc_results <- check_model_roc_curve( nhefs_weights, .truth = qsmk, .estimate = .fitted, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato) ) -auc_results <- check_auc( +auc_results <- check_model_auc( nhefs_weights, .truth = qsmk, .estimate = .fitted, - .wts = starts_with("w_") + .wts = c(w_ate, w_att, w_atm, w_ato) ) # Plot ROC curves -plot_roc_curve(roc_results) +plot_model_roc_curve(roc_results) ``` @@ -139,7 +140,7 @@ plot_roc_curve(roc_results) ``` r # Display AUC values -plot_roc_auc(auc_results) +plot_model_auc(auc_results) ``` @@ -150,7 +151,7 @@ Evaluate whether predicted probabilities align with observed treatment frequencies: ``` r -plot_calibration(nhefs_weights, .fitted, qsmk) +plot_model_calibration(nhefs_weights, .fitted, qsmk) ``` @@ -165,7 +166,7 @@ balance_results <- check_balance( nhefs_weights, .vars = race:active, .group = qsmk, - .wts = starts_with("w_"), + .wts = c(w_ate, w_att, w_atm, w_ato), .metrics = c("smd", "vr", "ks", "energy") ) @@ -213,13 +214,14 @@ One option is to just look at the matched dataset with halfmoon: ``` r matched_data <- get_matches(m.out1) -match_smd <- tidy_smd( +match_smd <- check_balance( matched_data, - c(age, educ, race, nodegree, married, re74, re75), - .group = treat + c(age, educ, race, nodegree, married, re74, re75), + .group = treat, + .metrics = "smd" ) -love_plot(match_smd) +plot_balance(match_smd) ``` @@ -248,14 +250,15 @@ matches, we can more easily compare multiple matched datasets with `.wts`: ``` r -many_matched_smds <- tidy_smd( +many_matched_smds <- check_balance( matches, - c(age, educ, race, nodegree, married, re74, re75), - .group = treat, - .wts = c(m.out1, m.out2) -) + c(age, educ, race, nodegree, married, re74, re75), + .group = treat, + .wts = c(m.out1, m.out2), + .metrics = "smd" +) -love_plot(many_matched_smds) +plot_balance(many_matched_smds) ``` diff --git a/man/autoplot-halfmoon.Rd b/man/autoplot-halfmoon.Rd new file mode 100644 index 0000000..3acbca8 --- /dev/null +++ b/man/autoplot-halfmoon.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autoplot-methods.R +\name{autoplot-halfmoon} +\alias{autoplot-halfmoon} +\alias{autoplot.halfmoon_balance} +\alias{autoplot.halfmoon_ess} +\alias{autoplot.halfmoon_calibration} +\alias{autoplot.halfmoon_roc} +\alias{autoplot.halfmoon_auc} +\alias{autoplot.halfmoon_qq} +\title{Autoplot Methods for halfmoon Objects} +\usage{ +\method{autoplot}{halfmoon_balance}(object, ...) + +\method{autoplot}{halfmoon_ess}(object, ...) + +\method{autoplot}{halfmoon_calibration}(object, ...) + +\method{autoplot}{halfmoon_roc}(object, ...) + +\method{autoplot}{halfmoon_auc}(object, ...) + +\method{autoplot}{halfmoon_qq}(object, ...) +} +\arguments{ +\item{object}{A halfmoon data object with appropriate class} + +\item{...}{Additional arguments passed to the underlying plot_*() function} +} +\value{ +A ggplot2 object +} +\description{ +These methods provide automatic plot generation for halfmoon data objects +using ggplot2's autoplot interface. Each method dispatches to the appropriate +plot_*() function as follows: +} +\details{ +\itemize{ +\item \code{autoplot.halfmoon_balance} calls \code{\link[=plot_balance]{plot_balance()}} +\item \code{autoplot.halfmoon_ess} calls \code{\link[=plot_ess]{plot_ess()}} +\item \code{autoplot.halfmoon_calibration} calls \code{\link[=plot_model_calibration]{plot_model_calibration()}} +\item \code{autoplot.halfmoon_roc} calls \code{\link[=plot_model_roc_curve]{plot_model_roc_curve()}} +\item \code{autoplot.halfmoon_auc} calls \code{\link[=plot_model_auc]{plot_model_auc()}} +\item \code{autoplot.halfmoon_qq} calls \code{\link[=plot_qq]{plot_qq()}} +} +} diff --git a/man/bal_corr.Rd b/man/bal_corr.Rd index 0b98a0f..1a79b49 100644 --- a/man/bal_corr.Rd +++ b/man/bal_corr.Rd @@ -36,12 +36,18 @@ bal_corr(nhefs_weights$age, nhefs_weights$wt71) \code{\link[=check_balance]{check_balance()}} for computing multiple balance metrics at once Other balance functions: +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, \code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/bal_ess.Rd b/man/bal_ess.Rd new file mode 100644 index 0000000..87f3aa9 --- /dev/null +++ b/man/bal_ess.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bal_ess.R +\name{bal_ess} +\alias{bal_ess} +\title{Calculate Effective Sample Size for Single Weight Vector} +\usage{ +bal_ess(.wts, na.rm = FALSE) +} +\arguments{ +\item{.wts}{A numeric vector of weights or a single weight column from a data frame.} + +\item{na.rm}{A logical value indicating whether to remove missing values +before computation. If \code{FALSE} (default), missing values in the input +will produce \code{NA} in the output.} +} +\value{ +A single numeric value representing the effective sample size. +} +\description{ +Computes the effective sample size (ESS) for a single weighting scheme. +This is a wrapper around \code{\link[=ess]{ess()}} that follows the bal_*() naming convention +for API consistency. +} +\details{ +The effective sample size (ESS) is calculated using the classical formula: +\eqn{ESS = (\sum w)^2 / \sum(w^2)}. + +ESS reflects how many observations you would have if all were equally weighted. +When weights vary substantially, the ESS can be much smaller than the actual +number of observations, indicating that a few observations carry +disproportionately large weights. + +\strong{Diagnostic Value}: +\itemize{ +\item A large discrepancy between ESS and the actual sample size indicates that +a few observations carry disproportionately large weights +\item A small ESS signals that weighted estimates are more sensitive to a handful +of observations, inflating the variance and standard errors +\item If ESS is much lower than the total sample size, consider investigating +why some weights are extremely large or small +} +} +\examples{ +# ESS for ATE weights +bal_ess(nhefs_weights$w_ate) + +# ESS for ATT weights +bal_ess(nhefs_weights$w_att) + +# With missing values +weights_with_na <- nhefs_weights$w_ate +weights_with_na[1:5] <- NA +bal_ess(weights_with_na, na.rm = TRUE) + +} +\seealso{ +\code{\link[=ess]{ess()}} for the underlying implementation, \code{\link[=check_ess]{check_ess()}} for +computing ESS across multiple weighting schemes + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/bal_ks.Rd b/man/bal_ks.Rd index 8378ad1..ceb69b2 100644 --- a/man/bal_ks.Rd +++ b/man/bal_ks.Rd @@ -72,11 +72,17 @@ bal_ks(nhefs_weights$wt71, nhefs_weights$alcoholfreq_cat, Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, \code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/bal_model_auc.Rd b/man/bal_model_auc.Rd new file mode 100644 index 0000000..7f7c038 --- /dev/null +++ b/man/bal_model_auc.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bal_model_auc.R +\name{bal_model_auc} +\alias{bal_model_auc} +\title{Calculate Single AUC for Model Balance Assessment} +\usage{ +bal_model_auc( + .data, + .truth, + .estimate, + .wts = NULL, + na.rm = TRUE, + treatment_level = NULL +) +} +\arguments{ +\item{.data}{A data frame containing the variables.} + +\item{.truth}{The treatment/outcome variable (unquoted).} + +\item{.estimate}{The propensity score or fitted values (unquoted).} + +\item{.wts}{Optional single weight variable (unquoted). If NULL, computes +unweighted AUC.} + +\item{na.rm}{A logical value indicating whether to remove missing values +before computation. If \code{FALSE} (default), missing values in the input +will produce \code{NA} in the output.} + +\item{treatment_level}{The level of the outcome variable to consider as the +treatment/event. If \code{NULL} (default), uses the last level for factors or +the maximum value for numeric variables.} +} +\value{ +A numeric value representing the AUC. Values around 0.5 indicate +good balance, while values closer to 0 or 1 indicate poor balance. +} +\description{ +Computes the Area Under the ROC Curve (AUC) for a single weighting scheme +or unweighted data. In causal inference, an AUC around 0.5 indicates good +balance between treatment groups. +} +\details{ +The AUC provides a single metric for assessing propensity score balance. +When propensity scores achieve perfect balance, the weighted distribution +of scores should be identical between treatment groups, resulting in an +AUC of 0.5 (chance performance). + +AUC values significantly different from 0.5 indicate systematic differences +in propensity score distributions between groups, suggesting inadequate +balance. +} +\examples{ +# Unweighted AUC +bal_model_auc(nhefs_weights, qsmk, .fitted) + +# Weighted AUC +bal_model_auc(nhefs_weights, qsmk, .fitted, w_ate) + +} +\seealso{ +\code{\link[=check_model_auc]{check_model_auc()}} for computing AUC across multiple weights, +\code{\link[=bal_model_roc_curve]{bal_model_roc_curve()}} for the full ROC curve + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/bal_model_roc_curve.Rd b/man/bal_model_roc_curve.Rd new file mode 100644 index 0000000..c04a134 --- /dev/null +++ b/man/bal_model_roc_curve.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bal_model_roc_curve.R +\name{bal_model_roc_curve} +\alias{bal_model_roc_curve} +\title{Calculate Single ROC Curve for Model Balance Assessment} +\usage{ +bal_model_roc_curve( + .data, + .truth, + .estimate, + .wts = NULL, + na.rm = TRUE, + treatment_level = NULL +) +} +\arguments{ +\item{.data}{A data frame containing the variables.} + +\item{.truth}{The treatment/outcome variable (unquoted).} + +\item{.estimate}{The propensity score or fitted values (unquoted).} + +\item{.wts}{Optional single weight variable (unquoted). If NULL, computes +unweighted ROC curve.} + +\item{na.rm}{A logical value indicating whether to remove missing values +before computation. If \code{FALSE} (default), missing values in the input +will produce \code{NA} in the output.} + +\item{treatment_level}{The level of the outcome variable to consider as the +treatment/event. If \code{NULL} (default), uses the last level for factors or +the maximum value for numeric variables.} +} +\value{ +A tibble with columns: +\item{threshold}{Numeric. The decision threshold.} +\item{sensitivity}{Numeric. True positive rate at the threshold.} +\item{specificity}{Numeric. True negative rate at the threshold.} +} +\description{ +Computes the Receiver Operating Characteristic (ROC) curve for a single +weighting scheme or unweighted data. In causal inference, an ROC curve +near the diagonal indicates good balance between treatment groups. +} +\details{ +The ROC curve plots sensitivity (true positive rate) against 1-specificity +(false positive rate) across all possible threshold values. When propensity +scores achieve perfect balance, the ROC curve should lie close to the diagonal +line from (0,0) to (1,1), indicating that the propensity scores have no +discriminatory ability between treatment groups. + +ROC curves that bow significantly above the diagonal indicate that the +propensity scores can still distinguish between treatment groups, suggesting +inadequate balance. +} +\examples{ +# Unweighted ROC curve +bal_model_roc_curve(nhefs_weights, qsmk, .fitted) + +# Weighted ROC curve +bal_model_roc_curve(nhefs_weights, qsmk, .fitted, w_ate) + +} +\seealso{ +\code{\link[=check_model_roc_curve]{check_model_roc_curve()}} for computing ROC curves across multiple weights, +\code{\link[=bal_model_auc]{bal_model_auc()}} for the area under the curve summary + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_qq}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/bal_qq.Rd b/man/bal_qq.Rd new file mode 100644 index 0000000..3274e1c --- /dev/null +++ b/man/bal_qq.Rd @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bal_qq.R +\name{bal_qq} +\alias{bal_qq} +\title{Compute QQ Data for Single Variable and Weight} +\usage{ +bal_qq( + .data, + .var, + .group, + .wts = NULL, + quantiles = seq(0.01, 0.99, 0.01), + treatment_level = NULL, + na.rm = FALSE +) +} +\arguments{ +\item{.data}{A data frame containing the variables.} + +\item{.var}{Variable to compute quantiles for (unquoted).} + +\item{.group}{Column name of treatment/group variable (unquoted).} + +\item{.wts}{Optional single weight variable (unquoted). If NULL, computes +unweighted quantiles.} + +\item{quantiles}{Numeric vector of quantiles to compute. Default is +\code{seq(0.01, 0.99, 0.01)} for 99 quantiles.} + +\item{treatment_level}{The level of the outcome variable to consider as the +treatment/event. If \code{NULL} (default), uses the last level for factors or +the maximum value for numeric variables.} + +\item{na.rm}{A logical value indicating whether to remove missing values +before computation. If \code{FALSE} (default), missing values in the input +will produce \code{NA} in the output.} +} +\value{ +A tibble with columns: +\item{quantile}{Numeric. The quantile probability (0-1).} +\item{treated_quantiles}{Numeric. The quantile value for the treatment group.} +\item{untreated_quantiles}{Numeric. The quantile value for the control group.} +} +\description{ +Calculate quantile-quantile data comparing the distribution of a variable +between treatment groups for a single weighting scheme (or unweighted). +This function computes the quantiles for both groups and returns a data frame +suitable for plotting or further analysis. +} +\details{ +This function computes the data needed for quantile-quantile plots by calculating +corresponding quantiles from two distributions. The computation uses the inverse +of the empirical cumulative distribution function (ECDF). For weighted data, +it first computes the weighted ECDF and then inverts it to obtain quantiles. + +When the distributions of a variable are similar between treatment groups +(indicating good balance), the QQ plot points will lie close to the diagonal +line y = x. +} +\examples{ +# Unweighted QQ data +bal_qq(nhefs_weights, age, qsmk) + +# Weighted QQ data +bal_qq(nhefs_weights, age, qsmk, .wts = w_ate) + +# Custom quantiles +bal_qq(nhefs_weights, age, qsmk, .wts = w_ate, + quantiles = seq(0.1, 0.9, 0.1)) + +} +\seealso{ +\code{\link[=check_qq]{check_qq()}} for computing QQ data across multiple weights, +\code{\link[=plot_qq]{plot_qq()}} for visualization + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/bal_smd.Rd b/man/bal_smd.Rd index de7e845..bc8b253 100644 --- a/man/bal_smd.Rd +++ b/man/bal_smd.Rd @@ -72,11 +72,17 @@ bal_smd(nhefs_weights$wt71, nhefs_weights$alcoholfreq_cat, Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, \code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/bal_vr.Rd b/man/bal_vr.Rd index 4012d2d..3aeb5c8 100644 --- a/man/bal_vr.Rd +++ b/man/bal_vr.Rd @@ -69,11 +69,17 @@ bal_vr(nhefs_weights$wt71, nhefs_weights$alcoholfreq_cat, Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, \code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/check_balance.Rd b/man/check_balance.Rd index 8ac5cc4..2645f07 100644 --- a/man/check_balance.Rd +++ b/man/check_balance.Rd @@ -128,15 +128,22 @@ check_balance(nhefs_weights, c(age, sex, race), qsmk) check_balance(nhefs_weights, c(age, sex, race), qsmk, make_dummy_vars = FALSE) } \seealso{ -\code{\link[=bal_smd]{bal_smd()}}, \code{\link[=bal_vr]{bal_vr()}}, \code{\link[=bal_ks]{bal_ks()}}, \code{\link[=bal_corr]{bal_corr()}}, \code{\link[=bal_energy]{bal_energy()}} for individual metric functions +\code{\link[=bal_smd]{bal_smd()}}, \code{\link[=bal_vr]{bal_vr()}}, \code{\link[=bal_ks]{bal_ks()}}, \code{\link[=bal_corr]{bal_corr()}}, \code{\link[=bal_energy]{bal_energy()}} for individual metric functions, +\code{\link[=plot_balance]{plot_balance()}} for visualization Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/check_ess.Rd b/man/check_ess.Rd index 0069ebf..752eb78 100644 --- a/man/check_ess.Rd +++ b/man/check_ess.Rd @@ -91,11 +91,17 @@ check_ess(nhefs_weights, .wts = w_ate, .group = qsmk, Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/check_auc.Rd b/man/check_model_auc.Rd similarity index 80% rename from man/check_auc.Rd rename to man/check_model_auc.Rd index 8602608..d8e614e 100644 --- a/man/check_auc.Rd +++ b/man/check_model_auc.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/check_auc.R -\name{check_auc} -\alias{check_auc} +% Please edit documentation in R/check_model_auc.R +\name{check_model_auc} +\alias{check_model_auc} \title{Check Balance Using Weighted ROC Curves} \usage{ -check_auc( +check_model_auc( .data, .truth, .estimate, @@ -60,22 +60,29 @@ specifically on the propensity score overlap and balance. } \examples{ # Check balance for propensity scores -check_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)) +check_model_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)) # Without observed results -check_auc(nhefs_weights, qsmk, .fitted, w_ate, include_observed = FALSE) +check_model_auc(nhefs_weights, qsmk, .fitted, w_ate, include_observed = FALSE) } \seealso{ -\code{\link[=check_balance]{check_balance()}} for other balance metrics, \code{\link[=geom_roc]{geom_roc()}} for plotting ROC curves +\code{\link[=bal_model_auc]{bal_model_auc()}} for single AUC values, \code{\link[=plot_model_auc]{plot_model_auc()}} for visualization, +\code{\link[=check_balance]{check_balance()}} for other balance metrics Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, \code{\link{check_balance}()}, \code{\link{check_ess}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()}, \code{\link{plot_balance}()} } \concept{balance functions} diff --git a/man/check_calibration.Rd b/man/check_model_calibration.Rd similarity index 88% rename from man/check_calibration.Rd rename to man/check_model_calibration.Rd index 1a12bae..ed7d8c8 100644 --- a/man/check_calibration.Rd +++ b/man/check_model_calibration.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/geom_calibration.R -\name{check_calibration} -\alias{check_calibration} +\name{check_model_calibration} +\alias{check_model_calibration} \title{Compute calibration data for binary outcomes} \usage{ -check_calibration( +check_model_calibration( data, .fitted, .group, @@ -73,7 +73,7 @@ A tibble with columns: } } \description{ -\code{check_calibration()} summarizes predicted probabilities and observed outcomes, +\code{check_model_calibration()} summarizes predicted probabilities and observed outcomes, computing mean prediction, observed rate, counts, and confidence intervals. Calibration represents the agreement between predicted probabilities and observed outcomes. Supports multiple methods for calibration assessment. @@ -81,12 +81,12 @@ Supports multiple methods for calibration assessment. \examples{ # Using the included `nhefs_weights` dataset # `.fitted` contains propensity scores, and `qsmk` is the treatment variable -check_calibration(nhefs_weights, .fitted, qsmk) +check_model_calibration(nhefs_weights, .fitted, qsmk) # Logistic method with smoothing -check_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") +check_model_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") # Windowed method -check_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") +check_model_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") } diff --git a/man/roc_curve.Rd b/man/check_model_roc_curve.Rd similarity index 52% rename from man/roc_curve.Rd rename to man/check_model_roc_curve.Rd index e06c43d..a167a4e 100644 --- a/man/roc_curve.Rd +++ b/man/check_model_roc_curve.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/check_auc.R -\name{roc_curve} -\alias{roc_curve} -\title{ROC Curve for Causal Inference} +% Please edit documentation in R/check_model_auc.R +\name{check_model_roc_curve} +\alias{check_model_roc_curve} +\title{Check ROC Curves for Multiple Weights} \usage{ -roc_curve( +check_model_roc_curve( .data, .truth, .estimate, @@ -31,10 +31,29 @@ roc_curve( Default is NULL, which uses the second level.} } \value{ -A tibble with ROC curve data. +A tibble with class "halfmoon_roc" containing ROC curve data. } \description{ Computes ROC curves (weighted or unweighted) for evaluating propensity score balance. In causal inference, an ROC curve near the diagonal (AUC around 0.5) indicates good balance between treatment groups. } +\seealso{ +\code{\link[=check_model_auc]{check_model_auc()}} for AUC summaries, \code{\link[=bal_model_roc_curve]{bal_model_roc_curve()}} for single ROC curves + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_qq}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/qq.Rd b/man/check_qq.Rd similarity index 70% rename from man/qq.Rd rename to man/check_qq.Rd index a04bd89..be28d0c 100644 --- a/man/qq.Rd +++ b/man/check_qq.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/compute_qq.R -\name{qq} -\alias{qq} -\title{Compute QQ plot data for weighted and unweighted samples} +% Please edit documentation in R/check_qq.R +\name{check_qq} +\alias{check_qq} +\title{Check QQ Data for Multiple Weights} \usage{ -qq( +check_qq( .data, .var, .group, @@ -38,7 +38,7 @@ If \code{NULL} (default), uses the last level for factors or the maximum value f \item{na.rm}{Logical; if TRUE, drop NA values before computation.} } \value{ -A tibble with columns: +A tibble with class "halfmoon_qq" containing columns: \item{method}{Character. The weighting method ("observed" or weight variable name).} \item{quantile}{Numeric. The quantile probability (0-1).} \item{treated_quantiles}{Numeric. The quantile value for the treatment group.} @@ -57,12 +57,31 @@ it first computes the weighted ECDF and then inverts it to obtain quantiles. } \examples{ # Basic QQ data (observed only) -qq(nhefs_weights, age, qsmk) +check_qq(nhefs_weights, age, qsmk) # With weighting -qq(nhefs_weights, age, qsmk, .wts = w_ate) +check_qq(nhefs_weights, age, qsmk, .wts = w_ate) # Compare multiple weighting schemes -qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) +check_qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) } +\seealso{ +\code{\link[=bal_qq]{bal_qq()}} for single weight QQ data, \code{\link[=plot_qq]{plot_qq()}} for visualization + +Other balance functions: +\code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, +\code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, +\code{\link{bal_smd}()}, +\code{\link{bal_vr}()}, +\code{\link{check_balance}()}, +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{plot_balance}()} +} +\concept{balance functions} diff --git a/man/figures/README-balance-example-1.png b/man/figures/README-balance-example-1.png index 9ff7bc1..782d706 100644 Binary files a/man/figures/README-balance-example-1.png and b/man/figures/README-balance-example-1.png differ diff --git a/man/figures/README-example-3.png b/man/figures/README-example-3.png index feabf64..8154ad9 100644 Binary files a/man/figures/README-example-3.png and b/man/figures/README-example-3.png differ diff --git a/man/figures/README-roc-example-1.png b/man/figures/README-roc-example-1.png index e11343a..3d58815 100644 Binary files a/man/figures/README-roc-example-1.png and b/man/figures/README-roc-example-1.png differ diff --git a/man/figures/README-roc-example-2.png b/man/figures/README-roc-example-2.png index a57e08d..ef9c62c 100644 Binary files a/man/figures/README-roc-example-2.png and b/man/figures/README-roc-example-2.png differ diff --git a/man/figures/README-unnamed-chunk-3-1.png b/man/figures/README-unnamed-chunk-3-1.png index 368f5a7..591ee2e 100644 Binary files a/man/figures/README-unnamed-chunk-3-1.png and b/man/figures/README-unnamed-chunk-3-1.png differ diff --git a/man/figures/README-unnamed-chunk-5-1.png b/man/figures/README-unnamed-chunk-5-1.png index d95bf40..89cdd05 100644 Binary files a/man/figures/README-unnamed-chunk-5-1.png and b/man/figures/README-unnamed-chunk-5-1.png differ diff --git a/man/geom_calibration.Rd b/man/geom_calibration.Rd index ecb6ee8..03bc860 100644 --- a/man/geom_calibration.Rd +++ b/man/geom_calibration.Rd @@ -74,7 +74,7 @@ A ggplot2 layer or list of layers \description{ \code{geom_calibration()} creates calibration plots to assess the agreement between predicted probabilities and observed binary outcomes. It supports three methods: -binning ("breaks"), logistic regression ("logistic"), and windowed ("windowed"), all computed with \code{\link[=check_calibration]{check_calibration()}}. +binning ("breaks"), logistic regression ("logistic"), and windowed ("windowed"), all computed with \code{\link[=check_model_calibration]{check_model_calibration()}}. } \details{ This geom provides a ggplot2 layer for creating calibration plots with confidence @@ -121,7 +121,7 @@ ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + labs(x = "Propensity Score", y = "Observed Treatment Rate") } \seealso{ -\code{\link[=check_calibration]{check_calibration()}} for computing calibration statistics +\code{\link[=check_model_calibration]{check_model_calibration()}} for computing calibration statistics Other ggplot2 functions: \code{\link{geom_ecdf}()}, diff --git a/man/geom_qq2.Rd b/man/geom_qq2.Rd index 671919c..765a6ef 100644 --- a/man/geom_qq2.Rd +++ b/man/geom_qq2.Rd @@ -100,7 +100,7 @@ ggplot(long_data, aes(color = weight_type)) + \itemize{ \item \code{\link[=geom_ecdf]{geom_ecdf()}} for an alternative visualization of distributional differences \item \code{\link[=plot_qq]{plot_qq()}} for a complete plotting function with reference line and labels -\item \code{\link[=qq]{qq()}} for the underlying data computation +\item \code{\link[=check_qq]{check_qq()}} for the underlying data computation } Other ggplot2 functions: diff --git a/man/geom_roc.Rd b/man/geom_roc.Rd index b943857..373c840 100644 --- a/man/geom_roc.Rd +++ b/man/geom_roc.Rd @@ -72,7 +72,7 @@ ggplot(long_data, aes(estimate = .fitted, truth = qsmk, weight = weight)) + } \seealso{ -\code{\link[=check_auc]{check_auc()}} for computing AUC values, \code{\link[=stat_roc]{stat_roc()}} for the underlying stat +\code{\link[=check_model_auc]{check_model_auc()}} for computing AUC values, \code{\link[=stat_roc]{stat_roc()}} for the underlying stat Other ggplot2 functions: \code{\link{geom_calibration}()}, diff --git a/man/plot-halfmoon.Rd b/man/plot-halfmoon.Rd new file mode 100644 index 0000000..038c09a --- /dev/null +++ b/man/plot-halfmoon.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autoplot-methods.R +\name{plot-halfmoon} +\alias{plot-halfmoon} +\alias{plot.halfmoon_balance} +\alias{plot.halfmoon_ess} +\alias{plot.halfmoon_calibration} +\alias{plot.halfmoon_roc} +\alias{plot.halfmoon_auc} +\alias{plot.halfmoon_qq} +\title{Plot Methods for halfmoon Objects} +\usage{ +\method{plot}{halfmoon_balance}(x, ...) + +\method{plot}{halfmoon_ess}(x, ...) + +\method{plot}{halfmoon_calibration}(x, ...) + +\method{plot}{halfmoon_roc}(x, ...) + +\method{plot}{halfmoon_auc}(x, ...) + +\method{plot}{halfmoon_qq}(x, ...) +} +\arguments{ +\item{x}{A halfmoon data object with appropriate class} + +\item{...}{Additional arguments passed to autoplot()} +} +\value{ +Invisibly returns the ggplot2 object after printing +} +\description{ +These methods provide standard plot generation for halfmoon data objects. +They create the plot using autoplot() and then print it. +} diff --git a/man/plot_balance.Rd b/man/plot_balance.Rd index eebd0f9..3a937df 100644 --- a/man/plot_balance.Rd +++ b/man/plot_balance.Rd @@ -108,11 +108,17 @@ the underlying geom Other balance functions: \code{\link{bal_corr}()}, +\code{\link{bal_ess}()}, \code{\link{bal_ks}()}, +\code{\link{bal_model_auc}()}, +\code{\link{bal_model_roc_curve}()}, +\code{\link{bal_qq}()}, \code{\link{bal_smd}()}, \code{\link{bal_vr}()}, -\code{\link{check_auc}()}, \code{\link{check_balance}()}, -\code{\link{check_ess}()} +\code{\link{check_ess}()}, +\code{\link{check_model_auc}()}, +\code{\link{check_model_roc_curve}()}, +\code{\link{check_qq}()} } \concept{balance functions} diff --git a/man/plot_mirror_distributions.Rd b/man/plot_mirror_distributions.Rd index 7565410..debb36f 100644 --- a/man/plot_mirror_distributions.Rd +++ b/man/plot_mirror_distributions.Rd @@ -11,7 +11,7 @@ plot_mirror_distributions( .wts = NULL, type = c("histogram", "density"), mirror_axis = "y", - bins = NULL, + bins = 30, binwidth = NULL, bw = "nrd0", adjust = 1, diff --git a/man/plot_roc_auc.Rd b/man/plot_model_auc.Rd similarity index 82% rename from man/plot_roc_auc.Rd rename to man/plot_model_auc.Rd index 0b69c8f..3cb0029 100644 --- a/man/plot_roc_auc.Rd +++ b/man/plot_model_auc.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_roc.R -\name{plot_roc_auc} -\alias{plot_roc_auc} +\name{plot_model_auc} +\alias{plot_model_auc} \title{Plot ROC AUC Values for Balance Assessment} \usage{ -plot_roc_auc( +plot_model_auc( .data, ref_line = TRUE, ref_color = "red", @@ -13,7 +13,7 @@ plot_roc_auc( ) } \arguments{ -\item{.data}{Output from \code{check_auc()}.} +\item{.data}{Output from \code{check_model_auc()}.} \item{ref_line}{Show reference line at AUC = 0.5? Default is TRUE.} @@ -32,7 +32,7 @@ Values near 0.5 indicate good balance. } \examples{ # Compute AUC values -auc_data <- check_auc( +auc_data <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -40,6 +40,6 @@ auc_data <- check_auc( ) # Create plot -plot_roc_auc(auc_data) +plot_model_auc(auc_data) } diff --git a/man/plot_calibration.Rd b/man/plot_model_calibration.Rd similarity index 80% rename from man/plot_calibration.Rd rename to man/plot_model_calibration.Rd index f38c79d..778ec65 100644 --- a/man/plot_calibration.Rd +++ b/man/plot_model_calibration.Rd @@ -1,15 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_calibration.R -\name{plot_calibration} -\alias{plot_calibration} -\alias{plot_calibration.data.frame} -\alias{plot_calibration.glm} -\alias{plot_calibration.lm} +\name{plot_model_calibration} +\alias{plot_model_calibration} +\alias{plot_model_calibration.data.frame} +\alias{plot_model_calibration.glm} +\alias{plot_model_calibration.lm} +\alias{plot_model_calibration.halfmoon_calibration} \title{Create calibration plot} \usage{ -plot_calibration(x, ...) +plot_model_calibration(x, ...) -\method{plot_calibration}{data.frame}( +\method{plot_model_calibration}{data.frame}( x, .fitted, .group, @@ -28,7 +29,7 @@ plot_calibration(x, ...) ... ) -\method{plot_calibration}{glm}( +\method{plot_model_calibration}{glm}( x, treatment_level = NULL, method = "breaks", @@ -45,7 +46,7 @@ plot_calibration(x, ...) ... ) -\method{plot_calibration}{lm}( +\method{plot_model_calibration}{lm}( x, treatment_level = NULL, method = "breaks", @@ -61,6 +62,14 @@ plot_calibration(x, ...) na.rm = FALSE, ... ) + +\method{plot_model_calibration}{halfmoon_calibration}( + x, + include_rug = FALSE, + include_ribbon = TRUE, + include_points = TRUE, + ... +) } \arguments{ \item{x}{Either a fitted model object (lm or glm) or a data frame} @@ -135,17 +144,17 @@ The function supports two approaches: library(ggplot2) # Method 1: Using data frame -plot_calibration(nhefs_weights, .fitted, qsmk) +plot_model_calibration(nhefs_weights, .fitted, qsmk) # With rug plot -plot_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) +plot_model_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) # Different methods -plot_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") -plot_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") +plot_model_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") +plot_model_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") # Specify treatment level explicitly -plot_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") +plot_model_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") # Method 2: Using model objects # Fit a propensity score model @@ -154,15 +163,15 @@ ps_model <- glm(qsmk ~ age + sex + race + education, family = binomial()) # Plot calibration from the model -plot_calibration(ps_model) +plot_model_calibration(ps_model) } \seealso{ \itemize{ \item \code{\link[=geom_calibration]{geom_calibration()}} for the underlying geom -\item \code{\link[=check_calibration]{check_calibration()}} for numerical calibration metrics +\item \code{\link[=check_model_calibration]{check_model_calibration()}} for numerical calibration metrics \item \code{\link[=plot_stratified_residuals]{plot_stratified_residuals()}} for residual diagnostic plots -\item \code{\link[=plot_roc_curve]{plot_roc_curve()}} for ROC curves +\item \code{\link[=plot_model_roc_curve]{plot_model_roc_curve()}} for ROC curves \item \code{\link[=plot_qq]{plot_qq()}} for QQ plots } } diff --git a/man/plot_roc_curve.Rd b/man/plot_model_roc_curve.Rd similarity index 84% rename from man/plot_roc_curve.Rd rename to man/plot_model_roc_curve.Rd index f64e1e3..2107ef9 100644 --- a/man/plot_roc_curve.Rd +++ b/man/plot_model_roc_curve.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_roc.R -\name{plot_roc_curve} -\alias{plot_roc_curve} +\name{plot_model_roc_curve} +\alias{plot_model_roc_curve} \title{Plot weighted ROC Curves for Balance Assessment} \usage{ -plot_roc_curve( +plot_model_roc_curve( .data, linewidth = 0.5, diagonal_color = "gray50", @@ -12,7 +12,7 @@ plot_roc_curve( ) } \arguments{ -\item{.data}{Output from \code{\link[=roc_curve]{roc_curve()}}.} +\item{.data}{Output from \code{\link[=check_model_roc_curve]{check_model_roc_curve()}} with class "halfmoon_roc".} \item{linewidth}{Width of the ROC curve lines. Default is 1.} @@ -40,14 +40,14 @@ residual imbalance. The closer the curve is to the diagonal, the better the balance achieved by the weighting scheme. } \examples{ -roc_data <- roc_curve( +roc_data <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, c(w_ate, w_att) ) -plot_roc_curve(roc_data) +plot_model_roc_curve(roc_data) } diff --git a/man/plot_qq.Rd b/man/plot_qq.Rd index dd16c37..9a418e2 100644 --- a/man/plot_qq.Rd +++ b/man/plot_qq.Rd @@ -2,9 +2,13 @@ % Please edit documentation in R/plot_qq.R \name{plot_qq} \alias{plot_qq} +\alias{plot_qq.default} +\alias{plot_qq.halfmoon_qq} \title{Create QQ plots for weighted and unweighted samples} \usage{ -plot_qq( +plot_qq(.data, ...) + +\method{plot_qq}{default}( .data, .var, .group, @@ -12,11 +16,16 @@ plot_qq( quantiles = seq(0.01, 0.99, 0.01), include_observed = TRUE, treatment_level = NULL, - na.rm = FALSE + na.rm = FALSE, + ... ) + +\method{plot_qq}{halfmoon_qq}(.data, ...) } \arguments{ -\item{.data}{A data frame containing the variables.} +\item{.data}{A data frame containing the variables or a halfmoon_qq object.} + +\item{...}{Arguments passed to methods (see Methods section).} \item{.var}{Variable to plot. Can be unquoted (e.g., \code{age}) or quoted (e.g., \code{"age"}).} @@ -55,6 +64,14 @@ appropriate axis labels. For an alternative visualization of the same information, see \code{\link[=geom_ecdf]{geom_ecdf()}}, which shows the empirical cumulative distribution functions directly. } +\section{Methods}{ + +\describe{ +\item{\code{plot_qq.default}}{For data frames. Accepts all documented parameters.} +\item{\code{plot_qq.halfmoon_qq}}{For halfmoon_qq objects from \code{check_qq()}. Only uses \code{.data} and \code{...} parameters.} +} +} + \examples{ library(ggplot2) @@ -78,6 +95,6 @@ plot_qq(nhefs_weights, age, qsmk, .wts = w_ate, include_observed = FALSE) \itemize{ \item \code{\link[=geom_ecdf]{geom_ecdf()}} for ECDF plots, an alternative distributional visualization \item \code{\link[=geom_qq2]{geom_qq2()}} for the underlying geom used by this function -\item \code{\link[=qq]{qq()}} for computing QQ data without plotting +\item \code{\link[=check_qq]{check_qq()}} for computing QQ data without plotting } } diff --git a/man/plot_stratified_residuals.Rd b/man/plot_stratified_residuals.Rd index 67c96ee..f102eee 100644 --- a/man/plot_stratified_residuals.Rd +++ b/man/plot_stratified_residuals.Rd @@ -167,8 +167,8 @@ A Visual Diagnostic Tool for Causal Inference. Observational Studies, } \seealso{ \itemize{ -\item \code{\link[=plot_calibration]{plot_calibration()}} for calibration plots -\item \code{\link[=plot_roc_curve]{plot_roc_curve()}} for ROC curves +\item \code{\link[=plot_model_calibration]{plot_model_calibration()}} for calibration plots +\item \code{\link[=plot_model_roc_curve]{plot_model_roc_curve()}} for ROC curves \item \code{\link[=plot_qq]{plot_qq()}} for QQ plots } } diff --git a/man/weighted_quantile.Rd b/man/weighted_quantile.Rd index d80ac24..f1cd7a0 100644 --- a/man/weighted_quantile.Rd +++ b/man/weighted_quantile.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/compute_qq.R +% Please edit documentation in R/check_qq.R \name{weighted_quantile} \alias{weighted_quantile} \title{Compute weighted quantiles} diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-auc.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-auc.svg new file mode 100644 index 0000000..2786d15 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-auc.svg @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + + + + + +0.663 +0.502 +0.495 + + + + +observed +w_ate +w_att + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +auc +method +autoplot-halfmoon-auc + + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-balance.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-balance.svg new file mode 100644 index 0000000..3855f52 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-balance.svg @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +standardized mean difference + + + + + + + + + + +variance ratio + + + + + + + + + + +energy distance + + + + + + + + + + +kolmogorov-smirnov + + + + + +0.0 +0.1 +0.2 + + + + +1.00 +1.02 +1.04 +1.06 + + + + + + +0.00 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + +0.025 +0.050 +0.075 +0.100 +0.125 +age +wt71 + + +age +wt71 + + +overall (multivariate) + +age +wt71 + + +balance metric +variable + +method + + + + + + + + +observed +w_ate +autoplot-halfmoon-balance +smd values shown as absolute values + + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg new file mode 100644 index 0000000..b856057 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +0.00 +0.25 +0.50 +0.75 +1.00 +predicted probability +observed rate +autoplot-halfmoon-calibration + + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-ess.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-ess.svg new file mode 100644 index 0000000..b08bba8 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-ess.svg @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + + + + + +100.0% +64.7% +68.3% + + + + +0% +25% +50% +75% +100% + + + + + + + + +observed +w_ate +w_att +method +effective sample size (%) +autoplot-halfmoon-ess + + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg new file mode 100644 index 0000000..15d3179 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg @@ -0,0 +1,384 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +30 +40 +50 +60 +70 +30 +40 +50 +60 +70 +Control group quantiles +Treatment group quantiles +method + + + + + + +observed +w_ate +w_att +autoplot-halfmoon-qq + + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-roc.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-roc.svg new file mode 100644 index 0000000..6bbfd6c --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-roc.svg @@ -0,0 +1,81 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +1 - specificity +sensitivity + +method + + + + + + +observed +w_ate +w_att +autoplot-halfmoon-roc + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-auc.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-auc.svg new file mode 100644 index 0000000..479fcfa --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-auc.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + +0.663 +0.502 + + + + +observed +w_ate + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +auc +method +plot-halfmoon-auc + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-balance.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-balance.svg new file mode 100644 index 0000000..a9adbce --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-balance.svg @@ -0,0 +1,197 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +standardized mean difference + + + + + + + + + + +variance ratio + + + + + + + + + + +energy distance + + + + + + + + + + +kolmogorov-smirnov + + + + + +0.0 +0.1 +0.2 + + + + +1.00 +1.02 +1.04 +1.06 + + + + + + +0.00 +0.01 +0.02 +0.03 +0.04 +0.05 + + + + + +0.025 +0.050 +0.075 +0.100 +0.125 +age +wt71 + + +age +wt71 + + +overall (multivariate) + +age +wt71 + + +balance metric +variable + +method + + + + + + + + +observed +w_ate +plot-halfmoon-balance +smd values shown as absolute values + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg new file mode 100644 index 0000000..67ff99e --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +0.00 +0.25 +0.50 +0.75 +1.00 +predicted probability +observed rate +plot-halfmoon-calibration + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-ess.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-ess.svg new file mode 100644 index 0000000..1787978 --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-ess.svg @@ -0,0 +1,56 @@ + + + + + + + + + + + + + + + + + + + + + + + +100.0% +64.7% + + + + +0% +25% +50% +75% +100% + + + + + + + +observed +w_ate +method +effective sample size (%) +plot-halfmoon-ess + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg new file mode 100644 index 0000000..3aeb1ac --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg @@ -0,0 +1,281 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +30 +40 +50 +60 +70 +30 +40 +50 +60 +70 +Control group quantiles +Treatment group quantiles +method + + + + +observed +w_ate +plot-halfmoon-qq + + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-roc.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-roc.svg new file mode 100644 index 0000000..51248db --- /dev/null +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-roc.svg @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +1 - specificity +sensitivity + +method + + + + +observed +w_ate +plot-halfmoon-roc + + diff --git a/tests/testthat/_snaps/bal_model_auc.md b/tests/testthat/_snaps/bal_model_auc.md new file mode 100644 index 0000000..a632fe6 --- /dev/null +++ b/tests/testthat/_snaps/bal_model_auc.md @@ -0,0 +1,26 @@ +# bal_model_auc validates inputs + + Code + expr + Condition + Error in `bal_model_auc()`: + ! Can't select columns that don't exist. + x Column `nonexistent` doesn't exist. + +--- + + Code + expr + Condition + Error in `bal_model_auc()`: + ! Can't select columns that don't exist. + x Column `nonexistent` doesn't exist. + +--- + + Code + expr + Condition + Error in `bal_model_auc()`: + ! `.wts` must select exactly one variable or be NULL + diff --git a/tests/testthat/_snaps/bal_model_roc_curve.md b/tests/testthat/_snaps/bal_model_roc_curve.md new file mode 100644 index 0000000..77e0d36 --- /dev/null +++ b/tests/testthat/_snaps/bal_model_roc_curve.md @@ -0,0 +1,26 @@ +# bal_model_roc_curve validates inputs + + Code + expr + Condition + Error in `bal_model_roc_curve()`: + ! Can't select columns that don't exist. + x Column `nonexistent` doesn't exist. + +--- + + Code + expr + Condition + Error in `bal_model_roc_curve()`: + ! Can't select columns that don't exist. + x Column `nonexistent` doesn't exist. + +--- + + Code + expr + Condition + Error in `bal_model_roc_curve()`: + ! `.wts` must select exactly one variable or be NULL + diff --git a/tests/testthat/_snaps/bal_qq.md b/tests/testthat/_snaps/bal_qq.md new file mode 100644 index 0000000..abed0eb --- /dev/null +++ b/tests/testthat/_snaps/bal_qq.md @@ -0,0 +1,48 @@ +# bal_qq handles missing values + + Code + expr + Condition + Error in `bal_qq()`: + ! Variable `age` contains missing values and `na.rm = FALSE` + +# bal_qq validates inputs + + Code + expr + Condition + Error: + ! Column `nonexistent` not found in `.var` + +--- + + Code + expr + Condition + Error: + ! Column `nonexistent` not found in `.group` + +--- + + Code + expr + Condition + Error in `bal_qq()`: + ! Group variable must have exactly two levels, got 5 + +--- + + Code + expr + Condition + Error in `bal_qq()`: + ! `.wts` must select exactly one variable or be NULL + +# bal_qq works with different treatment levels + + Code + expr + Condition + Error in `bal_qq()`: + ! `treatment_level` '2' not found in `.group` levels: "0" and "1" + diff --git a/tests/testthat/_snaps/check_auc.md b/tests/testthat/_snaps/check_model_auc.md similarity index 80% rename from tests/testthat/_snaps/check_auc.md rename to tests/testthat/_snaps/check_model_auc.md index 3a732da..ef3a210 100644 --- a/tests/testthat/_snaps/check_auc.md +++ b/tests/testthat/_snaps/check_model_auc.md @@ -3,7 +3,7 @@ Code expr Condition - Error in `roc_curve()`: + Error in `check_model_roc_curve()`: ! Missing values found and `na.rm = FALSE` # functions handle different truth variable types @@ -11,7 +11,7 @@ Code expr Condition - Error in `roc_curve()`: + Error in `check_model_roc_curve()`: ! `.truth` must have exactly 2 unique values # error messages use proper cli formatting @@ -19,7 +19,7 @@ Code expr Condition - Error in `roc_curve()`: + Error in `check_model_roc_curve()`: ! `.data` must be a data frame --- @@ -27,7 +27,7 @@ Code expr Condition - Error in `roc_curve()`: + Error in `check_model_roc_curve()`: ! `.estimate` must be numeric, got --- @@ -35,7 +35,7 @@ Code expr Condition - Error in `roc_curve()`: + Error in `check_model_roc_curve()`: ! `.truth` must have exactly 2 levels # treatment_level parameter works correctly diff --git a/tests/testthat/_snaps/compute_qq.md b/tests/testthat/_snaps/compute_qq.md index d882bdd..63f274c 100644 --- a/tests/testthat/_snaps/compute_qq.md +++ b/tests/testthat/_snaps/compute_qq.md @@ -1,9 +1,9 @@ -# qq errors with missing columns +# check_qq errors with missing columns Code expr Condition - Error in `qq()`: + Error in `check_qq()`: ! Column `missing_var` not found in data --- @@ -11,22 +11,22 @@ Code expr Condition - Error in `qq()`: + Error in `check_qq()`: ! Column `missing_group` not found in data -# qq errors with non-binary groups +# check_qq errors with non-binary groups Code expr Condition - Error in `qq()`: + Error in `check_qq()`: ! Group variable must have exactly 2 levels -# qq handles NA values correctly +# check_qq handles NA values correctly Code expr Condition - Error in `qq()`: + Error in `check_qq()`: ! Variable `age` contains missing values and `na.rm = FALSE` diff --git a/tests/testthat/_snaps/geom_calibration.md b/tests/testthat/_snaps/geom_calibration.md index 3323eaf..6c514b8 100644 --- a/tests/testthat/_snaps/geom_calibration.md +++ b/tests/testthat/_snaps/geom_calibration.md @@ -1,9 +1,9 @@ -# check_calibration provides clear error messages for missing columns +# check_model_calibration provides clear error messages for missing columns Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! Column `nonexistent` not found in data --- @@ -11,23 +11,23 @@ Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! Column `nonexistent` not found in data -# check_calibration method parameter validation +# check_model_calibration method parameter validation Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! `method` must be one of "breaks", "logistic", or "windowed", not "invalid". -# check_calibration validates input parameters +# check_model_calibration validates input parameters Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! `bins` must be an integer > 1. --- @@ -35,7 +35,7 @@ Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! `bins` must be an integer > 1. --- @@ -43,15 +43,15 @@ Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! Column `nonexistent` not found in data -# check_calibration provides helpful warnings for small cell sizes +# check_model_calibration provides helpful warnings for small cell sizes Code expr Condition - Warning in `check_calibration()`: + Warning in `check_model_calibration()`: Small sample sizes or extreme proportions detected in bins 6, 10 (n = 2, 10). Confidence intervals may be unreliable. Consider using fewer bins or a different calibration method. Output # A tibble: 7 x 6 @@ -65,12 +65,12 @@ 6 6 0.495 0 2 0 0 7 10 0.941 0.2 10 0.0354 0.558 -# check_calibration provides helpful warnings for extreme proportions +# check_model_calibration provides helpful warnings for extreme proportions Code expr Condition - Warning in `check_calibration()`: + Warning in `check_model_calibration()`: Small sample sizes or extreme proportions detected in bins 1, 2, 3, 8, 9, 10 (n = 17, 16, 17, 16, 17, 17). Confidence intervals may be unreliable. Consider using fewer bins or a different calibration method. Output # A tibble: 6 x 6 @@ -83,12 +83,12 @@ 5 9 0.840 1 17 1 1 6 10 0.938 1 17 1 1 -# check_calibration windowed method provides helpful warnings +# check_model_calibration windowed method provides helpful warnings Code expr Condition - Warning in `check_calibration()`: + Warning in `check_model_calibration()`: Small sample sizes or extreme proportions detected in windows centered at 0.4, 0.5, 0.6 (n = 3, 6, 6). Confidence intervals may be unreliable. Consider using a larger window size or a different calibration method. Output # A tibble: 3 x 4 @@ -98,12 +98,12 @@ 2 0.5 0.667 0.241 0.940 3 0.6 0.667 0.241 0.940 -# check_calibration errors with invalid bins +# check_model_calibration errors with invalid bins Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! `bins` must be an integer > 1. --- @@ -111,6 +111,6 @@ Code expr Condition - Error in `check_calibration()`: + Error in `check_model_calibration()`: ! `bins` must be an integer > 1. diff --git a/tests/testthat/_snaps/geom_roc/geom-roc-multiple-groups.svg b/tests/testthat/_snaps/geom_roc/geom-roc-multiple-groups.svg index 679677c..fea112c 100644 --- a/tests/testthat/_snaps/geom_roc/geom-roc-multiple-groups.svg +++ b/tests/testthat/_snaps/geom_roc/geom-roc-multiple-groups.svg @@ -21,15 +21,15 @@ - - + + - - - - - + + + + + 0.00 @@ -42,26 +42,26 @@ - - - - - -0.00 -0.25 -0.50 -0.75 -1.00 -fpr + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +fpr tpr - -Weight Type - - - - -w_ate -w_att + +Weight Type + + + + +w_ate_num +w_att_num geom-roc-multiple-groups diff --git a/tests/testthat/_snaps/plot_roc.md b/tests/testthat/_snaps/plot_roc.md index 1f754af..1217aca 100644 --- a/tests/testthat/_snaps/plot_roc.md +++ b/tests/testthat/_snaps/plot_roc.md @@ -3,7 +3,7 @@ Code expr Condition - Error in `plot_roc_curve()`: + Error in `plot_model_roc_curve()`: ! `.data` must contain columns: "threshold", "sensitivity", "specificity", and "method". Missing: "threshold", "sensitivity", "specificity", and "method" --- @@ -11,7 +11,7 @@ Code expr Condition - Error in `plot_roc_auc()`: + Error in `plot_model_auc()`: ! `.data` must contain columns: "method" and "auc". Missing: "method" and "auc" --- @@ -19,14 +19,14 @@ Code expr Condition - Error in `plot_roc_curve()`: - ! `.data` must be a data frame or tibble from `roc_curve()` + Error in `plot_model_roc_curve()`: + ! `.data` must be a data frame or tibble from `check_model_roc_curve()` --- Code expr Condition - Error in `plot_roc_auc()`: - ! `.data` must be a data frame or tibble from `check_auc()` + Error in `plot_model_auc()`: + ! `.data` must be a data frame or tibble from `check_model_auc()` diff --git a/tests/testthat/test-autoplot-methods.R b/tests/testthat/test-autoplot-methods.R new file mode 100644 index 0000000..72d8934 --- /dev/null +++ b/tests/testthat/test-autoplot-methods.R @@ -0,0 +1,107 @@ +test_that("autoplot works for halfmoon_balance", { + balance_data <- check_balance(nhefs_weights, c(age, wt71), qsmk, .wts = w_ate) + + p <- autoplot(balance_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-balance", p) +}) + +test_that("autoplot works for halfmoon_auc", { + auc_data <- check_model_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)) + + p <- autoplot(auc_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-auc", p) +}) + +test_that("autoplot works for halfmoon_ess", { + ess_data <- check_ess(nhefs_weights, .wts = c(w_ate, w_att)) + + p <- autoplot(ess_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-ess", p) +}) + +test_that("autoplot works for halfmoon_calibration", { + cal_data <- suppress_calibration_warnings(check_model_calibration( + nhefs_weights, + .fitted, + qsmk + )) + + p <- autoplot(cal_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-calibration", p) +}) + +test_that("autoplot works for halfmoon_roc", { + roc_data <- check_model_roc_curve( + nhefs_weights, + qsmk, + .fitted, + c(w_ate, w_att) + ) + + p <- autoplot(roc_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-roc", p) +}) + +test_that("autoplot works for halfmoon_qq", { + qq_data <- check_qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) + + p <- autoplot(qq_data) + expect_s3_class(p, "ggplot") + + expect_doppelganger("autoplot-halfmoon-qq", p) +}) + +test_that("plot methods work for all halfmoon classes", { + # Create all data types + balance_data <- check_balance(nhefs_weights, c(age, wt71), qsmk, .wts = w_ate) + auc_data <- check_model_auc(nhefs_weights, qsmk, .fitted, w_ate) + ess_data <- check_ess(nhefs_weights, .wts = w_ate) + cal_data <- suppress_calibration_warnings(check_model_calibration( + nhefs_weights, + .fitted, + qsmk + )) + roc_data <- check_model_roc_curve(nhefs_weights, qsmk, .fitted, w_ate) + qq_data <- check_qq(nhefs_weights, age, qsmk, .wts = w_ate) + + # Test plot() methods with vdiffr + expect_doppelganger( + "plot-halfmoon-balance", + plot(balance_data) + ) + + expect_doppelganger( + "plot-halfmoon-auc", + plot(auc_data) + ) + + expect_doppelganger( + "plot-halfmoon-ess", + plot(ess_data) + ) + + expect_doppelganger( + "plot-halfmoon-calibration", + plot(cal_data) + ) + + expect_doppelganger( + "plot-halfmoon-roc", + plot(roc_data) + ) + + expect_doppelganger( + "plot-halfmoon-qq", + plot(qq_data) + ) +}) diff --git a/tests/testthat/test-bal_ess.R b/tests/testthat/test-bal_ess.R new file mode 100644 index 0000000..d906d9d --- /dev/null +++ b/tests/testthat/test-bal_ess.R @@ -0,0 +1,38 @@ +test_that("bal_ess is equivalent to ess", { + # Should be a simple wrapper + weights <- nhefs_weights$w_ate + + ess_val <- ess(weights) + bal_ess_val <- bal_ess(weights) + + expect_identical(ess_val, bal_ess_val) +}) + +test_that("bal_ess handles NA values", { + weights_na <- c(1, 2, NA, 3, 4) + + # With na.rm = FALSE (default) + expect_true(is.na(bal_ess(weights_na))) + + # With na.rm = TRUE + ess_val <- bal_ess(weights_na, na.rm = TRUE) + expect_type(ess_val, "double") + expect_false(is.na(ess_val)) +}) + +test_that("bal_ess works with different weight types", { + # Numeric vector + ess1 <- bal_ess(c(1, 1, 1, 1)) + expect_equal(ess1, 4) + + # Variable weights + ess2 <- bal_ess(c(1, 2, 3, 4)) + expect_true(ess2 < 4) + + # PSW weights + if (propensity::is_psw(nhefs_weights$w_ate)) { + ess_psw <- bal_ess(nhefs_weights$w_ate) + expect_type(ess_psw, "double") + expect_true(ess_psw > 0) + } +}) diff --git a/tests/testthat/test-bal_model_auc.R b/tests/testthat/test-bal_model_auc.R new file mode 100644 index 0000000..df28a37 --- /dev/null +++ b/tests/testthat/test-bal_model_auc.R @@ -0,0 +1,89 @@ +test_that("bal_model_auc works with unweighted data", { + auc_val <- bal_model_auc(nhefs_weights, qsmk, .fitted) + + expect_type(auc_val, "double") + expect_length(auc_val, 1) + expect_true(auc_val >= 0 && auc_val <= 1) + + # Should match check_model_auc for single method + auc_check <- check_model_auc( + nhefs_weights, + qsmk, + .fitted, + include_observed = TRUE + ) + expect_equal(auc_val, auc_check$auc[auc_check$method == "observed"]) +}) + +test_that("bal_model_auc works with weighted data", { + auc_val <- bal_model_auc(nhefs_weights, qsmk, .fitted, w_ate) + + expect_type(auc_val, "double") + expect_length(auc_val, 1) + expect_true(auc_val >= 0 && auc_val <= 1) + + # Should match check_model_auc for single weight + auc_check <- check_model_auc( + nhefs_weights, + qsmk, + .fitted, + w_ate, + include_observed = FALSE + ) + expect_equal(auc_val, auc_check$auc[1]) +}) + +test_that("bal_model_auc handles missing values", { + # Create data with NAs + nhefs_na <- nhefs_weights + nhefs_na$.fitted[1:5] <- NA + + # With na.rm = TRUE + auc_val <- bal_model_auc(nhefs_na, qsmk, .fitted, na.rm = TRUE) + expect_type(auc_val, "double") + expect_false(is.na(auc_val)) + + # With na.rm = FALSE + auc_val_na <- bal_model_auc(nhefs_na, qsmk, .fitted, na.rm = FALSE) + expect_true(is.na(auc_val_na)) +}) + +test_that("bal_model_auc validates inputs", { + expect_halfmoon_error( + bal_model_auc(nhefs_weights, nonexistent, .fitted), + class = "halfmoon_arg_error" + ) + + expect_halfmoon_error( + bal_model_auc(nhefs_weights, qsmk, nonexistent), + class = "halfmoon_arg_error" + ) + + # Multiple weights should error + expect_halfmoon_error( + bal_model_auc(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)), + class = "halfmoon_arg_error" + ) +}) + +test_that("bal_model_auc works with different treatment levels", { + # Default treatment level + auc_default <- bal_model_auc(nhefs_weights, qsmk, .fitted) + + # Explicit treatment level + auc_explicit <- bal_model_auc( + nhefs_weights, + qsmk, + .fitted, + treatment_level = 1 + ) + + # Should be different from opposite level + auc_opposite <- bal_model_auc( + nhefs_weights, + qsmk, + .fitted, + treatment_level = 0 + ) + expect_false(isTRUE(all.equal(auc_explicit, auc_opposite))) +}) diff --git a/tests/testthat/test-bal_model_roc_curve.R b/tests/testthat/test-bal_model_roc_curve.R new file mode 100644 index 0000000..4363ce5 --- /dev/null +++ b/tests/testthat/test-bal_model_roc_curve.R @@ -0,0 +1,77 @@ +test_that("bal_model_roc_curve works with unweighted data", { + roc_data <- bal_model_roc_curve(nhefs_weights, qsmk, .fitted) + + expect_s3_class(roc_data, "tbl_df") + expect_named(roc_data, c("threshold", "sensitivity", "specificity")) + + # Check values are in valid range + expect_true(all(roc_data$sensitivity >= 0 & roc_data$sensitivity <= 1)) + expect_true(all(roc_data$specificity >= 0 & roc_data$specificity <= 1)) + + # Should have endpoints + expect_true(any(roc_data$sensitivity == 1 & roc_data$specificity == 0)) + expect_true(any(roc_data$sensitivity == 0 & roc_data$specificity == 1)) +}) + +test_that("bal_model_roc_curve works with weighted data", { + roc_data <- bal_model_roc_curve(nhefs_weights, qsmk, .fitted, w_ate) + + expect_s3_class(roc_data, "tbl_df") + expect_named(roc_data, c("threshold", "sensitivity", "specificity")) + + # Should be different from unweighted + roc_unweighted <- bal_model_roc_curve(nhefs_weights, qsmk, .fitted) + expect_false(identical(roc_data, roc_unweighted)) +}) + +test_that("bal_model_roc_curve handles missing values", { + # Create data with NAs + nhefs_na <- nhefs_weights + nhefs_na$.fitted[1:5] <- NA + + # With na.rm = TRUE + roc_data <- bal_model_roc_curve(nhefs_na, qsmk, .fitted, na.rm = TRUE) + expect_s3_class(roc_data, "tbl_df") + expect_true(nrow(roc_data) > 0) + + # With na.rm = FALSE + roc_na <- bal_model_roc_curve(nhefs_na, qsmk, .fitted, na.rm = FALSE) + expect_true(all(is.na(roc_na$sensitivity))) +}) + +test_that("bal_model_roc_curve validates inputs", { + expect_halfmoon_error( + bal_model_roc_curve(nhefs_weights, nonexistent, .fitted), + class = "halfmoon_arg_error" + ) + + expect_halfmoon_error( + bal_model_roc_curve(nhefs_weights, qsmk, nonexistent), + class = "halfmoon_arg_error" + ) + + # Multiple weights should error + expect_halfmoon_error( + bal_model_roc_curve(nhefs_weights, qsmk, .fitted, c(w_ate, w_att)), + class = "halfmoon_arg_error" + ) +}) + +test_that("bal_model_roc_curve matches check_model_roc_curve for single method", { + # Get single ROC curve + roc_single <- bal_model_roc_curve(nhefs_weights, qsmk, .fitted, w_ate) + + # Get from check_model_roc_curve + roc_check <- check_model_roc_curve( + nhefs_weights, + qsmk, + .fitted, + w_ate, + include_observed = FALSE + ) + + # Should match the values (check_model_roc_curve has an additional method column) + expect_equal(roc_single$threshold, roc_check$threshold) + expect_equal(roc_single$sensitivity, roc_check$sensitivity) + expect_equal(roc_single$specificity, roc_check$specificity) +}) diff --git a/tests/testthat/test-bal_qq.R b/tests/testthat/test-bal_qq.R new file mode 100644 index 0000000..fb9f7aa --- /dev/null +++ b/tests/testthat/test-bal_qq.R @@ -0,0 +1,158 @@ +test_that("bal_qq works with unweighted data", { + qq_data <- bal_qq(nhefs_weights, age, qsmk) + + expect_s3_class(qq_data, "tbl_df") + expect_named( + qq_data, + c("quantile", "treated_quantiles", "untreated_quantiles") + ) + + # Default should be 99 quantiles + expect_equal(nrow(qq_data), 99) + + # Quantiles should be in order + expect_true(all(diff(qq_data$treated_quantiles) >= 0)) + expect_true(all(diff(qq_data$untreated_quantiles) >= 0)) +}) + +test_that("bal_qq works with weighted data", { + qq_data <- bal_qq(nhefs_weights, age, qsmk, .wts = w_ate) + + expect_s3_class(qq_data, "tbl_df") + expect_named( + qq_data, + c("quantile", "treated_quantiles", "untreated_quantiles") + ) + + # Should be different from unweighted + qq_unweighted <- bal_qq(nhefs_weights, age, qsmk) + expect_false(identical( + qq_data$treated_quantiles, + qq_unweighted$treated_quantiles + )) +}) + +test_that("bal_qq handles custom quantiles", { + custom_q <- seq(0.1, 0.9, 0.1) + qq_data <- bal_qq(nhefs_weights, age, qsmk, quantiles = custom_q) + + expect_equal(nrow(qq_data), length(custom_q)) + expect_equal(qq_data$quantile, custom_q) +}) + +test_that("bal_qq handles missing values", { + # Create data with NAs + nhefs_na <- nhefs_weights + nhefs_na$age[1:5] <- NA + + # With na.rm = TRUE + qq_data <- bal_qq(nhefs_na, age, qsmk, na.rm = TRUE) + expect_s3_class(qq_data, "tbl_df") + expect_false(any(is.na(qq_data$treated_quantiles))) + + # With na.rm = FALSE should error + expect_halfmoon_error( + bal_qq(nhefs_na, age, qsmk, na.rm = FALSE), + class = "halfmoon_na_error" + ) +}) + +test_that("bal_qq validates inputs", { + # Non-existent variable + expect_halfmoon_error( + bal_qq(nhefs_weights, nonexistent, qsmk), + class = "halfmoon_column_error" + ) + + # Non-existent group + expect_halfmoon_error( + bal_qq(nhefs_weights, age, nonexistent), + class = "halfmoon_column_error" + ) + + # Non-binary group + expect_halfmoon_error( + bal_qq(nhefs_weights, age, alcoholfreq_cat), + class = "halfmoon_group_error" + ) + + # Multiple weights should error + expect_halfmoon_error( + bal_qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)), + class = "halfmoon_arg_error" + ) +}) + +test_that("bal_qq works with different treatment levels", { + # Default treatment level should be 1 (last level) - same as check_qq + qq_default <- bal_qq(nhefs_weights, age, qsmk, quantiles = c(0.25, 0.5, 0.75)) + + # Explicit treatment level = 1 + qq_1 <- bal_qq( + nhefs_weights, + age, + qsmk, + treatment_level = 1, + quantiles = c(0.25, 0.5, 0.75) + ) + + # Default should match explicit treatment_level = 1 + expect_equal(qq_default$treated_quantiles, qq_1$treated_quantiles) + expect_equal(qq_default$untreated_quantiles, qq_1$untreated_quantiles) + + # Explicit treatment level = 0 + qq_0 <- bal_qq( + nhefs_weights, + age, + qsmk, + treatment_level = 0, + quantiles = c(0.25, 0.5, 0.75) + ) + + # Treated and untreated should swap + expect_equal(qq_1$treated_quantiles, qq_0$untreated_quantiles) + expect_equal(qq_1$untreated_quantiles, qq_0$treated_quantiles) + + # Invalid treatment level should error + expect_halfmoon_error( + bal_qq(nhefs_weights, age, qsmk, treatment_level = 2), + class = "halfmoon_reference_error" + ) +}) + +test_that("bal_qq matches single method from check_qq", { + # Test with default treatment_level (should use last/max level) + qq_single <- bal_qq(nhefs_weights, age, qsmk, quantiles = seq(0.1, 0.9, 0.1)) + qq_check <- check_qq( + nhefs_weights, + age, + qsmk, + quantiles = seq(0.1, 0.9, 0.1), + include_observed = TRUE + ) + qq_check_observed <- qq_check[qq_check$method == "observed", ] + + expect_equal(qq_single$quantile, qq_check_observed$quantile) + expect_equal(qq_single$treated_quantiles, qq_check_observed$treated_quantiles) + expect_equal( + qq_single$untreated_quantiles, + qq_check_observed$untreated_quantiles + ) + + # Test with weighted data + qq_single_wt <- bal_qq(nhefs_weights, age, qsmk, .wts = w_ate) + qq_check_wt <- check_qq( + nhefs_weights, + age, + qsmk, + .wts = w_ate, + include_observed = FALSE + ) + + expect_equal(qq_single_wt$quantile, qq_check_wt$quantile) + expect_equal(qq_single_wt$treated_quantiles, qq_check_wt$treated_quantiles) + expect_equal( + qq_single_wt$untreated_quantiles, + qq_check_wt$untreated_quantiles + ) +}) diff --git a/tests/testthat/test-check_auc.R b/tests/testthat/test-check_model_auc.R similarity index 82% rename from tests/testthat/test-check_auc.R rename to tests/testthat/test-check_model_auc.R index b466bc9..fa3db7e 100644 --- a/tests/testthat/test-check_auc.R +++ b/tests/testthat/test-check_model_auc.R @@ -1,4 +1,4 @@ -test_that("roc_curve works with basic inputs", { +test_that("check_model_roc_curve works with basic inputs", { # Create simple test data set.seed(42) test_data <- tibble::tibble( @@ -9,7 +9,7 @@ test_that("roc_curve works with basic inputs", { ) # Test unweighted ROC curve - roc_basic <- roc_curve( + roc_basic <- check_model_roc_curve( test_data, truth, estimate, @@ -25,11 +25,11 @@ test_that("roc_curve works with basic inputs", { expect_true(all(roc_basic$specificity >= 0 & roc_basic$specificity <= 1)) # Test with single weight - roc_weighted <- roc_curve(test_data, truth, estimate, weight1) + roc_weighted <- check_model_roc_curve(test_data, truth, estimate, weight1) expect_equal(sort(unique(roc_weighted$method)), c("observed", "weight1")) # Test with multiple weights - roc_multi <- roc_curve( + roc_multi <- check_model_roc_curve( test_data, truth, estimate, @@ -41,7 +41,7 @@ test_that("roc_curve works with basic inputs", { ) # Test without observed - roc_no_obs <- roc_curve( + roc_no_obs <- check_model_roc_curve( test_data, truth, estimate, @@ -64,7 +64,7 @@ test_that("check_auc computes correct AUC values", { ) # Test good separation - auc_good <- check_auc( + auc_good <- check_model_auc( test_data, truth, estimate_good, @@ -77,7 +77,7 @@ test_that("check_auc computes correct AUC values", { expect_true(abs(auc_good$auc[auc_good$method == "observed"] - 0.5) > 0.4) # Test random separation - auc_random <- check_auc( + auc_random <- check_model_auc( test_data, truth, estimate_random, @@ -86,13 +86,13 @@ test_that("check_auc computes correct AUC values", { expect_true(abs(auc_random$auc[auc_random$method == "observed"] - 0.5) < 0.1) # Test with weights - auc_weighted <- check_auc(test_data, truth, estimate_good, weight1) + auc_weighted <- check_model_auc(test_data, truth, estimate_good, weight1) expect_equal(nrow(auc_weighted), 2) # observed + weight1 }) test_that("check_auc returns correct structure", { # Test basic functionality - balance_check <- check_auc( + balance_check <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -106,7 +106,7 @@ test_that("check_auc returns correct structure", { expect_true(all(balance_check$auc >= 0 & balance_check$auc <= 1)) # Test without observed - balance_no_obs <- check_auc( + balance_no_obs <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -126,7 +126,7 @@ test_that("functions handle edge cases correctly", { ) # With na.rm = TRUE - roc_na_rm <- suppressMessages(roc_curve( + roc_na_rm <- suppressMessages(check_model_roc_curve( test_data_na, truth, estimate, @@ -137,7 +137,13 @@ test_that("functions handle edge cases correctly", { # With na.rm = FALSE should error expect_halfmoon_error( - roc_curve(test_data_na, truth, estimate, weight1, na.rm = FALSE), + check_model_roc_curve( + test_data_na, + truth, + estimate, + weight1, + na.rm = FALSE + ), "halfmoon_na_error" ) @@ -149,7 +155,7 @@ test_that("functions handle edge cases correctly", { ) expect_warning( - roc_const <- roc_curve(test_data_const, truth, estimate), + roc_const <- check_model_roc_curve(test_data_const, truth, estimate), class = "halfmoon_data_warning" ) expect_equal(nrow(roc_const), 3) # Should have 3 points for degenerate curve @@ -162,7 +168,12 @@ test_that("functions handle edge cases correctly", { ) expect_warning( - roc_zero <- roc_curve(test_data_zero, truth, estimate, weight_zero), + roc_zero <- check_model_roc_curve( + test_data_zero, + truth, + estimate, + weight_zero + ), class = "halfmoon_data_warning" ) expect_s3_class(roc_zero, "tbl_df") @@ -175,7 +186,12 @@ test_that("functions handle edge cases correctly", { ) expect_warning( - roc_neg <- roc_curve(test_data_neg, truth, estimate, weight_neg), + roc_neg <- check_model_roc_curve( + test_data_neg, + truth, + estimate, + weight_neg + ), class = "halfmoon_data_warning" ) expect_s3_class(roc_neg, "tbl_df") @@ -190,23 +206,23 @@ test_that("functions handle different truth variable types", { # Test with character test_char <- dplyr::mutate(base_data, truth = rep(c("Yes", "No"), 50)) - roc_char <- roc_curve(test_char, truth, estimate) + roc_char <- check_model_roc_curve(test_char, truth, estimate) expect_s3_class(roc_char, "tbl_df") # Test with logical test_logical <- dplyr::mutate(base_data, truth = rep(c(TRUE, FALSE), 50)) - roc_logical <- roc_curve(test_logical, truth, estimate) + roc_logical <- check_model_roc_curve(test_logical, truth, estimate) expect_s3_class(roc_logical, "tbl_df") # Test with binary numeric test_numeric <- dplyr::mutate(base_data, truth = rep(c(0, 1), 50)) - roc_numeric <- roc_curve(test_numeric, truth, estimate) + roc_numeric <- check_model_roc_curve(test_numeric, truth, estimate) expect_s3_class(roc_numeric, "tbl_df") # Test with non-binary numeric (should error) test_multi <- dplyr::mutate(base_data, truth = rep(1:3, length.out = 100)) expect_halfmoon_error( - roc_curve(test_multi, truth, estimate), + check_model_roc_curve(test_multi, truth, estimate), "halfmoon_group_error" ) }) @@ -219,21 +235,21 @@ test_that("error messages use proper cli formatting", { # Test .data not a data frame expect_halfmoon_error( - roc_curve("not a data frame", truth, estimate), + check_model_roc_curve("not a data frame", truth, estimate), "halfmoon_type_error" ) # Test non-numeric estimate test_data$estimate_char <- as.character(test_data$estimate) expect_halfmoon_error( - roc_curve(test_data, truth, estimate_char), + check_model_roc_curve(test_data, truth, estimate_char), "halfmoon_type_error" ) # Test multi-level truth test_data$truth_multi <- factor(rep(c("A", "B", "C"), length.out = 20)) expect_halfmoon_error( - roc_curve(test_data, truth_multi, estimate), + check_model_roc_curve(test_data, truth_multi, estimate), "halfmoon_group_error" ) }) @@ -249,7 +265,7 @@ test_that("tidyselect works for weight selection", { ) # Test starts_with - roc_starts <- roc_curve( + roc_starts <- check_model_roc_curve( test_data, truth, estimate, @@ -261,7 +277,7 @@ test_that("tidyselect works for weight selection", { ) # Test specific selection - roc_specific <- roc_curve(test_data, truth, estimate, c(w_1, w_3)) + roc_specific <- check_model_roc_curve(test_data, truth, estimate, c(w_1, w_3)) expect_equal(sort(unique(roc_specific$method)), c("observed", "w_1", "w_3")) }) @@ -275,7 +291,7 @@ test_that("weighted ROC/AUC integrates with check_balance patterns", { .metrics = "smd" ) - balance_roc <- check_auc( + balance_roc <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -293,7 +309,7 @@ test_that("weighted ROC/AUC integrates with check_balance patterns", { test_that("treatment_level parameter works correctly", { # Test with default (second level) - roc_default <- roc_curve( + roc_default <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -301,7 +317,7 @@ test_that("treatment_level parameter works correctly", { ) # Test with explicit treatment_level = "1" (same as default) - roc_explicit <- roc_curve( + roc_explicit <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -313,7 +329,7 @@ test_that("treatment_level parameter works correctly", { expect_equal(roc_default, roc_explicit) # Test with treatment_level = "0" (opposite) - roc_opposite <- roc_curve( + roc_opposite <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -326,7 +342,7 @@ test_that("treatment_level parameter works correctly", { # Test with invalid treatment_level expect_halfmoon_error( - roc_curve( + check_model_roc_curve( nhefs_weights, qsmk, .fitted, diff --git a/tests/testthat/test-compute_qq.R b/tests/testthat/test-compute_qq.R index 0927721..9d00626 100644 --- a/tests/testthat/test-compute_qq.R +++ b/tests/testthat/test-compute_qq.R @@ -1,5 +1,5 @@ -test_that("qq computes basic quantiles", { - result <- qq(nhefs_weights, age, qsmk) +test_that("check_qq computes basic quantiles", { + result <- check_qq(nhefs_weights, age, qsmk) expect_s3_class(result, "tbl_df") expect_equal(nrow(result), 99) # 99 quantiles for observed only @@ -10,85 +10,91 @@ test_that("qq computes basic quantiles", { expect_equal(unique(result$method), factor("observed")) }) -test_that("qq works with weights", { - result <- qq(nhefs_weights, age, qsmk, .wts = w_ate) +test_that("check_qq works with weights", { + result <- check_qq(nhefs_weights, age, qsmk, .wts = w_ate) expect_equal(nrow(result), 198) # 99 quantiles * 2 methods expect_equal(levels(result$method), c("observed", "w_ate")) }) -test_that("qq works with multiple weights", { - result <- qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) +test_that("check_qq works with multiple weights", { + result <- check_qq(nhefs_weights, age, qsmk, .wts = c(w_ate, w_att)) expect_equal(nrow(result), 297) # 99 quantiles * 3 methods expect_equal(levels(result$method), c("observed", "w_ate", "w_att")) }) -test_that("qq works without observed", { - result <- qq(nhefs_weights, age, qsmk, .wts = w_ate, include_observed = FALSE) +test_that("check_qq works without observed", { + result <- check_qq( + nhefs_weights, + age, + qsmk, + .wts = w_ate, + include_observed = FALSE + ) expect_equal(nrow(result), 99) # 99 quantiles * 1 method expect_equal(unique(result$method), factor("w_ate")) }) -test_that("qq handles custom quantiles", { +test_that("check_qq handles custom quantiles", { custom_q <- c(0.1, 0.25, 0.5, 0.75, 0.9) - result <- qq(nhefs_weights, age, qsmk, quantiles = custom_q) + result <- check_qq(nhefs_weights, age, qsmk, quantiles = custom_q) expect_equal(nrow(result), 5) expect_equal(unique(result$quantile), custom_q) }) -test_that("qq handles quoted column names", { - result1 <- qq(nhefs_weights, age, qsmk) - result2 <- qq(nhefs_weights, "age", "qsmk") +test_that("check_qq handles quoted column names", { + result1 <- check_qq(nhefs_weights, age, qsmk) + result2 <- check_qq(nhefs_weights, "age", "qsmk") expect_equal(result1, result2) }) -test_that("qq errors with missing columns", { +test_that("check_qq errors with missing columns", { expect_halfmoon_error( - qq(nhefs_weights, missing_var, qsmk), + check_qq(nhefs_weights, missing_var, qsmk), "halfmoon_column_error" ) expect_halfmoon_error( - qq(nhefs_weights, age, missing_group), + check_qq(nhefs_weights, age, missing_group), "halfmoon_column_error" ) }) -test_that("qq errors with non-binary groups", { +test_that("check_qq errors with non-binary groups", { df <- nhefs_weights df$three_groups <- rep(1:3, length.out = nrow(df)) expect_halfmoon_error( - qq(df, age, three_groups), + check_qq(df, age, three_groups), "halfmoon_group_error" ) }) -test_that("qq handles NA values correctly", { +test_that("check_qq handles NA values correctly", { df <- nhefs_weights df$age[1:10] <- NA # Should work with na.rm = TRUE - result <- qq(df, age, qsmk, na.rm = TRUE) + result <- check_qq(df, age, qsmk, na.rm = TRUE) expect_false(any(is.na(result$treated_quantiles))) expect_false(any(is.na(result$untreated_quantiles))) # Should have NAs with na.rm = FALSE - expect_halfmoon_error(qq(df, age, qsmk), "halfmoon_na_error") + expect_halfmoon_error(check_qq(df, age, qsmk), "halfmoon_na_error") }) -test_that("qq handles NULL treatment_level correctly", { +test_that("check_qq handles NULL treatment_level correctly", { # Test with factor test_factor <- data.frame( x = 1:10, group = factor(rep(c("Control", "Treatment"), each = 5)) ) - result_factor <- qq(test_factor, x, group, quantiles = 0.5) + result_factor <- check_qq(test_factor, x, group, quantiles = 0.5) # Should use "Treatment" (last level) as reference expect_equal(as.numeric(result_factor$treated_quantiles), 8) # median of 6:10 expect_equal(as.numeric(result_factor$untreated_quantiles), 3) # median of 1:5 @@ -99,13 +105,13 @@ test_that("qq handles NULL treatment_level correctly", { group = rep(c(0, 1), each = 5) ) - result_numeric <- qq(test_numeric, x, group, quantiles = 0.5) + result_numeric <- check_qq(test_numeric, x, group, quantiles = 0.5) # Should use 1 (max value) as reference expect_equal(as.numeric(result_numeric$treated_quantiles), 8) # median of 6:10 expect_equal(as.numeric(result_numeric$untreated_quantiles), 3) # median of 1:5 }) -test_that("qq returns expected quantile values", { +test_that("check_qq returns expected quantile values", { # Create simple test data set.seed(123) test_data <- data.frame( @@ -113,7 +119,7 @@ test_that("qq returns expected quantile values", { group = rep(c("A", "B"), each = 50) ) - result <- qq(test_data, x, group, quantiles = c(0.25, 0.5, 0.75)) + result <- check_qq(test_data, x, group, quantiles = c(0.25, 0.5, 0.75)) # Check that we get 3 quantiles expect_equal(nrow(result), 3) @@ -123,7 +129,7 @@ test_that("qq returns expected quantile values", { expect_true(all(result$treated_quantiles > result$untreated_quantiles)) # Test with explicit treatment_level = "A" - result_explicit <- qq( + result_explicit <- check_qq( test_data, x, group, diff --git a/tests/testthat/test-geom_calibration.R b/tests/testthat/test-geom_calibration.R index e643508..0c8f7c0 100644 --- a/tests/testthat/test-geom_calibration.R +++ b/tests/testthat/test-geom_calibration.R @@ -1,6 +1,6 @@ library(ggplot2) -test_that("check_calibration works with basic input", { +test_that("check_model_calibration works with basic input", { # Create simple test data with larger sample size set.seed(123) n <- 500 @@ -13,7 +13,7 @@ test_that("check_calibration works with basic input", { ) # Test basic functionality - result <- suppress_calibration_warnings(check_calibration( + result <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs @@ -30,7 +30,7 @@ test_that("check_calibration works with basic input", { expect_true(all(result$count > 0)) }) -test_that("check_calibration works with quoted column names", { +test_that("check_model_calibration works with quoted column names", { # Create simple test data set.seed(123) n <- 500 @@ -43,7 +43,7 @@ test_that("check_calibration works with quoted column names", { ) # Test with quoted column names - result <- suppress_calibration_warnings(check_calibration( + result <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs @@ -53,7 +53,7 @@ test_that("check_calibration works with quoted column names", { expect_true(nrow(result) > 0) }) -test_that("check_calibration works with unquoted column names", { +test_that("check_model_calibration works with unquoted column names", { # Create simple test data set.seed(123) n <- 500 @@ -65,7 +65,7 @@ test_that("check_calibration works with unquoted column names", { obs = actual ) - result <- suppress_calibration_warnings(check_calibration( + result <- suppress_calibration_warnings(check_model_calibration( test_data, "pred", "obs" @@ -75,7 +75,7 @@ test_that("check_calibration works with unquoted column names", { expect_true(nrow(result) > 0) }) -test_that("check_calibration provides clear error messages for missing columns", { +test_that("check_model_calibration provides clear error messages for missing columns", { # Create test data set.seed(123) test_data <- data.frame( @@ -85,18 +85,18 @@ test_that("check_calibration provides clear error messages for missing columns", # Test with non-existent .fitted column expect_halfmoon_error( - check_calibration(test_data, "nonexistent", "obs"), + check_model_calibration(test_data, "nonexistent", "obs"), "halfmoon_column_error" ) # Test with non-existent .group column expect_halfmoon_error( - check_calibration(test_data, "pred", "nonexistent"), + check_model_calibration(test_data, "pred", "nonexistent"), "halfmoon_column_error" ) }) -test_that("check_calibration handles different binning methods", { +test_that("check_model_calibration handles different binning methods", { # Create test data set.seed(123) n <- 500 @@ -109,7 +109,7 @@ test_that("check_calibration handles different binning methods", { ) # Test equal_width binning - result_eq <- suppress_calibration_warnings(check_calibration( + result_eq <- suppress_calibration_warnings(check_model_calibration( test_data, "pred", "obs", @@ -117,7 +117,7 @@ test_that("check_calibration handles different binning methods", { )) # Test quantile binning - result_qt <- suppress_calibration_warnings(check_calibration( + result_qt <- suppress_calibration_warnings(check_model_calibration( test_data, "pred", "obs", @@ -130,17 +130,17 @@ test_that("check_calibration handles different binning methods", { expect_true(nrow(result_qt) > 0) }) -test_that("check_calibration handles edge cases", { +test_that("check_model_calibration handles edge cases", { # Test empty data empty_data <- data.frame(pred = numeric(0), obs = numeric(0)) - result_empty <- check_calibration(empty_data, pred, obs) + result_empty <- check_model_calibration(empty_data, pred, obs) expect_s3_class(result_empty, "tbl_df") expect_equal(nrow(result_empty), 0) # Test all zeros (treatment level 0, so observed_rate should be 1) all_zeros <- data.frame(pred = runif(50, 0, 1), obs = rep(0, 50)) - result_zeros <- suppress_calibration_warnings(check_calibration( + result_zeros <- suppress_calibration_warnings(check_model_calibration( all_zeros, pred, obs @@ -151,7 +151,7 @@ test_that("check_calibration handles edge cases", { # Test all ones (treatment level 1, so observed_rate should be 1) all_ones <- data.frame(pred = runif(50, 0, 1), obs = rep(1, 50)) - result_ones <- suppress_calibration_warnings(check_calibration( + result_ones <- suppress_calibration_warnings(check_model_calibration( all_ones, pred, obs @@ -161,7 +161,7 @@ test_that("check_calibration handles edge cases", { expect_true(all(result_ones$observed_rate == 1)) # All obs are 1, which becomes the treatment level }) -test_that("check_calibration handles NA values", { +test_that("check_model_calibration handles NA values", { # Create test data with NAs set.seed(123) n <- 100 @@ -178,7 +178,7 @@ test_that("check_calibration handles NA values", { ) # Test with na.rm = TRUE - result_na_rm <- suppress_calibration_warnings(check_calibration( + result_na_rm <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -189,7 +189,7 @@ test_that("check_calibration handles NA values", { expect_true(nrow(result_na_rm) > 0) # Test with na.rm = FALSE (should have fewer complete cases) - result_na_keep <- suppress_calibration_warnings(check_calibration( + result_na_keep <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -199,7 +199,7 @@ test_that("check_calibration handles NA values", { expect_s3_class(result_na_keep, "tbl_df") }) -test_that("check_calibration works with logistic method", { +test_that("check_model_calibration works with logistic method", { # Create test data set.seed(123) n <- 200 @@ -212,7 +212,7 @@ test_that("check_calibration works with logistic method", { ) # Test logistic without smoothing - result_logistic <- check_calibration( + result_logistic <- check_model_calibration( test_data, pred, obs, @@ -238,7 +238,7 @@ test_that("check_calibration works with logistic method", { expect_true(all(result_logistic$upper >= result_logistic$observed_rate)) # Test logistic with smoothing - result_smooth <- suppress_calibration_warnings(check_calibration( + result_smooth <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -256,7 +256,7 @@ test_that("check_calibration works with logistic method", { expect_equal(max(result_logistic$predicted_rate), max(test_data$pred)) }) -test_that("check_calibration logistic method handles different confidence levels", { +test_that("check_model_calibration logistic method handles different confidence levels", { set.seed(123) test_data <- data.frame( pred = runif(100, 0, 1), @@ -264,7 +264,7 @@ test_that("check_calibration logistic method handles different confidence levels ) # Test with 90% confidence - result_90 <- suppress_calibration_warnings(check_calibration( + result_90 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -273,7 +273,7 @@ test_that("check_calibration logistic method handles different confidence levels )) # Test with 99% confidence - result_99 <- suppress_calibration_warnings(check_calibration( + result_99 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -288,7 +288,7 @@ test_that("check_calibration logistic method handles different confidence levels ) }) -test_that("check_calibration logistic method handles perfect separation", { +test_that("check_model_calibration logistic method handles perfect separation", { # Create data with perfect separation test_data <- data.frame( pred = c(rep(0.1, 50), rep(0.9, 50)), @@ -297,7 +297,7 @@ test_that("check_calibration logistic method handles perfect separation", { # Should not error with perfect separation expect_no_error({ - result <- check_calibration( + result <- check_model_calibration( test_data, pred, obs, @@ -307,7 +307,7 @@ test_that("check_calibration logistic method handles perfect separation", { }) }) -test_that("check_calibration works with windowed method", { +test_that("check_model_calibration works with windowed method", { # Create test data set.seed(123) n <- 200 @@ -320,7 +320,7 @@ test_that("check_calibration works with windowed method", { ) # Test windowed method - result_windowed <- suppress_calibration_warnings(check_calibration( + result_windowed <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -347,7 +347,7 @@ test_that("check_calibration works with windowed method", { expect_true(all(result_windowed$upper >= result_windowed$observed_rate)) # Test with different window sizes - result_small_window <- suppress_calibration_warnings(check_calibration( + result_small_window <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -363,7 +363,7 @@ test_that("check_calibration works with windowed method", { expect_equal(result_windowed$predicted_rate, expected_centers) }) -test_that("check_calibration windowed method handles edge cases", { +test_that("check_model_calibration windowed method handles edge cases", { set.seed(123) # Test with data concentrated at edges @@ -372,7 +372,7 @@ test_that("check_calibration windowed method handles edge cases", { obs = rbinom(100, 1, 0.5) ) - result <- check_calibration( + result <- check_model_calibration( test_data, pred, obs, @@ -385,7 +385,7 @@ test_that("check_calibration windowed method handles edge cases", { expect_true(nrow(result) > 0) # Test with very small window - result_tiny <- suppress_calibration_warnings(check_calibration( + result_tiny <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -398,14 +398,14 @@ test_that("check_calibration windowed method handles edge cases", { expect_true(nrow(result_tiny) <= length(seq(0, 1, by = 0.1))) }) -test_that("check_calibration windowed method respects window boundaries", { +test_that("check_model_calibration windowed method respects window boundaries", { # Create data only in middle range test_data <- data.frame( pred = runif(100, 0.4, 0.6), obs = rbinom(100, 1, 0.5) ) - result <- check_calibration( + result <- check_model_calibration( test_data, pred, obs, @@ -421,25 +421,30 @@ test_that("check_calibration windowed method respects window boundaries", { expect_true(center_window$observed_rate >= 0) }) -test_that("check_calibration method parameter validation", { +test_that("check_model_calibration method parameter validation", { test_data <- data.frame(pred = runif(50), obs = rbinom(50, 1, 0.5)) # Test invalid method expect_halfmoon_error( - check_calibration(test_data, pred, obs, method = "invalid") + check_model_calibration(test_data, pred, obs, method = "invalid") ) }) -test_that("check_calibration handles edge cases with all methods", { +test_that("check_model_calibration handles edge cases with all methods", { # Empty data empty_data <- data.frame(pred = numeric(0), obs = numeric(0)) - result_breaks <- check_calibration(empty_data, pred, obs, method = "breaks") + result_breaks <- check_model_calibration( + empty_data, + pred, + obs, + method = "breaks" + ) expect_equal(nrow(result_breaks), 0) expect_true("count" %in% names(result_breaks)) expect_true(".bin" %in% names(result_breaks)) - result_logistic <- check_calibration( + result_logistic <- check_model_calibration( empty_data, pred, obs, @@ -449,7 +454,7 @@ test_that("check_calibration handles edge cases with all methods", { expect_false("count" %in% names(result_logistic)) expect_false(".bin" %in% names(result_logistic)) - result_windowed <- check_calibration( + result_windowed <- check_model_calibration( empty_data, pred, obs, @@ -460,7 +465,7 @@ test_that("check_calibration handles edge cases with all methods", { expect_false(".bin" %in% names(result_windowed)) }) -test_that("check_calibration handles all zeros and all ones", { +test_that("check_model_calibration handles all zeros and all ones", { set.seed(123) # All zeros - when treatment_level is not specified, 0 becomes the treatment level @@ -472,7 +477,7 @@ test_that("check_calibration handles all zeros and all ones", { # When all observations are 0, default treatment_level will be 0 # Test the actual behavior - result_breaks_zeros_default <- suppress_calibration_warnings(check_calibration( + result_breaks_zeros_default <- suppress_calibration_warnings(check_model_calibration( zeros_data, pred, obs, @@ -487,7 +492,7 @@ test_that("check_calibration handles all zeros and all ones", { obs = c(rep(0, 25), rep(1, 25)) ) - result_mixed <- suppress_calibration_warnings(check_calibration( + result_mixed <- suppress_calibration_warnings(check_model_calibration( mixed_data, pred, obs, @@ -505,7 +510,7 @@ test_that("check_calibration handles all zeros and all ones", { obs = rep(1, 50) ) - result_breaks_ones <- suppress_calibration_warnings(check_calibration( + result_breaks_ones <- suppress_calibration_warnings(check_model_calibration( ones_data, pred, obs, @@ -513,7 +518,7 @@ test_that("check_calibration handles all zeros and all ones", { )) expect_true(all(result_breaks_ones$observed_rate == 1)) - result_windowed_ones <- suppress_calibration_warnings(check_calibration( + result_windowed_ones <- suppress_calibration_warnings(check_model_calibration( ones_data, pred, obs, @@ -522,7 +527,7 @@ test_that("check_calibration handles all zeros and all ones", { expect_true(all(result_windowed_ones$observed_rate == 1)) # Test the default behavior with all zeros - result_default_zeros <- suppress_calibration_warnings(check_calibration( + result_default_zeros <- suppress_calibration_warnings(check_model_calibration( zeros_data, pred, obs, @@ -532,7 +537,7 @@ test_that("check_calibration handles all zeros and all ones", { expect_true(all(result_default_zeros$observed_rate == 1)) }) -test_that("check_calibration handles NA values correctly", { +test_that("check_model_calibration handles NA values correctly", { # Create data with NAs set.seed(123) test_data <- data.frame( @@ -541,7 +546,7 @@ test_that("check_calibration handles NA values correctly", { ) # Test with na.rm = FALSE (default) - result_false <- suppress_calibration_warnings(check_calibration( + result_false <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -550,7 +555,7 @@ test_that("check_calibration handles NA values correctly", { )) # Test with na.rm = TRUE - result_true <- suppress_calibration_warnings(check_calibration( + result_true <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -562,7 +567,7 @@ test_that("check_calibration handles NA values correctly", { expect_true(sum(result_true$count) == 45) }) -test_that("check_calibration handles factor treatment variables", { +test_that("check_model_calibration handles factor treatment variables", { set.seed(123) test_data <- data.frame( pred = runif(100, 0, 1), @@ -570,7 +575,7 @@ test_that("check_calibration handles factor treatment variables", { ) # Should work with factor - result <- suppress_calibration_warnings(check_calibration( + result <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -582,29 +587,35 @@ test_that("check_calibration handles factor treatment variables", { expect_true(all(result$observed_rate >= 0 & result$observed_rate <= 1)) }) -test_that("check_calibration validates input parameters", { +test_that("check_model_calibration validates input parameters", { test_data <- data.frame(pred = runif(50), obs = rbinom(50, 1, 0.5)) # Invalid bins for breaks method expect_halfmoon_error( - check_calibration(test_data, pred, obs, method = "breaks", bins = 1), + check_model_calibration(test_data, pred, obs, method = "breaks", bins = 1), "halfmoon_arg_error" ) # Non-integer bins expect_halfmoon_error( - check_calibration(test_data, pred, obs, method = "breaks", bins = 2.5), + check_model_calibration( + test_data, + pred, + obs, + method = "breaks", + bins = 2.5 + ), "halfmoon_arg_error" ) # Missing column expect_halfmoon_error( - check_calibration(test_data, nonexistent, obs), + check_model_calibration(test_data, nonexistent, obs), "halfmoon_column_error" ) }) -test_that("check_calibration produces consistent results across methods", { +test_that("check_model_calibration produces consistent results across methods", { # Create well-calibrated data set.seed(123) n <- 500 @@ -614,20 +625,20 @@ test_that("check_calibration produces consistent results across methods", { test_data <- data.frame(pred = pred, obs = obs) # Get results from all methods - result_breaks <- check_calibration( + result_breaks <- check_model_calibration( test_data, pred, obs, method = "breaks", bins = 5 ) - result_logistic <- suppress_calibration_warnings(check_calibration( + result_logistic <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, method = "logistic" )) - result_windowed <- suppress_calibration_warnings(check_calibration( + result_windowed <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -649,7 +660,7 @@ test_that("check_calibration produces consistent results across methods", { expect_true(windowed_diff < 0.2) }) -test_that("check_calibration provides helpful warnings for small cell sizes", { +test_that("check_model_calibration provides helpful warnings for small cell sizes", { # Create test data with imbalanced distribution to create small cells set.seed(123) n <- 100 @@ -660,12 +671,12 @@ test_that("check_calibration provides helpful warnings for small cell sizes", { # Test breaks method with small cells expect_halfmoon_warning( - check_calibration(test_data, pred, obs, method = "breaks", bins = 10), + check_model_calibration(test_data, pred, obs, method = "breaks", bins = 10), class = "halfmoon_data_warning" ) }) -test_that("check_calibration provides helpful warnings for extreme proportions", { +test_that("check_model_calibration provides helpful warnings for extreme proportions", { # Create data where some bins have all 0s or all 1s set.seed(123) test_data <- data.frame( @@ -674,12 +685,12 @@ test_that("check_calibration provides helpful warnings for extreme proportions", ) expect_halfmoon_warning( - check_calibration(test_data, pred, obs, method = "breaks", bins = 10), + check_model_calibration(test_data, pred, obs, method = "breaks", bins = 10), "halfmoon_data_warning" ) }) -test_that("check_calibration windowed method provides helpful warnings", { +test_that("check_model_calibration windowed method provides helpful warnings", { # Create sparse data set.seed(123) test_data <- data.frame( @@ -689,7 +700,7 @@ test_that("check_calibration windowed method provides helpful warnings", { # Small window size will create windows with few observations expect_halfmoon_warning( - check_calibration( + check_model_calibration( test_data, pred, obs, @@ -702,7 +713,7 @@ test_that("check_calibration windowed method provides helpful warnings", { # Capture the specific warning message warning_msg <- capture_warnings( - check_calibration( + check_model_calibration( test_data, pred, obs, @@ -716,7 +727,7 @@ test_that("check_calibration windowed method provides helpful warnings", { expect_match(warning_msg[1], "Consider using a larger window size") }) -test_that("check_calibration doesn't warn for adequate sample sizes", { +test_that("check_model_calibration doesn't warn for adequate sample sizes", { # Create well-distributed data set.seed(123) n <- 1000 @@ -727,11 +738,11 @@ test_that("check_calibration doesn't warn for adequate sample sizes", { # Should not produce warnings expect_no_warning( - check_calibration(test_data, pred, obs, method = "breaks", bins = 10) + check_model_calibration(test_data, pred, obs, method = "breaks", bins = 10) ) expect_no_warning( - check_calibration( + check_model_calibration( test_data, pred, obs, @@ -751,7 +762,7 @@ test_that("warnings include specific bin/window information", { ) warning_msg <- capture_warnings( - check_calibration(test_data, pred, obs, method = "breaks", bins = 10) + check_model_calibration(test_data, pred, obs, method = "breaks", bins = 10) ) # Should mention specific bins @@ -764,7 +775,7 @@ test_that("warnings include specific bin/window information", { ) warning_msg2 <- capture_warnings( - check_calibration( + check_model_calibration( test_data2, pred, obs, @@ -784,11 +795,11 @@ test_that("warnings handle edge case with no valid results gracefully", { # Should not produce warnings for empty data expect_no_warning( - check_calibration(empty_data, pred, obs, method = "breaks") + check_model_calibration(empty_data, pred, obs, method = "breaks") ) expect_no_warning( - check_calibration(empty_data, pred, obs, method = "windowed") + check_model_calibration(empty_data, pred, obs, method = "windowed") ) }) @@ -991,7 +1002,7 @@ test_that("geom_calibration errors with invalid method", { ) }) -test_that("check_calibration errors with invalid bins", { +test_that("check_model_calibration errors with invalid bins", { # Create test data set.seed(123) n <- 50 @@ -1005,11 +1016,11 @@ test_that("check_calibration errors with invalid bins", { # Test with invalid bins expect_halfmoon_error( - check_calibration(cal_data, pred, obs, bins = 1) + check_model_calibration(cal_data, pred, obs, bins = 1) ) expect_halfmoon_error( - check_calibration(cal_data, pred, obs, bins = 2.5) + check_model_calibration(cal_data, pred, obs, bins = 2.5) ) }) @@ -1051,7 +1062,7 @@ test_that("k parameter works in check_calibration", { ) # Test with default k = 10 - result_k10 <- check_calibration( + result_k10 <- check_model_calibration( test_data, pred, obs, @@ -1061,7 +1072,7 @@ test_that("k parameter works in check_calibration", { ) # Test with smaller k = 5 - result_k5 <- check_calibration( + result_k5 <- check_model_calibration( test_data, pred, obs, @@ -1071,7 +1082,7 @@ test_that("k parameter works in check_calibration", { ) # Test with larger k = 20 - result_k20 <- check_calibration( + result_k20 <- check_model_calibration( test_data, pred, obs, @@ -1113,7 +1124,7 @@ test_that("k parameter is ignored when smooth = FALSE", { ) # Results should be identical when smooth = FALSE - result1 <- check_calibration( + result1 <- check_model_calibration( test_data, pred, obs, @@ -1122,7 +1133,7 @@ test_that("k parameter is ignored when smooth = FALSE", { k = 5 ) - result2 <- check_calibration( + result2 <- check_model_calibration( test_data, pred, obs, @@ -1149,7 +1160,7 @@ test_that("k parameter is ignored for non-logistic methods", { ) # k should be ignored for breaks method - result1 <- suppress_calibration_warnings(check_calibration( + result1 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -1157,7 +1168,7 @@ test_that("k parameter is ignored for non-logistic methods", { k = 5 )) - result2 <- suppress_calibration_warnings(check_calibration( + result2 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -1169,7 +1180,7 @@ test_that("k parameter is ignored for non-logistic methods", { expect_equal(result1$observed_rate, result2$observed_rate) # k should be ignored for windowed method - result3 <- suppress_calibration_warnings(check_calibration( + result3 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -1177,7 +1188,7 @@ test_that("k parameter is ignored for non-logistic methods", { k = 5 )) - result4 <- suppress_calibration_warnings(check_calibration( + result4 <- suppress_calibration_warnings(check_model_calibration( test_data, pred, obs, @@ -1241,9 +1252,27 @@ test_that("k parameter works in plot_calibration", { ) # Create plots with different k values - p_k5 <- plot_calibration(test_data, pred, obs, method = "logistic", k = 5) - p_k10 <- plot_calibration(test_data, pred, obs, method = "logistic", k = 10) - p_k20 <- plot_calibration(test_data, pred, obs, method = "logistic", k = 20) + p_k5 <- plot_model_calibration( + test_data, + pred, + obs, + method = "logistic", + k = 5 + ) + p_k10 <- plot_model_calibration( + test_data, + pred, + obs, + method = "logistic", + k = 10 + ) + p_k20 <- plot_model_calibration( + test_data, + pred, + obs, + method = "logistic", + k = 20 + ) # Test with vdiffr expect_doppelganger("plot_calibration k=5", p_k5) diff --git a/tests/testthat/test-geom_mirrored_histogram.R b/tests/testthat/test-geom_mirrored_histogram.R index 38cdbc9..c454a2c 100644 --- a/tests/testthat/test-geom_mirrored_histogram.R +++ b/tests/testthat/test-geom_mirrored_histogram.R @@ -32,7 +32,7 @@ test_that("geom_mirrored_histogram errors correctly", { no_group <- ggplot(nhefs_weights, aes(.fitted)) + geom_mirror_histogram(bins = 50) - expect_snapshot_warning(print(no_group)) + expect_snapshot_warning(b <- ggplot_build(no_group)) }) test_that("NO_GROUP is still -1", { diff --git a/tests/testthat/test-geom_qq2.R b/tests/testthat/test-geom_qq2.R index 8ad6803..70da38d 100644 --- a/tests/testthat/test-geom_qq2.R +++ b/tests/testthat/test-geom_qq2.R @@ -44,12 +44,16 @@ test_that("geom_qq2 works with weights", { test_that("geom_qq2 works with color aesthetic for multiple weights", { # Create long format data - long_data <- tidyr::pivot_longer( - nhefs_weights, - cols = c(w_ate, w_att), - names_to = "weight_type", - values_to = "weight" - ) + long_data <- nhefs_weights |> + dplyr::mutate( + w_ate_num = as.numeric(w_ate), + w_att_num = as.numeric(w_att) + ) |> + tidyr::pivot_longer( + cols = c(w_ate_num, w_att_num), + names_to = "weight_type", + values_to = "weight" + ) p <- ggplot2::ggplot( long_data, @@ -116,6 +120,7 @@ test_that("plot_qq and geom_qq2 produce equivalent results", { # vdiffr visual regression tests test_that("geom_qq2 visual regression tests", { + withr::local_seed(123) # Basic geom_qq2 expect_doppelganger( "geom_qq2 basic", @@ -139,17 +144,13 @@ test_that("geom_qq2 visual regression tests", { ) # With color for multiple weights - # TODO: Remove vec_data() workaround once propensity implements vctrs methods - nhefs_for_pivot2 <- nhefs_weights - nhefs_for_pivot2$w_ate <- vctrs::vec_data(nhefs_weights$w_ate) - nhefs_for_pivot2$w_att <- vctrs::vec_data(nhefs_weights$w_att) - - long_data <- tidyr::pivot_longer( - nhefs_for_pivot2, - cols = c(w_ate, w_att), - names_to = "weight_type", - values_to = "weight" - ) + long_data <- nhefs_weights |> + dplyr::mutate(dplyr::across(c(w_ate, w_att), as.numeric)) |> + tidyr::pivot_longer( + cols = c(w_ate, w_att), + names_to = "weight_type", + values_to = "weight" + ) expect_doppelganger( "geom_qq2 multiple weights", diff --git a/tests/testthat/test-geom_roc.R b/tests/testthat/test-geom_roc.R index 58eb3d4..7d6e042 100644 --- a/tests/testthat/test-geom_roc.R +++ b/tests/testthat/test-geom_roc.R @@ -76,12 +76,16 @@ test_that("geom_roc visual regression", { # Multiple groups with different weights # Create long format data - long_data <- tidyr::pivot_longer( - nhefs_weights, - cols = c(w_ate, w_att), - names_to = "weight_type", - values_to = "weight" - ) + long_data <- nhefs_weights |> + dplyr::mutate( + w_ate_num = as.numeric(w_ate), + w_att_num = as.numeric(w_att) + ) |> + tidyr::pivot_longer( + cols = c(w_ate_num, w_att_num), + names_to = "weight_type", + values_to = "weight" + ) expect_doppelganger( "geom-roc-multiple-groups", diff --git a/tests/testthat/test-plot_calibration.R b/tests/testthat/test-plot_calibration.R index 53bf4c5..a16c111 100644 --- a/tests/testthat/test-plot_calibration.R +++ b/tests/testthat/test-plot_calibration.R @@ -1,8 +1,8 @@ library(ggplot2) -test_that("plot_calibration works with basic input", { +test_that("plot_model_calibration works with basic input", { # Basic functionality - p <- plot_calibration(nhefs_weights, .fitted, qsmk) + p <- plot_model_calibration(nhefs_weights, .fitted, qsmk) expect_s3_class(p, "ggplot") expect_gte(length(p$layers), 3) # calibration layers + abline @@ -11,21 +11,26 @@ test_that("plot_calibration works with basic input", { expect_no_error(suppress_calibration_warnings(ggplot_build(p))) }) -test_that("plot_calibration works with quoted column names", { +test_that("plot_model_calibration works with quoted column names", { # Test with quoted column names - p <- plot_calibration(nhefs_weights, ".fitted", "qsmk") + p <- plot_model_calibration(nhefs_weights, ".fitted", "qsmk") expect_s3_class(p, "ggplot") expect_no_error(suppress_calibration_warnings(ggplot_build(p))) }) -test_that("plot_calibration works with different methods", { +test_that("plot_model_calibration works with different methods", { # Test breaks method - p_breaks <- plot_calibration(nhefs_weights, .fitted, qsmk, method = "breaks") + p_breaks <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + method = "breaks" + ) expect_s3_class(p_breaks, "ggplot") # Test logistic method - p_logistic <- plot_calibration( + p_logistic <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -34,7 +39,7 @@ test_that("plot_calibration works with different methods", { expect_s3_class(p_logistic, "ggplot") # Test windowed method - p_windowed <- plot_calibration( + p_windowed <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -43,17 +48,22 @@ test_that("plot_calibration works with different methods", { expect_s3_class(p_windowed, "ggplot") }) -test_that("plot_calibration works with treatment level specification", { +test_that("plot_model_calibration works with treatment level specification", { # Test with explicit treatment level - p <- plot_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") + p <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + treatment_level = "1" + ) expect_s3_class(p, "ggplot") expect_no_error(suppress_calibration_warnings(ggplot_build(p))) }) -test_that("plot_calibration works with rug option", { +test_that("plot_model_calibration works with rug option", { # Test with rug disabled (default) - p_no_rug <- plot_calibration( + p_no_rug <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -62,16 +72,21 @@ test_that("plot_calibration works with rug option", { expect_s3_class(p_no_rug, "ggplot") # Test with rug enabled - p_rug <- plot_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) + p_rug <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + include_rug = TRUE + ) expect_s3_class(p_rug, "ggplot") # Rug plot should have one more layer expect_gt(length(p_rug$layers), length(p_no_rug$layers)) }) -test_that("plot_calibration works with ribbon and points options", { +test_that("plot_model_calibration works with ribbon and points options", { # Test with ribbon disabled - p_no_ribbon <- plot_calibration( + p_no_ribbon <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -80,7 +95,7 @@ test_that("plot_calibration works with ribbon and points options", { expect_s3_class(p_no_ribbon, "ggplot") # Test with points disabled - p_no_points <- plot_calibration( + p_no_points <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -89,7 +104,7 @@ test_that("plot_calibration works with ribbon and points options", { expect_s3_class(p_no_points, "ggplot") # Test with both disabled - p_minimal <- plot_calibration( + p_minimal <- plot_model_calibration( nhefs_weights, .fitted, qsmk, @@ -99,37 +114,47 @@ test_that("plot_calibration works with ribbon and points options", { expect_s3_class(p_minimal, "ggplot") }) -test_that("plot_calibration works with different bin counts", { +test_that("plot_model_calibration works with different bin counts", { # Test with different bin counts - p_5bins <- plot_calibration(nhefs_weights, .fitted, qsmk, bins = 5) + p_5bins <- plot_model_calibration(nhefs_weights, .fitted, qsmk, bins = 5) expect_s3_class(p_5bins, "ggplot") - p_15bins <- plot_calibration(nhefs_weights, .fitted, qsmk, bins = 15) + p_15bins <- plot_model_calibration(nhefs_weights, .fitted, qsmk, bins = 15) expect_s3_class(p_15bins, "ggplot") }) -test_that("plot_calibration works with different confidence levels", { +test_that("plot_model_calibration works with different confidence levels", { # Test with different confidence levels - p_90 <- plot_calibration(nhefs_weights, .fitted, qsmk, conf_level = 0.90) + p_90 <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + conf_level = 0.90 + ) expect_s3_class(p_90, "ggplot") - p_99 <- plot_calibration(nhefs_weights, .fitted, qsmk, conf_level = 0.99) + p_99 <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + conf_level = 0.99 + ) expect_s3_class(p_99, "ggplot") }) -test_that("plot_calibration handles NA values", { +test_that("plot_model_calibration handles NA values", { # Create test data with NAs test_data <- nhefs_weights[1:100, ] test_data$.fitted[1:5] <- NA test_data$qsmk[6:10] <- NA # Test with na.rm = TRUE - p_na_rm <- plot_calibration(test_data, .fitted, qsmk, na.rm = TRUE) + p_na_rm <- plot_model_calibration(test_data, .fitted, qsmk, na.rm = TRUE) expect_s3_class(p_na_rm, "ggplot") expect_no_error(suppress_calibration_warnings(ggplot_build(p_na_rm))) # Test with na.rm = FALSE - p_na_keep <- suppress_calibration_warnings(plot_calibration( + p_na_keep <- suppress_calibration_warnings(plot_model_calibration( test_data, .fitted, qsmk, @@ -139,8 +164,8 @@ test_that("plot_calibration handles NA values", { expect_no_error(suppressWarnings(ggplot_build(p_na_keep))) }) -test_that("plot_calibration has correct labels and theme", { - p <- plot_calibration(nhefs_weights, .fitted, qsmk) +test_that("plot_model_calibration has correct labels and theme", { + p <- plot_model_calibration(nhefs_weights, .fitted, qsmk) # Check labels expect_equal(p$labels$x, "predicted probability") @@ -153,7 +178,7 @@ test_that("plot_calibration has correct labels and theme", { )) }) -test_that("plot_calibration works with glm objects", { +test_that("plot_model_calibration works with glm objects", { # Fit a propensity score model ps_model <- glm( qsmk ~ age + sex + race + education, @@ -162,7 +187,7 @@ test_that("plot_calibration works with glm objects", { ) # Basic functionality - p <- plot_calibration(ps_model) + p <- plot_model_calibration(ps_model) expect_s3_class(p, "ggplot") expect_gte(length(p$layers), 3) # calibration layers + abline @@ -170,22 +195,22 @@ test_that("plot_calibration works with glm objects", { expect_no_error(suppress_calibration_warnings(ggplot_build(p))) # Test with different methods - p_logistic <- plot_calibration(ps_model, method = "logistic") + p_logistic <- plot_model_calibration(ps_model, method = "logistic") expect_s3_class(p_logistic, "ggplot") - p_windowed <- plot_calibration(ps_model, method = "windowed") + p_windowed <- plot_model_calibration(ps_model, method = "windowed") expect_s3_class(p_windowed, "ggplot") # Test with options - p_rug <- plot_calibration(ps_model, include_rug = TRUE) + p_rug <- plot_model_calibration(ps_model, include_rug = TRUE) expect_s3_class(p_rug, "ggplot") # Test with treatment level - p_treatment <- plot_calibration(ps_model, treatment_level = 1) + p_treatment <- plot_model_calibration(ps_model, treatment_level = 1) expect_s3_class(p_treatment, "ggplot") }) -test_that("plot_calibration works with lm objects", { +test_that("plot_model_calibration works with lm objects", { # Create a linear probability model lpm_model <- lm( as.numeric(qsmk == "1") ~ age + sex + race + education, @@ -193,7 +218,7 @@ test_that("plot_calibration works with lm objects", { ) # Basic functionality - p <- plot_calibration(lpm_model) + p <- plot_model_calibration(lpm_model) expect_s3_class(p, "ggplot") expect_gte(length(p$layers), 3) # calibration layers + abline @@ -201,7 +226,7 @@ test_that("plot_calibration works with lm objects", { expect_no_error(suppress_calibration_warnings(ggplot_build(p))) }) -test_that("plot_calibration model method handles NA values", { +test_that("plot_model_calibration model method handles NA values", { # Create test data with NAs test_data <- nhefs_weights[1:100, ] test_data$age[1:5] <- NA @@ -215,38 +240,53 @@ test_that("plot_calibration model method handles NA values", { ) # Test with na.rm = TRUE - p_na_rm <- plot_calibration(ps_model, na.rm = TRUE) + p_na_rm <- plot_model_calibration(ps_model, na.rm = TRUE) expect_s3_class(p_na_rm, "ggplot") expect_no_error(suppress_calibration_warnings(ggplot_build(p_na_rm))) # Test with na.rm = FALSE - p_na_keep <- plot_calibration(ps_model, na.rm = FALSE) + p_na_keep <- plot_model_calibration(ps_model, na.rm = FALSE) expect_s3_class(p_na_keep, "ggplot") expect_no_error(suppress_calibration_warnings(ggplot_build(p_na_keep))) }) -test_that("plot_calibration visual snapshot tests", { +test_that("plot_model_calibration visual snapshot tests", { # Skip on CI to avoid platform-specific rendering differences skip_on_ci() # Basic plot - p1 <- plot_calibration(nhefs_weights, .fitted, qsmk) + p1 <- plot_model_calibration(nhefs_weights, .fitted, qsmk) expect_doppelganger("plot_calibration basic", p1) # With rug - p2 <- plot_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) + p2 <- plot_model_calibration(nhefs_weights, .fitted, qsmk, include_rug = TRUE) expect_doppelganger("plot_calibration with rug", p2) # Logistic method - p3 <- plot_calibration(nhefs_weights, .fitted, qsmk, method = "logistic") + p3 <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + method = "logistic" + ) expect_doppelganger("plot_calibration logistic", p3) # Windowed method - p4 <- plot_calibration(nhefs_weights, .fitted, qsmk, method = "windowed") + p4 <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + method = "windowed" + ) expect_doppelganger("plot_calibration windowed", p4) # With explicit treatment level - p5 <- plot_calibration(nhefs_weights, .fitted, qsmk, treatment_level = "1") + p5 <- plot_model_calibration( + nhefs_weights, + .fitted, + qsmk, + treatment_level = "1" + ) expect_doppelganger("plot_calibration explicit treatment", p5) # GLM model tests @@ -257,31 +297,31 @@ test_that("plot_calibration visual snapshot tests", { ) # Basic GLM plot - p6 <- plot_calibration(ps_model) + p6 <- plot_model_calibration(ps_model) expect_doppelganger("plot_calibration glm basic", p6) # GLM with rug - p7 <- plot_calibration(ps_model, include_rug = TRUE) + p7 <- plot_model_calibration(ps_model, include_rug = TRUE) expect_doppelganger("plot_calibration glm with rug", p7) # GLM with logistic method - p8 <- plot_calibration(ps_model, method = "logistic") + p8 <- plot_model_calibration(ps_model, method = "logistic") expect_doppelganger("plot_calibration glm logistic", p8) # GLM with windowed method - p9 <- plot_calibration(ps_model, method = "windowed") + p9 <- plot_model_calibration(ps_model, method = "windowed") expect_doppelganger("plot_calibration glm windowed", p9) # GLM with no ribbon - p10 <- plot_calibration(ps_model, include_ribbon = FALSE) + p10 <- plot_model_calibration(ps_model, include_ribbon = FALSE) expect_doppelganger("plot_calibration glm no ribbon", p10) # GLM with no points - p11 <- plot_calibration(ps_model, include_points = FALSE) + p11 <- plot_model_calibration(ps_model, include_points = FALSE) expect_doppelganger("plot_calibration glm no points", p11) # GLM with different bins - p12 <- plot_calibration(ps_model, bins = 5) + p12 <- plot_model_calibration(ps_model, bins = 5) expect_doppelganger("plot_calibration glm 5 bins", p12) # LM model test (linear probability model) @@ -290,9 +330,13 @@ test_that("plot_calibration visual snapshot tests", { data = nhefs_weights ) - p13 <- plot_calibration(lpm_model) + p13 <- plot_model_calibration(lpm_model) expect_doppelganger("plot_calibration lm basic", p13) - p14 <- plot_calibration(lpm_model, method = "logistic", include_rug = TRUE) + p14 <- plot_model_calibration( + lpm_model, + method = "logistic", + include_rug = TRUE + ) expect_doppelganger("plot_calibration lm logistic with rug", p14) }) diff --git a/tests/testthat/test-plot_roc.R b/tests/testthat/test-plot_roc.R index 3705117..c4da25a 100644 --- a/tests/testthat/test-plot_roc.R +++ b/tests/testthat/test-plot_roc.R @@ -1,7 +1,7 @@ library(ggplot2) test_that("plot_roc_curve works with basic inputs", { # Create test ROC data - roc_data <- roc_curve( + roc_data <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -9,7 +9,7 @@ test_that("plot_roc_curve works with basic inputs", { ) # Test basic plot - p <- plot_roc_curve(roc_data) + p <- plot_model_roc_curve(roc_data) expect_s3_class(p, "gg") expect_s3_class(p, "ggplot") @@ -17,19 +17,19 @@ test_that("plot_roc_curve works with basic inputs", { expect_true(length(p$layers) >= 2) # At least ROC curve and diagonal # Test single method - roc_single <- roc_curve( + roc_single <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, include_observed = TRUE ) - p_single <- plot_roc_curve(roc_single) + p_single <- plot_model_roc_curve(roc_single) expect_s3_class(p_single, "gg") }) test_that("plot_roc_auc works with basic inputs", { # Create test AUC data - auc_data <- check_auc( + auc_data <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -37,22 +37,22 @@ test_that("plot_roc_auc works with basic inputs", { ) # Test basic plot - p <- plot_roc_auc(auc_data) + p <- plot_model_auc(auc_data) expect_s3_class(p, "gg") expect_s3_class(p, "ggplot") # Test without reference line - p_no_ref <- plot_roc_auc(auc_data, ref_line = FALSE) + p_no_ref <- plot_model_auc(auc_data, ref_line = FALSE) expect_s3_class(p_no_ref, "gg") # Test with check_auc output - balance_data <- check_auc( + balance_data <- check_model_auc( nhefs_weights, qsmk, .fitted, c(w_ate, w_att) ) - p_balance <- plot_roc_auc(balance_data) + p_balance <- plot_model_auc(balance_data) expect_s3_class(p_balance, "gg") }) @@ -61,29 +61,29 @@ test_that("plot functions handle invalid inputs", { bad_data <- data.frame(x = 1:10, y = 1:10) expect_halfmoon_error( - plot_roc_curve(bad_data), + plot_model_roc_curve(bad_data), "halfmoon_column_error" ) expect_halfmoon_error( - plot_roc_auc(bad_data), + plot_model_auc(bad_data), "halfmoon_column_error" ) # Test with non-data frame expect_halfmoon_error( - plot_roc_curve("not a data frame"), + plot_model_roc_curve("not a data frame"), "halfmoon_type_error" ) expect_halfmoon_error( - plot_roc_auc("not a data frame"), + plot_model_auc("not a data frame"), "halfmoon_type_error" ) }) test_that("plot_roc_curve customization works", { - roc_data <- roc_curve( + roc_data <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -91,7 +91,7 @@ test_that("plot_roc_curve customization works", { ) # Test custom line width - p_custom <- plot_roc_curve( + p_custom <- plot_model_roc_curve( roc_data, linewidth = 2, diagonal_color = "blue", @@ -101,7 +101,7 @@ test_that("plot_roc_curve customization works", { }) test_that("plot_roc_auc customization works", { - auc_data <- check_auc( + auc_data <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -109,7 +109,7 @@ test_that("plot_roc_auc customization works", { ) # Test custom point settings - p_custom <- plot_roc_auc( + p_custom <- plot_model_auc( auc_data, ref_color = "blue", point_size = 5, @@ -147,21 +147,21 @@ test_that("StatRoc handles edge cases", { test_that("plot functions produce expected output structure", { # Generate plots - roc_data <- roc_curve( + roc_data <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, c(w_ate, w_att) ) - auc_data <- check_auc( + auc_data <- check_model_auc( nhefs_weights, qsmk, .fitted, c(w_ate, w_att) ) - p_roc <- plot_roc_curve(roc_data) - p_auc <- plot_roc_auc(auc_data) + p_roc <- plot_model_roc_curve(roc_data) + p_auc <- plot_model_auc(auc_data) # Check axis labels expect_equal(p_roc$labels$x, "1 - specificity") @@ -180,7 +180,7 @@ test_that("plot_roc_curve visual regression", { skip_on_ci() # Multiple methods - roc_multi <- roc_curve( + roc_multi <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -189,11 +189,11 @@ test_that("plot_roc_curve visual regression", { expect_doppelganger( "roc-curve-multiple-methods", - plot_roc_curve(roc_multi) + plot_model_roc_curve(roc_multi) ) # Single method - roc_single <- roc_curve( + roc_single <- check_model_roc_curve( nhefs_weights, qsmk, .fitted, @@ -202,13 +202,13 @@ test_that("plot_roc_curve visual regression", { expect_doppelganger( "roc-curve-single-method", - plot_roc_curve(roc_single) + plot_model_roc_curve(roc_single) ) # Custom styling expect_doppelganger( "roc-curve-custom-style", - plot_roc_curve( + plot_model_roc_curve( roc_multi, linewidth = 2, diagonal_color = "red", @@ -221,7 +221,7 @@ test_that("plot_roc_auc visual regression", { skip_on_ci() # Multiple methods - auc_multi <- check_auc( + auc_multi <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -230,16 +230,16 @@ test_that("plot_roc_auc visual regression", { expect_doppelganger( "roc-auc-multiple-methods", - plot_roc_auc(auc_multi) + plot_model_auc(auc_multi) ) expect_doppelganger( "roc-auc-no-reference", - plot_roc_auc(auc_multi, ref_line = FALSE) + plot_model_auc(auc_multi, ref_line = FALSE) ) # Single method - auc_single <- check_auc( + auc_single <- check_model_auc( nhefs_weights, qsmk, .fitted, @@ -248,13 +248,13 @@ test_that("plot_roc_auc visual regression", { expect_doppelganger( "roc-auc-single-method", - plot_roc_auc(auc_single) + plot_model_auc(auc_single) ) # Custom styling expect_doppelganger( "roc-auc-custom-style", - plot_roc_auc( + plot_model_auc( auc_multi, ref_color = "blue", point_size = 5, @@ -270,6 +270,6 @@ test_that("plot_roc_auc visual regression", { expect_doppelganger( "roc-auc-balance-colors", - plot_roc_auc(test_auc) + plot_model_auc(test_auc) ) })