---
title: "IA para Científicos Sociales"
subtitle: "Sesión 2.3: Laboratorio 3 - Clasificación avanzada"
author:
- name: Danilo Freire
orcid: 0000-0002-4712-6810
email: danilofreire@gmail.com
affiliations: "Department of Data and Decision Sciences
Emory University"
format:
clean-revealjs:
self-contained: true
footer: "[Sesión 2.3](https://danilofreire.github.io/introduccion-ia-ucu/clases/dia-02/07-laboratorio-03.html)"
transition: slide
transition-speed: default
scrollable: true
revealjs-plugins:
- multimodal
engine: knitr
editor:
render-on-save: true
lang: es
---
```{r setup, include=FALSE}
options(htmltools.dir.version = FALSE)
library(knitr)
opts_chunk$set(
prompt = T,
fig.align = "center",
dpi = 300,
cache = T,
engine.opts = list(bash = "-l")
)
knit_hooks$set(
prompt = function(before, options, envir) {
options(
prompt = if (options$engine %in% c("sh", "bash", "zsh")) "$ " else "R> ",
continue = if (options$engine %in% c("sh", "bash", "zsh")) "$ " else "+ "
)
}
)
options(repos = c(CRAN = "https://cran.rstudio.com/"))
if (!require("fontawesome", character.only = TRUE)) {
install.packages("fontawesome", dependencies = TRUE)
library(fontawesome, character.only = TRUE)
}
```
# Laboratorio 3: Clasificación avanzada {background-color="#2d4563"}
## Objetivos del laboratorio
:::{style="margin-top: 30px; font-size: 28px;"}
:::{.columns}
:::{.column width=50%}
**Lo que vamos a hacer:**
1. Predecir participación electoral
2. Baseline con regresión logística
3. Ajustar un Random Forest con CV
4. Interpretar con VIP y PDP
5. Comparar modelos en el conjunto de test
:::
:::{.column width=50%}
**Lo que vamos a aprender:**
- [Random Forest]{.alert} para clasificación
- [Tuning]{.alert} de hiperparámetros con grilla
- [Interpretación]{.alert} de modelos complejos
- [Cuándo vale la pena la complejidad extra]{.alert}
[¡Trabajen en sus computadoras y pregunten si tienen dudas!]{.alert}
:::
:::
:::
# Parte 1: Preparación y baseline {background-color="#2d4563"}
## Cargar los paquetes necesarios
:::{style="margin-top: 30px; font-size: 24px;"}
```{r cargar-paquetes, message=FALSE, warning=FALSE, prompt=FALSE, echo=TRUE}
# Si algún paquete falta:
# install.packages(c("tidyverse", "tidymodels", "ranger", "vip", "pdp", "xgboost", "patchwork"))
library(tidyverse) # readr, dplyr, ggplot2, etc
library(tidymodels) # rsample, parsnip, recipes, workflows, tune, yardstick
library(ranger) # motor rápido para Random Forest
library(vip) # Variable Importance Plots
library(pdp) # Partial Dependence Plots
library(xgboost) # Gradient Boosting (apéndice 4)
library(patchwork) # combinar gráficos con +
set.seed(2026)
```
:::
## El dataset: Latinobarómetro (simulado)
:::{style="margin-top: 30px; font-size: 24px;"}
Vamos a trabajar con datos simulados inspirados en el [Latinobarómetro](https://www.latinobarometro.org/), una encuesta de opinión pública en América Latina:
- ~500 encuestados distribuidos en varios países de la región
- Combina variables [demográficas]{.alert} (edad, educación, ingreso, zona, género) con [actitudes políticas]{.alert} (confianza en instituciones, satisfacción, interés)
- Dos posibles variables objetivo en el mismo dataset:
- **`voto`** (sí/no): ¿el encuestado votó en la última elección? → [Lab 3 (clasificación)]{.alert}
- **`satisfaccion_vida`** (1-10): satisfacción general con la vida → [Lab 4 (regresión)]{.alert}
**En este laboratorio**, nuestro objetivo es predecir [`voto`]{.alert} usando los demás predictores
:::
## Descripción de las variables
:::{style="margin-top: 30px; font-size: 23px;"}
:::{.columns}
:::{.column width=55%}
**Variables numéricas**
| Variable | Descripción |
|----------|-------------|
| `edad` | Edad del encuestado |
| `educacion_anios` | Años de educación formal |
| `ingreso_hogar` | Ingreso mensual del hogar (USD) |
| `confianza_gobierno` | Confianza en el gobierno (1-10) |
| `confianza_justicia` | Confianza en el poder judicial (1-10) |
| `satisfaccion_democracia` | Satisfacción con la democracia (1-5) |
| `percepcion_economia` | Percepción de la economía (1-5) |
| `interes_politica` | Interés en política (0-10) |
| `satisfaccion_vida` | Satisfacción con la vida (Lab 4) |
:::
:::{.column width=45%}
**Variables categóricas**
| Variable | Valores |
|----------|---------|
| **`voto`** | sí / no (outcome) |
| `uso_internet` | nunca / semanal / diario |
| `zona` | urbano / rural |
| `genero` | masculino / femenino |
| `pais` | varios países |
:::
:::
:::
## Cargar y explorar los datos
:::{style="margin-top: 30px; font-size: 20px;"}
```{r cargar-datos, prompt=FALSE, echo=TRUE}
# Cargar el dataset (generado con datos/crear-datos.R)
datos <- read_csv("datos/latinobarometro_sim.csv", show_col_types = FALSE)
# Lean el archivo directo desde la web:
# datos <- read_csv("https://raw.githubusercontent.com/danilofreire/introduccion-ia-ucu/main/clases/dia-02/datos/latinobarometro_sim.csv", show_col_types = FALSE)
# Convertir variables categóricas a factores
# El orden de niveles en uso_internet y voto es importante para interpretación
# voto usa c("no", "si"), la misma convención del Día 1: "si" es la clase
# positiva y por eso pasamos event_level = "second" a las métricas
datos <- datos |>
mutate(
pais = factor(pais),
zona = factor(zona),
genero = factor(genero),
uso_internet = factor(uso_internet, levels = c("nunca", "semanal", "diario")),
voto = factor(voto, levels = c("no", "si"))
)
# Estructura y distribución del voto
glimpse(datos)
datos |> count(voto) |> mutate(proporcion = n / sum(n))
```
:::
## Dividir los datos
:::{style="margin-top: 30px; font-size: 22px;"}
```{r dividir-datos, prompt=FALSE, echo=TRUE}
# initial_split(): divide los datos aleatoriamente en train y test
# prop = 0.75: 75% para entrenamiento, 25% para test
# strata = voto: estratificar para mantener la proporción de clases
datos_split <- initial_split(datos, prop = 0.75, strata = voto)
datos_train <- training(datos_split)
datos_test <- testing(datos_split)
# Verificar proporciones
cat("Proporción en train:\n")
prop.table(table(datos_train$voto))
cat("\nProporción en test:\n")
prop.table(table(datos_test$voto))
```
:::
## Preprocesamiento con recipes
:::{style="margin-top: 30px; font-size: 20px;"}
```{r crear-receta, prompt=FALSE, echo=TRUE}
# recipe(): define el preprocesamiento como una "receta de cocina"
# voto ~ ...: la fórmula indica variable objetivo ~ predictores
receta <- recipe(voto ~ ., data = datos_train) |>
# step_rm(): excluir pais (alta cardinalidad) y satisfaccion_vida (outcome del Lab 4)
step_rm(pais, satisfaccion_vida) |>
# step_dummy(): convierte categóricas a variables indicadoras (0/1)
step_dummy(all_nominal_predictors()) |>
# step_normalize(): centra (media = 0) y escala (sd = 1) las numéricas
step_normalize(all_numeric_predictors()) |>
# step_zv(): elimina variables con varianza cero (constantes)
step_zv(all_predictors())
# prep(): estima los parámetros de la receta (ej: medias para normalizar)
# juice(): aplica la receta y devuelve los datos transformados
receta |> prep() |> juice() |> glimpse()
```
:::
## Modelo baseline: Regresión logística
:::{style="margin-top: 30px; font-size: 20px;"}
```{r modelo-baseline, prompt=FALSE, echo=TRUE}
# logistic_reg(): modelo de regresión logística
# set_engine("glm"): usar el motor glm de R base
# set_mode("classification"): tarea de clasificación (no regresión)
modelo_logit <- logistic_reg() |>
set_engine("glm") |>
set_mode("classification")
# workflow(): combina preprocesamiento (receta) + modelo + ajuste en una pipeline
ajuste_logit <- workflow() |>
add_recipe(receta) |> # agregar la receta de preprocesamiento
add_model(modelo_logit) |> # agregar el modelo
fit(data = datos_train) # ajustar a los datos de entrenamiento
# augment(): genera predicciones y métricas para cada observación
pred_logit <- augment(ajuste_logit, datos_test)
# metric_set(): las cuatro métricas que usaremos en todo el lab
mis_metricas <- metric_set(accuracy, precision, recall, roc_auc)
# truth: variable real, estimate: predicción de clase, .pred_si: probabilidades
# event_level = "second": "si" es la clase positiva (igual que en el Día 1)
metricas_logit <- pred_logit |>
mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second")
metricas_logit
```
[En la sesión 2.2 vimos `last_fit()`, que hace `fit()` + predicciones + métricas en una sola llamada. Acá guardamos las predicciones aparte porque las vamos a reusar en la matriz de confusión, la curva ROC y la comparación final]{.alert}
:::
## Matriz de confusión del baseline
:::{style="margin-top: 30px; font-size: 22px;"}
```{r confusion-baseline, prompt=FALSE, echo=TRUE, fig.width=5, fig.height=4, out.width="50%"}
# conf_mat(): construye la tabla de predicho vs. real
# autoplot(type = "heatmap"): visualización como mapa de calor
conf_mat(pred_logit, truth = voto, estimate = .pred_class) |>
autoplot(type = "heatmap") +
labs(title = "Matriz de confusión - Regresión logística")
```
:::
## Ejercicio 1: Umbral óptimo {#sec:exercise01}
:::{style="margin-top: 30px; font-size: 20px;"}
Por defecto, clasificamos como "sí" si P(sí) > 0.5. Pero este umbral (threshold) puede no ser óptimo
**Tarea:** ejecuten el código abajo (compara F1 con tres umbrales) y respondan:
1. ¿Qué umbral da el F1 más alto?
2. ¿Cómo cambia el F1 cuando subimos el umbral? ¿Por qué?
```{r ej1-codigo, eval=FALSE, prompt=FALSE, echo=TRUE}
# F1 para tres umbrales distintos
umbrales <- c(0.3, 0.5, 0.7)
for (umbral in umbrales) {
# 1. Clasificar como "si" si la probabilidad supera el umbral
pred_umbral <- pred_logit |>
mutate(
clase = ifelse(.pred_si > umbral, "si", "no"),
clase = factor(clase, levels = c("no", "si"))
)
# 2. Calcular el F1 de esas predicciones ("si" es la clase positiva)
f1 <- f_meas(pred_umbral, truth = voto, estimate = clase,
event_level = "second")
# 3. Mostrar el umbral y su F1
cat("Umbral", umbral, "→ F1 =", round(f1$.estimate, 3), "\n")
}
```
:::{.callout-note}
**¿Por qué F1 y no precisión o recall?** F1 [combina ambas]{.alert} y obliga al modelo a encontrar un equilibrio. Si fuera un test de cáncer (falso negativo = paciente sin diagnosticar) usaríamos [recall]{.alert}. Si fuera un sistema de recomendación (falso positivo = recomendar algo malo) usaríamos [precisión]{.alert}. Aquí ambos errores son igual de problemáticos, así que F1 nos da el equilibrio.
:::
[¡Tómense 3-5 minutos!]{.alert}
[[Apéndice 1: Solución]{.button}](#sec:appendix01)
:::
# Parte 2: Random Forest con tuning {background-color="#2d4563"}
## Definir Random Forest con hiperparámetros a ajustar
:::{style="margin-top: 30px; font-size: 22px;"}
```{r rf-tune-spec, prompt=FALSE, echo=TRUE}
# rand_forest(): modelo de Random Forest
# tune(): marcador especial que indica "optimizar este valor automáticamente"
modelo_rf_tune <- rand_forest(
mtry = tune(), # Número de variables a considerar en cada split
trees = 500, # Número de árboles (fijo, no se optimiza)
min_n = tune() # Mínimo de observaciones en nodo terminal
) |>
# importance = "permutation": importancia por permutación (la usaremos en el VIP)
set_engine("ranger", importance = "permutation") |> # ranger es un motor rápido para Random Forest
set_mode("classification")
# workflow(): combina receta + modelo
wf_rf_tune <- workflow() |>
add_recipe(receta) |>
add_model(modelo_rf_tune)
```
:::
## Crear la grilla de búsqueda
:::{style="margin-top: 30px; font-size: 22px;"}
```{r crear-grilla, prompt=FALSE, echo=TRUE}
# grid_regular(): crea una grilla con valores uniformemente espaciados
# Cada parámetro tiene un rango definido; levels indica cuántos valores probar
grilla_rf <- grid_regular(
mtry(range = c(2, 8)), # De 2 a 8 variables por split
min_n(range = c(5, 30)), # De 5 a 30 obs mínimas por nodo
levels = c(4, 4) # 4 valores de cada uno = 4 x 4 = 16 combinaciones
)
# Ver la grilla
grilla_rf
# Alternativa: grilla aleatoria (más eficiente para muchos hiperparámetros)
# grilla_rf <- grid_random(
# mtry(range = c(2, 8)),
# min_n(range = c(5, 30)),
# size = 20 # 20 combinaciones aleatorias
# )
```
:::
## Configurar validación cruzada
:::{style="margin-top: 30px; font-size: 20px;"}
```{r crear-folds, prompt=FALSE, echo=TRUE}
# vfold_cv(): divide los datos en v grupos (folds) para validación cruzada
# strata = voto: estratificar para que cada fold mantenga la proporción de clases
folds <- vfold_cv(datos_train, v = 10, strata = voto)
# Ver los folds
folds
# Cada fold tiene 9/10 de los datos en training y 1/10 en assessment
```
:::{.callout-note}
Con 10 folds las estimaciones son más estables que con 5, y para este tamaño de dataset corre en pocos segundos. Para datasets mucho más grandes (>10K observaciones), 5 folds es un compromiso razonable entre estabilidad y tiempo de cómputo.
:::
:::
## Ejecutar el tuning
:::{style="margin-top: 30px; font-size: 20px;"}
```{r ejecutar-tuning, prompt=FALSE, echo=TRUE, cache=TRUE}
# tune_grid(): evalúa cada combinación de hiperparámetros con CV
# Para cada combinación de la grilla, entrena el modelo en cada fold
# y calcula las métricas especificadas
resultados_tune <- tune_grid(
wf_rf_tune, # el workflow con tune() pendientes
resamples = folds, # los folds de validación cruzada
grid = grilla_rf, # la grilla de combinaciones a probar
# metric_set(): para elegir hiperparámetros alcanza con roc_auc
metrics = metric_set(roc_auc),
control = control_grid(verbose = FALSE) # no imprimir progreso
)
# collect_metrics(): extrae los resultados promediados de todos los folds
resultados_tune |>
collect_metrics() |>
filter(.metric == "roc_auc") |>
arrange(desc(mean))
```
:::
## Seleccionar y ajustar el modelo final
:::{style="margin-top: 30px; font-size: 20px;"}
```{r ajustar-final, prompt=FALSE, echo=TRUE}
# select_best(): elige la combinación con el mejor valor de la métrica
mejor_rf <- select_best(resultados_tune, metric = "roc_auc")
mejor_rf
# finalize_workflow(): reemplaza los tune() por los valores óptimos;
# luego fit() ajusta con todos los datos de entrenamiento, en una pipeline
ajuste_rf <- wf_rf_tune |>
finalize_workflow(mejor_rf) |>
fit(data = datos_train)
# Predicciones y métricas en test
pred_rf <- augment(ajuste_rf, datos_test)
metricas_rf <- pred_rf |>
mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second")
cat("Regresión logística:\n"); print(metricas_logit)
cat("\nRandom Forest:\n"); print(metricas_rf)
```
:::
## Curva ROC comparativa
:::{style="margin-top: 30px; font-size: 22px;"}
```{r curva-roc, prompt=FALSE, echo=TRUE, fig.width=8, fig.height=6}
# roc_curve(): calcula sensibilidad y especificidad para cada umbral
# truth: la variable real, .pred_si: probabilidades predichas
roc_logit <- pred_logit |>
roc_curve(truth = voto, .pred_si, event_level = "second") |>
mutate(modelo = "Regresión logística")
roc_rf <- pred_rf |>
roc_curve(truth = voto, .pred_si, event_level = "second") |>
mutate(modelo = "Random Forest")
# Combinar y graficar
bind_rows(roc_logit, roc_rf) |>
ggplot(aes(x = 1 - specificity, y = sensitivity, color = modelo)) +
geom_path(linewidth = 1.2) +
geom_abline(linetype = "dashed", color = "gray50") +
coord_equal() +
labs(title = "Comparación de curvas ROC",
x = "1 - Especificidad (Tasa de falsos positivos)",
y = "Sensibilidad (Tasa de verdaderos positivos)",
color = "Modelo") +
theme_minimal()
```
:::
# Parte 3: Interpretación {background-color="#2d4563"}
## Importancia de variables
:::{style="margin-top: 30px; font-size: 22px;"}
:::{.columns}
:::{.column width=60%}
```{r vip-gini, prompt=FALSE, echo=TRUE, fig.width=8, fig.height=5}
rf_parsnip <- extract_fit_parsnip(ajuste_rf)
vip(rf_parsnip, num_features = 15) +
labs(title = "Importancia de variables") +
theme_minimal()
```
:::
:::{.column width=40%}
**Lo que vemos**
- [Edad]{.alert} es el predictor más fuerte, seguida por educación e ingreso
- [Interés en política]{.alert} es la actitud más predictiva
- Confianza en justicia supera a confianza en el gobierno
- [Género, zona, internet]{.alert}: baja importancia
:::{.callout-warning}
Importancia mide [predictibilidad]{.alert}, no efecto causal: que la edad importe no significa que "envejecer causa votar"
:::
:::
:::
:::
## Partial Dependence Plots
:::{style="margin-top: 30px; font-size: 20px;"}
```{r pdp-combinado, prompt=FALSE, echo=TRUE, fig.width=12, fig.height=3.5}
rf_engine <- extract_fit_engine(ajuste_rf)
datos_prep <- bake(prep(receta), new_data = datos_train)
# partial() calcula el efecto marginal sobre P(voto = "si")
pdp_edad <- partial(rf_engine, pred.var = "edad",
train = datos_prep, prob = TRUE, which.class = "si")
pdp_interes <- partial(rf_engine, pred.var = "interes_politica",
train = datos_prep, prob = TRUE, which.class = "si")
autoplot(pdp_edad) + labs(title = "Edad", y = "P(voto = sí)") +
autoplot(pdp_interes) + labs(title = "Interés en política", y = NULL) &
theme_minimal()
```
:::{.columns}
:::{.column width=55%}
**Interpretación**
- [Edad]{.alert}: la probabilidad de votar aumenta con la edad; el efecto se acelera entre los más viejos
- [Interés en política]{.alert}: relación monotónica y aproximadamente lineal
:::
:::{.column width=45%}
:::{.callout-tip}
**PDPs vs. coeficientes**: si el PDP es aproximadamente lineal → la regresión logística podría bastar. Si tiene curvas o mesetas → Random Forest captura patrones que otros modelos pierden
:::
:::
:::
:::
## Ejercicio 2: Análisis por país {#sec:exercise02}
:::{style="margin-top: 30px; font-size: 22px;"}
**Instrucciones:**
1. Filtrar los datos para Uruguay solamente
2. Entrenar el mismo modelo de Random Forest (sin tuning, con hiperparámetros fijos)
3. ¿Cambia la importancia de las variables?
4. ¿La edad sigue siendo el predictor más importante?
```{r ejercicio-2, eval=FALSE, prompt=FALSE, echo=TRUE}
# Tu código aquí
datos_uruguay <- datos |>
filter(pais == "Uruguay")
# Crear receta y workflow, ajustar el modelo...
# Comparar el VIP con el modelo general
```
[Pista: con pocos datos, usen hiperparámetros fijos en vez de tuning]{.alert}
[[Apéndice 2: Solución]{.button}](#sec:appendix02)
:::
# Parte 4: Discusión y cierre {background-color="#2d4563"}
## ¿Cuál modelo elegir?
:::{style="margin-top: 30px; font-size: 24px;"}
:::{.columns}
:::{.column width=50%}
**Si el objetivo es [predicción pura]{.alert}:**
- Elegir el modelo con mejor AUC
- Random Forest suele superar a la regresión logística
- La interpretabilidad es secundaria
**Si el objetivo es [entender los factores]{.alert}:**
- Regresión logística da coeficientes interpretables
- Random Forest con VIP + PDP es un compromiso
:::
:::{.column width=50%}
**Consideraciones prácticas:**
- [Tiempo]{.alert}: RF es más lento que la regresión logística
- [Explicabilidad]{.alert}: ¿Podemos justificar las predicciones?
- [Mejora marginal]{.alert}: ¿Vale la pena 2% más de AUC?
[En ciencias sociales, la interpretabilidad suele ser tan importante como el rendimiento]{.alert}
[[Apéndice 3: árbol de decisión]{.button}](#sec:appendix03) · [[Apéndice 4: XGBoost opcional]{.button}](#sec:appendix04)
:::
:::
:::
## Resumen del laboratorio
:::{style="margin-top: 30px; font-size: 24px;"}
:::{.columns}
:::{.column width=50%}
**Lo que practicamos:**
- Flujo completo de clasificación
- Tuning de hiperparámetros con CV
- Interpretación con VIP y PDP
- Comparación de modelos en test
:::
:::{.column width=50%}
**Conceptos clave:**
- [tune()]{.alert} marca hiperparámetros a ajustar
- [grid_regular()]{.alert} crea combinaciones
- [tune_grid()]{.alert} evalúa con CV
- [select_best()]{.alert} elige la mejor combinación
- [finalize_workflow()]{.alert} aplica los valores
:::
:::
[En el próximo laboratorio aplicaremos estos conceptos a regresión]{.alert}
:::
# Continuar con el laboratorio de regresión {background-color="#2d4563"}
# Apéndice: Soluciones {background-color="#2d4563"}
## Apéndice 1: Umbral óptimo {#sec:appendix01}
:::{style="margin-top: 20px; font-size: 20px;"}
**Respuestas:**
1. El umbral cercano a [0.4-0.5]{.alert} suele dar el F1 más alto (varía según la muestra)
2. Al subir el umbral el modelo predice "sí" con más cautela: la **precisión** sube (menos falsos positivos) pero el **recall** baja (perdemos casos reales). El F1 balancea ambos, así que crece hasta cierto punto y después baja
**Versión extendida** — barrer umbrales finos (cada 0.05) y graficar la curva:
```{r ap1-sol, prompt=FALSE, echo=TRUE, eval=TRUE, fig.width=8, fig.height=3.5}
umbrales <- seq(0.3, 0.7, by = 0.05)
resultados <- data.frame(umbral = numeric(), f1 = numeric())
for (t in umbrales) {
pred_nuevo <- pred_logit |>
mutate(.pred_class_nuevo = factor(
ifelse(.pred_si > t, "si", "no"), levels = c("no", "si")))
f1 <- f_meas(pred_nuevo, truth = voto, estimate = .pred_class_nuevo,
event_level = "second")
resultados <- rbind(resultados,
data.frame(umbral = t, f1 = f1$.estimate))
}
resultados |> arrange(desc(f1))
ggplot(resultados, aes(x = umbral, y = f1)) +
geom_line(linewidth = 1.2, color = "#2d4563") +
geom_point(size = 3, color = "#2d4563") +
labs(title = "F1 según el umbral",
x = "Umbral", y = "F1") +
theme_minimal()
```
- El umbral óptimo depende del [costo relativo]{.alert} de cada tipo de error: si los falsos positivos son caros, subir; si los falsos negativos son caros, bajar
[[Volver al ejercicio]{.button}](#sec:exercise01)
:::
## Apéndice 2: Análisis por país {#sec:appendix02}
:::{style="margin-top: 20px; font-size: 20px;"}
```{r ap2-sol, prompt=FALSE, echo=TRUE, eval=TRUE, fig.width=10, fig.height=5}
# Filtrar datos de Uruguay
datos_uruguay <- datos |> filter(pais == "Uruguay")
cat("Observaciones en Uruguay:", nrow(datos_uruguay), "\n")
# Con pocos datos (~31 obs), no dividimos en train/test
# Entrenamos con todo el subconjunto solo para comparar VIP
receta_uy <- recipe(voto ~ ., data = datos_uruguay) |>
step_rm(pais, satisfaccion_vida) |>
step_dummy(all_nominal_predictors()) |>
step_normalize(all_numeric_predictors()) |>
step_zv(all_predictors())
modelo_rf_uy <- rand_forest(trees = 500, mtry = 4, min_n = 3) |>
set_engine("ranger", importance = "permutation") |>
set_mode("classification")
ajuste_rf_uy <- workflow() |>
add_recipe(receta_uy) |>
add_model(modelo_rf_uy) |>
fit(data = datos_uruguay)
# Comparar importancia de variables
vip(extract_fit_parsnip(ajuste_rf_uy), num_features = 10) +
labs(title = "Importancia de variables - solo Uruguay",
subtitle = paste0("n = ", nrow(datos_uruguay), " observaciones")) +
theme_minimal()
```
- Con tan pocos datos (~31 obs), los resultados son [inestables]{.alert}: cambian con la semilla
- El ranking de importancia puede diferir del modelo general
- Para conclusiones confiables a nivel país, necesitaríamos [muestras más grandes]{.alert}
[[Volver al ejercicio]{.button}](#sec:exercise02)
:::
## Apéndice 3: Árbol de decisión {#sec:appendix03}
:::{style="margin-top: 20px; font-size: 20px;"}
```{r ap3-sol, prompt=FALSE, echo=TRUE, eval=TRUE, cache=TRUE}
# Modelo de árbol con costo de complejidad a ajustar
modelo_arbol <- decision_tree(
cost_complexity = tune(),
tree_depth = 10,
min_n = 10
) |>
set_engine("rpart") |>
set_mode("classification")
# Workflow con la misma receta
wf_arbol <- workflow() |>
add_recipe(receta) |>
add_model(modelo_arbol)
# Grilla de búsqueda para cost_complexity
# range en escala log10: 10^-4 = 0.0001 a 10^-1 = 0.1
grilla_arbol <- grid_regular(
cost_complexity(range = c(-4, -1)),
levels = 10
)
# Tuning con validación cruzada (reutilizamos folds)
resultados_arbol <- tune_grid(
wf_arbol,
resamples = folds,
grid = grilla_arbol,
metrics = metric_set(roc_auc),
control = control_grid(verbose = FALSE)
)
# Mejor modelo
mejor_arbol <- select_best(resultados_arbol, metric = "roc_auc")
cat("Mejor cost_complexity:", mejor_arbol$cost_complexity, "\n")
```
```{r ap3-eval, prompt=FALSE, echo=TRUE, eval=TRUE, fig.width=10, fig.height=5}
# Ajustar y evaluar (finalize_workflow + fit en una pipeline)
ajuste_arbol <- wf_arbol |>
finalize_workflow(mejor_arbol) |>
fit(data = datos_train)
pred_arbol <- augment(ajuste_arbol, datos_test)
# Comparar métricas
cat("Árbol de decisión:\n")
print(pred_arbol |> mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second"))
cat("\nRandom Forest:\n")
print(metricas_rf)
# Visualizar el tuning
autoplot(resultados_arbol) +
theme_minimal() +
labs(title = "Tuning del árbol de decisión")
```
- El árbol de decisión suele tener [menor AUC]{.alert} que Random Forest
- A cambio, es mucho más [interpretable]{.alert}: se puede visualizar como un diagrama de flujo
- `cost_complexity` controla la poda: valores más altos producen árboles más simples
:::
## Apéndice 4: XGBoost opcional {#sec:appendix04}
:::{style="margin-top: 20px; font-size: 18px;"}
```{r ap4-xgb, prompt=FALSE, echo=TRUE, eval=TRUE, cache=TRUE}
# boost_tree(): Gradient Boosting (árboles secuenciales)
# tree_depth y learn_rate a optimizar; min_n fijo
modelo_xgb <- boost_tree(
trees = 500,
tree_depth = tune(),
learn_rate = tune(),
min_n = 10
) |>
set_engine("xgboost") |>
set_mode("classification")
wf_xgb <- workflow() |>
add_recipe(receta) |>
add_model(modelo_xgb)
# learn_rate en escala log10: 10^-3 a 10^-1
grilla_xgb <- grid_regular(
tree_depth(range = c(3, 8)),
learn_rate(range = c(-3, -1)),
levels = c(3, 3)
)
resultados_xgb <- tune_grid(
wf_xgb, resamples = folds, grid = grilla_xgb,
metrics = metric_set(roc_auc),
control = control_grid(verbose = FALSE)
)
mejor_xgb <- select_best(resultados_xgb, metric = "roc_auc")
ajuste_xgb <- wf_xgb |>
finalize_workflow(mejor_xgb) |>
fit(data = datos_train)
# Predicciones y comparación final
pred_xgb <- augment(ajuste_xgb, datos_test)
bind_rows(
pred_logit |> mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second") |>
mutate(modelo = "Regresión logística"),
pred_rf |> mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second") |>
mutate(modelo = "Random Forest"),
pred_xgb |> mis_metricas(truth = voto, estimate = .pred_class, .pred_si,
event_level = "second") |>
mutate(modelo = "XGBoost")
) |>
select(modelo, .metric, .estimate) |>
pivot_wider(names_from = .metric, values_from = .estimate) |>
arrange(desc(roc_auc))
```
- XGBoost suele igualar o superar a Random Forest en datasets tabulares
- Requiere más tuning (tree_depth, learn_rate, trees) y más tiempo de cómputo
- En ciencias sociales, la mejora marginal rara vez justifica la pérdida de interpretabilidad
:::