Ganador 2023 según elecciones anteriores

Análisis electoral

Predecir al ganador de las elecciones 2023 según elecciones anteriores

Este análisis se realiza en el contexto del módulo “Machine Learning en Aplicaciones Espaciales” del curso de FLACSO “Big Data e Inteligencia Territorial”. El objetivo es predecir, utilizando resultados electorales históricos (2011-2019, elecciones presidenciales generales), el ganador de las elecciones generales 2023 en Argentina a nivel de sección electoral (también llamado departamento). Es el primer nivel de desagregación dentro de cada provincia. Se aplicará un modelo de Random Forest.

Cargamos las librerías.

library(tidyverse)
library(tidymodels)
library(sf)
library(themis) # función step_downsample
library(spatialsample) # para probar muestreo espacial
library(vip) # importancia de variables
set.seed(42)

Procesamiento

Se toman los resultados electorales entre 2011 y 2023, sólo para elecciones presidenciales y tomando la primera vuelta de cada elección (es decir, ni PASO ni balotaje). No se toman estos dos escenarios para evitar tener varias columnas con información excesivamente similar. Los resultados electorales a nivel sección electoral están tomados de https://datacp.streamlit.app/ que facilitó la limpieza de la información.

Se realiza una pequeña limpieza previa para trabajar de manera más cómoda con la base de datos.

path_pre <- 'bases/2011_2023_por_seccion_electoral/241222_elecciones_presidente_completas.csv'
df <- read_csv(path_pre) %>% 
  mutate(tipo='presidente') %>% 
  rename_with(tolower) %>% 
  filter(grepl('GENERA', elecciones)) %>% 
  filter(id != "TIERRA DEL FUEGO_ANTARTIDA ARGENTINA")

alianza_jxc <- c('CAMBIEMOS','COALICION CIVICA-ARI','JUNTOS POR EL CAMBIO','UNION PARA EL DESARROLLO SOCIAL')
alianza_uxp <- c('UNION POR LA PATRIA','FRENTE PARA LA VICTORIA','FRENTE DE TODOS')
negativos <- c('NULO','IMPUGNADO','BLANCO')
lla <- c('LA LIBERTAD AVANZA')

df <- df %>% 
  # construimos una variable reducida para homogeneizar los distintos nombres que tienen las alianzas electorales a través de los años
  mutate(partido_reducido = case_when(
    partido %in% negativos ~ "negativo",
    partido %in% alianza_jxc ~ "alianza_jxc",
    partido %in% alianza_uxp ~ "alianza_uxp",
    partido %in% lla ~ "lla",
    TRUE ~ "otro")) %>% 
  # limpiamos algunos nombres para poder unir después con el archivo geográfico
  mutate(across('id', str_replace, 'Ñ', 'N'),
         across('id', str_replace, 'Ü', 'U')) %>% 
  mutate(id = case_when(
    id == "CHACO_1° DE MAYO"~"CHACO_1º DE MAYO",
    id == "TUCUMAN_JUAN BAUTISTA ALBERDI"~"TUCUMAN_JUAN B. ALBERDI",
    id == "TIERRA DEL FUEGO_TOLHUIN"~"TIERRA DEL FUEGO_RIO GRANDE",
    id == "JUJUY_DOCTOR MANUEL BELGRANO"~"JUJUY_DR. MANUEL BELGRANO",
    id == "SAN LUIS_JUAN MARTIN DE PUEYRREDON"~"SAN LUIS_LA CAPITAL",
    id == "ENTRE RIOS_PARANA - CAMPANA"~"ENTRE RIOS_PARANA",
    id == "SANTA FE_LA CAPITAL CAMP."~"SANTA FE_LA CAPITAL",
    id == "SANTA FE_ROSARIO BARR."~"SANTA FE_ROSARIO",
    id == "SANTA FE_ROSARIO CAMP."~"SANTA FE_ROSARIO",
    id == "BUENOS AIRES_LEZAMA"~"BUENOS AIRES_CHASCOMUS",
    TRUE ~ id)
         )
dim(df)

[1] 18953    12

# chequeamos equivalencias
df %>% 
  group_by(partido, partido_reducido) %>% 
  summarise(votos = sum(votos)) %>% 
  spread(partido_reducido, votos) %>% 
  arrange(desc(otro)) %>% 
  arrange(desc(alianza_jxc)) %>% 
  arrange(desc(alianza_uxp)) %>% 
  arrange(desc(lla)) %>% 
  kableExtra::kable() %>% 
  kableExtra::kable_styling()

