Factores Predictores del Costo de Atención en Salud: Modelamiento, Validación y Testeo
Seminario de Investigación I Cuantitativo — Semana 5
Jose Daniel Jurado Villamil — Maestría en Administración en Salud, FUCS
28 de June de 2026
1 Problema de investigación
Pregunta: ¿Qué factores clínicos y demográficos predicen el costo de atención en salud (charges), y cómo afecta el hábito de fumar la gestión económica del gasto sanitario individual?
Variable dependiente: charges — costo
médico facturado, en USD.
Variables independientes: age,
sex, bmi, children,
smoker, region.
Tipo de modelo: Estocástico. Se asume la forma general charges = f(X) + error, donde el término de error captura la variabilidad individual no observada (predisposición genética, acceso a servicios, comorbilidades no registradas en la base). Un modelo determinístico no sería adecuado: dos personas con idénticas características observadas pueden tener costos médicos distintos por factores que la base no captura.
Fuente de datos: Medical Cost Personal Dataset (Kaggle, Lantz).
datos <- read_csv("/Users/josedanieljuradovillamil/Documents/investigacion/base de datos semana 4 investigación.csv") %>%
distinct() %>%
mutate(sex = as.factor(sex), smoker = as.factor(smoker), region = as.factor(region))
cat("Registros:", nrow(datos), "| Variables:", ncol(datos), "| Sin duplicados ni nulos.")## Registros: 1337 | Variables: 7 | Sin duplicados ni nulos.2 Exploración analítica de datos (EDA)
2.1 Frecuencias de variables categóricas
tabla_frec_smoker <- datos %>% count(smoker) %>% mutate(Pct = round(n/sum(n)*100,2))
tabla_frec_sex <- datos %>% count(sex) %>% mutate(Pct = round(n/sum(n)*100,2))
tabla_frec_region <- datos %>% count(region) %>% mutate(Pct = round(n/sum(n)*100,2))
kable(tabla_frec_smoker, caption = "Smoker")| smoker | n | Pct |
|---|---|---|
| no | 1063 | 79.51 |
| yes | 274 | 20.49 |
kable(tabla_frec_sex, caption = "Sex")| sex | n | Pct |
|---|---|---|
| female | 662 | 49.51 |
| male | 675 | 50.49 |
kable(tabla_frec_region, caption = "Region")| region | n | Pct |
|---|---|---|
| northeast | 324 | 24.23 |
| northwest | 324 | 24.23 |
| southeast | 364 | 27.23 |
| southwest | 325 | 24.31 |
p_smoker_bar <- ggplot(tabla_frec_smoker, aes(x = smoker, y = n, fill = smoker)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
geom_text(aes(label = paste0(n," (",Pct,"%)")), vjust = -0.5, size = 3) +
scale_fill_manual(values = c("no" = paleta[1], "yes" = paleta[2])) +
labs(title = "Smoker", x = "", y = "N") + theme_minimal(base_size = 10)
p_sex_bar <- ggplot(tabla_frec_sex, aes(x = sex, y = n, fill = sex)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
geom_text(aes(label = paste0(n," (",Pct,"%)")), vjust = -0.5, size = 3) +
scale_fill_manual(values = c("female" = paleta[4], "male" = paleta[5])) +
labs(title = "Sex", x = "", y = "N") + theme_minimal(base_size = 10)
p_region_bar <- ggplot(tabla_frec_region, aes(x = region, y = n, fill = region)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
geom_text(aes(label = n), vjust = -0.5, size = 3) +
scale_fill_manual(values = paleta) +
labs(title = "Region", x = "", y = "N") + theme_minimal(base_size = 10) +
theme(axis.text.x = element_text(angle = 20, hjust = 1))
grid.arrange(p_smoker_bar, p_sex_bar, p_region_bar, ncol = 3)
Las variables sex y region están
balanceadas. smoker es la única variable categórica con
distribución desigual (20.5% vs 79.5%), pero —como se verá— con un
efecto desproporcionadamente grande sobre charges.
2.2 Detección de outliers en charges (método IQR)
Q1_ch <- quantile(datos$charges, 0.25)
Q3_ch <- quantile(datos$charges, 0.75)
IQR_ch <- Q3_ch - Q1_ch
lim_inf_ch <- Q1_ch - 1.5 * IQR_ch
lim_sup_ch <- Q3_ch + 1.5 * IQR_ch
datos_outlier <- datos %>%
mutate(es_outlier = ifelse(charges < lim_inf_ch | charges > lim_sup_ch, "Outlier", "Normal"))
outliers_charges <- datos_outlier %>% filter(es_outlier == "Outlier")
tabla_outliers <- data.frame(
Metrica = c("Límite inferior", "Límite superior", "N° outliers",
"% del total", "Outliers que son fumadores"),
Valor = c(round(lim_inf_ch,0), round(lim_sup_ch,0), nrow(outliers_charges),
paste0(round(nrow(outliers_charges)/nrow(datos)*100,2), "%"),
paste0(sum(outliers_charges$smoker == "yes"), " de ", nrow(outliers_charges)))
)
kable(tabla_outliers)| Metrica | Valor |
|---|---|
| Límite inferior | -13121 |
| Límite superior | 34525 |
| N° outliers | 139 |
| % del total | 10.4% |
| Outliers que son fumadores | 136 de 139 |
ggplot(datos_outlier, aes(x = charges, fill = es_outlier)) +
geom_histogram(bins = 40, alpha = 0.85, position = "identity") +
scale_fill_manual(values = c("Normal" = paleta[1], "Outlier" = paleta[2])) +
geom_vline(xintercept = lim_sup_ch, color = "black", linetype = "dashed") +
scale_x_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Outliers de Charges (método IQR)",
subtitle = "Línea negra = límite superior",
x = "Costo (USD)", y = "Frecuencia", fill = "Clasificación") +
theme_minimal(base_size = 12)
De los 139 outliers detectados (10.4% del total), 136 son fumadores.
No son errores de datos: son el subgrupo de fumadores con costos
estructuralmente más altos, lo que anticipa la necesidad de tratar a
smoker de forma diferenciada en el modelo.
3 Estadística descriptiva
tabla_descriptiva <- datos %>%
summarise(across(c(age, bmi, children, charges),
list(Media = ~round(mean(.),2), Mediana = ~round(median(.),2),
DE = ~round(sd(.),2), CV_pct = ~round(sd(.)/mean(.)*100,2),
Asimetria = ~round(skewness(.),3), Curtosis = ~round(kurtosis(.),3)))) %>%
pivot_longer(everything(), names_to = "stat", values_to = "valor") %>%
separate(stat, into = c("Variable", "Medida"), sep = "_(?=[A-Za-z]+$)") %>%
pivot_wider(names_from = Medida, values_from = valor)
kable(tabla_descriptiva)| Variable | Media | Mediana | DE | pct | Asimetria | Curtosis |
|---|---|---|---|---|---|---|
| age | 39.22 | 39.00 | 14.04 | NA | 0.055 | 1.756 |
| age_CV | NA | NA | NA | 35.81 | NA | NA |
| bmi | 30.66 | 30.40 | 6.10 | NA | 0.284 | 2.943 |
| bmi_CV | NA | NA | NA | 19.89 | NA | NA |
| children | 1.10 | 1.00 | 1.21 | NA | 0.936 | 3.196 |
| children_CV | NA | NA | NA | 110.02 | NA | NA |
| charges | 13279.12 | 9386.16 | 12110.36 | NA | 1.514 | 4.594 |
| charges_CV | NA | NA | NA | 91.20 | NA | NA |
p_age <- ggplot(datos, aes(x = age)) +
geom_histogram(bins = 25, fill = paleta[1], color = "white", alpha = 0.85) +
geom_vline(aes(xintercept = mean(age)), color = "red", linetype = "dashed") +
labs(title = "Edad", x = "Años", y = "Frecuencia") + theme_minimal(base_size = 10)
p_bmi <- ggplot(datos, aes(x = bmi)) +
geom_histogram(bins = 25, fill = paleta[3], color = "white", alpha = 0.85) +
geom_vline(aes(xintercept = mean(bmi)), color = "red", linetype = "dashed") +
labs(title = "BMI", x = "Índice", y = "Frecuencia") + theme_minimal(base_size = 10)
p_children <- ggplot(datos, aes(x = children)) +
geom_histogram(bins = 6, fill = paleta[4], color = "white", alpha = 0.85) +
geom_vline(aes(xintercept = mean(children)), color = "red", linetype = "dashed") +
labs(title = "Children", x = "N° hijos", y = "Frecuencia") + theme_minimal(base_size = 10)
p_charges <- ggplot(datos, aes(x = charges)) +
geom_histogram(bins = 35, fill = paleta[2], color = "white", alpha = 0.85) +
geom_vline(aes(xintercept = mean(charges)), color = "red", linetype = "dashed") +
scale_x_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Charges", x = "USD", y = "Frecuencia") + theme_minimal(base_size = 10)
grid.arrange(p_age, p_bmi, p_children, p_charges, ncol = 2)
charges es la variable más asimétrica (1.51) y
leptocúrtica (4.59) — visible en la cola derecha del histograma.
age y bmi son aproximadamente simétricas.
3.1 Costo según hábito de fumar
tabla_smoker <- datos %>%
group_by(Fumador = smoker) %>%
summarise(Media_USD = round(mean(charges),0), Mediana_USD = round(median(charges),0),
DE_USD = round(sd(charges),0), N = n())
kable(tabla_smoker)| Fumador | Media_USD | Mediana_USD | DE_USD | N |
|---|---|---|---|---|
| no | 8441 | 7346 | 5993 | 1063 |
| yes | 32050 | 34456 | 11542 | 274 |
ggplot(datos, aes(x = smoker, y = charges, fill = smoker)) +
geom_boxplot(show.legend = FALSE, alpha = 0.85) +
scale_fill_manual(values = c("no" = paleta[1], "yes" = paleta[2])) +
scale_y_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Costo Médico según Hábito de Fumar",
subtitle = "Fumadores pagan ~3.8x más en promedio",
x = "Fumador", y = "Costo (USD)") +
theme_minimal(base_size = 12)
Los fumadores (20.5% de la muestra) pagan aproximadamente 3.8 veces más que los no fumadores — el predictor individual más fuerte de todo el análisis.
3.2 Correlación entre variables numéricas
vars_cor <- datos %>% select(age, bmi, children, charges) %>% cor()
kable(round(vars_cor, 3))| age | bmi | children | charges | |
|---|---|---|---|---|
| age | 1.000 | 0.109 | 0.042 | 0.298 |
| bmi | 0.109 | 1.000 | 0.013 | 0.198 |
| children | 0.042 | 0.013 | 1.000 | 0.067 |
| charges | 0.298 | 0.198 | 0.067 | 1.000 |
corrplot(vars_cor, method = "color", type = "upper", addCoef.col = "black",
tl.col = "black", tl.srt = 45, col = brewer.pal(8, "RdBu"), mar = c(0,0,1,0))
Ninguna correlación numérica supera 0.30. El predictor dominante
(smoker) es categórico, y su efecto solo se revela al
construir el modelo de regresión.
4 Modelo matemático: estimación por MCO
El método de Mínimos Cuadrados Ordinarios (MCO) estima los parámetros que minimizan la suma de los cuadrados de los residuos. Se construyen dos especificaciones para comparar:
Modelo Lineal (referencia): \[charges = \beta_0 + \beta_1 \cdot age + \beta_2 \cdot sex + \beta_3 \cdot bmi + \beta_4 \cdot children + \beta_5 \cdot smoker + \beta_6 \cdot region + \varepsilon\]
Modelo No Lineal (principal — incorpora curvatura e interacción): \[charges = \beta_0 + \beta_1 \cdot age + \beta_2 \cdot sex + \beta_3 \cdot bmi + \beta_4 \cdot bmi^2 + \beta_5 \cdot children + \beta_6 \cdot smoker + \beta_7 \cdot region + \beta_8 \cdot (bmi \times smoker) + \varepsilon\]
set.seed(123)
n <- nrow(datos)
indices_train <- sample(1:n, size = round(0.8 * n))
datos_train <- datos[indices_train, ]
datos_test <- datos[-indices_train, ]
modelo_lineal <- lm(charges ~ age + sex + bmi + children + smoker + region, data = datos_train)
modelo_nolineal <- lm(charges ~ age + sex + bmi + I(bmi^2) + children + smoker + region + bmi:smoker,
data = datos_train)División Holdout: 1070 registros de entrenamiento (80%) y 267 de prueba (20%), con semilla fija (123) para reproducibilidad.
4.1 Coeficientes del modelo principal
tabla_coefs <- tidy(modelo_nolineal) %>% mutate(across(where(is.numeric), ~round(.,3)))
kable(tabla_coefs)| term | estimate | std.error | statistic | p.value |
|---|---|---|---|---|
| (Intercept) | -10789.249 | 2960.797 | -3.644 | 0.000 |
| age | 254.866 | 11.052 | 23.060 | 0.000 |
| sexmale | -578.085 | 305.631 | -1.891 | 0.059 |
| bmi | 634.929 | 188.411 | 3.370 | 0.001 |
| I(bmi^2) | -9.815 | 2.952 | -3.325 | 0.001 |
| children | 542.149 | 127.388 | 4.256 | 0.000 |
| smokeryes | -20461.803 | 1879.204 | -10.889 | 0.000 |
| regionnorthwest | -980.345 | 441.411 | -2.221 | 0.027 |
| regionsoutheast | -1315.087 | 435.726 | -3.018 | 0.003 |
| regionsouthwest | -1530.795 | 440.861 | -3.472 | 0.001 |
| bmi:smokeryes | 1443.981 | 59.744 | 24.169 | 0.000 |
tabla_coefs %>%
filter(term != "(Intercept)") %>%
mutate(term = fct_reorder(term, estimate)) %>%
ggplot(aes(x = term, y = estimate, fill = estimate > 0)) +
geom_col(show.legend = FALSE) +
scale_fill_manual(values = c("TRUE" = paleta[1], "FALSE" = paleta[2])) +
coord_flip() +
labs(title = "Coeficientes del Modelo No Lineal",
subtitle = "Azul = efecto positivo sobre charges | Rojo = efecto negativo",
x = "", y = "Estimate (USD)") +
theme_minimal(base_size = 12)
4.2 El efecto de fumar depende del IMC
bmi_ref <- c(20, 25, 30, 35, 40, 45)
coef_nl <- coef(modelo_nolineal)
efecto_fumar <- coef_nl["smokeryes"] + coef_nl["bmi:smokeryes"] * bmi_ref
tabla_interaccion <- data.frame(BMI = bmi_ref, Efecto_Fumar_USD = round(efecto_fumar,0))
kable(tabla_interaccion)| BMI | Efecto_Fumar_USD |
|---|---|
| 20 | 8418 |
| 25 | 15638 |
| 30 | 22858 |
| 35 | 30078 |
| 40 | 37297 |
| 45 | 44517 |
ggplot(tabla_interaccion, aes(x = BMI, y = Efecto_Fumar_USD)) +
geom_line(color = paleta[2], linewidth = 1.2) +
geom_point(color = paleta[2], size = 3) +
scale_y_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Efecto de Fumar sobre el Costo, según IMC",
subtitle = "El sobrecosto de fumar se cuadriplica entre IMC=20 y IMC=40",
x = "Índice de Masa Corporal (BMI)", y = "Sobrecosto por fumar (USD)") +
theme_minimal(base_size = 12)
El efecto de fumar sobre el costo no es constante: se cuadriplica entre IMC=20 e IMC=40. La combinación de tabaquismo y obesidad representa un riesgo financiero sustancialmente mayor que cualquiera de los dos factores por separado.
5 Validación del modelo
5.1 Validación interna
Evalúa el modelo en el mismo conjunto usado para estimarlo. Permite detectar mal ajuste, pero no garantiza generalización a datos nuevos.
r2_nl_train <- summary(modelo_nolineal)$r.squared
cat("R² (entrenamiento, modelo no lineal):", round(r2_nl_train, 4))## R² (entrenamiento, modelo no lineal): 0.83825.2 Validación externa (holdout)
Evalúa el modelo en datos completamente independientes — el 20% nunca visto durante el entrenamiento.
pred_nl_test <- predict(modelo_nolineal, newdata = datos_test)
rmse_holdout <- rmse(datos_test$charges, pred_nl_test)
r2_holdout <- cor(datos_test$charges, pred_nl_test)^2
tabla_holdout <- data.frame(Metrica = c("RMSE (USD)", "R²"),
Valor = c(round(rmse_holdout,2), round(r2_holdout,4)))
kable(tabla_holdout)| Metrica | Valor |
|---|---|
| RMSE (USD) | 4278.3100 |
| R² | 0.8585 |
df_holdout <- data.frame(Real = datos_test$charges, Predicho = pred_nl_test)
ggplot(df_holdout, aes(x = Real, y = Predicho)) +
geom_point(alpha = 0.5, color = paleta[1]) +
geom_abline(slope = 1, intercept = 0, color = paleta[2], linetype = "dashed", linewidth = 1) +
scale_x_continuous(labels = dollar_format(prefix = "USD ")) +
scale_y_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Validación Externa: Real vs Predicho",
subtitle = paste0("RMSE = USD ", round(rmse_holdout,0), " | R² = ", round(r2_holdout,3)),
x = "Costo real (USD)", y = "Costo predicho (USD)") +
theme_minimal(base_size = 12)
5.3 Validación cruzada K-Fold (k=5)
Divide los datos en 5 partes; entrena en 4 y prueba en la restante, rotando 5 veces. Evalúa la estabilidad del modelo y permite detectar sobreajuste. Se aplica a los tres modelos considerados: Lineal, No Lineal y Red Neuronal.
set.seed(123)
folds <- createFolds(datos$charges, k = 5)
resultados_kfold <- data.frame(Fold = integer(), Modelo = character(),
RMSE = numeric(), R2 = numeric())
for (i in seq_along(folds)) {
test_idx <- folds[[i]]
train_idx <- setdiff(1:nrow(datos), test_idx)
train_i <- datos[train_idx, ]
test_i <- datos[test_idx, ]
m1 <- lm(charges ~ age + sex + bmi + children + smoker + region, data = train_i)
p1 <- predict(m1, newdata = test_i)
resultados_kfold <- rbind(resultados_kfold, data.frame(
Fold = i, Modelo = "1.Lineal", RMSE = rmse(test_i$charges, p1), R2 = cor(test_i$charges, p1)^2))
m2 <- lm(charges ~ age + sex + bmi + I(bmi^2) + children + smoker + region + bmi:smoker, data = train_i)
p2 <- predict(m2, newdata = test_i)
resultados_kfold <- rbind(resultados_kfold, data.frame(
Fold = i, Modelo = "2.NoLineal", RMSE = rmse(test_i$charges, p2), R2 = cor(test_i$charges, p2)^2))
train_rn_i <- train_i %>%
mutate(sex_male = ifelse(sex=="male",1,0), smoker_yes = ifelse(smoker=="yes",1,0),
region_nw = ifelse(region=="northwest",1,0), region_se = ifelse(region=="southeast",1,0),
region_sw = ifelse(region=="southwest",1,0)) %>%
select(age, sex_male, bmi, children, smoker_yes, region_nw, region_se, region_sw, charges)
test_rn_i <- test_i %>%
mutate(sex_male = ifelse(sex=="male",1,0), smoker_yes = ifelse(smoker=="yes",1,0),
region_nw = ifelse(region=="northwest",1,0), region_se = ifelse(region=="southeast",1,0),
region_sw = ifelse(region=="southwest",1,0)) %>%
select(age, sex_male, bmi, children, smoker_yes, region_nw, region_se, region_sw, charges)
cmin <- min(train_rn_i$charges); cmax <- max(train_rn_i$charges)
train_rn_norm <- train_rn_i %>% mutate(across(everything(), ~ (.-min(.))/(max(.)-min(.))))
test_rn_norm <- test_rn_i
for(col in names(test_rn_norm)) {
mn <- min(train_rn_i[[col]]); mx <- max(train_rn_i[[col]])
test_rn_norm[[col]] <- (test_rn_i[[col]] - mn) / (mx - mn)
}
m3 <- neuralnet(charges ~ age + sex_male + bmi + children + smoker_yes + region_nw + region_se + region_sw,
data = train_rn_norm, hidden = c(5,3), linear.output = TRUE, stepmax = 1e6)
p3_norm <- predict(m3, test_rn_norm)
p3 <- p3_norm * (cmax - cmin) + cmin
real3 <- test_rn_i$charges
resultados_kfold <- rbind(resultados_kfold, data.frame(
Fold = i, Modelo = "3.RedNeuronal", RMSE = rmse(real3, p3), R2 = cor(real3, p3)^2))
}kable(resultados_kfold %>% mutate(RMSE = round(RMSE,0), R2 = round(R2,4)))| Fold | Modelo | RMSE | R2 |
|---|---|---|---|
| 1 | 1.Lineal | 5859 | 0.7426 |
| 1 | 2.NoLineal | 4509 | 0.8461 |
| 1 | 3.RedNeuronal | 4498 | 0.8466 |
| 2 | 1.Lineal | 5793 | 0.7636 |
| 2 | 2.NoLineal | 4506 | 0.8579 |
| 2 | 3.RedNeuronal | 4390 | 0.8651 |
| 3 | 1.Lineal | 6210 | 0.7512 |
| 3 | 2.NoLineal | 4720 | 0.8561 |
| 3 | 3.RedNeuronal | 4874 | 0.8488 |
| 4 | 1.Lineal | 6222 | 0.7598 |
| 4 | 2.NoLineal | 5017 | 0.8430 |
| 4 | 3.RedNeuronal | 4861 | 0.8522 |
| 5 | 1.Lineal | 6323 | 0.7249 |
| 5 | 2.NoLineal | 5397 | 0.8003 |
| 5 | 3.RedNeuronal | 5158 | 0.8178 |
ggplot(resultados_kfold, aes(x = Modelo, y = RMSE, fill = Modelo)) +
geom_boxplot(alpha = 0.85, show.legend = FALSE) +
geom_jitter(width = 0.1, size = 2, alpha = 0.6) +
scale_fill_manual(values = paleta[1:3]) +
scale_y_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "Variabilidad del RMSE entre los 5 Folds",
subtitle = "Cajas más angostas = modelo más estable entre particiones",
x = "", y = "RMSE (USD)") +
theme_minimal(base_size = 12)
resumen_kfold <- resultados_kfold %>%
group_by(Modelo) %>%
summarise(RMSE_promedio = round(mean(RMSE),0), RMSE_DE = round(sd(RMSE),0),
R2_promedio = round(mean(R2),4), R2_DE = round(sd(R2),4))
kable(resumen_kfold)| Modelo | RMSE_promedio | RMSE_DE | R2_promedio | R2_DE |
|---|---|---|---|---|
| 1.Lineal | 6081 | 238 | 0.7484 | 0.0155 |
| 2.NoLineal | 4829 | 380 | 0.8407 | 0.0235 |
| 3.RedNeuronal | 4756 | 311 | 0.8461 | 0.0174 |
ggplot(resumen_kfold, aes(x = Modelo, y = RMSE_promedio, fill = Modelo)) +
geom_col(alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = RMSE_promedio - RMSE_DE, ymax = RMSE_promedio + RMSE_DE), width = 0.2, linewidth = 0.8) +
geom_text(aes(label = dollar(RMSE_promedio)), vjust = -2.5) +
scale_fill_manual(values = paleta[1:3]) +
scale_y_continuous(labels = dollar_format(prefix = "USD "), expand = expansion(mult = c(0,0.2))) +
labs(title = "RMSE Promedio ± DE entre 5 Folds",
subtitle = "Barras de error = desviación estándar entre folds (estabilidad)",
x = "", y = "RMSE promedio (USD)") +
theme_minimal(base_size = 12)
La desviación estándar del RMSE entre folds indica estabilidad: un modelo estable varía poco entre particiones, sin depender de qué datos le tocaron.
5.4 Fuentes de error y sesgo
- Sesgo de selección: la base corresponde a pacientes asegurados en EE.UU.; puede no generalizar a otros sistemas de salud (p. ej. Colombia, SGSSS).
- Sobreajuste: el Modelo No Lineal agrega dos términos (bmi², bmi:smoker) — el K-Fold confirma si ese ajuste se sostiene fuera de muestra.
- Suposiciones incorrectas: se verifica formalmente en la sección de diagnóstico de residuos.
- Calidad de datos: 0 valores nulos, 1 duplicado eliminado en la preparación inicial.
6 Capacidad explicativa y predictiva
aic_lineal <- AIC(modelo_lineal); bic_lineal <- BIC(modelo_lineal)
aic_nl <- AIC(modelo_nolineal); bic_nl <- BIC(modelo_nolineal)
tabla_final <- resumen_kfold %>%
mutate(AIC = c(round(aic_lineal,0), round(aic_nl,0), NA),
BIC = c(round(bic_lineal,0), round(bic_nl,0), NA))
kable(tabla_final)| Modelo | RMSE_promedio | RMSE_DE | R2_promedio | R2_DE | AIC | BIC |
|---|---|---|---|---|---|---|
| 1.Lineal | 6081 | 238 | 0.7484 | 0.0155 | 21730 | 21780 |
| 2.NoLineal | 4829 | 380 | 0.8407 | 0.0235 | 21261 | 21320 |
| 3.RedNeuronal | 4756 | 311 | 0.8461 | 0.0174 | NA | NA |
p_rmse_final <- ggplot(tabla_final, aes(x = Modelo, y = RMSE_promedio, fill = Modelo)) +
geom_col(show.legend = FALSE, alpha = 0.85) +
geom_text(aes(label = dollar(RMSE_promedio)), vjust = -0.5) +
scale_fill_manual(values = paleta[1:3]) +
scale_y_continuous(labels = dollar_format(prefix = "USD ")) +
labs(title = "RMSE Promedio (K-Fold)", x = "", y = "USD") +
theme_minimal(base_size = 11)
tabla_aicbic <- tabla_final %>% filter(!is.na(AIC)) %>%
select(Modelo, AIC, BIC) %>%
pivot_longer(cols = c(AIC, BIC), names_to = "Criterio", values_to = "Valor")
p_aicbic <- ggplot(tabla_aicbic, aes(x = Modelo, y = Valor, fill = Criterio)) +
geom_col(position = "dodge", alpha = 0.85) +
scale_fill_manual(values = c("AIC" = paleta[1], "BIC" = paleta[2])) +
labs(title = "AIC y BIC (no aplica a Red Neuronal)", x = "", y = "Valor") +
theme_minimal(base_size = 11)
grid.arrange(p_rmse_final, p_aicbic, ncol = 2)
AIC y BIC favorecen al Modelo No Lineal sobre el Lineal (menor valor en ambos). No aplican a la Red Neuronal, que no tiene una función de verosimilitud definida —se entrena minimizando error mediante backpropagation, no maximizando verosimilitud.
En capacidad explicativa, el Modelo No Lineal es superior por su interpretabilidad directa. En capacidad predictiva pura, la Red Neuronal compite de cerca en RMSE, a costa de perder esa interpretabilidad.
7 Diagnóstico: análisis de residuos y supuestos
shapiro_nl <- shapiro.test(residuals(modelo_nolineal))
bp_nl <- bptest(modelo_nolineal)
vif_nl <- vif(modelo_nolineal)
tabla_supuestos <- data.frame(
Supuesto = c("Normalidad (Shapiro-Wilk)", "Homocedasticidad (Breusch-Pagan)", "Multicolinealidad (VIF máx.)"),
Estadistico = c(round(shapiro_nl$statistic,4), round(bp_nl$statistic,4), round(max(vif_nl[,1]),2)),
p_valor = c(format(shapiro_nl$p.value, scientific=TRUE, digits=3),
format(bp_nl$p.value, scientific=TRUE, digits=3), "N/A"),
Conclusion = c(ifelse(shapiro_nl$p.value<0.05,"Se viola (no normal)","Se cumple"),
ifelse(bp_nl$p.value<0.05,"Se viola (heterocedástico)","Se cumple"),
"Esperado por interacción bmi:smoker")
)
kable(tabla_supuestos)| Supuesto | Estadistico | p_valor | Conclusion | |
|---|---|---|---|---|
| W | Normalidad (Shapiro-Wilk) | 0.6810 | 8.3e-41 | Se viola (no normal) |
| BP | Homocedasticidad (Breusch-Pagan) | 10.4995 | 3.98e-01 | Se cumple |
| Multicolinealidad (VIF máx.) | 57.6500 | N/A | Esperado por interacción bmi:smoker |
par(mfrow = c(2, 2))
plot(modelo_nolineal)
par(mfrow = c(1, 1))# vif() devuelve una matriz cuando el modelo tiene términos de interacción;
# se usa rownames() y la primera columna (GVIF) en lugar de names()/as.numeric()
tabla_vif <- data.frame(Variable = rownames(vif_nl), VIF = round(vif_nl[,1], 2))
kable(tabla_vif)| Variable | VIF | |
|---|---|---|
| age | age | 1.02 |
| sex | sex | 1.01 |
| bmi | bmi | 57.45 |
| I(bmi^2) | I(bmi^2) | 57.65 |
| children | children | 1.00 |
| smoker | smoker | 25.47 |
| region | region | 1.12 |
| bmi:smoker | bmi:smoker | 25.84 |
ggplot(tabla_vif, aes(x = fct_reorder(Variable, VIF), y = VIF)) +
geom_col(fill = paleta[3], alpha = 0.85) +
geom_hline(yintercept = 5, color = paleta[2], linetype = "dashed", linewidth = 1) +
coord_flip() +
labs(title = "Factor de Inflación de Varianza (VIF) por Variable",
subtitle = "Línea roja = umbral convencional (VIF=5)",
x = "", y = "VIF") +
theme_minimal(base_size = 12)
Los supuestos de normalidad y homocedasticidad se violan, lo esperado
dado el sesgo de charges por el subgrupo de fumadores. El
VIF elevado en bmi, bmi² y la interacción es
estructural —son variables derivadas entre sí por construcción— y no
indica un problema real de multicolinealidad entre predictores
independientes como age, children o
region.
8 Conclusiones
A la luz del problema de investigación planteado:
Fumar es el predictor dominante del costo médico, y su efecto se intensifica con el IMC del paciente —relación confirmada por el modelo y validada mediante K-Fold.
El Modelo No Lineal mejora significativamente al Lineal simple (menor AIC/BIC, mejor RMSE promedio en validación cruzada) sin sacrificar interpretabilidad. Es el modelo recomendado para apoyar decisiones de política sanitaria.
La Red Neuronal iguala o mejora marginalmente el RMSE, pero al funcionar como una “caja negra” resulta menos útil para justificar decisiones ante un comité directivo no técnico.
Los supuestos de normalidad y homocedasticidad se violan de forma esperable por el sesgo natural de
charges. Esta limitación queda documentada; una transformación logarítmica de la variable dependiente podría explorarse en trabajo futuro.Recomendación para la gestión de recursos sanitarios: incorporar el tabaquismo y el IMC —junto con su interacción— en los modelos actuariales de fijación de primas y en el diseño de programas de prevención focalizados en pacientes que presentan ambos factores de riesgo simultáneamente.