Transportability and Policy Learning

1. Transportability: Lalonde’s Job Training

A common challenge in causal inference is external validity: Can we apply the results of a Randomized Controlled Trial (RCT) to a diferent target population?

We use the Lalonde dataset to simulate a transportability problem. * Source Population (\(S=1\)): The NSW experimental participants (typically disjoint from the general population). * Target Population (\(S=0\)): The CPS comparison group (representative of the broader population).

data("nsw_benchmark")

# Define Source: Experimental Sample
source_data <- subset(nsw_benchmark, sample_id %in% c("nsw_treated", "nsw_control"))

# Define Target: CPS Control Group (Broader population)
target_data <- subset(nsw_benchmark, sample_id == "cps_control")

# Covariates available for transport
transport_vars <- c("age", "education", "black", "hispanic", "married", "nodegree", "re74", "re75")

# Comparison of demographics
print(summary(source_data[, c("age", "education", "re74")]))
#>       age          education         re74        
#>  Min.   :17.00   Min.   : 3.0   Min.   :    0.0  
#>  1st Qu.:20.00   1st Qu.: 9.0   1st Qu.:    0.0  
#>  Median :24.00   Median :10.0   Median :    0.0  
#>  Mean   :25.37   Mean   :10.2   Mean   : 2102.3  
#>  3rd Qu.:28.00   3rd Qu.:11.0   3rd Qu.:  824.4  
#>  Max.   :55.00   Max.   :16.0   Max.   :39570.7
print(summary(target_data[, c("age", "education", "re74")]))
#>       age          education          re74      
#>  Min.   :16.00   Min.   : 0.00   Min.   :    0  
#>  1st Qu.:24.00   1st Qu.:11.00   1st Qu.: 4403  
#>  Median :31.00   Median :12.00   Median :15124  
#>  Mean   :33.23   Mean   :12.03   Mean   :14017  
#>  3rd Qu.:42.00   3rd Qu.:13.00   3rd Qu.:23584  
#>  Max.   :55.00   Max.   :18.00   Max.   :25862

The target population (CPS) is significantly wealthier (re74 mean is much higher) and slightly older. We want to know: What would be the effect of job training if applied to the CPS population?

# Create causal specification for the SOURCE
source_spec <- causal_spec(
  data = source_data,
  treatment = "treat",
  outcome = "re78",
  covariates = transport_vars
)
#> ✔ Created causal specification: n=445, 8 covariate(s)

# Compute Transport Deficiency
trans_def <- transport_deficiency(
  source_spec,
  target_data = target_data,
  transport_vars = transport_vars,
  method = "iptw",
  n_boot = 50 # Low for vignette speed
)
#> ✖ Transport proxy: 0.995 (ESS: 13.3%)
#> ℹ Severe distribution shift; transport may be unreliable

print(trans_def)
#> 
#> ── Transport Diagnostic Analysis ───────────────────────────────────────────────
#> Method: "iptw"
#> Source n: 445 | Target n: 15992
#> 
#> ── Transport Diagnostic ──
#> 
#>   transport proxy:       0.9954
#>   Standard error:        0.0250
#>   95% CI:               [1.1735, 1.2776]
#>   Effective sample size: 59.0 (13.3% of source)
#>   Note: this is a heuristic transport-risk proxy, not an exact transport deficiency.
#> ── Covariate Shift ──
#>            variable shift_metric severity
#> age             age   0.84595761   severe
#> education education   0.76555133   severe
#> black         black   2.36239417   severe
#> hispanic   hispanic   0.05755963      low
#> married     married   1.30665468   severe
#> nodegree   nodegree   1.11659926   severe
#> re74           re74   1.53592792   severe
#> re75           re75   1.77276154   severe
#> ── Effect Estimates ──
#>   ATE (source):     1676.3426
#>   ATE (transport):  778.8984
plot(trans_def, type = "shift")

2. Policy Learning Bounds: RHC

In Policy Learning, we seek an optimal treatment rule \(\pi(X)\) to maximize utility. However, with observational data, our estimate of a policy’s value is biased by confounding.

We use the Right Heart Catheterization (RHC) dataset to evaluate a risk-based policy. * Decision: Treat with RHC? * Outcome: 30-day Mortality (lower is better). * Policy: “Treat only high-risk patients” (e.g., APACHE score > 50).

data("rhc")

# Preprocessing
if (is.factor(rhc$swang1)) rhc$treat <- as.numeric(rhc$swang1) - 1 else rhc$treat <- rhc$swang1
if (is.factor(rhc$dth30)) rhc$outcome <- as.numeric(rhc$dth30) - 1 else rhc$outcome <- rhc$dth30

# Variables for adjustment
covariates <- c("age", "sex", "race", "aps1", "cat1") 

spec_rhc <- causal_spec(
  data = rhc,
  treatment = "treat",
  outcome = "outcome",
  covariates = covariates
)
#> ✔ Created causal specification: n=5735, 5 covariate(s)

# Estimate propensity scores for adjustment
ps_model <- glm(treat ~ age + sex + race + aps1 + cat1, data = rhc, family = binomial)
rhc$ps <- predict(ps_model, type = "response")

# Define policies
policy_all <- rep(1, nrow(rhc))
policy_risk <- ifelse(rhc$aps1 > 50, 1, 0)

# Estimate Value (Inverse Propensity Weighted)
# Value = Mean of Y under policy. We want to MINIMIZE mortality.
# Equivalent to Maximizing Survival (1 - Y).
# Let's compute expected mortality.

get_policy_value <- function(policy, treat, outcome, ps) {
  # IPW estimator for policy value
  # Weight = I(A = \pi(X)) / P(A|X)
  w <- (treat == policy) / ifelse(policy == 1, ps, 1 - ps)
  mean(w * outcome) # Expected Mortality
}

val_all <- get_policy_value(policy_all, rhc$treat, rhc$outcome, rhc$ps)
val_risk <- get_policy_value(policy_risk, rhc$treat, rhc$outcome, rhc$ps)

cat("Estimated Mortality (Treat All):", round(val_all, 3), "\n")
#> Estimated Mortality (Treat All): 0.352
cat("Estimated Mortality (Risk-Based):", round(val_risk, 3), "\n")
#> Estimated Mortality (Risk-Based): 0.358

# 1. Estimate Deficiency of the dataset
defom <- estimate_deficiency(spec_rhc, methods = "iptw", n_boot = 0)
#> ℹ Estimating deficiency: iptw
delta <- defom$estimates["iptw"]

# 2. Compute Safety Floor
# Utility range is [0, 1] (Mortality 0 or 1)
bounds <- policy_regret_bound(defom, utility_range = c(0, 1), method = "iptw")
#> ℹ Transfer penalty: 0.0184 (delta = 0.0184)

print(bounds)
#> 
#> -- Policy Regret Bounds -------------------------------------------------
#> 
#> * Deficiency delta: 0.0184 
#> * Delta mode: point 
#> * Delta method: iptw 
#> * Delta selection: pre-specified method 
#> * Utility range: [0, 1]
#> * Transfer penalty: 0.0184 (additive regret upper bound)
#> * Minimax floor: 0.0092 (worst-case lower bound)
#> 
#> Note: this is a plug-in bound using a deficiency proxy rather than an identified exact deficiency.
#> 
#> Interpretation: Transfer penalty is 1.8 % of utility range given delta