partido	alianza_jxc	alianza_uxp	lla	negativo	otro
LA LIBERTAD AVANZA	NA	NA	7884199	NA	NA
FRENTE PARA LA VICTORIA	NA	20288438	NA	NA	NA
FRENTE DE TODOS	NA	12473704	NA	NA	NA
UNION POR LA PATRIA	NA	9645975	NA	NA	NA
JUNTOS POR EL CAMBIO	16737613	NA	NA	NA	NA
CAMBIEMOS	8382512	NA	NA	NA	NA
UNION PARA EL DESARROLLO SOCIAL	2364606	NA	NA	NA	NA
COALICION CIVICA-ARI	386857	NA	NA	NA	NA
UNIDOS POR UNA NUEVA ALTERNATIVA (UNA)	NA	NA	NA	NA	5211672
FRENTE AMPLIO PROGRESISTA	NA	NA	NA	NA	3378100
COMPROMISO FEDERAL	NA	NA	NA	NA	2091863
HACEMOS POR NUESTRO PAIS	NA	NA	NA	NA	1784309
CONSENSO FEDERAL	NA	NA	NA	NA	1599705
FRENTE DE IZQUIERDA Y DE LOS TRABAJADORES	NA	NA	NA	NA	1283130
FRENTE DE IZQUIERDA Y DE TRABAJADORES - UNIDAD	NA	NA	NA	NA	1271142
FRENTE POPULAR	NA	NA	NA	NA	1240618
PROGRESISTAS	NA	NA	NA	NA	619049
FRENTE NOS	NA	NA	NA	NA	443506
UNITE POR LA LIBERTAD Y LA DIGNIDAD	NA	NA	NA	NA	382816
BLANCO	NA	NA	NA	2215157	NA
IMPUGNADO	NA	NA	NA	103226	NA
NULO	NA	NA	NA	842870	NA

# graficamos los totales de votos para ver que tenga sentido el agrupamiento 
options(scipen = 999) 
df %>% 
  group_by(elecciones, partido_reducido) %>% 
  summarise(votos = sum(votos)) %>% 
  ggplot(aes(x=reorder(partido_reducido,votos), y=votos, fill=partido_reducido))+
  geom_col()+
  scale_y_continuous(labels = label_number(scale_cut = cut_short_scale()))+
  coord_flip()+
  facet_wrap(~elecciones, ncol=2)+
  scale_fill_manual(values=c("orange","blue","purple","black","seagreen"))+
  theme_minimal()+
  labs(x="")

Para trabajar con problemas de predicción, el formato ideal es wide: en cada fila una observación (en este caso, un departamento) y en cada columna las distintas variables que vamos a predecir. En este caso, resultados de cada partido en elecciones anteriores y el partido ganador en cada departamento para cada elección.

ganadores <- df %>% 
  select(id, elecciones, partido_reducido, porcentaje) %>% 
  group_by(id, elecciones) %>% 
  slice_max(porcentaje, n=1, with_ties=F) %>% 
  select(id, elecciones, partido_reducido) %>% 
  pivot_wider(names_from=elecciones, 
              values_from=partido_reducido, 
              names_prefix="ganador_")

df_wide <- df %>% 
  group_by(id, elecciones, partido_reducido) %>% 
  summarise(porcentaje = sum(porcentaje)) %>% 
  pivot_wider(id_cols="id", names_from=c('elecciones','partido_reducido'), values_from='porcentaje') %>% 
  left_join(ganadores, by='id') %>% 
  mutate(target = case_when(`ganador_GENERALES 2023` == "lla"~"lla", 
                            T ~ "otro"))
df_wide %>% 
  head() %>% 
  kableExtra::kable() %>% 
  kableExtra::kable_styling()

id	GENERALES 2011_alianza_jxc	GENERALES 2011_alianza_uxp	GENERALES 2011_negativo	GENERALES 2011_otro	GENERALES 2015_alianza_jxc	GENERALES 2015_alianza_uxp	GENERALES 2015_negativo	GENERALES 2015_otro	GENERALES 2019_alianza_jxc	GENERALES 2019_alianza_uxp	GENERALES 2019_negativo	GENERALES 2019_otro	GENERALES 2023_alianza_jxc	GENERALES 2023_alianza_uxp	GENERALES 2023_lla	GENERALES 2023_negativo	GENERALES 2023_otro	ganador_GENERALES 2011	ganador_GENERALES 2015	ganador_GENERALES 2019	ganador_GENERALES 2023	target
BUENOS AIRES_25 DE MAYO	17.28	50.88	5.33	31.84	40.60	29.27	4.53	30.13	49.88	42.30	2.89	7.82	32.17	32.05	29.90	4.47	5.87	alianza_uxp	alianza_jxc	alianza_jxc	alianza_jxc	otro
BUENOS AIRES_9 DE JULIO	25.32	46.36	3.43	28.31	45.84	29.87	2.35	24.29	51.20	39.29	1.99	9.50	33.97	27.44	31.07	2.85	7.52	alianza_uxp	alianza_jxc	alianza_jxc	alianza_jxc	otro
BUENOS AIRES_ADOLFO ALSINA	23.94	38.42	3.82	37.63	50.58	28.00	3.67	21.41	51.96	38.07	2.43	9.97	33.50	25.53	33.46	4.07	7.51	alianza_uxp	alianza_jxc	alianza_jxc	alianza_jxc	otro
BUENOS AIRES_ADOLFO GONZALES CHAVES	13.96	58.81	12.64	27.23	32.27	42.55	5.59	25.19	37.32	54.59	5.82	8.10	24.81	38.38	29.66	6.38	7.15	alianza_uxp	alianza_uxp	alianza_uxp	alianza_uxp	otro
BUENOS AIRES_ALBERTI	27.68	49.66	5.81	22.67	42.36	38.00	3.01	19.64	46.70	45.36	3.16	7.95	29.70	35.49	28.54	3.73	6.27	alianza_uxp	alianza_jxc	alianza_jxc	alianza_uxp	otro
BUENOS AIRES_ALMIRANTE BROWN	7.89	64.38	3.58	27.73	26.44	42.96	3.14	30.60	26.73	60.23	2.31	13.05	18.36	50.55	23.11	3.34	7.97	alianza_uxp	alianza_uxp	alianza_uxp	alianza_uxp	otro

