diff --git a/R/bal_model_auc.R b/R/bal_model_auc.R index 6ea4c39..b39ba3c 100644 --- a/R/bal_model_auc.R +++ b/R/bal_model_auc.R @@ -16,7 +16,7 @@ #' #' @param .data A data frame containing the variables. #' @param .exposure The treatment/outcome variable (unquoted). -#' @param .estimate The propensity score or fitted values (unquoted). +#' @param .fitted The propensity score or fitted values (unquoted). #' @param .weights Optional single weight variable (unquoted). If NULL, computes #' unweighted AUC. #' @inheritParams balance_params @@ -40,7 +40,7 @@ bal_model_auc <- function( .data, .exposure, - .estimate, + .fitted, .weights = NULL, na.rm = TRUE, .focal_level = NULL @@ -48,7 +48,7 @@ bal_model_auc <- function( validate_data_frame(.data, call = rlang::caller_env()) exposure_quo <- rlang::enquo(.exposure) - estimate_quo <- rlang::enquo(.estimate) + estimate_quo <- rlang::enquo(.fitted) wts_quo <- rlang::enquo(.weights) # Extract column names @@ -64,7 +64,7 @@ bal_model_auc <- function( } if (length(estimate_name) != 1) { abort( - "{.arg .estimate} must select exactly one variable", + "{.arg .fitted} must select exactly one variable", error_class = "halfmoon_arg_error", call = rlang::current_env() ) diff --git a/R/bal_model_roc_curve.R b/R/bal_model_roc_curve.R index a69e5fd..bdfc646 100644 --- a/R/bal_model_roc_curve.R +++ b/R/bal_model_roc_curve.R @@ -17,7 +17,7 @@ #' #' @param .data A data frame containing the variables. #' @param .exposure The treatment/outcome variable (unquoted). -#' @param .estimate The propensity score or fitted values (unquoted). +#' @param .fitted The propensity score or fitted values (unquoted). #' @param .weights Optional single weight variable (unquoted). If NULL, computes #' unweighted ROC curve. #' @inheritParams balance_params @@ -43,7 +43,7 @@ bal_model_roc_curve <- function( .data, .exposure, - .estimate, + .fitted, .weights = NULL, na.rm = TRUE, .focal_level = NULL @@ -51,7 +51,7 @@ bal_model_roc_curve <- function( validate_data_frame(.data, call = rlang::caller_env()) exposure_quo <- rlang::enquo(.exposure) - estimate_quo <- rlang::enquo(.estimate) + estimate_quo <- rlang::enquo(.fitted) wts_quo <- rlang::enquo(.weights) # Extract column names @@ -67,7 +67,7 @@ bal_model_roc_curve <- function( } if (length(estimate_name) != 1) { abort( - "{.arg .estimate} must select exactly one variable", + "{.arg .fitted} must select exactly one variable", error_class = "halfmoon_arg_error", call = rlang::current_env() ) diff --git a/R/check_balance.R b/R/check_balance.R index 2b31735..a7d5bcb 100644 --- a/R/check_balance.R +++ b/R/check_balance.R @@ -122,9 +122,18 @@ check_balance <- function( # Extract just the variables we're working with vars_data <- dplyr::select(.data, dplyr::all_of(var_names)) + # Track variable origins for interaction filtering + dummy_var_mapping <- list() + # Create dummy variables if requested if (make_dummy_vars) { - vars_data <- create_dummy_variables(vars_data, binary_as_single = TRUE) + dummy_result <- create_dummy_variables( + vars_data, + binary_as_single = TRUE, + return_mapping = TRUE + ) + vars_data <- dummy_result$data + dummy_var_mapping <- dummy_result$mapping } # Add squared terms if requested @@ -132,14 +141,21 @@ check_balance <- function( numeric_vars <- purrr::map_lgl(vars_data, is.numeric) if (any(numeric_vars)) { numeric_data <- dplyr::select(vars_data, dplyr::where(is.numeric)) - squared_data <- dplyr::mutate( + # Only square non-binary numeric variables + non_binary_numeric <- dplyr::select( numeric_data, - dplyr::across(everything(), \(x) x^2, .names = "{.col}_squared") - ) - vars_data <- dplyr::bind_cols( - vars_data, - dplyr::select(squared_data, dplyr::ends_with("_squared")) + dplyr::where(\(x) !is_binary(x)) ) + if (ncol(non_binary_numeric) > 0) { + squared_data <- dplyr::mutate( + non_binary_numeric, + dplyr::across(everything(), \(x) x^2, .names = "{.col}_squared") + ) + vars_data <- dplyr::bind_cols( + vars_data, + dplyr::select(squared_data, dplyr::ends_with("_squared")) + ) + } } } @@ -148,14 +164,19 @@ check_balance <- function( numeric_vars <- purrr::map_lgl(vars_data, is.numeric) if (any(numeric_vars)) { numeric_data <- dplyr::select(vars_data, dplyr::where(is.numeric)) - # Only cube original variables, not squared ones + # Only cube original non-binary variables, not squared ones original_numeric <- dplyr::select( numeric_data, -dplyr::ends_with("_squared") ) - if (ncol(original_numeric) > 0) { + # Filter out binary variables + non_binary_original <- dplyr::select( + original_numeric, + dplyr::where(\(x) !is_binary(x)) + ) + if (ncol(non_binary_original) > 0) { cubed_data <- dplyr::mutate( - original_numeric, + non_binary_original, dplyr::across(everything(), \(x) x^3, .names = "{.col}_cubed") ) vars_data <- dplyr::bind_cols( @@ -206,13 +227,32 @@ check_balance <- function( } # Prepare variables for interactions - interaction_vars <- purrr::imap( + interaction_vars_list <- purrr::imap( original_numeric, prepare_interaction_variable, binary_categorical_names = binary_categorical_names, original_vars_data = original_vars_data - ) |> - purrr::flatten() + ) + + # Extract the variables and update mapping for expanded binaries + interaction_vars <- purrr::flatten(interaction_vars_list) + + # Update mapping for any expanded binary categoricals + for (i in seq_along(interaction_vars_list)) { + var_result <- interaction_vars_list[[i]] + var_name <- names(original_numeric)[i] + + # Check if this variable was expanded (binary categorical) + if (var_name %in% binary_categorical_names) { + # The result is already flattened by prepare_interaction_variable + # Get the names of the expanded dummies + expanded_names <- names(var_result) + for (expanded_name in expanded_names) { + # Track that this expanded dummy came from the original variable + dummy_var_mapping[[expanded_name]] <- var_name + } + } + } # Now create interactions between all pairs var_combinations <- utils::combn( @@ -224,7 +264,7 @@ check_balance <- function( # Filter out same-variable dummy interactions (e.g., sex0 x sex1) valid_combinations <- purrr::keep( var_combinations, - is_valid_interaction_combo + \(combo) is_valid_interaction_combo(combo, dummy_var_mapping) ) # Create interaction terms using functional programming @@ -234,9 +274,12 @@ check_balance <- function( interaction_vars = interaction_vars ) - # Flatten the list and add to vars_data + # Flatten the list and convert to data frame interaction_terms <- purrr::flatten(interaction_terms) - vars_data <- c(vars_data, interaction_terms) + if (length(interaction_terms) > 0) { + interaction_df <- dplyr::as_tibble(interaction_terms) + vars_data <- dplyr::bind_cols(vars_data, interaction_df) + } } } } @@ -568,10 +611,21 @@ prepare_interaction_variable <- function( } # Check if an interaction combination is valid (not between same variable dummies) -is_valid_interaction_combo <- function(combo) { +is_valid_interaction_combo <- function(combo, variable_mapping = NULL) { var1 <- combo[1] var2 <- combo[2] + # If we have a mapping, use it to determine if variables come from same source + if (!is.null(variable_mapping)) { + # Get the original variable for each dummy (or the variable itself if not a dummy) + origin1 <- variable_mapping[[var1]] %||% var1 + origin2 <- variable_mapping[[var2]] %||% var2 + + # Only keep interactions between different original variables + return(origin1 != origin2) + } + + # Fallback to the old regex approach if no mapping provided # Extract base variable names (before dummy suffixes) base1 <- sub("^([^0-9]+).*", "\\1", var1) base2 <- sub("^([^0-9]+).*", "\\1", var2) diff --git a/R/check_ess.R b/R/check_ess.R index 9f50746..39190ff 100644 --- a/R/check_ess.R +++ b/R/check_ess.R @@ -12,7 +12,7 @@ #' number of observations, indicating that a few observations carry #' disproportionately large weights. #' -#' When `.group` is provided, ESS is calculated separately for each group level: +#' When `.exposure` is provided, ESS is calculated separately for each exposure level: #' - For binary/categorical exposures: ESS is computed within each treatment level #' - For continuous exposures: The variable is divided into quantiles (using #' `dplyr::ntile()`) and ESS is computed within each quantile @@ -21,17 +21,17 @@ #' further analysis. #' #' @inheritParams check_params -#' @param .group Optional grouping variable. When provided, ESS is calculated -#' separately for each group level. For continuous variables, groups are +#' @param .exposure Optional exposure variable. When provided, ESS is calculated +#' separately for each exposure level. For continuous variables, groups are #' created using quantiles. -#' @param n_tiles For continuous `.group` variables, the number of quantile +#' @param n_tiles For continuous `.exposure` variables, the number of quantile #' groups to create. Default is 4 (quartiles). #' @param tile_labels Optional character vector of labels for the quantile groups -#' when `.group` is continuous. If NULL, uses "Q1", "Q2", etc. +#' when `.exposure` is continuous. If NULL, uses "Q1", "Q2", etc. #' #' @return A tibble with columns: #' \item{method}{Character. The weighting method ("observed" or weight variable name).} -#' \item{group}{Character. The group level (if `.group` is provided).} +#' \item{group}{Character. The exposure level (if `.exposure` is provided).} #' \item{n}{Integer. The number of observations in the group.} #' \item{ess}{Numeric. The effective sample size.} #' \item{ess_pct}{Numeric. ESS as a percentage of the actual sample size.} @@ -44,27 +44,27 @@ #' check_ess(nhefs_weights, .weights = c(w_ate, w_att, w_atm)) #' #' # ESS by treatment group (binary exposure) -#' check_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) +#' check_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) #' #' # ESS by treatment group (categorical exposure) -#' check_ess(nhefs_weights, .weights = w_cat_ate, .group = alcoholfreq_cat) +#' check_ess(nhefs_weights, .weights = w_cat_ate, .exposure = alcoholfreq_cat) #' #' # ESS by quartiles of a continuous variable -#' check_ess(nhefs_weights, .weights = w_ate, .group = age, n_tiles = 4) +#' check_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 4) #' #' # Custom labels for continuous groups -#' check_ess(nhefs_weights, .weights = w_ate, .group = age, +#' check_ess(nhefs_weights, .weights = w_ate, .exposure = age, #' n_tiles = 3, tile_labels = c("Young", "Middle", "Older")) #' #' # Without unweighted comparison -#' check_ess(nhefs_weights, .weights = w_ate, .group = qsmk, +#' check_ess(nhefs_weights, .weights = w_ate, .exposure = qsmk, #' include_observed = FALSE) #' #' @export check_ess <- function( .data, .weights = NULL, - .group = NULL, + .exposure = NULL, include_observed = TRUE, n_tiles = 4, tile_labels = NULL @@ -72,13 +72,13 @@ check_ess <- function( # Validate inputs validate_data_frame(.data) - # Handle group variable - group_quo <- rlang::enquo(.group) + # Handle exposure variable + group_quo <- rlang::enquo(.exposure) has_group <- !rlang::quo_is_null(group_quo) if (has_group) { - group_name <- get_column_name(group_quo, ".group") - validate_column_exists(.data, group_name, ".group") + group_name <- get_column_name(group_quo, ".exposure") + validate_column_exists(.data, group_name, ".exposure") group_var <- .data[[group_name]] # Check if continuous (numeric and more than 10 unique values) diff --git a/R/check_model_auc.R b/R/check_model_auc.R index d89b7b4..8473dcd 100644 --- a/R/check_model_auc.R +++ b/R/check_model_auc.R @@ -20,7 +20,7 @@ #' #' @param .data A data frame containing the variables. #' @param .exposure The treatment/outcome variable. -#' @param .estimate The propensity score or fitted values. +#' @param .fitted The propensity score or fitted values. #' @param .weights Weighting variables (supports tidyselect). #' @inheritParams check_params #' @inheritParams balance_params @@ -44,7 +44,7 @@ check_model_auc <- function( .data, .exposure, - .estimate, + .fitted, .weights, include_observed = TRUE, na.rm = TRUE, @@ -55,7 +55,7 @@ check_model_auc <- function( roc_data <- check_model_roc_curve( .data, {{ .exposure }}, - {{ .estimate }}, + {{ .fitted }}, {{ .weights }}, include_observed, na.rm, @@ -100,7 +100,7 @@ compute_method_auc <- function(method, roc_data) { #' #' @param .data A data frame containing the variables. #' @param .exposure The treatment/outcome variable (unquoted). -#' @param .estimate The propensity score or covariate (unquoted). +#' @param .fitted The propensity score or covariate (unquoted). #' @param .weights Optional weighting variables (unquoted, can be multiple). #' @param include_observed Include unweighted results? Default TRUE. #' @param na.rm Remove missing values? Default TRUE. @@ -110,18 +110,44 @@ compute_method_auc <- function(method, roc_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 +#' @examples +#' # Check ROC curves for propensity scores with multiple weights +#' roc_data <- check_model_roc_curve( +#' nhefs_weights, +#' qsmk, +#' .fitted, +#' c(w_ate, w_att) +#' ) +#' +#' # Check ROC curve for a single weight without observed +#' check_model_roc_curve( +#' nhefs_weights, +#' qsmk, +#' .fitted, +#' w_ate, +#' include_observed = FALSE +#' ) +#' +#' # Specify a different focal level +#' check_model_roc_curve( +#' nhefs_weights, +#' qsmk, +#' .fitted, +#' w_ate, +#' .focal_level = 0 # Use 0 as the treatment level instead of 1 +#' ) #' @export check_model_roc_curve <- function( .data, .exposure, - .estimate, + .fitted, .weights = NULL, include_observed = TRUE, na.rm = TRUE, .focal_level = NULL ) { truth_quo <- rlang::enquo(.exposure) - estimate_quo <- rlang::enquo(.estimate) + estimate_quo <- rlang::enquo(.fitted) wts_quo <- rlang::enquo(.weights) validate_data_frame(.data) @@ -139,7 +165,7 @@ check_model_roc_curve <- function( } if (length(estimate_name) != 1) { abort( - "{.arg .estimate} must select exactly one variable", + "{.arg .fitted} must select exactly one variable", error_class = "halfmoon_select_error", call = rlang::current_env() ) @@ -186,7 +212,7 @@ check_model_roc_curve <- function( ) } - validate_numeric(estimate, ".estimate") + validate_numeric(estimate, ".fitted") if (na.rm) { complete_cases <- stats::complete.cases(truth, estimate) diff --git a/R/compute_balance.R b/R/compute_balance.R index 36976e3..7ddeb15 100644 --- a/R/compute_balance.R +++ b/R/compute_balance.R @@ -110,10 +110,6 @@ bal_smd <- function( res$estimate } -is_binary <- function(x) { - unique_vals <- unique(stats::na.omit(x)) - length(unique_vals) == 2 && all(unique_vals %in% c(0, 1)) -} #' Balance Variance Ratio for Two Groups #' diff --git a/R/geom_calibration.R b/R/geom_calibration.R index cadba8f..4ed0274 100644 --- a/R/geom_calibration.R +++ b/R/geom_calibration.R @@ -8,7 +8,7 @@ #' @param data A data frame containing the data. #' @param .fitted Column name of predicted probabilities (numeric between 0 and 1). #' Can be unquoted (e.g., `p`) or quoted (e.g., `"p"`). -#' @param .group Column name of treatment/group variable. +#' @param .exposure Column name of treatment/exposure variable. #' Can be unquoted (e.g., `g`) or quoted (e.g., `"g"`). #' @inheritParams treatment_param #' @param method Character; calibration method. One of: "breaks", "logistic", or "windowed". @@ -50,7 +50,7 @@ check_model_calibration <- function( data, .fitted, - .group, + .exposure, .focal_level = NULL, method = c("breaks", "logistic", "windowed"), bins = 10, @@ -75,16 +75,16 @@ check_model_calibration <- function( } fitted_quo <- rlang::enquo(.fitted) - group_quo <- rlang::enquo(.group) + group_quo <- rlang::enquo(.exposure) fitted_name <- get_column_name(fitted_quo, ".fitted") - group_name <- get_column_name(group_quo, ".group") + group_name <- get_column_name(group_quo, ".exposure") group_var <- data[[group_name]] check_columns(data, fitted_name, group_name, .focal_level) - treatment_indicator <- check_treatment_level(group_var, .focal_level) + treatment_indicator <- check_focal_level(group_var, .focal_level) df <- tibble::tibble( x_var = data[[fitted_name]], @@ -139,13 +139,13 @@ empty_calibration <- function(method = "breaks") { } } -check_treatment_level <- function(group_var, .focal_level) { +check_focal_level <- function(group_var, .focal_level) { # Validate treatment level exists if provided if (!is.null(.focal_level)) { unique_levels <- unique(group_var[!is.na(group_var)]) if (length(unique_levels) > 0 && !.focal_level %in% unique_levels) { abort( - "{.code .focal_level} {.code {.focal_level}} not found in {.code .group} variable", + "{.code .focal_level} {.code {.focal_level}} not found in {.code .exposure} variable", error_class = "halfmoon_reference_error" ) } @@ -457,7 +457,7 @@ calculate_window_statistics <- function( StatCalibration <- ggplot2::ggproto( "StatCalibration", ggplot2::Stat, - required_aes = c("estimate", "truth"), + required_aes = c(".fitted", ".exposure"), default_aes = ggplot2::aes( x = ggplot2::after_stat(predicted_rate), y = ggplot2::after_stat(observed_rate), @@ -465,7 +465,7 @@ StatCalibration <- ggplot2::ggproto( ymax = ggplot2::after_stat(upper), alpha = 0.3 ), - dropped_aes = c("truth"), + dropped_aes = c(".exposure"), setup_params = function(data, params) { # Set default parameters params$method <- params$method %||% "breaks" @@ -500,7 +500,7 @@ StatCalibration <- ggplot2::ggproto( # We want to merge groups that differ only by truth factor levels aes_cols <- setdiff( names(data), - c("estimate", "truth", "weight", "PANEL", "group", "x", "y") + c(".fitted", ".exposure", "weight", "PANEL", "group", "x", "y") ) group_signatures <- purrr::map_chr( @@ -573,12 +573,12 @@ compute_calibration_for_group <- function( call = rlang::caller_env() ) { # Convert to binary using helper function - truth <- data$truth - treatment_indicator <- create_treatment_indicator(truth, .focal_level) + exposure <- data$.exposure + treatment_indicator <- create_treatment_indicator(exposure, .focal_level) # Create data frame for calibration computation df <- tibble::tibble( - x_var = data$estimate, + x_var = data$.fitted, y_var = treatment_indicator ) @@ -710,8 +710,8 @@ GeomCalibrationPoint <- ggplot2::ggproto( #' requiring additional packages #' } #' -#' @param mapping Aesthetic mapping (must supply `estimate` and `truth` if not inherited). -#' `estimate` should be propensity scores/predicted probabilities, `truth` should be treatment variable. +#' @param mapping Aesthetic mapping (must supply `.fitted` and `.exposure` if not inherited). +#' `.fitted` should be propensity scores/predicted probabilities, `.exposure` should be treatment variable. #' @param data Data frame or tibble; if NULL, uses ggplot default. #' @param method Character; calibration method - "breaks", "logistic", or "windowed". #' @param bins Integer >1; number of bins for the "breaks" method. @@ -733,25 +733,25 @@ GeomCalibrationPoint <- ggplot2::ggproto( #' #' # Basic calibration plot using nhefs_weights dataset #' # .fitted contains propensity scores, qsmk is the treatment variable -#' ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +#' ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + #' geom_calibration() + #' geom_abline(intercept = 0, slope = 1, linetype = "dashed") + #' labs(x = "Propensity Score", y = "Observed Treatment Rate") #' #' # Using different methods -#' ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +#' ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + #' geom_calibration(method = "logistic") + #' geom_abline(intercept = 0, slope = 1, linetype = "dashed") + #' labs(x = "Propensity Score", y = "Observed Treatment Rate") #' #' # Specify treatment level explicitly -#' ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +#' ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + #' geom_calibration(.focal_level = "1") + #' geom_abline(intercept = 0, slope = 1, linetype = "dashed") + #' labs(x = "Propensity Score", y = "Observed Treatment Rate") #' #' # Windowed method with custom parameters -#' ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +#' ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + #' geom_calibration(method = "windowed", window_size = 0.2, step_size = 0.1) + #' geom_abline(intercept = 0, slope = 1, linetype = "dashed") + #' labs(x = "Propensity Score", y = "Observed Treatment Rate") diff --git a/R/geom_mirrored_histogram.R b/R/geom_mirrored_histogram.R index c7ac3cf..7e18bfb 100644 --- a/R/geom_mirrored_histogram.R +++ b/R/geom_mirrored_histogram.R @@ -94,8 +94,7 @@ StatMirrorCount <- ggplot2::ggproto( pad = FALSE, breaks = NULL, flipped_aes = FALSE, - origin = NULL, - right = NULL, + ..., drop = NULL ) { # Check for no group @@ -130,8 +129,7 @@ StatMirrorCount <- ggplot2::ggproto( pad = pad, breaks = breaks, flipped_aes = flipped_aes, - origin = origin, - right = right, + ..., drop = drop ) diff --git a/R/plot_balance.R b/R/plot_balance.R index 51ca7c4..4895295 100644 --- a/R/plot_balance.R +++ b/R/plot_balance.R @@ -148,7 +148,7 @@ plot_balance <- function( } # Create caption based on whether we're using absolute values - caption_text <- if (abs_smd) { + caption_text <- if (any(.df$metric %in% "smd") && abs_smd) { "smd values shown as absolute values" } else { NULL diff --git a/R/plot_calibration.R b/R/plot_calibration.R index 87f3909..8761aac 100644 --- a/R/plot_calibration.R +++ b/R/plot_calibration.R @@ -70,9 +70,9 @@ plot_model_calibration <- function(x, ...) { #' @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. +#' @param .exposure Column name of treatment/exposure variable. #' Can be unquoted (e.g., `qsmk`) or quoted (e.g., `"qsmk"`). -#' @param .focal_level Value indicating which level of `.group` represents treatment. +#' @param .focal_level Value indicating which level of `.exposure` represents treatment. #' If NULL (default), uses the last level for factors or max value for numeric. #' @param method Character; calibration method - "breaks", "logistic", or "windowed". #' @param bins Integer >1; number of bins for the "breaks" method. @@ -89,7 +89,7 @@ plot_model_calibration <- function(x, ...) { plot_model_calibration.data.frame <- function( x, .fitted, - .group, + .exposure, .focal_level = NULL, method = "breaks", bins = 10, @@ -106,15 +106,18 @@ plot_model_calibration.data.frame <- function( ) { # Handle both quoted and unquoted column names using the same logic as check_calibration fitted_quo <- rlang::enquo(.fitted) - group_quo <- rlang::enquo(.group) + group_quo <- rlang::enquo(.exposure) fitted_name <- get_column_name(fitted_quo, ".fitted") - group_name <- get_column_name(group_quo, ".group") + group_name <- get_column_name(group_quo, ".exposure") # Create the base plot with new aesthetics p <- ggplot2::ggplot( x, - ggplot2::aes(estimate = .data[[fitted_name]], truth = .data[[group_name]]) + ggplot2::aes( + .fitted = .data[[fitted_name]], + .exposure = .data[[group_name]] + ) ) + geom_calibration( method = method, @@ -193,19 +196,19 @@ plot_model_calibration.glm <- function( .fitted <- stats::fitted(x) # For GLM/LM models, the response is the first column of the model frame - .group <- model_frame[[1]] + .exposure <- model_frame[[1]] # Create a data frame for plotting plot_data <- data.frame( .fitted = .fitted, - .group = .group + .exposure = .exposure ) # Call the data frame method plot_model_calibration.data.frame( plot_data, .fitted = .fitted, - .group = .group, + .exposure = .exposure, .focal_level = .focal_level, method = method, bins = bins, diff --git a/R/plot_ess.R b/R/plot_ess.R index 26f4e38..aefb34f 100644 --- a/R/plot_ess.R +++ b/R/plot_ess.R @@ -9,9 +9,9 @@ #' from the provided data. The plot shows how much "effective" sample size remains #' after weighting, which is a key diagnostic for assessing weight variability. #' -#' When `.group` is not provided, the function displays overall ESS for each -#' weighting method. When `.group` is provided, ESS is shown separately for each -#' group level using dodged bars. +#' When `.exposure` is not provided, the function displays overall ESS for each +#' weighting method. When `.exposure` is provided, ESS is shown separately for each +#' exposure level using dodged bars. #' #' For continuous grouping variables, the function automatically creates quantile #' groups (quartiles by default) to show how ESS varies across the distribution @@ -27,7 +27,7 @@ #' - Output from `check_ess()` containing ESS calculations #' - Raw data to compute ESS from (requires `.weights` to be specified) #' @inheritParams check_ess -#' @param fill_color Color for the bars when `.group` is not provided. +#' @param fill_color Color for the bars when `.exposure` is not provided. #' Default is "#0172B1". #' @param alpha Transparency level for the bars. Default is 0.8. #' @param show_labels Logical. Show ESS percentage values as text labels on bars? @@ -47,24 +47,24 @@ #' plot_ess(nhefs_weights, .weights = c(w_ate, w_att, w_atm)) #' #' # ESS by treatment group (binary exposure) -#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) +#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) #' #' # ESS by treatment group (categorical exposure) -#' plot_ess(nhefs_weights, .weights = w_cat_ate, .group = alcoholfreq_cat) +#' plot_ess(nhefs_weights, .weights = w_cat_ate, .exposure = alcoholfreq_cat) #' #' # ESS by age quartiles -#' plot_ess(nhefs_weights, .weights = w_ate, .group = age) +#' plot_ess(nhefs_weights, .weights = w_ate, .exposure = age) #' #' # Customize quantiles for continuous variable -#' plot_ess(nhefs_weights, .weights = w_ate, .group = age, +#' plot_ess(nhefs_weights, .weights = w_ate, .exposure = age, #' n_tiles = 5, tile_labels = c("Youngest", "Young", "Middle", "Older", "Oldest")) #' #' # Without percentage labels -#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk, +#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk, #' show_labels = FALSE) #' #' # Custom styling -#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk, +#' plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk, #' alpha = 0.6, fill_color = "steelblue", #' reference_line_color = "red") #' @@ -79,7 +79,7 @@ plot_ess <- function( .data, .weights = NULL, - .group = NULL, + .exposure = NULL, include_observed = TRUE, n_tiles = 4, tile_labels = NULL, @@ -99,7 +99,7 @@ plot_ess <- function( .data <- check_ess( .data = .data, .weights = {{ .weights }}, - .group = {{ .group }}, + .exposure = {{ .exposure }}, include_observed = include_observed, n_tiles = n_tiles, tile_labels = tile_labels diff --git a/R/plot_mirror_distributions.R b/R/plot_mirror_distributions.R index a14a819..c17032a 100644 --- a/R/plot_mirror_distributions.R +++ b/R/plot_mirror_distributions.R @@ -44,6 +44,10 @@ #' @param .reference_level The reference group level for categorical exposures (>2 levels). #' Can be a string (group level) or numeric (position). Defaults to 1 (first level). #' Only used when .exposure has more than 2 levels. +#' @param facet_scales Character. Scale specification for facets. Defaults to +#' "fixed" to match ggplot2's default behavior. Options are +#' "fixed", "free_x", "free_y", or "free". Use "free_y" to allow different +#' y-axis scales across panels, which was the previous default behavior. #' #' @return A ggplot2 object. #' @@ -115,7 +119,8 @@ plot_mirror_distributions <- function( include_unweighted = TRUE, alpha = 0.6, na.rm = FALSE, - .reference_level = 1L + .reference_level = 1L, + facet_scales = "fixed" ) { type <- match.arg(type) @@ -220,9 +225,9 @@ plot_mirror_distributions <- function( na.rm = na.rm ) + if (is_categorical) { - ggplot2::facet_grid(comparison ~ method, scales = "free_y") + ggplot2::facet_grid(comparison ~ method, scales = facet_scales) } else { - ggplot2::facet_wrap(~method, scales = "free_y") + ggplot2::facet_wrap(~method, scales = facet_scales) } } else { p <- ggplot2::ggplot(plot_data, ggplot2::aes(x = .data[[var_name]])) + @@ -238,9 +243,9 @@ plot_mirror_distributions <- function( na.rm = na.rm ) + if (is_categorical) { - ggplot2::facet_grid(comparison ~ method, scales = "free_y") + ggplot2::facet_grid(comparison ~ method, scales = facet_scales) } else { - ggplot2::facet_wrap(~method, scales = "free_y") + ggplot2::facet_wrap(~method, scales = facet_scales) } } } else { @@ -272,7 +277,7 @@ plot_mirror_distributions <- function( # Add faceting for categorical exposures without weights if (is_categorical) { - p <- p + ggplot2::facet_wrap(~comparison, scales = "free_y") + p <- p + ggplot2::facet_wrap(~comparison, scales = facet_scales) } } diff --git a/R/plot_qq.R b/R/plot_qq.R index bb0b642..7b9116d 100644 --- a/R/plot_qq.R +++ b/R/plot_qq.R @@ -17,7 +17,7 @@ #' @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 .exposure Column name of treatment/exposure variable. Can be unquoted (e.g., `qsmk`) or quoted (e.g., `"qsmk"`). #' @param .weights Optional weighting variable(s). Can be unquoted variable names, #' a character vector, or NULL. Multiple weights can be provided to compare #' different weighting schemes. Default is NULL (unweighted). @@ -70,7 +70,7 @@ plot_qq <- function(.data, ...) { plot_qq.default <- function( .data, .var, - .group, + .exposure, .weights = NULL, quantiles = seq(0.01, 0.99, 0.01), include_observed = TRUE, @@ -80,10 +80,10 @@ plot_qq.default <- function( ) { # Basic validation var_quo <- rlang::enquo(.var) - group_quo <- rlang::enquo(.group) + group_quo <- rlang::enquo(.exposure) var_name <- get_column_name(var_quo, ".var") - group_name <- get_column_name(group_quo, ".group") + group_name <- get_column_name(group_quo, ".exposure") if (!var_name %in% names(.data)) { abort( @@ -135,7 +135,7 @@ plot_qq.default <- function( # Validate .reference_level exists if (!.reference_level %in% group_levels) { abort( - "{.arg .reference_level} '{(.reference_level)}' not found in {.arg .group} levels: {.val {group_levels}}", + "{.arg .reference_level} '{(.reference_level)}' not found in {.arg .exposure} levels: {.val {group_levels}}", error_class = "halfmoon_reference_error" ) } @@ -185,7 +185,7 @@ plot_qq.default <- function( plot_data, ggplot2::aes( sample = {{ .var }}, - treatment = {{ .group }}, + treatment = {{ .exposure }}, weight = weight ) ) + @@ -199,7 +199,7 @@ plot_qq.default <- function( # No weights - just use geom_qq2 directly p <- ggplot2::ggplot( .data, - ggplot2::aes(sample = {{ .var }}, treatment = {{ .group }}) + ggplot2::aes(sample = {{ .var }}, treatment = {{ .exposure }}) ) + geom_qq2( quantiles = quantiles, diff --git a/R/utils-group.R b/R/utils-group.R index 3654883..33b28f8 100644 --- a/R/utils-group.R +++ b/R/utils-group.R @@ -65,7 +65,7 @@ determine_reference_group <- function( } # Create treatment indicator -create_treatment_indicator <- function(group, treatment_level = NULL) { +create_treatment_indicator <- function(group, .focal_level = NULL) { unique_levels <- unique(group[!is.na(group)]) # Handle empty groups @@ -73,19 +73,19 @@ create_treatment_indicator <- function(group, treatment_level = NULL) { return(integer(length(group))) } - if (is.null(treatment_level)) { + if (is.null(.focal_level)) { if (is.factor(group)) { - treatment_level <- levels(group)[length(levels(group))] + .focal_level <- levels(group)[length(levels(group))] } else { - treatment_level <- max(unique_levels, na.rm = TRUE) + .focal_level <- max(unique_levels, na.rm = TRUE) } } # Handle both factor and non-factor variables if (is.factor(group)) { - as.integer(as.character(group) == as.character(treatment_level)) + as.integer(as.character(group) == as.character(.focal_level)) } else { - as.integer(group == treatment_level) + as.integer(group == .focal_level) } } diff --git a/R/utils.R b/R/utils.R index 7d64bed..7099bb4 100644 --- a/R/utils.R +++ b/R/utils.R @@ -92,7 +92,6 @@ utils::globalVariables(c( "method", "metric", "variable", - "estimate", ".bin", "bin", "n_events", @@ -104,7 +103,9 @@ utils::globalVariables(c( "fitted_mean", "group_mean", ".fitted", + ".exposure", ".group", + "estimate", "ymin", "ymax", "x_quantiles", @@ -187,7 +188,11 @@ utils::globalVariables(c( #' variable representations #' #' @noRd -create_dummy_variables <- function(data, binary_as_single = TRUE) { +create_dummy_variables <- function( + data, + binary_as_single = TRUE, + return_mapping = FALSE +) { # Identify categorical variables (factors and character variables) categorical_vars <- purrr::map_lgl( data, @@ -196,7 +201,11 @@ create_dummy_variables <- function(data, binary_as_single = TRUE) { if (!any(categorical_vars)) { # No categorical variables, return data as-is - return(data) + if (return_mapping) { + return(list(data = data, mapping = list())) + } else { + return(data) + } } # Extract categorical and non-categorical data @@ -210,6 +219,9 @@ create_dummy_variables <- function(data, binary_as_single = TRUE) { -dplyr::where(\(x) is.factor(x) || is.character(x)) ) + # Track dummy variable mapping + dummy_mapping <- list() + # Create dummy variables using functional programming dummy_vars <- purrr::imap( categorical_data, @@ -232,6 +244,8 @@ create_dummy_variables <- function(data, binary_as_single = TRUE) { col_factor <- factor(col_data, levels = levels_to_use) dummy_values <- as.numeric(col_factor) - 1 } + # Track that this dummy came from the original variable + dummy_mapping[[col_name]] <<- col_name stats::setNames(list(dummy_values), col_name) } else { # Multi-level variable or binary with binary_as_single = FALSE: @@ -241,6 +255,10 @@ create_dummy_variables <- function(data, binary_as_single = TRUE) { levels_to_use, \(x) as.numeric(col_data == x) ) + # Track that all these dummies came from the original variable + for (dummy_name in dummy_names) { + dummy_mapping[[dummy_name]] <<- col_name + } stats::setNames(dummy_values, dummy_names) } } @@ -250,7 +268,19 @@ create_dummy_variables <- function(data, binary_as_single = TRUE) { dummy_df <- dplyr::as_tibble(purrr::flatten(dummy_vars)) # Combine non-categorical and dummy variables - dplyr::bind_cols(non_categorical_data, dummy_df) + result_data <- dplyr::bind_cols(non_categorical_data, dummy_df) + + if (return_mapping) { + return(list(data = result_data, mapping = dummy_mapping)) + } else { + return(result_data) + } +} + +# Check if a numeric vector is binary (only contains 0 and 1) +is_binary <- function(x) { + unique_vals <- unique(stats::na.omit(x)) + length(unique_vals) == 2 && all(unique_vals %in% c(0, 1)) } # Create a signature for a group based on aesthetic columns diff --git a/README.Rmd b/README.Rmd index dddc90f..5c989b8 100644 --- a/README.Rmd +++ b/README.Rmd @@ -59,7 +59,7 @@ library(ggplot2) # weighted mirrored histograms ggplot(nhefs_weights, aes(.fitted)) + geom_mirror_histogram( - aes(exposure = qsmk), + aes(group = qsmk), bins = 50 ) + geom_mirror_histogram( @@ -111,14 +111,14 @@ Assess how well your propensity score model discriminates between treatment grou roc_results <- check_model_roc_curve( nhefs_weights, .exposure = qsmk, - .estimate = .fitted, + .fitted = .fitted, .weights = c(w_ate, w_att, w_atm, w_ato) ) auc_results <- check_model_auc( nhefs_weights, .exposure = qsmk, - .estimate = .fitted, + .fitted = .fitted, .weights = c(w_ate, w_att, w_atm, w_ato) ) @@ -229,7 +229,7 @@ matches$ps <- m.out1$distance ggplot(matches, aes(ps)) + geom_mirror_histogram( - aes(exposure = factor(treat)), + aes(group = factor(treat)), bins = 50 ) + geom_mirror_histogram( diff --git a/README.md b/README.md index 0fbab59..95f705a 100644 --- a/README.md +++ b/README.md @@ -52,7 +52,7 @@ library(ggplot2) # weighted mirrored histograms ggplot(nhefs_weights, aes(.fitted)) + geom_mirror_histogram( - aes(exposure = qsmk), + aes(group = qsmk), bins = 50 ) + geom_mirror_histogram( @@ -60,8 +60,6 @@ ggplot(nhefs_weights, aes(.fitted)) + bins = 50, alpha = 0.5 ) + scale_y_continuous(labels = abs) -#> Warning in ggplot2::geom_histogram(mapping = mapping, data = data, stat = -#> StatMirrorCount, : Ignoring unknown aesthetics: exposure ``` @@ -122,14 +120,14 @@ about 0.5 (what you would observe from a randomized experiment): roc_results <- check_model_roc_curve( nhefs_weights, .exposure = qsmk, - .estimate = .fitted, + .fitted = .fitted, .weights = c(w_ate, w_att, w_atm, w_ato) ) auc_results <- check_model_auc( nhefs_weights, .exposure = qsmk, - .estimate = .fitted, + .fitted = .fitted, .weights = c(w_ate, w_att, w_atm, w_ato) ) @@ -275,7 +273,7 @@ matches$ps <- m.out1$distance ggplot(matches, aes(ps)) + geom_mirror_histogram( - aes(exposure = factor(treat)), + aes(group = factor(treat)), bins = 50 ) + geom_mirror_histogram( @@ -283,8 +281,6 @@ ggplot(matches, aes(ps)) + bins = 50, alpha = 0.5 ) + scale_y_continuous(labels = abs) -#> Warning in ggplot2::geom_histogram(mapping = mapping, data = data, stat = -#> StatMirrorCount, : Ignoring unknown aesthetics: exposure ``` diff --git a/data-raw/nhefs_weights.R b/data-raw/nhefs_weights.R index 4888fa2..1504668 100644 --- a/data-raw/nhefs_weights.R +++ b/data-raw/nhefs_weights.R @@ -8,18 +8,18 @@ library(propensity) propensity_model <- glm( qsmk ~ sex + - race + - age + - I(age^2) + - education + - smokeintensity + - I(smokeintensity^2) + - smokeyrs + - I(smokeyrs^2) + - exercise + - active + - wt71 + - I(wt71^2), + race + + age + + I(age^2) + + education + + smokeintensity + + I(smokeintensity^2) + + smokeyrs + + I(smokeyrs^2) + + exercise + + active + + wt71 + + I(wt71^2), family = binomial(), data = nhefs_complete ) @@ -67,18 +67,18 @@ nhefs_for_model <- nhefs_with_cat %>% cat_ps_model <- multinom( alcoholfreq_cat ~ sex + - race + - age + - I(age^2) + - education + - smokeintensity + - I(smokeintensity^2) + - smokeyrs + - I(smokeyrs^2) + - exercise + - active + - wt71 + - I(wt71^2), + race + + age + + I(age^2) + + education + + smokeintensity + + I(smokeintensity^2) + + smokeyrs + + I(smokeyrs^2) + + exercise + + active + + wt71 + + I(wt71^2), data = nhefs_for_model, trace = FALSE ) diff --git a/man/bal_model_auc.Rd b/man/bal_model_auc.Rd index a3ca113..deb28c0 100644 --- a/man/bal_model_auc.Rd +++ b/man/bal_model_auc.Rd @@ -7,7 +7,7 @@ bal_model_auc( .data, .exposure, - .estimate, + .fitted, .weights = NULL, na.rm = TRUE, .focal_level = NULL @@ -18,7 +18,7 @@ bal_model_auc( \item{.exposure}{The treatment/outcome variable (unquoted).} -\item{.estimate}{The propensity score or fitted values (unquoted).} +\item{.fitted}{The propensity score or fitted values (unquoted).} \item{.weights}{Optional single weight variable (unquoted). If NULL, computes unweighted AUC.} diff --git a/man/bal_model_roc_curve.Rd b/man/bal_model_roc_curve.Rd index d3e147d..a58cb2e 100644 --- a/man/bal_model_roc_curve.Rd +++ b/man/bal_model_roc_curve.Rd @@ -7,7 +7,7 @@ bal_model_roc_curve( .data, .exposure, - .estimate, + .fitted, .weights = NULL, na.rm = TRUE, .focal_level = NULL @@ -18,7 +18,7 @@ bal_model_roc_curve( \item{.exposure}{The treatment/outcome variable (unquoted).} -\item{.estimate}{The propensity score or fitted values (unquoted).} +\item{.fitted}{The propensity score or fitted values (unquoted).} \item{.weights}{Optional single weight variable (unquoted). If NULL, computes unweighted ROC curve.} diff --git a/man/check_ess.Rd b/man/check_ess.Rd index 30a1698..c4c0b78 100644 --- a/man/check_ess.Rd +++ b/man/check_ess.Rd @@ -7,7 +7,7 @@ check_ess( .data, .weights = NULL, - .group = NULL, + .exposure = NULL, include_observed = TRUE, n_tiles = 4, tile_labels = NULL @@ -20,23 +20,23 @@ check_ess( a character vector, or NULL. Multiple weights can be provided to compare different weighting schemes.} -\item{.group}{Optional grouping variable. When provided, ESS is calculated -separately for each group level. For continuous variables, groups are +\item{.exposure}{Optional exposure variable. When provided, ESS is calculated +separately for each exposure level. For continuous variables, groups are created using quantiles.} \item{include_observed}{Logical. If using \code{.weights}, also calculate observed (unweighted) metrics? Defaults to TRUE.} -\item{n_tiles}{For continuous \code{.group} variables, the number of quantile +\item{n_tiles}{For continuous \code{.exposure} variables, the number of quantile groups to create. Default is 4 (quartiles).} \item{tile_labels}{Optional character vector of labels for the quantile groups -when \code{.group} is continuous. If NULL, uses "Q1", "Q2", etc.} +when \code{.exposure} is continuous. If NULL, uses "Q1", "Q2", etc.} } \value{ A tibble with columns: \item{method}{Character. The weighting method ("observed" or weight variable name).} -\item{group}{Character. The group level (if \code{.group} is provided).} +\item{group}{Character. The exposure level (if \code{.exposure} is provided).} \item{n}{Integer. The number of observations in the group.} \item{ess}{Numeric. The effective sample size.} \item{ess_pct}{Numeric. ESS as a percentage of the actual sample size.} @@ -54,7 +54,7 @@ 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. -When \code{.group} is provided, ESS is calculated separately for each group level: +When \code{.exposure} is provided, ESS is calculated separately for each exposure level: \itemize{ \item For binary/categorical exposures: ESS is computed within each treatment level \item For continuous exposures: The variable is divided into quantiles (using @@ -69,20 +69,20 @@ further analysis. check_ess(nhefs_weights, .weights = c(w_ate, w_att, w_atm)) # ESS by treatment group (binary exposure) -check_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) +check_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) # ESS by treatment group (categorical exposure) -check_ess(nhefs_weights, .weights = w_cat_ate, .group = alcoholfreq_cat) +check_ess(nhefs_weights, .weights = w_cat_ate, .exposure = alcoholfreq_cat) # ESS by quartiles of a continuous variable -check_ess(nhefs_weights, .weights = w_ate, .group = age, n_tiles = 4) +check_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 4) # Custom labels for continuous groups -check_ess(nhefs_weights, .weights = w_ate, .group = age, +check_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 3, tile_labels = c("Young", "Middle", "Older")) # Without unweighted comparison -check_ess(nhefs_weights, .weights = w_ate, .group = qsmk, +check_ess(nhefs_weights, .weights = w_ate, .exposure = qsmk, include_observed = FALSE) } diff --git a/man/check_model_auc.Rd b/man/check_model_auc.Rd index 531cfe9..27af5b1 100644 --- a/man/check_model_auc.Rd +++ b/man/check_model_auc.Rd @@ -7,7 +7,7 @@ check_model_auc( .data, .exposure, - .estimate, + .fitted, .weights, include_observed = TRUE, na.rm = TRUE, @@ -19,7 +19,7 @@ check_model_auc( \item{.exposure}{The treatment/outcome variable.} -\item{.estimate}{The propensity score or fitted values.} +\item{.fitted}{The propensity score or fitted values.} \item{.weights}{Weighting variables (supports tidyselect).} diff --git a/man/check_model_calibration.Rd b/man/check_model_calibration.Rd index bb1ef41..2f24ec2 100644 --- a/man/check_model_calibration.Rd +++ b/man/check_model_calibration.Rd @@ -7,7 +7,7 @@ check_model_calibration( data, .fitted, - .group, + .exposure, .focal_level = NULL, method = c("breaks", "logistic", "windowed"), bins = 10, @@ -26,7 +26,7 @@ check_model_calibration( \item{.fitted}{Column name of predicted probabilities (numeric between 0 and 1). Can be unquoted (e.g., \code{p}) or quoted (e.g., \code{"p"}).} -\item{.group}{Column name of treatment/group variable. +\item{.exposure}{Column name of treatment/exposure variable. Can be unquoted (e.g., \code{g}) or quoted (e.g., \code{"g"}).} \item{.focal_level}{The level of the outcome variable to consider as the diff --git a/man/check_model_roc_curve.Rd b/man/check_model_roc_curve.Rd index 2c2fe77..5aaf24e 100644 --- a/man/check_model_roc_curve.Rd +++ b/man/check_model_roc_curve.Rd @@ -7,7 +7,7 @@ check_model_roc_curve( .data, .exposure, - .estimate, + .fitted, .weights = NULL, include_observed = TRUE, na.rm = TRUE, @@ -19,7 +19,7 @@ check_model_roc_curve( \item{.exposure}{The treatment/outcome variable (unquoted).} -\item{.estimate}{The propensity score or covariate (unquoted).} +\item{.fitted}{The propensity score or covariate (unquoted).} \item{.weights}{Optional weighting variables (unquoted, can be multiple).} @@ -38,6 +38,33 @@ Computes ROC curves (weighted or unweighted) for evaluating propensity score bal In causal inference, an ROC curve near the diagonal (AUC around 0.5) indicates good balance between treatment groups. } +\examples{ +# Check ROC curves for propensity scores with multiple weights +roc_data <- check_model_roc_curve( + nhefs_weights, + qsmk, + .fitted, + c(w_ate, w_att) +) + +# Check ROC curve for a single weight without observed +check_model_roc_curve( + nhefs_weights, + qsmk, + .fitted, + w_ate, + include_observed = FALSE +) + +# Specify a different focal level +check_model_roc_curve( + nhefs_weights, + qsmk, + .fitted, + w_ate, + .focal_level = 0 # Use 0 as the treatment level instead of 1 +) +} \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 diff --git a/man/figures/README-example-1.png b/man/figures/README-example-1.png index 48ab000..77e54c6 100644 Binary files a/man/figures/README-example-1.png and b/man/figures/README-example-1.png differ diff --git a/man/figures/README-qq-example-1.png b/man/figures/README-qq-example-1.png index 066f17a..57f4d7d 100644 Binary files a/man/figures/README-qq-example-1.png and b/man/figures/README-qq-example-1.png differ diff --git a/man/figures/README-unnamed-chunk-6-1.png b/man/figures/README-unnamed-chunk-6-1.png index 7b9733b..7f18ac6 100644 Binary files a/man/figures/README-unnamed-chunk-6-1.png and b/man/figures/README-unnamed-chunk-6-1.png differ diff --git a/man/geom_calibration.Rd b/man/geom_calibration.Rd index 30eddc8..c302e3b 100644 --- a/man/geom_calibration.Rd +++ b/man/geom_calibration.Rd @@ -26,8 +26,8 @@ geom_calibration( ) } \arguments{ -\item{mapping}{Aesthetic mapping (must supply \code{estimate} and \code{truth} if not inherited). -\code{estimate} should be propensity scores/predicted probabilities, \code{truth} should be treatment variable.} +\item{mapping}{Aesthetic mapping (must supply \code{.fitted} and \code{.exposure} if not inherited). +\code{.fitted} should be propensity scores/predicted probabilities, \code{.exposure} should be treatment variable.} \item{data}{Data frame or tibble; if NULL, uses ggplot default.} @@ -97,25 +97,25 @@ library(ggplot2) # Basic calibration plot using nhefs_weights dataset # .fitted contains propensity scores, qsmk is the treatment variable -ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + geom_calibration() + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Propensity Score", y = "Observed Treatment Rate") # Using different methods -ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + geom_calibration(method = "logistic") + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Propensity Score", y = "Observed Treatment Rate") # Specify treatment level explicitly -ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + geom_calibration(.focal_level = "1") + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Propensity Score", y = "Observed Treatment Rate") # Windowed method with custom parameters -ggplot(nhefs_weights, aes(estimate = .fitted, truth = qsmk)) + +ggplot(nhefs_weights, aes(.fitted = .fitted, .exposure = qsmk)) + geom_calibration(method = "windowed", window_size = 0.2, step_size = 0.1) + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Propensity Score", y = "Observed Treatment Rate") diff --git a/man/plot_ess.Rd b/man/plot_ess.Rd index 8faf88a..852d5f4 100644 --- a/man/plot_ess.Rd +++ b/man/plot_ess.Rd @@ -7,7 +7,7 @@ plot_ess( .data, .weights = NULL, - .group = NULL, + .exposure = NULL, include_observed = TRUE, n_tiles = 4, tile_labels = NULL, @@ -31,20 +31,20 @@ plot_ess( a character vector, or NULL. Multiple weights can be provided to compare different weighting schemes.} -\item{.group}{Optional grouping variable. When provided, ESS is calculated -separately for each group level. For continuous variables, groups are +\item{.exposure}{Optional exposure variable. When provided, ESS is calculated +separately for each exposure level. For continuous variables, groups are created using quantiles.} \item{include_observed}{Logical. If using \code{.weights}, also calculate observed (unweighted) metrics? Defaults to TRUE.} -\item{n_tiles}{For continuous \code{.group} variables, the number of quantile +\item{n_tiles}{For continuous \code{.exposure} variables, the number of quantile groups to create. Default is 4 (quartiles).} \item{tile_labels}{Optional character vector of labels for the quantile groups -when \code{.group} is continuous. If NULL, uses "Q1", "Q2", etc.} +when \code{.exposure} is continuous. If NULL, uses "Q1", "Q2", etc.} -\item{fill_color}{Color for the bars when \code{.group} is not provided. +\item{fill_color}{Color for the bars when \code{.exposure} is not provided. Default is "#0172B1".} \item{alpha}{Transparency level for the bars. Default is 0.8.} @@ -74,9 +74,9 @@ This function visualizes the output of \code{check_ess()} or computes ESS direct from the provided data. The plot shows how much "effective" sample size remains after weighting, which is a key diagnostic for assessing weight variability. -When \code{.group} is not provided, the function displays overall ESS for each -weighting method. When \code{.group} is provided, ESS is shown separately for each -group level using dodged bars. +When \code{.exposure} is not provided, the function displays overall ESS for each +weighting method. When \code{.exposure} is provided, ESS is shown separately for each +exposure level using dodged bars. For continuous grouping variables, the function automatically creates quantile groups (quartiles by default) to show how ESS varies across the distribution @@ -95,24 +95,24 @@ Lower ESS percentages indicate: plot_ess(nhefs_weights, .weights = c(w_ate, w_att, w_atm)) # ESS by treatment group (binary exposure) -plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) +plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) # ESS by treatment group (categorical exposure) -plot_ess(nhefs_weights, .weights = w_cat_ate, .group = alcoholfreq_cat) +plot_ess(nhefs_weights, .weights = w_cat_ate, .exposure = alcoholfreq_cat) # ESS by age quartiles -plot_ess(nhefs_weights, .weights = w_ate, .group = age) +plot_ess(nhefs_weights, .weights = w_ate, .exposure = age) # Customize quantiles for continuous variable -plot_ess(nhefs_weights, .weights = w_ate, .group = age, +plot_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 5, tile_labels = c("Youngest", "Young", "Middle", "Older", "Oldest")) # Without percentage labels -plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk, +plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk, show_labels = FALSE) # Custom styling -plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk, +plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk, alpha = 0.6, fill_color = "steelblue", reference_line_color = "red") diff --git a/man/plot_mirror_distributions.Rd b/man/plot_mirror_distributions.Rd index 015c5e3..c9df3cf 100644 --- a/man/plot_mirror_distributions.Rd +++ b/man/plot_mirror_distributions.Rd @@ -18,7 +18,8 @@ plot_mirror_distributions( include_unweighted = TRUE, alpha = 0.6, na.rm = FALSE, - .reference_level = 1L + .reference_level = 1L, + facet_scales = "fixed" ) } \arguments{ @@ -59,6 +60,11 @@ distribution? Defaults to TRUE.} \item{.reference_level}{The reference group level for categorical exposures (>2 levels). Can be a string (group level) or numeric (position). Defaults to 1 (first level). Only used when .exposure has more than 2 levels.} + +\item{facet_scales}{Character. Scale specification for facets. Defaults to +"fixed" to match ggplot2's default behavior. Options are +"fixed", "free_x", "free_y", or "free". Use "free_y" to allow different +y-axis scales across panels, which was the previous default behavior.} } \value{ A ggplot2 object. diff --git a/man/plot_model_calibration.Rd b/man/plot_model_calibration.Rd index d0516d3..2904acc 100644 --- a/man/plot_model_calibration.Rd +++ b/man/plot_model_calibration.Rd @@ -13,7 +13,7 @@ plot_model_calibration(x, ...) \method{plot_model_calibration}{data.frame}( x, .fitted, - .group, + .exposure, .focal_level = NULL, method = "breaks", bins = 10, @@ -79,10 +79,10 @@ plot_model_calibration(x, ...) \item{.fitted}{Column name of predicted probabilities (propensity scores). Can be unquoted (e.g., \code{.fitted}) or quoted (e.g., \code{".fitted"}).} -\item{.group}{Column name of treatment/group variable. +\item{.exposure}{Column name of treatment/exposure variable. Can be unquoted (e.g., \code{qsmk}) or quoted (e.g., \code{"qsmk"}).} -\item{.focal_level}{Value indicating which level of \code{.group} represents treatment. +\item{.focal_level}{Value indicating which level of \code{.exposure} represents treatment. If NULL (default), uses the last level for factors or max value for numeric.} \item{method}{Character; calibration method - "breaks", "logistic", or "windowed".} diff --git a/man/plot_qq.Rd b/man/plot_qq.Rd index abe0eb2..6d24bf2 100644 --- a/man/plot_qq.Rd +++ b/man/plot_qq.Rd @@ -11,7 +11,7 @@ plot_qq(.data, ...) \method{plot_qq}{default}( .data, .var, - .group, + .exposure, .weights = NULL, quantiles = seq(0.01, 0.99, 0.01), include_observed = TRUE, @@ -29,7 +29,7 @@ plot_qq(.data, ...) \item{.var}{Variable to plot. Can be unquoted (e.g., \code{age}) or quoted (e.g., \code{"age"}).} -\item{.group}{Column name of treatment/group variable. Can be unquoted (e.g., \code{qsmk}) or quoted (e.g., \code{"qsmk"}).} +\item{.exposure}{Column name of treatment/exposure variable. Can be unquoted (e.g., \code{qsmk}) or quoted (e.g., \code{"qsmk"}).} \item{.weights}{Optional weighting variable(s). Can be unquoted variable names, a character vector, or NULL. Multiple weights can be provided to compare diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg index b856057..c1980ca 100644 --- a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-calibration.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg index d769a35..411b2c8 100644 --- a/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg +++ b/tests/testthat/_snaps/autoplot-methods/autoplot-halfmoon-qq.svg @@ -25,6 +25,7 @@ + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg index 67ff99e..f0d37d2 100644 --- a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-calibration.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg index 11da3b6..1538f3f 100644 --- a/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg +++ b/tests/testthat/_snaps/autoplot-methods/plot-halfmoon-qq.svg @@ -25,6 +25,7 @@ + diff --git a/tests/testthat/_snaps/check_ess.md b/tests/testthat/_snaps/check_ess.md index f1d9446..a3c454e 100644 --- a/tests/testthat/_snaps/check_ess.md +++ b/tests/testthat/_snaps/check_ess.md @@ -12,7 +12,7 @@ expr Condition Error in `check_ess()`: - ! Column `not_a_column` not found in `.group` + ! Column `not_a_column` not found in `.exposure` --- diff --git a/tests/testthat/_snaps/check_model_auc.md b/tests/testthat/_snaps/check_model_auc.md index 0cc2dab..9e40425 100644 --- a/tests/testthat/_snaps/check_model_auc.md +++ b/tests/testthat/_snaps/check_model_auc.md @@ -28,7 +28,7 @@ expr Condition Error in `check_model_roc_curve()`: - ! `.estimate` must be numeric, got + ! `.fitted` must be numeric, got --- @@ -38,7 +38,7 @@ Error in `check_model_roc_curve()`: ! `.exposure` must have exactly 2 levels -# treatment_level parameter works correctly +# .focal_level parameter works correctly Code expr diff --git a/tests/testthat/_snaps/error-messages.md b/tests/testthat/_snaps/error-messages.md index d98ad66..f22fc3b 100644 --- a/tests/testthat/_snaps/error-messages.md +++ b/tests/testthat/_snaps/error-messages.md @@ -38,7 +38,7 @@ plot_qq(nhefs_weights, age, qsmk, .reference_level = "invalid") Condition Error in `plot_qq()`: - ! `.reference_level` 'invalid' not found in `.group` levels: "0" and "1" + ! `.reference_level` 'invalid' not found in `.exposure` levels: "0" and "1" --- diff --git a/tests/testthat/_snaps/geom_mirrored_density/fill-with-theme.svg b/tests/testthat/_snaps/geom_mirrored_density/fill-with-theme.svg index 7017d06..0d1805b 100644 --- a/tests/testthat/_snaps/geom_mirrored_density/fill-with-theme.svg +++ b/tests/testthat/_snaps/geom_mirrored_density/fill-with-theme.svg @@ -18,6 +18,7 @@ + diff --git a/tests/testthat/_snaps/geom_mirrored_histogram/layered-weighted-and-unweighted.svg b/tests/testthat/_snaps/geom_mirrored_histogram/layered-weighted-and-unweighted.svg index 65e2784..9e8e608 100644 --- a/tests/testthat/_snaps/geom_mirrored_histogram/layered-weighted-and-unweighted.svg +++ b/tests/testthat/_snaps/geom_mirrored_histogram/layered-weighted-and-unweighted.svg @@ -27,229 +27,227 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -100 -50 -0 -50 -100 - - - - - - - - - - -0.0 -0.2 -0.4 -0.6 -0.8 +100 +50 +0 +50 +100 + + + + + + + + + +0.2 +0.4 +0.6 +0.8 .fitted count diff --git a/tests/testthat/_snaps/geom_qq2/geom-qq2-basic.svg b/tests/testthat/_snaps/geom_qq2/geom-qq2-basic.svg index b268a9a..303e465 100644 --- a/tests/testthat/_snaps/geom_qq2/geom-qq2-basic.svg +++ b/tests/testthat/_snaps/geom_qq2/geom-qq2-basic.svg @@ -126,7 +126,7 @@ - + diff --git a/tests/testthat/_snaps/geom_qq2/geom-qq2-custom-quantiles.svg b/tests/testthat/_snaps/geom_qq2/geom-qq2-custom-quantiles.svg index 9a766cc..83a2cb1 100644 --- a/tests/testthat/_snaps/geom_qq2/geom-qq2-custom-quantiles.svg +++ b/tests/testthat/_snaps/geom_qq2/geom-qq2-custom-quantiles.svg @@ -32,7 +32,7 @@ - + diff --git a/tests/testthat/_snaps/geom_qq2/geom-qq2-multiple-weights.svg b/tests/testthat/_snaps/geom_qq2/geom-qq2-multiple-weights.svg index 0a42fbb..ff7b6b0 100644 --- a/tests/testthat/_snaps/geom_qq2/geom-qq2-multiple-weights.svg +++ b/tests/testthat/_snaps/geom_qq2/geom-qq2-multiple-weights.svg @@ -225,7 +225,7 @@ - + diff --git a/tests/testthat/_snaps/geom_qq2/geom-qq2-weighted.svg b/tests/testthat/_snaps/geom_qq2/geom-qq2-weighted.svg index 3e05b8c..c27a030 100644 --- a/tests/testthat/_snaps/geom_qq2/geom-qq2-weighted.svg +++ b/tests/testthat/_snaps/geom_qq2/geom-qq2-weighted.svg @@ -126,7 +126,7 @@ - + diff --git a/tests/testthat/_snaps/plot_balance/balance-plot-categorical-ks-only.svg b/tests/testthat/_snaps/plot_balance/balance-plot-categorical-ks-only.svg index 17cf72f..1552ff9 100644 --- a/tests/testthat/_snaps/plot_balance/balance-plot-categorical-ks-only.svg +++ b/tests/testthat/_snaps/plot_balance/balance-plot-categorical-ks-only.svg @@ -21,100 +21,100 @@ - - + + - - - - - - - - - - - + + + + + + + + + + + - - + + - - - - - - - - - - - + + + + + + + + + + + - - + + - - - - - - - - - - - + + + + + + + + + + + - - + + - - - - - - - - - - - + + + + + + + + + + + - - + + - - -daily + + +daily - - + + - - -lt_12_per_year + + +lt_12_per_year @@ -139,73 +139,72 @@ 2_3_per_week - - - -0.08 -0.12 -0.16 - - - - -0.05 -0.10 -0.15 -0.20 - - - -0.1 -0.2 -0.3 - - - - - -0.05 -0.10 -0.15 -0.20 -0.25 -age -smokeintensity -wt71 - - - -age -smokeintensity -wt71 - - - -age -smokeintensity -wt71 - - - -age -smokeintensity -wt71 - - - -balance metric -variable - -method - - - - - - -observed -w_cat_ate + + + +0.08 +0.12 +0.16 + + + + +0.05 +0.10 +0.15 +0.20 + + + +0.1 +0.2 +0.3 + + + + + +0.05 +0.10 +0.15 +0.20 +0.25 +age +smokeintensity +wt71 + + + +age +smokeintensity +wt71 + + + +age +smokeintensity +wt71 + + + +age +smokeintensity +wt71 + + + +balance metric +variable + +method + + + + + + +observed +w_cat_ate balance-plot-categorical-ks-only -smd values shown as absolute values diff --git a/tests/testthat/_snaps/plot_balance/balance-plot-variance-ratio.svg b/tests/testthat/_snaps/plot_balance/balance-plot-variance-ratio.svg index 5bfd222..247402d 100644 --- a/tests/testthat/_snaps/plot_balance/balance-plot-variance-ratio.svg +++ b/tests/testthat/_snaps/plot_balance/balance-plot-variance-ratio.svg @@ -21,62 +21,61 @@ - - + + - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + -age -education1 -education2 -education3 -education4 -education5 - - - - - - - - - - -0.4 -0.8 -1.2 -1.6 -balance metric -variable - -method - - - - - - -observed -w_ate +age +education1 +education2 +education3 +education4 +education5 + + + + + + + + + + +0.4 +0.8 +1.2 +1.6 +balance metric +variable + +method + + + + + + +observed +w_ate balance-plot-variance-ratio -smd values shown as absolute values diff --git a/tests/testthat/_snaps/plot_calibration/plot-calibration-glm-with-rug.svg b/tests/testthat/_snaps/plot_calibration/plot-calibration-glm-with-rug.svg index 3d421d9..e60c598 100644 --- a/tests/testthat/_snaps/plot_calibration/plot-calibration-glm-with-rug.svg +++ b/tests/testthat/_snaps/plot_calibration/plot-calibration-glm-with-rug.svg @@ -21,28 +21,28 @@ - - + + - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + 0.00 @@ -55,26 +55,26 @@ - - - - - -0.00 -0.25 -0.50 -0.75 -1.00 -predicted probability + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +predicted probability observed rate - -.group - - - - -0 -1 + +.exposure + + + + +0 +1 plot_calibration glm with rug diff --git a/tests/testthat/_snaps/plot_calibration/plot-calibration-lm-logistic-with-rug.svg b/tests/testthat/_snaps/plot_calibration/plot-calibration-lm-logistic-with-rug.svg index fc9eac7..1e707b2 100644 --- a/tests/testthat/_snaps/plot_calibration/plot-calibration-lm-logistic-with-rug.svg +++ b/tests/testthat/_snaps/plot_calibration/plot-calibration-lm-logistic-with-rug.svg @@ -21,18 +21,18 @@ - - + + - - - - - - - - + + + + + + + + 0.00 @@ -45,36 +45,36 @@ - - - - - -0.00 -0.25 -0.50 -0.75 -1.00 -predicted probability + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 +predicted probability observed rate - -.group - - - - - - - - - - - -0.00 -0.25 -0.50 -0.75 -1.00 + +.exposure + + + + + + + + + + + +0.00 +0.25 +0.50 +0.75 +1.00 plot_calibration lm logistic with rug diff --git a/tests/testthat/_snaps/plot_mirror_distributions/basic-histogram.svg b/tests/testthat/_snaps/plot_mirror_distributions/basic-histogram.svg index e8c1c4a..afd466c 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/basic-histogram.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/basic-histogram.svg @@ -27,88 +27,81 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -120 -80 -40 -0 -40 - - - - - - - - - - -30 -40 -50 -60 -70 +100 +50 +0 + + + + + + + + +30 +40 +50 +60 +70 age Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-custom-reference.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-custom-reference.svg index 7f6a8d2..775ae48 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-custom-reference.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-custom-reference.svg @@ -18,240 +18,219 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -lt_12_per_year vs daily + + +lt_12_per_year vs daily - - + + - - -none vs daily + + +none vs daily - - + + - - -1_4_per_month vs daily + + +1_4_per_month vs daily - - + + - - -2_3_per_week vs daily + + +2_3_per_week vs daily - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -0.02 -0 -0.02 - - - -0.02 -0 -0.02 -0.04 - - - - -0.02 -0 -0.02 - - - -0.03 -0.02 -0.01 -0 -0.01 -0.02 -0.03 - - - - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +0.02 +0 +0.02 +0.04 + + + + +0.02 +0 +0.02 +0.04 + + + + age Density diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-density.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-density.svg index 25916d5..b29f525 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-density.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-density.svg @@ -18,219 +18,203 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -daily vs none + + +daily vs none - - + + - - -lt_12_per_year vs none + + +lt_12_per_year vs none - - + + - - -1_4_per_month vs none + + +1_4_per_month vs none - - + + - - -2_3_per_week vs none + + +2_3_per_week vs none - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -0.04 -0.02 -0 -0.02 - - - - -0.04 -0.02 -0 -0.02 - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 0.04 0.02 0 @@ -239,14 +223,14 @@ -0.04 -0.02 -0 -0.02 - - - - +0.04 +0.02 +0 +0.02 + + + + age Density diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-histogram.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-histogram.svg index add9aef..d6d9cb6 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-histogram.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-exposure-histogram.svg @@ -18,409 +18,375 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -daily vs none + + +daily vs none - - + + - - -lt_12_per_year vs none + + +lt_12_per_year vs none - - + + - - -1_4_per_month vs none + + +1_4_per_month vs none - - + + - - -2_3_per_week vs none + + +2_3_per_week vs none - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -30 -20 -10 -0 -10 -20 - - - - - - -30 -20 -10 -0 -10 -20 -30 - - - - - - - -25 -0 -25 -50 - - - - -30 -20 -10 -0 -10 -20 -30 - - - - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +20 +0 +20 +40 +60 + + + + + +20 +0 +20 +40 +60 + + + + + age Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-fixed-scales.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-fixed-scales.svg new file mode 100644 index 0000000..b73b30d --- /dev/null +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-fixed-scales.svg @@ -0,0 +1,255 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +daily vs none + + + + + + + + + + +lt_12_per_year vs none + + + + + + + + + + +1_4_per_month vs none + + + + + + + + + + +2_3_per_week vs none + + + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + +age +Density + +alcoholfreq_cat + + + + + + + + + + +none +lt_12_per_year +1_4_per_month +2_3_per_week +daily +categorical fixed scales + + diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-free-y-scales.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-free-y-scales.svg new file mode 100644 index 0000000..479c6d9 --- /dev/null +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-free-y-scales.svg @@ -0,0 +1,271 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +daily vs none + + + + + + + + + + +lt_12_per_year vs none + + + + + + + + + + +1_4_per_month vs none + + + + + + + + + + +2_3_per_week vs none + + + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + +age +Density + +alcoholfreq_cat + + + + + + + + + + +none +lt_12_per_year +1_4_per_month +2_3_per_week +daily +categorical free_y scales + + diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-multiple-weights.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-multiple-weights.svg index d3e0bb8..dc9705b 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-multiple-weights.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-multiple-weights.svg @@ -60,29 +60,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -93,29 +93,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -126,29 +126,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -192,29 +192,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -225,29 +225,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -258,29 +258,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -324,29 +324,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -357,29 +357,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -390,29 +390,29 @@ - - - - + + + + - - - - + + + + - - - - + + + + @@ -530,30 +530,30 @@ -0.04 -0.02 -0 -0.02 - - - - -0.04 -0.02 -0 -0.02 - - - - -0.04 -0.02 -0 -0.02 - - - - +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + +0.04 +0.02 +0 +0.02 + + + + age Density diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-no-unweighted.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-no-unweighted.svg index 868b0c7..99b8a2c 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-no-unweighted.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-no-unweighted.svg @@ -27,33 +27,33 @@ - - - - - - + + + + + + - - - - - - + + + + + + - - - - + + + + @@ -101,32 +101,33 @@ - - - - - - + + + + + + - - - - - + + + + + + - - - - + + + + @@ -137,33 +138,33 @@ - - - - - - + + + + + + - - - - - - + + + + + + - - - - + + + + @@ -231,18 +232,18 @@ 50 60 70 -0.02 -0.01 -0 -0.01 -0.02 -0.03 - - - - - - +0.02 +0.01 +0 +0.01 +0.02 +0.03 + + + + + + 0.02 0.01 0 @@ -255,28 +256,30 @@ -0.02 -0.01 -0 -0.01 -0.02 - - - - - -0.02 -0.01 -0 -0.01 -0.02 -0.03 - - - - - - +0.02 +0.01 +0 +0.01 +0.02 +0.03 + + + + + + +0.02 +0.01 +0 +0.01 +0.02 +0.03 + + + + + + age Density diff --git a/tests/testthat/_snaps/plot_mirror_distributions/categorical-with-weights.svg b/tests/testthat/_snaps/plot_mirror_distributions/categorical-with-weights.svg index 441a80d..b569a82 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/categorical-with-weights.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/categorical-with-weights.svg @@ -27,65 +27,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -96,60 +97,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -160,66 +167,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -230,65 +237,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -299,65 +307,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -368,60 +377,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -432,66 +447,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -502,65 +517,66 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -629,66 +645,70 @@ lt_12_per_year vs none - - - - -40 -80 -120 -160 - - - - -40 -80 -120 -160 -300 -200 -100 -0 -100 -200 - - - - - - -200 -0 -200 - - - -300 -200 -100 -0 -100 -200 -300 - - - - - - - -300 -200 -100 -0 -100 -200 - - - - - - + + + + +60 +90 +120 +150 + + + + +60 +90 +120 +150 +200 +100 +0 +100 +200 +300 + + + + + + +200 +100 +0 +100 +200 +300 + + + + + + +200 +100 +0 +100 +200 +300 + + + + + + +200 +100 +0 +100 +200 +300 + + + + + + wt71 Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/custom-aesthetics.svg b/tests/testthat/_snaps/plot_mirror_distributions/custom-aesthetics.svg index f8dfd8c..4bffbbd 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/custom-aesthetics.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/custom-aesthetics.svg @@ -27,88 +27,81 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -120 -80 -40 -0 -40 - - - - - - - - - - -30 -40 -50 -60 -70 +100 +50 +0 + + + + + + + + +30 +40 +50 +60 +70 age Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/fixed-facet-scales-default.svg b/tests/testthat/_snaps/plot_mirror_distributions/fixed-facet-scales-default.svg new file mode 100644 index 0000000..8a68ed7 --- /dev/null +++ b/tests/testthat/_snaps/plot_mirror_distributions/fixed-facet-scales-default.svg @@ -0,0 +1,218 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +observed + + + + + + + + + + +w_ate + + + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +100 +0 +100 + + + +age +Count + +qsmk + + + + +0 +1 +fixed facet scales default + + diff --git a/tests/testthat/_snaps/plot_mirror_distributions/free-facet-scales.svg b/tests/testthat/_snaps/plot_mirror_distributions/free-facet-scales.svg new file mode 100644 index 0000000..5b25681 --- /dev/null +++ b/tests/testthat/_snaps/plot_mirror_distributions/free-facet-scales.svg @@ -0,0 +1,321 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +observed + + + + + + + + + + +w_ate + + + + + + + + + + +w_att + + + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +40 +20 +0 +20 + + + + +100 +0 +100 + + + +100 +50 +0 + + + +age +Count + +qsmk + + + + +0 +1 +free facet scales + + diff --git a/tests/testthat/_snaps/plot_mirror_distributions/free-y-facet-scales.svg b/tests/testthat/_snaps/plot_mirror_distributions/free-y-facet-scales.svg new file mode 100644 index 0000000..0882703 --- /dev/null +++ b/tests/testthat/_snaps/plot_mirror_distributions/free-y-facet-scales.svg @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +observed + + + + + + + + + + +w_ate + + + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +100 +0 +100 + + + +100 +50 +0 + + + +age +Count + +qsmk + + + + +0 +1 +free_y facet scales + + diff --git a/tests/testthat/_snaps/plot_mirror_distributions/mirror-x-axis.svg b/tests/testthat/_snaps/plot_mirror_distributions/mirror-x-axis.svg index aeaed2a..65dfe05 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/mirror-x-axis.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/mirror-x-axis.svg @@ -27,88 +27,81 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -30 -40 -50 -60 -70 - - - - - - - - - - -120 -80 -40 -0 -40 +30 +40 +50 +60 +70 + + + + + + + + +100 +50 +0 Count age diff --git a/tests/testthat/_snaps/plot_mirror_distributions/multiple-weights.svg b/tests/testthat/_snaps/plot_mirror_distributions/multiple-weights.svg index cdf850d..47a5574 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/multiple-weights.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/multiple-weights.svg @@ -21,295 +21,277 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -observed + + +observed - - + + - - -w_ate + + +w_ate - - + + - - -w_att + + +w_att - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -25 -0 -25 - - - -100 -0 -100 - - - -120 -80 -40 -0 -40 - - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +100 +0 +100 + + + age Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/no-unweighted.svg b/tests/testthat/_snaps/plot_mirror_distributions/no-unweighted.svg index 4731bdc..257cde3 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/no-unweighted.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/no-unweighted.svg @@ -27,64 +27,64 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -98,22 +98,22 @@ w_ate - - - - - -30 -40 -50 -60 -70 -100 -0 -100 - - - + + + + + +30 +40 +50 +60 +70 +100 +0 +100 + + + age Count diff --git a/tests/testthat/_snaps/plot_mirror_distributions/weighted-density.svg b/tests/testthat/_snaps/plot_mirror_distributions/weighted-density.svg index 52bab1f..114f288 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/weighted-density.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/weighted-density.svg @@ -18,139 +18,125 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -observed + + +observed - - + + - - -w_ate + + +w_ate - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -0.03 -0.02 -0.01 -0 -0.01 -0.02 -0.03 - - - - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 0.03 0.02 0.01 diff --git a/tests/testthat/_snaps/plot_mirror_distributions/weighted-histogram-default.svg b/tests/testthat/_snaps/plot_mirror_distributions/weighted-histogram-default.svg index 43b493f..b2b6156 100644 --- a/tests/testthat/_snaps/plot_mirror_distributions/weighted-histogram-default.svg +++ b/tests/testthat/_snaps/plot_mirror_distributions/weighted-histogram-default.svg @@ -21,200 +21,188 @@ - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + - - -observed + + +observed - - + + - - -w_ate + + +w_ate - - - - - -30 -40 -50 -60 -70 - - - - - -30 -40 -50 -60 -70 -100 -0 -100 - - - -120 -80 -40 -0 -40 - - - - - + + + + + +30 +40 +50 +60 +70 + + + + + +30 +40 +50 +60 +70 +100 +0 +100 + + + age Count diff --git a/tests/testthat/_snaps/plot_qq.md b/tests/testthat/_snaps/plot_qq.md index a47eca8..39b49c1 100644 --- a/tests/testthat/_snaps/plot_qq.md +++ b/tests/testthat/_snaps/plot_qq.md @@ -12,7 +12,7 @@ expr Condition Error in `plot_qq()`: - ! Argument `.group` is required + ! Argument `.exposure` is required # plot_qq errors with missing columns diff --git a/tests/testthat/_snaps/plot_qq/basic-qq-plot.svg b/tests/testthat/_snaps/plot_qq/basic-qq-plot.svg index f1fbf76..6f82717 100644 --- a/tests/testthat/_snaps/plot_qq/basic-qq-plot.svg +++ b/tests/testthat/_snaps/plot_qq/basic-qq-plot.svg @@ -126,7 +126,7 @@ - + diff --git a/tests/testthat/_snaps/plot_qq/qq-plot-multiple-weights.svg b/tests/testthat/_snaps/plot_qq/qq-plot-multiple-weights.svg index 7dc3405..09b1415 100644 --- a/tests/testthat/_snaps/plot_qq/qq-plot-multiple-weights.svg +++ b/tests/testthat/_snaps/plot_qq/qq-plot-multiple-weights.svg @@ -324,7 +324,7 @@ - + diff --git a/tests/testthat/_snaps/plot_qq/qq-plot-no-observed.svg b/tests/testthat/_snaps/plot_qq/qq-plot-no-observed.svg index f86cdc5..ddab31f 100644 --- a/tests/testthat/_snaps/plot_qq/qq-plot-no-observed.svg +++ b/tests/testthat/_snaps/plot_qq/qq-plot-no-observed.svg @@ -126,7 +126,7 @@ - + diff --git a/tests/testthat/_snaps/plot_qq/qq-plot-propensity-score.svg b/tests/testthat/_snaps/plot_qq/qq-plot-propensity-score.svg index f462ce8..387298a 100644 --- a/tests/testthat/_snaps/plot_qq/qq-plot-propensity-score.svg +++ b/tests/testthat/_snaps/plot_qq/qq-plot-propensity-score.svg @@ -225,7 +225,7 @@ - + diff --git a/tests/testthat/_snaps/plot_qq/qq-plot-with-weight.svg b/tests/testthat/_snaps/plot_qq/qq-plot-with-weight.svg index b0b547c..ae9a860 100644 --- a/tests/testthat/_snaps/plot_qq/qq-plot-with-weight.svg +++ b/tests/testthat/_snaps/plot_qq/qq-plot-with-weight.svg @@ -225,7 +225,7 @@ - + diff --git a/tests/testthat/test-bal_qq.R b/tests/testthat/test-bal_qq.R index 6d083fa..614282a 100644 --- a/tests/testthat/test-bal_qq.R +++ b/tests/testthat/test-bal_qq.R @@ -96,7 +96,7 @@ test_that("bal_qq works with different treatment levels", { quantiles = c(0.25, 0.5, 0.75) ) - # Default should match explicit treatment_level = 1 + # Default should match explicit .focal_level = 1 expect_equal(qq_default$exposed_quantiles, qq_1$exposed_quantiles) expect_equal(qq_default$unexposed_quantiles, qq_1$unexposed_quantiles) @@ -121,7 +121,7 @@ test_that("bal_qq works with different treatment levels", { }) test_that("bal_qq matches single method from check_qq", { - # Test with default treatment_level (should use last/max level) + # Test with default .focal_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, diff --git a/tests/testthat/test-check_balance_interactions.R b/tests/testthat/test-check_balance_interactions.R new file mode 100644 index 0000000..1f8e69a --- /dev/null +++ b/tests/testthat/test-check_balance_interactions.R @@ -0,0 +1,153 @@ +test_that("check_balance does not create interactions between levels of same variable", { + # Create test data with various factor types + test_data <- data.frame( + # Binary factors with text levels + sex = factor(c(rep("male", 50), rep("female", 50))), + race = factor(c(rep("white", 40), rep("black", 60))), + employment = factor(c(rep("employed", 45), rep("unemployed", 55))), + # Binary factor with numeric-like levels + treatment = factor(c(rep("0", 50), rep("1", 50))), + # Continuous variable + age = rnorm(100, 50, 10), + # Multi-level factor + education = factor(sample(c("high", "medium", "low"), 100, replace = TRUE)), + # Outcome + outcome = c(rep(0, 50), rep(1, 50)) + ) + + # Run check_balance with interactions + result <- check_balance( + test_data, + c(sex, race, employment, age, education), + outcome, + interactions = TRUE, + .metrics = "smd" + ) + + # Get all interaction variables + interaction_vars <- unique(result$variable)[grepl( + "_x_", + unique(result$variable) + )] + + # Check that no self-interactions exist + + # Sex should not interact with itself + sex_self <- interaction_vars[grepl("sex.*_x_sex", interaction_vars)] + expect_length(sex_self, 0) + + # Race should not interact with itself + race_self <- interaction_vars[grepl("race.*_x_race", interaction_vars)] + expect_length(race_self, 0) + + # Employment should not interact with itself + employment_self <- interaction_vars[grepl( + "employ.*_x_employ", + interaction_vars + )] + expect_length(employment_self, 0) + + # Education (multi-level) should not interact with itself + education_self <- interaction_vars[grepl( + "education.*_x_education", + interaction_vars + )] + expect_length(education_self, 0) + + # But different variables should interact + expect_true(any(grepl("age_x_sex", interaction_vars))) + expect_true(any(grepl("age_x_race", interaction_vars))) + expect_true(any(grepl("sex.*_x_race", interaction_vars))) + expect_true(any(grepl("age_x_education", interaction_vars))) +}) + +test_that("is_valid_interaction_combo works with mapping", { + # Direct test of the helper function + # Note: This requires access to the internal function + check_combo <- halfmoon:::is_valid_interaction_combo + + # Test with mapping (the primary approach) + mapping <- list( + sex0 = "sex", + sex1 = "sex", + sexmale = "sex", + sexfemale = "sex", + race0 = "race", + race1 = "race", + racewhite = "race", + raceblack = "race", + employedemployed = "employed", + employedunemployed = "employed", + marriedmarried = "married", + marriedsingle = "married", + sex_male = "sex", + sex_female = "sex", + race_white = "race", + race_black = "race", + age = "age", + educationhigh = "education", + var0 = "var0", + var1 = "var1" + ) + + # Same variable - should return FALSE with mapping + expect_false(check_combo(c("sex0", "sex1"), mapping)) + expect_false(check_combo(c("race0", "race1"), mapping)) + expect_false(check_combo(c("sexmale", "sexfemale"), mapping)) + expect_false(check_combo(c("racewhite", "raceblack"), mapping)) + expect_false(check_combo( + c("employedemployed", "employedunemployed"), + mapping + )) + expect_false(check_combo(c("marriedmarried", "marriedsingle"), mapping)) + expect_false(check_combo(c("sex_male", "sex_female"), mapping)) + expect_false(check_combo(c("race_white", "race_black"), mapping)) + + # Different variables - should return TRUE with mapping + expect_true(check_combo(c("var0", "var1"), mapping)) + expect_true(check_combo(c("age", "sex0"), mapping)) + expect_true(check_combo(c("sexmale", "racewhite"), mapping)) + expect_true(check_combo(c("age", "educationhigh"), mapping)) + expect_true(check_combo(c("sex0", "race1"), mapping)) + expect_true(check_combo(c("employedemployed", "sexmale"), mapping)) + + # Test fallback to regex when no mapping provided + # The regex approach is less sophisticated and only handles numeric suffixes + expect_false(check_combo(c("sex0", "sex1"), NULL)) + expect_false(check_combo(c("race0", "race1"), NULL)) +}) + +test_that("interaction creation handles edge cases correctly", { + # Test with variables that might confuse the pattern matching + tricky_data <- data.frame( + # Variable names that contain suffixes within them + female_headed = factor(c(rep("yes", 50), rep("no", 50))), + male_presence = factor(c(rep("present", 60), rep("absent", 40))), + # Variable that ends with a number + var1 = rnorm(100), + var2 = rnorm(100), + # Outcome + y = rbinom(100, 1, 0.5) + ) + + result <- check_balance( + tricky_data, + c(female_headed, male_presence, var1, var2), + y, + interactions = TRUE, + .metrics = "smd" + ) + + interaction_vars <- unique(result$variable)[grepl( + "_x_", + unique(result$variable) + )] + + # These should create interactions because they're different variables + expect_true(any(grepl("female_headed.*_x_male_presence", interaction_vars))) + expect_true(any(grepl("var1_x_var2", interaction_vars))) + + # But not self-interactions + expect_false(any(grepl("female_headed.*_x_female_headed", interaction_vars))) + expect_false(any(grepl("male_presence.*_x_male_presence", interaction_vars))) +}) diff --git a/tests/testthat/test-check_ess.R b/tests/testthat/test-check_ess.R index 215000c..f79f723 100644 --- a/tests/testthat/test-check_ess.R +++ b/tests/testthat/test-check_ess.R @@ -35,7 +35,7 @@ test_that("check_ess works without observed", { }) test_that("check_ess works with binary groups", { - result <- check_ess(nhefs_weights, .weights = w_ate, .group = qsmk) + result <- check_ess(nhefs_weights, .weights = w_ate, .exposure = qsmk) expect_s3_class(result, "tbl_df") expect_true("group" %in% names(result)) @@ -47,7 +47,7 @@ test_that("check_ess works with categorical groups", { result <- check_ess( nhefs_weights, .weights = w_cat_ate, - .group = alcoholfreq_cat + .exposure = alcoholfreq_cat ) expect_s3_class(result, "tbl_df") @@ -59,7 +59,7 @@ test_that("check_ess works with continuous groups", { result <- check_ess( nhefs_weights, .weights = w_ate, - .group = age, + .exposure = age, n_tiles = 4 ) @@ -74,7 +74,7 @@ test_that("check_ess works with custom tile labels", { result <- check_ess( nhefs_weights, .weights = w_ate, - .group = age, + .exposure = age, n_tiles = 3, tile_labels = labels ) @@ -109,7 +109,7 @@ test_that("check_ess validates inputs", { ) expect_halfmoon_error( - check_ess(nhefs_weights, .group = "not_a_column"), + check_ess(nhefs_weights, .exposure = "not_a_column"), "halfmoon_column_error" ) @@ -117,7 +117,7 @@ test_that("check_ess validates inputs", { check_ess( nhefs_weights, .weights = w_ate, - .group = age, + .exposure = age, n_tiles = 3, tile_labels = c("Too", "Few") ), diff --git a/tests/testthat/test-check_model_auc.R b/tests/testthat/test-check_model_auc.R index 62049dc..a7a92d8 100644 --- a/tests/testthat/test-check_model_auc.R +++ b/tests/testthat/test-check_model_auc.R @@ -307,7 +307,7 @@ test_that("weighted ROC/AUC integrates with check_balance patterns", { expect_true(all(c("method", "auc") %in% colnames(balance_roc))) }) -test_that("treatment_level parameter works correctly", { +test_that(".focal_level parameter works correctly", { # Test with default (second level) roc_default <- check_model_roc_curve( nhefs_weights, @@ -328,7 +328,7 @@ test_that("treatment_level parameter works correctly", { # Should be identical expect_equal(roc_default, roc_explicit) - # Test with treatment_level = "0" (opposite) + # Test with .focal_level = "0" (opposite) roc_opposite <- check_model_roc_curve( nhefs_weights, qsmk, @@ -340,7 +340,7 @@ test_that("treatment_level parameter works correctly", { # ROC curves should be different expect_false(identical(roc_default, roc_opposite)) - # Test with invalid treatment_level + # Test with invalid .focal_level expect_halfmoon_error( check_model_roc_curve( nhefs_weights, diff --git a/tests/testthat/test-geom_calibration.R b/tests/testthat/test-geom_calibration.R index 69d6114..cb42260 100644 --- a/tests/testthat/test-geom_calibration.R +++ b/tests/testthat/test-geom_calibration.R @@ -468,14 +468,14 @@ test_that("check_model_calibration handles edge cases with all methods", { 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 + # All zeros - when .focal_level is not specified, 0 becomes the treatment level # so observed_rate will be 1 (all observations match treatment level) zeros_data <- data.frame( pred = runif(50, 0, 1), obs = rep(0, 50) ) - # When all observations are 0, default treatment_level will be 0 + # When all observations are 0, default .focal_level will be 0 # Test the actual behavior result_breaks_zeros_default <- suppress_calibration_warnings(check_model_calibration( zeros_data, @@ -483,7 +483,7 @@ test_that("check_model_calibration handles all zeros and all ones", { obs, method = "breaks" )) - # All values are 0 and treatment_level=0, so observed_rate=1 + # All values are 0 and .focal_level=0, so observed_rate=1 expect_true(all(result_breaks_zeros_default$observed_rate == 1)) # Now test with mixed data where 1 is the treatment level @@ -533,7 +533,7 @@ test_that("check_model_calibration handles all zeros and all ones", { obs, method = "breaks" )) - # With default treatment_level, all zeros means treatment_level=0, so observed_rate=1 + # With default .focal_level, all zeros means .focal_level=0, so observed_rate=1 expect_true(all(result_default_zeros$observed_rate == 1)) }) @@ -817,7 +817,7 @@ test_that("geom_calibration works with breaks method", { ) # Test breaks method - p_breaks <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_breaks <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "breaks", bins = 5) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + @@ -840,7 +840,7 @@ test_that("geom_calibration works with logistic method", { ) # Test logistic method (linear) - p_logistic <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_logistic <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "logistic", smooth = FALSE, show_points = FALSE) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + @@ -863,7 +863,7 @@ test_that("geom_calibration works with windowed method", { ) # Test windowed method - p_windowed <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_windowed <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "windowed", window_size = 0.2, step_size = 0.1) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + @@ -886,13 +886,13 @@ test_that("geom_calibration works with different show options", { ) # Test with ribbon hidden - p_no_ribbon <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_no_ribbon <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "breaks", show_ribbon = FALSE) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + lims(x = c(0, 1), y = c(0, 1)) # Test with points hidden - p_no_points <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_no_points <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "breaks", show_points = FALSE) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + lims(x = c(0, 1), y = c(0, 1)) @@ -916,7 +916,7 @@ test_that("geom_calibration handles different confidence levels", { ) # Test with 90% confidence level - p_90 <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_90 <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "breaks", conf_level = 0.90) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + lims(x = c(0, 1), y = c(0, 1)) @@ -932,7 +932,10 @@ test_that("geom_calibration works with nhefs_weights data", { cal_data <- nhefs_weights cal_data$binary_outcome <- rbinom(nrow(cal_data), 1, cal_data$.fitted) - p_nhefs <- ggplot(cal_data, aes(estimate = .fitted, truth = binary_outcome)) + + p_nhefs <- ggplot( + cal_data, + aes(.fitted = .fitted, .exposure = binary_outcome) + ) + geom_calibration(method = "breaks", bins = 8) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(x = "Propensity Score", y = "Observed Rate") + @@ -952,13 +955,13 @@ test_that("geom_calibration works with both numeric and factor outcomes", { test_data$obs_factor <- factor(test_data$obs_numeric, levels = c(0, 1)) # Test with numeric outcome - p_numeric <- ggplot(test_data, aes(estimate = pred, truth = obs_numeric)) + + p_numeric <- ggplot(test_data, aes(.fitted = pred, .exposure = obs_numeric)) + geom_calibration(method = "breaks", bins = 5) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(title = "Calibration with numeric outcome") # Test with factor outcome - p_factor <- ggplot(test_data, aes(estimate = pred, truth = obs_factor)) + + p_factor <- ggplot(test_data, aes(.fitted = pred, .exposure = obs_factor)) + geom_calibration(method = "breaks", bins = 5) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(title = "Calibration with factor outcome") @@ -988,7 +991,7 @@ test_that("geom_calibration errors with invalid method", { ) # Test with invalid method - error occurs during rendering - p <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "invalid_method") # We expect a warning with the halfmoon_method_warning class @@ -1037,7 +1040,7 @@ test_that("geom_calibration logistic method works with smooth = TRUE", { ) # Test logistic method with smooth = TRUE (should work regardless of mgcv availability) - p_smooth <- ggplot(cal_data, aes(estimate = pred, truth = obs)) + + p_smooth <- ggplot(cal_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "logistic", smooth = TRUE, show_points = FALSE) + geom_abline(slope = 1, intercept = 0, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + @@ -1214,19 +1217,19 @@ test_that("k parameter works in geom_calibration", { ) # Create plots with different k values - p_k5 <- ggplot(test_data, aes(estimate = pred, truth = obs)) + + p_k5 <- ggplot(test_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "logistic", smooth = TRUE, k = 5) + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + lims(x = c(0, 1), y = c(0, 1)) - p_k10 <- ggplot(test_data, aes(estimate = pred, truth = obs)) + + p_k10 <- ggplot(test_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "logistic", smooth = TRUE, k = 10) + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + lims(x = c(0, 1), y = c(0, 1)) - p_k20 <- ggplot(test_data, aes(estimate = pred, truth = obs)) + + p_k20 <- ggplot(test_data, aes(.fitted = pred, .exposure = obs)) + geom_calibration(method = "logistic", smooth = TRUE, k = 20) + geom_abline(intercept = 0, slope = 1, linetype = "dashed") + labs(x = "Predicted Probability", y = "Observed Rate") + diff --git a/tests/testthat/test-plot_calibration.R b/tests/testthat/test-plot_calibration.R index a16c111..55b7bd1 100644 --- a/tests/testthat/test-plot_calibration.R +++ b/tests/testthat/test-plot_calibration.R @@ -48,13 +48,13 @@ test_that("plot_model_calibration works with different methods", { expect_s3_class(p_windowed, "ggplot") }) -test_that("plot_model_calibration works with treatment level specification", { - # Test with explicit treatment level +test_that("plot_model_calibration works with focal level specification", { + # Test with explicit focal level p <- plot_model_calibration( nhefs_weights, .fitted, qsmk, - treatment_level = "1" + .focal_level = "1" ) expect_s3_class(p, "ggplot") @@ -205,8 +205,8 @@ test_that("plot_model_calibration works with glm objects", { p_rug <- plot_model_calibration(ps_model, include_rug = TRUE) expect_s3_class(p_rug, "ggplot") - # Test with treatment level - p_treatment <- plot_model_calibration(ps_model, treatment_level = 1) + # Test with focal level + p_treatment <- plot_model_calibration(ps_model, .focal_level = 1) expect_s3_class(p_treatment, "ggplot") }) @@ -280,12 +280,12 @@ test_that("plot_model_calibration visual snapshot tests", { ) expect_doppelganger("plot_calibration windowed", p4) - # With explicit treatment level + # With explicit focal level p5 <- plot_model_calibration( nhefs_weights, .fitted, qsmk, - treatment_level = "1" + .focal_level = "1" ) expect_doppelganger("plot_calibration explicit treatment", p5) diff --git a/tests/testthat/test-plot_ess.R b/tests/testthat/test-plot_ess.R index af98ee2..397320c 100644 --- a/tests/testthat/test-plot_ess.R +++ b/tests/testthat/test-plot_ess.R @@ -32,7 +32,7 @@ test_that("plot_ess works without groups", { }) test_that("plot_ess works with groups", { - p <- plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) + p <- plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) # Should have fill aesthetic for groups expect_true("fill" %in% names(p$mapping)) @@ -88,7 +88,7 @@ test_that("plot_ess y-axis uses percent scale", { }) test_that("plot_ess handles continuous groups", { - p <- plot_ess(nhefs_weights, .weights = w_ate, .group = age, n_tiles = 4) + p <- plot_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 4) expect_s3_class(p, "ggplot") expect_true("fill" %in% names(p$mapping)) @@ -154,7 +154,7 @@ test_that("plot_ess snapshot tests", { # Plot with groups expect_doppelganger( "plot_ess_groups", - plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .group = qsmk) + plot_ess(nhefs_weights, .weights = c(w_ate, w_att), .exposure = qsmk) ) # Plot without labels @@ -166,6 +166,6 @@ test_that("plot_ess snapshot tests", { # Plot with continuous groups expect_doppelganger( "plot_ess_continuous", - plot_ess(nhefs_weights, .weights = w_ate, .group = age, n_tiles = 3) + plot_ess(nhefs_weights, .weights = w_ate, .exposure = age, n_tiles = 3) ) }) diff --git a/tests/testthat/test-plot_mirror_distributions.R b/tests/testthat/test-plot_mirror_distributions.R index 3d82170..29d0627 100644 --- a/tests/testthat/test-plot_mirror_distributions.R +++ b/tests/testthat/test-plot_mirror_distributions.R @@ -224,8 +224,10 @@ test_that("plot_mirror_distributions produces correct plot structure", { expect_length(built$data, 1) # Check that y-axis uses absolute values - y_labels <- built$layout$panel_params[[1]]$y$get_labels() - expect_true(all(as.numeric(y_labels) >= 0)) + y_labels <- built$layout$panel_params[[1]]$y$get_labels() |> + stats::na.omit() |> + as.numeric() + expect_true(all(y_labels >= 0)) }) test_that("plot_mirror_distributions works with faceting", { @@ -340,3 +342,62 @@ test_that("plot_mirror_distributions validates categorical reference group", { "halfmoon_range_error" ) }) + +test_that("plot_mirror_distributions respects facet_scales parameter", { + # Test default fixed scales + p_fixed <- plot_mirror_distributions( + nhefs_weights, + age, + qsmk, + .weights = w_ate, + bins = 20 + ) + + expect_s3_class(p_fixed, "ggplot") + expect_doppelganger("fixed facet scales default", p_fixed) + + # Test free_y scales (previous default behavior) + p_free_y <- plot_mirror_distributions( + nhefs_weights, + age, + qsmk, + .weights = w_ate, + facet_scales = "free_y", + bins = 20 + ) + + expect_doppelganger("free_y facet scales", p_free_y) + + # Test with categorical exposure + p_cat_fixed <- plot_mirror_distributions( + nhefs_weights, + age, + alcoholfreq_cat, + type = "density" + ) + + expect_doppelganger("categorical fixed scales", p_cat_fixed) + + # Test categorical with free_y + p_cat_free <- plot_mirror_distributions( + nhefs_weights, + age, + alcoholfreq_cat, + type = "density", + facet_scales = "free_y" + ) + + expect_doppelganger("categorical free_y scales", p_cat_free) + + # Test other scale options + p_free <- plot_mirror_distributions( + nhefs_weights, + age, + qsmk, + .weights = c(w_ate, w_att), + facet_scales = "free", + bins = 20 + ) + + expect_doppelganger("free facet scales", p_free) +}) diff --git a/tests/testthat/test-plot_qq.R b/tests/testthat/test-plot_qq.R index 7523dd7..bcdd897 100644 --- a/tests/testthat/test-plot_qq.R +++ b/tests/testthat/test-plot_qq.R @@ -3,7 +3,7 @@ test_that("plot_qq creates basic QQ plot", { expect_s3_class(p, "ggplot") expect_equal(length(p$layers), 2) # points + abline - # With NULL treatment_level, uses last level (1) as reference + # With NULL .focal_level, uses last level (1) as reference expect_equal(p$labels$x, "age (qsmk = 1)") expect_equal(p$labels$y, "age (qsmk = 0)") }) diff --git a/tests/testthat/test-plot_roc.R b/tests/testthat/test-plot_roc.R index 5afa0e5..e3dce4b 100644 --- a/tests/testthat/test-plot_roc.R +++ b/tests/testthat/test-plot_roc.R @@ -170,9 +170,6 @@ test_that("plot functions produce expected output structure", { expect_equal(p_auc$labels$x, "auc") expect_equal(p_auc$labels$y, "method") - - # Check coordinate system for ROC plot - expect_s3_class(p_roc$coordinates, "CoordFixed") }) # vdiffr tests