Update repo
This commit is contained in:
@@ -0,0 +1,217 @@
|
||||
---
|
||||
title: "Why The Naive Analysis Is Biased"
|
||||
format:
|
||||
html:
|
||||
embed-resources: true
|
||||
docx: default
|
||||
execute:
|
||||
echo: true
|
||||
warning: false
|
||||
message: false
|
||||
---
|
||||
|
||||
## Goal
|
||||
|
||||
This notebook shows why the naive mortality comparison can be biased.
|
||||
|
||||
The key idea is **confounding by indication**: sicker ICU patients are more likely to receive early vasopressors, and sicker ICU patients are also more likely to die.
|
||||
|
||||
## Setup
|
||||
|
||||
```{r}
|
||||
suppressPackageStartupMessages({
|
||||
library(dplyr)
|
||||
library(gt)
|
||||
library(gtsummary)
|
||||
library(tibble)
|
||||
})
|
||||
|
||||
source("../R/simulate_icu_cohort.R")
|
||||
source("../R/estimate_naive_vasopressor_mortality_effect.R")
|
||||
source("../R/estimate_standardized_vasopressor_mortality_effect.R")
|
||||
```
|
||||
|
||||
## Simulate Data And Estimate Effects
|
||||
|
||||
```{r}
|
||||
icu_data <- simulate_icu_cohort(n_patients = 1000, seed = 20260531)
|
||||
|
||||
naive_mortality_analysis <- estimate_naive_vasopressor_mortality_effect(icu_data)
|
||||
standardized_mortality_analysis <- estimate_standardized_vasopressor_mortality_effect(icu_data)
|
||||
|
||||
eligible_icu_patients <- naive_mortality_analysis$eligible_icu_patients
|
||||
```
|
||||
|
||||
Both analyses use the same eligible ICU patients.
|
||||
|
||||
The naive analysis compares observed treatment groups directly.
|
||||
|
||||
The standardized analysis uses an outcome model to compare two treatment strategies in the same eligible cohort.
|
||||
|
||||
## Baseline Imbalance
|
||||
|
||||
```{r}
|
||||
eligible_icu_patients |>
|
||||
mutate(
|
||||
early_vasopressor = factor(
|
||||
early_vasopressor,
|
||||
levels = c(0, 1),
|
||||
labels = c("No early vasopressor", "Early vasopressor")
|
||||
)
|
||||
) |>
|
||||
select(early_vasopressor, age, sex, sofa_score, lactate, map, death_28d) |>
|
||||
tbl_summary(
|
||||
by = early_vasopressor,
|
||||
statistic = list(
|
||||
all_continuous() ~ "{mean} ({sd})",
|
||||
all_categorical() ~ "{n} ({p}%)"
|
||||
),
|
||||
missing = "no"
|
||||
) |>
|
||||
add_overall()
|
||||
```
|
||||
|
||||
The early vasopressor group is generally older and sicker.
|
||||
|
||||
That matters because age, SOFA score, lactate, and MAP are also predictors of 28-day mortality.
|
||||
|
||||
## Naive Mortality Effect Estimates
|
||||
|
||||
```{r}
|
||||
naive_mortality_analysis$mortality_effect_estimates |>
|
||||
gt() |>
|
||||
tab_header(title = "Naive Mortality Effect Estimates") |>
|
||||
cols_label(
|
||||
estimate = "Estimate",
|
||||
value = "Value"
|
||||
) |>
|
||||
fmt_number(columns = value, decimals = 3)
|
||||
```
|
||||
|
||||
The naive estimate does not compare like with like.
|
||||
|
||||
It compares patients who actually received early vasopressors with patients who did not, even though those groups differ in baseline severity.
|
||||
|
||||
## Outcome Model Used For Standardization
|
||||
|
||||
```{r}
|
||||
mortality_model_coefficients <- summary(
|
||||
standardized_mortality_analysis$mortality_outcome_model
|
||||
)$coefficients |>
|
||||
as.data.frame() |>
|
||||
rownames_to_column("model_term") |>
|
||||
as_tibble()
|
||||
|
||||
names(mortality_model_coefficients) <- c(
|
||||
"model_term",
|
||||
"log_odds_estimate",
|
||||
"standard_error",
|
||||
"z_statistic",
|
||||
"p_value"
|
||||
)
|
||||
|
||||
mortality_model_coefficients |>
|
||||
mutate(odds_ratio = exp(log_odds_estimate)) |>
|
||||
select(model_term, log_odds_estimate, odds_ratio, standard_error, p_value) |>
|
||||
gt() |>
|
||||
tab_header(title = "Mortality Outcome Model") |>
|
||||
cols_label(
|
||||
model_term = "Model term",
|
||||
log_odds_estimate = "Log-odds estimate",
|
||||
odds_ratio = "Odds ratio",
|
||||
standard_error = "Standard error",
|
||||
p_value = "P-value"
|
||||
) |>
|
||||
fmt_number(
|
||||
columns = c(log_odds_estimate, odds_ratio, standard_error, p_value),
|
||||
decimals = 3
|
||||
)
|
||||
```
|
||||
|
||||
This logistic regression models 28-day mortality using observed treatment and baseline severity variables.
|
||||
|
||||
The model is not the target trial by itself. It is a tool for predicting mortality risk under each treatment strategy while holding the eligible patient population fixed.
|
||||
|
||||
## Standardized Mortality Risks
|
||||
|
||||
```{r}
|
||||
standardized_mortality_analysis$standardized_mortality_risks |>
|
||||
gt() |>
|
||||
tab_header(title = "Standardized 28-Day Mortality Risks") |>
|
||||
cols_label(
|
||||
treatment_strategy = "Treatment strategy",
|
||||
patient_count = "Eligible patients",
|
||||
standardized_mortality_risk_28d = "Standardized mortality risk"
|
||||
) |>
|
||||
fmt_integer(columns = patient_count) |>
|
||||
fmt_number(columns = standardized_mortality_risk_28d, decimals = 3)
|
||||
```
|
||||
|
||||
These risks answer a target-trial-style question:
|
||||
|
||||
What would the average mortality risk be if the same eligible patients all followed one strategy versus the other?
|
||||
|
||||
## Standardized Mortality Effect Estimates
|
||||
|
||||
```{r}
|
||||
standardized_mortality_analysis$standardized_mortality_effect_estimates |>
|
||||
gt() |>
|
||||
tab_header(title = "Standardized Mortality Effect Estimates") |>
|
||||
cols_label(
|
||||
estimate = "Estimate",
|
||||
value = "Value"
|
||||
) |>
|
||||
fmt_number(columns = value, decimals = 3)
|
||||
```
|
||||
|
||||
The standardized risk difference is less distorted by baseline severity imbalance than the naive risk difference.
|
||||
|
||||
This does not make the estimate automatically correct, but it is closer to the target trial question than a direct treated-versus-untreated comparison.
|
||||
|
||||
## Naive Versus Standardized Estimates
|
||||
|
||||
```{r}
|
||||
naive_risk_difference <- naive_mortality_analysis$mortality_effect_estimates |>
|
||||
filter(estimate == "Naive risk difference") |>
|
||||
pull(value)
|
||||
|
||||
naive_risk_ratio <- naive_mortality_analysis$mortality_effect_estimates |>
|
||||
filter(estimate == "Naive risk ratio") |>
|
||||
pull(value)
|
||||
|
||||
standardized_risk_difference <- standardized_mortality_analysis$standardized_mortality_effect_estimates |>
|
||||
filter(estimate == "Standardized risk difference") |>
|
||||
pull(value)
|
||||
|
||||
standardized_risk_ratio <- standardized_mortality_analysis$standardized_mortality_effect_estimates |>
|
||||
filter(estimate == "Standardized risk ratio") |>
|
||||
pull(value)
|
||||
|
||||
effect_estimate_comparison <- tibble(
|
||||
method = c("Naive observed comparison", "Outcome regression standardization"),
|
||||
risk_difference = c(naive_risk_difference, standardized_risk_difference),
|
||||
risk_ratio = c(naive_risk_ratio, standardized_risk_ratio)
|
||||
)
|
||||
|
||||
effect_estimate_comparison |>
|
||||
gt() |>
|
||||
tab_header(title = "Naive Versus Standardized Mortality Effect Estimates") |>
|
||||
cols_label(
|
||||
method = "Method",
|
||||
risk_difference = "Risk difference",
|
||||
risk_ratio = "Risk ratio"
|
||||
) |>
|
||||
fmt_number(columns = c(risk_difference, risk_ratio), decimals = 3)
|
||||
```
|
||||
|
||||
In the simulated data-generating process, early vasopressors have a modest protective effect.
|
||||
|
||||
The naive comparison can still make early vasopressors look harmful because early-treated patients are more severely ill at baseline.
|
||||
|
||||
Standardization partially addresses that problem by comparing treatment strategies in the same eligible patient population.
|
||||
|
||||
## Next Step
|
||||
|
||||
The next tutorial step is to connect this back to target trial emulation mechanics: time zero, eligibility, and treatment assignment windows.
|
||||
|
||||
After that, we can introduce inverse probability weighting from first principles.
|
||||
Reference in New Issue
Block a user