En esta ocasión, se probará realizar un muestreo espacial para ver cómo varía el desempeño de nuestro modelo. Se carga el archivo geográfico de las secciones electorales para utilizar su disposición espacial desde https://www.indec.gob.ar/indec/web/Institucional-Indec-Codgeo.

Se observa el resultado.

geo %>% 
  ggplot()+
  geom_sf(aes(fill=densidad_q), color=NA)+
  scale_fill_brewer(palette="Spectral")+
  labs(title="Densidad (cuartiles)",
       subtitle='Argentina - por departamento')+
  theme_void()

geo %>% 
  ggplot()+
  geom_sf(aes(fill=personas_q), color=NA)+
  scale_fill_brewer(palette="Spectral")+
  labs(title="Personas (cuartiles)",
       subtitle='Argentina - por departamento')+
  theme_void()

Una vez que ambas bases están procesadas de manera correcta, unimos las dos bases. Además, se crean las variables de latitud y longitud que serán necesarias luego para realizar el muestreo espacial. Se define la variable target como factor para que “lla” sea tomada como la clase positiva para las métricas que se trabajarán luego.

# chequeamos cantidades. El que sobra son las Islas del Atlántico Sur
df  %>% distinct(id) %>% dim()

[1] 525   1

geo %>% as.data.frame() %>% distinct(id) %>% dim()

[1] 526   1

gdf <- full_join(df_wide, geo, by='id', keep=F) %>% 
  # se define como factor para que "lla" sea tomada como la clase positiva
  mutate(target = factor(target, levels=c("lla","otro")))

gdf$lat <- gdf %>%
  st_as_sf() %>%
  st_centroid() %>%
  st_coordinates() %>%
  as.data.frame() %>%
  select(Y)

gdf$lon <- gdf %>%
  st_as_sf() %>%
  st_centroid() %>%
  st_coordinates() %>%
  as.data.frame() %>%
  select(X)

table(gdf$target)

 lla otro 
 142  383 

class(gdf)

[1] "grouped_df" "tbl_df"     "tbl"        "data.frame"

Exploratorio

Así se distribuye la variable target.

gdf %>%
  st_as_sf() %>% 
  ggplot()+
  geom_sf(aes(fill=`ganador_GENERALES 2023`), color=NA)+
  scale_fill_manual(values=c("orange","blue","purple","seagreen"), na.value="white")+
  labs(title="Ganador generales 2023",
       subtitle='Argentina - por departamento')+
  theme_void()

Veamos rápidamente las variables que están en juego. Entre los departamentos donde ganó LLA en 2023 se ve mejor desempeño de otros partidos en 2011, de otros partidos y Cambiemos en 2015, de Juntos por el Cambio en 2019.

drop_cols <- c("id","link","geometry","lat","lon",
               'personas_q','densidad_q',
               'personas','densidad')

gdf %>% 
  as.data.frame() %>% 
  select(-drop_cols) %>%
  select(-contains('ganador')) %>% 
  pivot_longer(!target) %>% 
  drop_na() %>% 
  mutate(name = str_replace(name, "_", " "),
         name = str_replace(name, "GENERALES ", "G"),
         name = str_replace(name, "alianza_", "")) %>% 
  ggplot()+
  geom_boxplot(aes(x=target, y=value, fill=target), 
           show.legend = F)+
  facet_wrap(~name, scales="free") +
  labs(title="Variables cuantativas",
       subtitle="% por departamento")+
  theme_minimal()+ 
  theme(axis.text.y=element_blank(), 
      axis.ticks.y=element_blank()) 

