R/diagnostics.R

In WMAP: Weighted Meta-Analysis with Pseudo-Populations

# ======================================================================================
# WMAP PACKAGE - DIAGNOSTIC CHECKS
# ======================================================================================

# This file contains diagnostic functions for checking weight quality:
# - fn.check_ess: Warns when effective sample size is too low
# - fn.check_extreme_weights: Warns when weights are excessively large
# - fn.check_positivity: Warns when positivity assumption may be violated
# - fn.run_diagnostics: Wrapper that runs all three checks

# ======================================================================================
# VERSION HISTORY
# ======================================================================================

# Version 1.3 - New file to implement diagnostic checks

# ======================================================================================

# Thresholds for diagnostic warnings
DIAG_ESS_THRESHOLD <- 5
DIAG_WEIGHT_RATIO <- 20
DIAG_PROPENSITY_MIN <- 0.05 # fraction below truncation floor

#' Check for low effective sample size
#' 
#' Warns if the percentage ESS falls below a threshold, indicating that the
#' psuedo-population weights may be unreliable.
#' 
#' @param percentESS Percentage ESS value (0-100)
#' @param threshold Minimum acceptable percentage ESS (default: 5)
#' @return Invisibly returns TRUE if warning issued, FALSE otherwise
#' @keywords internal
fn.check_ess <- function(percentESS, threshold = DIAG_ESS_THRESHOLD) {

    if (percentESS < threshold) {
        warning(
            sprintf(
                "Low effective sample size: %.1f%% (threshold: %d%%).",
                percentESS, threshold
            ),
            call. = FALSE
        )
        return(invisible(TRUE))
    }
    return(invisible(FALSE))
}

#' Check for extreme weights
#' 
#' Warns if any weights are excessively large relative to the mean,
#' which can indicate positivity violations or model misspecification.
#' 
#' @param wt.v Vector of normalized weights
#' @param ratio_threshold Maximum acceptable max/mean weight ratio (default: 20)
#' @return Invisibly returns TRUE if warning issued, FALSE otherwise
#' @keywords internal
fn.check_extreme_weights <- function(wt.v, ratio_threshold = DIAG_WEIGHT_RATIO) {

    weight_ratio <- max(wt.v) / mean(wt.v)

    if (weight_ratio > ratio_threshold) {
        warning(
            sprintf(
                "Extreme weights: max/mean ratio = %.1f (threshold: %d).",
                weight_ratio, ratio_threshold
            ),
            call. = FALSE
        )
        return(invisible(TRUE))
    }
    return(invisible(FALSE))
}

#' Check for positivity violations
#' 
#' Warns if any study-group combination has very few observations or estimated
#' propensities near zero, suggesting positivity may be violated.
#' 
#' @param data Structured data list with N.sz (study-group counts)
#' @param parm Parameter list with diagnostics (frac_truncated)
#' @param propensity_min Fraction threshold: warn if this fraction of subjects
#'   had near-zero pre-truncation propensity (default: 0.05)
#' @return Invisibly returns TRUE if warning issued, FALSE otherwise
#' @keywords internal
fn.check_positivity <- function(data, parm, propensity_min = DIAG_PROPENSITY_MIN) {

    issued_warning <- FALSE

    # check for empty or near-empty study-group combinations
    if (any(data$N.sz < 5)) {
        sparse_cells <- which(data$N.sz < 5, arr.ind = TRUE)
        warning(
            sprintf(
                "Sparse study-group cells: %d cell(s) with < 5 observations.",
                nrow(sparse_cells)
            ),
            call. = FALSE
        )
        issued_warning <- TRUE
    }

    # warn if a meaningful fraction of subjects had near-zero propensity
    # before truncation, indicating potential positivity violations
    if (!is.null(parm$diagnostics$frac_truncated)) {
        if (parm$diagnostics$frac_truncated > propensity_min) {
            warning(
                sprintf(
                    "Near-zero propensity scores: %.1f%% of subjects truncated.",
                    100 * parm$diagnostics$frac_truncated
                ),
                call. = FALSE
            )
            issued_warning <- TRUE
        }
    }   
    return(invisible(issued_warning))
}

#' Run all diagnostic checks on balancing weights
#' 
#' Convenience wrapper that runs ESS, extreme weight, and positivity checks.
#' Called automatically by balancing.weights() and causal.estimate().
#' 
#' @param wt.v Vector of normalized weights
#' @param percentESS Percentage effective sample size
#' @param data Structured data list
#' @param parm Parameter list with propensity scores (optional)
#' @return Invisibly returns named logical vector of which warnings were issued
#' @keywords internal
fn.run_diagnostics <- function(wt.v, percentESS, data, parm = NULL) {

    ess_warned <- fn.check_ess(percentESS)
    weights_warned <- fn.check_extreme_weights(wt.v)
    positivity_warned <-
        if (!is.null(parm)) {
            fn.check_positivity(data, parm)
        } else {
            FALSE
        }

    return(invisible(c(
        low_ess = ess_warned,
        extreme_weights = weights_warned,
        positivity = positivity_warned
    )))
}