De las variables de densidad y personas (por cuartiles) se desprende que LLA ganó en departamentos más poblados y con mayor densidad de personas.

gdf %>% 
  as.data.frame() %>% 
  select(target, personas_q, densidad_q) %>% 
  pivot_longer(!target) %>% 
  drop_na() %>% 
  group_by(target, name, value) %>% 
  summarise(count = n(), .groups = "drop") %>%  
  group_by(name, target) %>% 
  mutate(percent = count / sum(count) * 100) %>% 
  mutate(name = str_replace_all(name, "_q",""),
         value = str_replace_all(value, "q_",""),
         value = fct_relevel(value, "muy alto","alto","bajo","muy bajo")) %>% 
  ggplot() +
  geom_col(aes(x = percent, y = target, fill = value), 
           position = "stack", width = 0.6) +
  geom_text(aes(x = percent, y = target, 
                label = sprintf("%.1f%%", percent), 
                group = value), 
            position = position_stack(vjust = 0.5), 
            size = 3) +
  facet_wrap(~name) +
  labs(title = 'Variables categóricas (por cuartiles)',
       y = "", x = "", fill="") +
  theme_minimal() +
  scale_fill_brewer(palette = "Spectral", direction=-1)+
  theme(
    legend.position = "bottom",  # Mueve la leyenda debajo
    legend.direction = "horizontal"  # Dirección horizontal
  )+
  guides(
    fill = guide_legend(reverse = TRUE)  # Invierte el orden de la leyenda
  )

Modelado

El primer paso para construir un modelo es separar la base de entrenamiento de la de validación. Además, eliminamos cualquier columna del año 2023 para evitar filtrado de información. La proporción será de 80% para entrenamiento y 20% para validación y estará estratificado por la densidad de cada departamento.

drop_cols <- c("link","geometry")

gdf_split <- gdf %>% 
  ungroup() %>% 
  drop_na() %>% 
  as.data.frame() %>% 
  select(-drop_cols) %>% 
  select(-contains('2023')) # para evitar filtrado de información

p_split <- initial_split(gdf_split, prop = 0.8, strata = densidad_q)
train <- training(p_split)
test <- testing(p_split)

Se chequean las proporciones de las dos varaibles clave en la división de la base de datos.

prop.table(table(gdf$target)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Target en base original", digits=2) %>% kableExtra::kable_styling()

Target en base original

Partido	%
lla	0.27
otro	0.73

prop.table(table(train$target)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Target en base train", digits=2) %>% kableExtra::kable_styling()

Target en base train

Partido	%
lla	0.27
otro	0.73

prop.table(table(test$target)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Target en base test", digits=2) %>% kableExtra::kable_styling()

Target en base test

Partido	%
lla	0.27
otro	0.73

prop.table(table(gdf$densidad_q)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Densidad en base original", digits=2) %>% kableExtra::kable_styling()

Densidad en base original

Partido	%
q_muy bajo	0.25
q_bajo	0.25
q_alto	0.25
q_muy alto	0.25

prop.table(table(train$densidad_q)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Densidad en base train", digits=2) %>% kableExtra::kable_styling()

Densidad en base train

Partido	%
q_muy bajo	0.25
q_bajo	0.25
q_alto	0.25
q_muy alto	0.25

prop.table(table(test$densidad_q)) %>% kableExtra::kable(col.names=c("Partido","%"), caption="Densidad en base test", digits=2) %>% kableExtra::kable_styling()

Densidad en base test

Partido	%
q_muy bajo	0.25
q_bajo	0.25
q_alto	0.25
q_muy alto	0.25

Definimos las particiones, tanto de manera clásica como teniendo en cuenta la distribución espacial.

n_folds <- 5
p_folds <- vfold_cv(train, v=n_folds, strata = target)


spatial_folds <- spatial_clustering_cv(train, v = n_folds, coords=c("lat","lon"))

Creamos la receta. En este caso, la fórmula incluirá todas las variables del dataset (21). Se listan para mayor claridad.

train %>% dim()

[1] 417  23

train %>% names() %>% kableExtra::kable() %>% kableExtra::kable_styling()

x
id
GENERALES 2011_alianza_jxc
GENERALES 2011_alianza_uxp
GENERALES 2011_negativo
GENERALES 2011_otro
GENERALES 2015_alianza_jxc
GENERALES 2015_alianza_uxp
GENERALES 2015_negativo
GENERALES 2015_otro
GENERALES 2019_alianza_jxc
GENERALES 2019_alianza_uxp
GENERALES 2019_negativo
GENERALES 2019_otro
ganador_GENERALES 2011
ganador_GENERALES 2015
ganador_GENERALES 2019
target
personas
personas_q
densidad
densidad_q
lat
lon

En la receta agregamos tres pasos. Primero, se eliminan las variables que se utilizaron para el muestreo espacial (lat, lon) y el id. Luego, se normalizan las variables numéricas. Por último, se convierten en dummies las variables categóricas. Debido al desbalanceo del dataset, se probó también realizar un submuestreo (o downsample) para evitar que las métricas estén basadas en el desempeño de la clase mayoritaria, aunque finalmente no se utilizó. Se logró trabajar esta problemática desde la métrica y no desde el muestreo para evitar perder casos, debido a que la base de datos es algo pequeña para trabajar con problemas de predicción (son sólo 525 observaciones en total y 417 para el entrenamiento).

rf_recipe <- recipe(target ~ ., 
                    data = train) %>%
  step_rm(lat, lon, id) %>% 
  step_normalize(all_numeric_predictors()) %>% 
  step_dummy(all_nominal_predictors())# %>% 
  #step_downsample(target) 

El modelo a utilizar es un Random Forest donde se ajustarán las variables de mtry (cantidad de predictores elegidos aleatoriamente en cada iteración) y min_n (mínimo requerido de observaciones en un nodo para que vuelva a dividirse) según el método de cross validation que se definió antes. La cantidad de árboles se fijó en 1500 y el problema será de clasificación, ya que se estará prediciendo aquellas secciones electorales donde triunfó el partido La Libertad Avanza en las elecciones generales de 2023.

rf_tune <- rand_forest(
  mtry = tune(),
  trees = 1500,
  min_n = tune()
) %>%
  set_mode("classification") %>%
  set_engine("ranger", importance = "permutation")

Se define el flujo de trabajo, agregando la receta y el modelo.

tune_wf <- workflow() %>%
  add_recipe(rf_recipe) %>%
  add_model(rf_tune)

Se observarán las métricas de F1, área bajo la curva y accuracy. Al tener clases desbalanceadas, accuracy puede ser algo engañosa, por lo que se priorizarán las otras dos métricas.

f_meas <- function(data, truth, estimate, na_rm = TRUE, ...) {
  yardstick::f_meas(
    data = data,
    truth = !!rlang::enquo(truth),
    estimate = !!rlang::enquo(estimate),
    estimator = "macro", # útil en caso de tener problemas con más de 2 clases
  )
}
f_meas <- new_class_metric(f_meas, "maximize")
metrics <- metric_set(f_meas, roc_auc, accuracy)

Antes de seguir con la implementación del modelo Random Forest, sería adecuado hacer una prueba con un modelo más simple para entender cuánto le aporta a la predicción la implementación de un modelo más complejo. Es decir, qué tanto mejoran las métricas al consumir más tiempo y recursos en el modelo. Se utilizará una regresión logística para usar de baseline.

lr_tune <- logistic_reg() %>% 
  set_mode("classification") %>% 
  set_engine("glm")

tune_lr <- workflow() %>%
  add_recipe(rf_recipe) %>%
  add_model(lr_tune)

baseline <- tune_grid(tune_lr, 
                      resamples=p_folds, 
                      metrics=metrics,
                      grid=50)

baseline %>% 
  collect_metrics() %>% 
  kableExtra::kable(digits=3, caption="Métricas para la regresión logística") %>% 
  kableExtra::kable_styling()

Métricas para la regresión logística

.metric	.estimator	mean	n	std_err	.config
accuracy	binary	0.836	5	0.003	Preprocessor1_Model1
f_meas	macro	0.783	5	0.003	Preprocessor1_Model1
roc_auc	binary	0.855	5	0.010	Preprocessor1_Model1

Finalmente, se realiza el entrenamiento del modelo. Aquí definimos una grilla con 50 combinaciones de mtry y min_n. Se realiza un entrenamiento por cada método de muestreo.

doParallel::registerDoParallel()

grid_n = 50

tune <-tune_grid(tune_wf,
                 resamples = p_folds,
                 metrics=metrics,
                 grid = grid_n
                 )

spatial_tune <- tune_grid(tune_wf,
                          resamples = spatial_folds,
                          metrics=metrics,
                          grid = grid_n
                          )

Se observan los distintos mejores resultados para cada métrica. Se ve que F1 y el área bajo la curva dan distintos valores óptimos de mrty y min_n. Priorizamos el área bajo la curva por ser agnóstica ante el umbral de clasificación. Además, las métricas del muestreo clásico son mejores que las del muestreo espacial y que los resultados de la regresión logística.

# vemos que F1 y roc_auc dan distintos valores óptimos de mrty y min_n. Priorizamos roc_auc por ser agnóstica ante el umbral de clasificación
tune %>% 
  collect_metrics() %>% 
  filter(.metric!="accuracy") %>% 
  group_by(.metric) %>%
  slice_max(order_by = mean, n = 3) %>% 
  ungroup() %>% 
  kableExtra::kable(digits=3, caption="Top 3 casos para F1 y Curva ROC") %>% 
  kableExtra::kable_styling()

Top 3 casos para F1 y Curva ROC

mtry	min_n	.metric	.estimator	mean	n	std_err	.config
26	3	f_meas	macro	0.843	5	0.018	Preprocessor1_Model45
18	9	f_meas	macro	0.841	5	0.007	Preprocessor1_Model38
25	16	f_meas	macro	0.840	5	0.011	Preprocessor1_Model29
9	2	roc_auc	binary	0.928	5	0.011	Preprocessor1_Model50
8	4	roc_auc	binary	0.927	5	0.013	Preprocessor1_Model08
5	8	roc_auc	binary	0.925	5	0.012	Preprocessor1_Model21

show_best(tune, metric = "roc_auc") %>% 
  kableExtra::kable(digits=3, caption="TOP Curva ROC para muestreo clásico") %>% 
  kableExtra::kable_styling()

TOP Curva ROC para muestreo clásico

mtry	min_n	.metric	.estimator	mean	n	std_err	.config
9	2	roc_auc	binary	0.928	5	0.011	Preprocessor1_Model50
8	4	roc_auc	binary	0.927	5	0.013	Preprocessor1_Model08
5	8	roc_auc	binary	0.925	5	0.012	Preprocessor1_Model21
8	8	roc_auc	binary	0.924	5	0.012	Preprocessor1_Model04
21	5	roc_auc	binary	0.922	5	0.015	Preprocessor1_Model47

show_best(spatial_tune, metric = "roc_auc") %>% 
  kableExtra::kable(digits=3, caption="TOP Curva ROC para muestreo espacial") %>% 
  kableExtra::kable_styling()

TOP Curva ROC para muestreo espacial

mtry	min_n	.metric	.estimator	mean	n	std_err	.config
1	6	roc_auc	binary	0.844	5	0.026	Preprocessor1_Model04
5	7	roc_auc	binary	0.833	5	0.021	Preprocessor1_Model13
5	6	roc_auc	binary	0.833	5	0.022	Preprocessor1_Model28
2	40	roc_auc	binary	0.833	5	0.027	Preprocessor1_Model21
4	12	roc_auc	binary	0.832	5	0.023	Preprocessor1_Model10

Se observan las distintas pruebas que se realizaron en el entrenamiento. Se observa un comportamiento interesante con la optimización de mtry con el muestreo espacial: mientras que el accuracy se incrementa con mayores valores de mtry, lo contrario sucede con el área bajo la curva.

tune %>%
  collect_metrics() %>% 
  select(.metric, mean, min_n, mtry) %>%
  pivot_longer(min_n:mtry,
    values_to = "value",
    names_to = "parameter"
  ) %>% 
  ggplot(aes(value, mean, color = parameter)) +
  geom_point(show.legend = FALSE) +
  facet_grid(cols=vars(parameter), rows=vars(.metric), scales='free')+
  labs(title="Métricas \nmuestreo clásico")+
  theme_minimal()

spatial_tune %>%
  collect_metrics() %>% 
  select(.metric, mean, min_n, mtry) %>%
  pivot_longer(min_n:mtry,
    values_to = "value",
    names_to = "parameter"
  ) %>% 
  ggplot(aes(value, mean, color = parameter)) +
  geom_point(show.legend = FALSE) +
  facet_grid(cols=vars(parameter), rows=vars(.metric), scales='free')+
  labs(title="Métricas \nmuestreo espacial")+
  theme_minimal()

Se ve más claro al graficar las tres variables (mtry, min_n y roc_auc) en un mismo gráfico. Se ven relaciones distintas en los distintos muestreos.

tune %>% 
  collect_metrics() %>% 
  filter(.metric=="roc_auc") %>% 
  ggplot()+
  geom_point(aes(x=min_n, y=mtry, size=mean, color=mean))+
  labs(title='Valores de ROC AUC con muestreo clásico',
  subtitle='según la combinación de mtry y min_n')+
  theme_minimal()

spatial_tune %>% 
  collect_metrics() %>% 
  filter(.metric=="roc_auc") %>% 
  ggplot()+
  geom_point(aes(x=min_n, y=mtry, size=mean, color=mean))+
  labs(title='Valores de ROC AUC con muestreo espacial',
  subtitle='según la combinación de mtry y min_n')+
  theme_minimal()

Se selecciona el mejor modelo en cada caso. Se observa que son valores similares (bajos) para ambas variables.

best <- select_best(tune, metric = "roc_auc")
best %>% 
  kableExtra::kable(digits=3, caption="Mejor modelo para muestreo clásico") %>% 
  kableExtra::kable_styling()

Mejor modelo para muestreo clásico

mtry	min_n	.config
9	2	Preprocessor1_Model50

best_sp <- select_best(spatial_tune, metric = "roc_auc")
best_sp %>% 
  kableExtra::kable(digits=3, caption="Mejor modelo para muestreo espacial") %>% 
  kableExtra::kable_styling()

Mejor modelo para muestreo espacial

mtry	min_n	.config
1	6	Preprocessor1_Model04

Se finaliza el flujo de trabajo, optimizando el modelo con el mejor resultado.

final_rf <- finalize_workflow(
  tune_wf,
  best
)
final_rf

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: rand_forest()

── Preprocessor ────────────────────────────────────────────────────────────────
3 Recipe Steps

• step_rm()
• step_normalize()
• step_dummy()

── Model ───────────────────────────────────────────────────────────────────────
Random Forest Model Specification (classification)

Main Arguments:
  mtry = 9
  trees = 1500
  min_n = 2

Engine-Specific Arguments:
  importance = permutation

Computational engine: ranger 

final_rf_sp <- finalize_workflow(
  tune_wf,
  best_sp
)
final_rf_sp

══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: rand_forest()

── Preprocessor ────────────────────────────────────────────────────────────────
3 Recipe Steps

• step_rm()
• step_normalize()
• step_dummy()

── Model ───────────────────────────────────────────────────────────────────────
Random Forest Model Specification (classification)

Main Arguments:
  mtry = 1
  trees = 1500
  min_n = 6

Engine-Specific Arguments:
  importance = permutation

Computational engine: ranger 

Se utiliza el workflow definido para aplicar sobre la base de validación.

final_res <- last_fit(final_rf, p_split, metrics=metrics)

# Obtener los valores verdaderos y predichos
predictions <- final_res %>%
  collect_predictions() %>% 
  mutate(muestreo = "clásico")

final_res_sp <- last_fit(final_rf_sp, p_split, metrics=metrics)

# Obtener los valores verdaderos y predichos
predictions_sp <- final_res_sp %>%
  collect_predictions() %>% 
  mutate(muestreo = "espacial")

Se observan las métricas sobre la base de validación. En el caso del muestreo clásico los resultados son similares. En el caso del muestreo espacial, los valores sobre test son mayores que los de train, una situación atípica.

# métricas de train
tune %>% 
  collect_metrics() %>% 
  group_by(.metric) %>%
  slice_max(order_by = mean, n = 1) %>% 
  ungroup() %>% 
  arrange(.metric) %>% 
  kableExtra::kable(digits=3, caption="Métricas de train. Muestreo clásico.") %>% 
  kableExtra::kable_styling()

Métricas de train. Muestreo clásico.

mtry	min_n	.metric	.estimator	mean	n	std_err	.config
26	3	accuracy	binary	0.880	5	0.015	Preprocessor1_Model45
26	3	f_meas	macro	0.843	5	0.018	Preprocessor1_Model45
9	2	roc_auc	binary	0.928	5	0.011	Preprocessor1_Model50

# métricas de test
final_res %>% 
  collect_metrics() %>% 
  arrange(.metric)%>% 
  kableExtra::kable(digits=3, caption="Métricas de test. Muestreo clásico.") %>% 
  kableExtra::kable_styling()

Métricas de test. Muestreo clásico.

.metric	.estimator	.estimate	.config
accuracy	binary	0.898	Preprocessor1_Model1
f_meas	macro	0.862	Preprocessor1_Model1
roc_auc	binary	0.936	Preprocessor1_Model1

# métricas de train
spatial_tune %>% 
  collect_metrics() %>% 
  group_by(.metric) %>%
  slice_max(order_by = mean, n = 1) %>% 
  ungroup() %>% 
  arrange(.metric)%>% 
  kableExtra::kable(digits=3, caption="Métricas de train. Muestreo espacial.") %>% 
  kableExtra::kable_styling()

Métricas de train. Muestreo espacial.

mtry	min_n	.metric	.estimator	mean	n	std_err	.config
23	8	accuracy	binary	0.713	5	0.080	Preprocessor1_Model16
23	16	accuracy	binary	0.713	5	0.080	Preprocessor1_Model36
23	8	f_meas	macro	0.617	5	0.066	Preprocessor1_Model16
23	16	f_meas	macro	0.617	5	0.066	Preprocessor1_Model36
1	6	roc_auc	binary	0.844	5	0.026	Preprocessor1_Model04

# métricas de test
final_res_sp %>% 
  collect_metrics() %>% 
  arrange(.metric)%>% 
  kableExtra::kable(digits=3, caption="Métricas de test. Muestreo espacial.") %>% 
  kableExtra::kable_styling()

Métricas de test. Muestreo espacial.

.metric	.estimator	.estimate	.config
accuracy	binary	0.824	Preprocessor1_Model1
f_meas	macro	0.703	Preprocessor1_Model1
roc_auc	binary	0.869	Preprocessor1_Model1

Se grafica la matriz de confusión. Nos interesan los resultados sobre la clase LLA: se predicen adecuadamente un 72.4% de los departamentos donde ganó LLA en 2023. Por otro lado, un 87.5% de los casos predichos como LLA resultaron correctos.

conf_mat <- cvms::confusion_matrix(targets = predictions$target,
                             predictions = predictions$.pred_class)

cvms::plot_confusion_matrix(conf_mat$`Confusion Matrix`[[1]],
                            add_sums=T) + labs(title="Matriz de confusión / muestreo clásico")

conf_mat <- cvms::confusion_matrix(targets = predictions_sp$target,
                             predictions = predictions_sp$.pred_class)

cvms::plot_confusion_matrix(conf_mat$`Confusion Matrix`[[1]],
                            add_sums=T) + labs(title="Matriz de confusión / muestreo espacial")

Graficamos curva ROC para ambos muestreos. El muestreo clásico tiene un área bajo la curva mayor.

predictions %>% 
  bind_rows(predictions_sp) %>% 
  group_by(muestreo) %>% 
  roc_curve(target, .pred_lla) %>% 
  autoplot() +
  labs(title="Curva ROC",
  subtitle="ambos tipos de muestreos")

Se pueden observar los resultados de otra forma: el resultado en % vs las probabilidades que devuelve el modelo.

predictions %>% 
  rename(id_split = id,
         target_split = target) %>% 
  bind_cols(test) %>% 
  left_join(select(gdf,c("id","GENERALES 2023_lla")), by="id") %>% 
  ggplot() +
  geom_point(aes(y=.pred_lla, x=`GENERALES 2023_lla`, colour=target_split))+
  labs(title="Resultado electoral vs probabilidad del modelo",
       subtitle = "Comparación entre el % obtenido en las elecciones vs la probabilidad del modelo")+
  theme_minimal()

Resultados

Se realiza una lectura sobre la importancia de variables. El resultado de la alianza UxP en 2019 es la más importante (probablemente ayude a distinguir los casos donde NO ganó LLA en 2023).

final_fit <- final_rf %>%
  fit(data = train)

vip(pull_workflow_fit(final_fit)$fit, geom = "point") + 
  labs(title="Importancia de variables / muestreo clásico") + 
  theme_minimal()

final_fit <- final_rf_sp %>%
  fit(data = train)

vip(pull_workflow_fit(final_fit)$fit, geom = "point") + 
  labs(title="Importancia de variables / muestreo espacial") + 
  theme_minimal()

La relación que se observa es: mayor resultado de UxP entre target=“otro”. La relación contraria se observa con los resultados de los otros partidos que no son ni UxP ni JxC.

gdf %>% 
  ggplot(aes(x=target, y=`GENERALES 2019_alianza_uxp`, fill=target))+
  geom_boxplot(show.legend=F)+
  labs(
    title="Alianza UxP - Resultado elecciones generales 2019",
       subtitle='según target')+
  theme_minimal()

gdf %>% 
  ggplot(aes(x=target, y=`GENERALES 2019_otro`, fill=target))+
  geom_boxplot(show.legend=F)+
  labs(
    title="Otros partidos - Resultado elecciones generales 2019",
       subtitle='según target')+
  theme_minimal()

Verificamos la fuga de cada alianza. A ambas alianzas LLA le conquista aproximadamente 70 secciones electorales, pero sobre niveles iniciales muy distintos (141 en el caso de JxC, 383 en el caso de UxP).

gdf %>% 
  group_by(`ganador_GENERALES 2019`,`ganador_GENERALES 2023`) %>% 
  tally() %>% 
  arrange(desc(n)) %>% 
  kableExtra::kable(caption="Fuga por alianza") %>% 
  kableExtra::kable_styling()

Fuga por alianza

ganador_GENERALES 2019	ganador_GENERALES 2023	n
alianza_uxp	alianza_uxp	303
alianza_jxc	lla	72
alianza_uxp	lla	70
alianza_jxc	alianza_jxc	45
alianza_jxc	alianza_uxp	20
alianza_uxp	alianza_jxc	6
alianza_jxc	otro	4
alianza_uxp	otro	4
negativo	alianza_uxp	1
NA	NA	1

gdf %>% 
  group_by(`ganador_GENERALES 2019`) %>% 
  tally() %>% 
  kableExtra::kable(caption="Total de departamentos ganados en 2019") %>% 
  kableExtra::kable_styling()

Total de departamentos ganados en 2019

ganador_GENERALES 2019	n
alianza_jxc	141
alianza_uxp	383
negativo	1
NA	1