LOGIT ORDINAL MULTIMODAL
SEBASTIAN VALENCIA Y FLAVIO CASTILLO
2026-04-02
Preparación y depuración de la base de datos
Carga y limpieza de la información
# Leer el archivo Excel desde la ruta especificada y guardar en df
df <- read_excel("C:/JOHAN SEBASTIAN/MAESTRIA - CIENCIA DE DATOS/TERCER SEMESTRE/PROYECTO APLICADO III/df_limpio.xlsx")
# Eliminar columnas administrativas/identificadoras que no aportan al modelo
df <- df %>%
dplyr::select(
-numero_banco, -fecha_prox_ven, -tipo_cartera,
-fecha_inicio_op, -fecha_ven_op, -tipo_identificacion,
-mo_nombre_cliente, -id
) %>%
mutate(across(where(is.character), as.factor)) # Convertir texto a factor
options(encoding = "UTF-8")
Sys.setlocale("LC_ALL", "es_ES.UTF-8")## [1] "LC_COLLATE=es_ES.UTF-8;LC_CTYPE=es_ES.UTF-8;LC_MONETARY=es_ES.UTF-8;LC_NUMERIC=C;LC_TIME=es_ES.UTF-8"Recodificación de variables categóricas
# Fusionar categorías poco frecuentes o similares en "Tipo Factor Externo"
df$`Tipo Factor Externo` <- fct_collapse(
df$`Tipo Factor Externo`,
Económico = c("Económico", "Orden Público") # Unir categorías similares
)
# Agrupar categorías con menos de 30 obs en "Other" para evitar sobreajuste
df$hecho_victimizante <- fct_lump_min(df$hecho_victimizante, min = 30)
# En tasa_referencial hay tres niveles con muy pocas observaciones:
# "SIN TASA DE REFERENCIA" (2 obs), "TASA LIMITE DE USURA CARTERA COMERCIAL" (2 obs)
# y "TASA LIMITE DE USURA CARTERA MICROCREDITO" (1 obs).
# Se colapsan en "Otras_tasas" para resolver el problema.
df$tasa_referencial <- fct_collapse(
df$tasa_referencial,
IBR_SEMESTRAL = "INDICADOR BANCARIO DE REFERENCIA SEMESTRAL",
IBR_MENSUAL = "INDICADOR BANCARIO DE REFERENCIA MENSUAL",
IBR_TRIMESTRAL = "INDICADOR BANCARIO DE REFERENCIA TRIMESTRAL",
Otras_tasas = c(
"SIN TASA DE REFERENCIA",
"TASA LIMITE DE USURA CARTERA COMERCIAL",
"TASA LIMITE DE USURA CARTERA MICROCREDITO"
)
)
cat("tasa_referencial tras recodificación:\n")## tasa_referencial tras recodificación:##
## DTF EFECTIVO ANUAL IBR_MENSUAL IBR_SEMESTRAL IBR_TRIMESTRAL
## 7612 251 44703 1722
## Otras_tasas TASA CERO
## 15 1151Selección de variables predictoras
var_sele <- c(
"tipo_de_producto", "tasa_referencial", "tipo_productor_pmg",
"destino_agrupado", "Banca_cliente", "mo_modalidad",
"Departamento_Inversion", "cuotas_pactadas", "Tipo Factor Externo",
"monto_desembolso", "saldo", "COMPARATIVO_OCURRENCIA_HECHO",
"genero", "hecho_victimizante", "dias_vencido"
)
df_modelo <- df[, var_sele] %>%
rename(Tipo_Factor_Externo = `Tipo Factor Externo`)
df_modelo <- df[, var_sele]
df_modelo$tipo_de_producto <- fct_lump_min(df_modelo$tipo_de_producto, 50)
df_modelo$Departamento_Inversion <- fct_lump_min(df_modelo$Departamento_Inversion, 30)
table(df_modelo$tipo_de_producto)##
## CAP TRABAJO MICROCREDITO MULTIDESTINO CAP TRABAJO MUJER MICROEMPRESARIA
## 81 364
## CAP. TRABAJO PROYECTO MICROCREDITO CAPITAL DE TRABAJO ORDINARIA FINAGRO
## 65 2626
## INV. VICTIMA CONFLICTO ARMADO INTERNO INVERSION - COMP. ANIM.Y RETEN.VIENTRES
## 1702 90
## INVERSION - PLANTACION Y MANTENIMIENTO INVERSION MUJER MICROEMPRESARIA
## 2682 327
## INVERSIÓN MULTIDESTINO IBR INVERSION MULTIDESTINO MICRO
## 105 109
## INVERSION ORDINARIA FINAGRO INVERSIÓN PROYECTO MICROCREDITO
## 46859 77
## MICROCREDITO ECONOMIA POPULAR RP NORMALIZACION DE RECURSOS FINAGRO IBR
## 125 65
## Other
## 177##
## Cauca Choco Nariño Valle del Cauca Other
## 25524 101 27662 2099 68Construcción de la variable dependiente
Definición del target binario
# Definir los niveles del target en orden ascendente de severidad de mora.
NIVELES_TARGET <- c("1-30", "31-90", "91+")
df_solo_mora <- df_modelo %>%
mutate(
dias_num = as.numeric(gsub("[^0-9]", "", as.character(dias_vencido)))
# gsub("[^0-9]", "", ...) elimina todo carácter que NO sea dígito.
# Esto maneja casos donde dias_vencido llega como "30 días" o con caracteres
# especiales.
) %>%
filter(!is.na(dias_num), dias_num > 0) %>%
# !is.na(dias_num): elimina filas donde dias_vencido era texto no numérico
# dias_num > 0: conserva SOLO clientes EN mora. Los clientes al día tienen
mutate(
target_bancario = factor(
case_when(
dias_num <= 30 ~ "1-30",
dias_num <= 90 ~ "31-90",
TRUE ~ "91+"
),
levels = NIVELES_TARGET,
ordered = TRUE
# Le indica a R que hay un orden intrínseco
# entre las categorías (1-30 < 31-90 < 91+)
)
) %>%
filter(!is.na(target_bancario)) %>%
# Eliminar filas donde el target quedó como NA
dplyr::select(-dias_vencido, -dias_num) %>%
# Eliminar las columnas usadas para construir el target.
# dias_vencido NO puede quedarse como predictor porque contiene exactamente
# la misma información que el target — causaría fuga de datos total.
mutate(across(where(is.factor), droplevels))
# Volver a eliminar niveles vacíos después del filtro de mora.
# Diagnósticos obligatorios antes de continuar
cat("\nDistribución target_bancario:\n")##
## Distribución target_bancario:##
## 1-30 31-90 91+
## 977 2671 3543##
## Proporción (%):##
## 1-30 31-90 91+
## 13.59 37.14 49.27# prop.table convierte frecuencias absolutas a proporciones.
# Multiplicar por 100 y redondear a 2 decimales da el porcentaje de cada clase.
cat("\nRatio desbalance:",
round(max(table(df_solo_mora$target_bancario)) /
min(table(df_solo_mora$target_bancario)), 2), ":1\n")##
## Ratio desbalance: 3.63 :1# Calcula cuántas veces es más frecuente la clase más grande vs la más pequeña.
# Un ratio > 3:1 indica desbalance que justifica usar pesos en el modelo.
cat("\nFrecuencia mo_modalidad:\n")##
## Frecuencia mo_modalidad:##
## AV MV SV TV
## 1392 342 5313 144Partición y preprocesamiento de datos
Se dividió la base de datos en:
- 70% para entrenamiento
- 30% para validación
# createDataPartition garantiza que cada categoría del target quede representada
train_idx <- createDataPartition(
df_solo_mora$target_bancario,
p = 0.7,
list = FALSE
)
train_raw <- df_solo_mora[ train_idx, ] # Filas seleccionadas → conjunto de entrenamiento
test_raw <- df_solo_mora[-train_idx, ] # Filas restantes → conjunto de prueba (nunca toca el modelo)
cat("\nTrain:", nrow(train_raw), "| Test:", nrow(test_raw), "\n")##
## Train: 5035 | Test: 2156##
## Distribución TRAIN:##
## 1-30 31-90 91+
## 684 1870 2481##
## Distribución TEST:##
## 1-30 31-90 91+
## 293 801 1062LUMP — aprender en TRAIN, aplicar a TEST (sin data leakage)
Esta función colapsa los niveles poco frecuentes de una variable categórica en una categoría “Other”, previniendo que el modelo intente estimar coeficientes con muy pocas observaciones (inestabilidad numérica).
aplicar_lump <- function(train_col, test_col, min_n) {
niveles_ok <- names(which(table(train_col) >= min_n))
# table(train_col): cuenta observaciones por nivel en train
# which(...>= min_n): índices de niveles que superan el umbral mínimo
# names(...): nombres de esos niveles — son los que se conservan tal cual
recodificar <- function(x) {
x_char <- as.character(x) # Convertir factor a texto para manipular
x_char[!x_char %in% niveles_ok] <- "Other" # Los niveles raros → "Other"
factor(x_char, levels = c(niveles_ok, "Other"))
# Reconstruir como factor con los niveles válidos + "Other" al final
}
list(train = recodificar(train_col), test = recodificar(test_col))
# Aplicar la misma recodificación (aprendida de train) a ambas columnas
}
# Umbrales mínimos de observaciones por nivel, definidos variable por variable.
# El criterio es que cada nivel tenga suficientes observaciones para que
# polr() pueda estimar un coeficiente con error estándar finito.
lump_vars <- list(
tipo_de_producto = 80, # Productos con < 80 obs en train → "Other"
Departamento_Inversion = 50, # Departamentos con < 50 obs → "Other"
tasa_referencial = 50, # Tasas con < 50 obs → "Other"
hecho_victimizante = 50 # Hechos victimizantes con < 50 obs → "Other"
)
for (var in names(lump_vars)) {
# Para cada variable en la lista, aplicar el lump y sobrescribir las columnas
resultado <- aplicar_lump(train_raw[[var]], test_raw[[var]], lump_vars[[var]])
train_raw[[var]] <- resultado$train # Columna recodificada en train
test_raw[[var]] <- resultado$test # Misma recodificación aplicada a test
}
cat("\nNiveles tasa_referencial (train):\n")##
## Niveles tasa_referencial (train):##
## DTF EFECTIVO ANUAL IBR_SEMESTRAL IBR_TRIMESTRAL TASA CERO
## 1017 3789 96 97
## Other
## 36# Verificar que los niveles retenidos tienen suficientes observaciones
# y que "Other" no acumula demasiados casos (señal de umbral muy agresivo)FILTRO DE DEPARTAMENTOS — SOLO sobre train
Identificar departamentos que tienen al menos 30 observaciones en train. Con menos de 30 obs, polr() no puede estimar el coeficiente del nivel con suficiente estabilidad estadística.
depts_validos <- names(which(table(train_raw$Departamento_Inversion) >= 30))
# En TRAIN: eliminar filas cuyo departamento no alcanza el umbral.
# Estas filas no aportan información suficiente para estimar el coeficiente.
train_ord <- train_raw %>%
filter(Departamento_Inversion %in% depts_validos) %>%
mutate(Departamento_Inversion = droplevels(Departamento_Inversion))
# droplevels() elimina del factor los niveles de departamentos que ya no
# tienen filas, para que no aparezcan en tablas y no generen coeficientes NA
# En TEST: NO se eliminan filas — esto preserva el tamaño real del conjunto de prueba.
# Los departamentos no vistos en train se convierten en NA.
# Cuando se prediga con el modelo, esas filas producirán NA en la predicción,
# y luego complete.cases() las excluirá de la evaluación. Esto es metodológicamente
# correcto: el modelo simplemente no puede predecir para departamentos que no conoce.
test_ord <- test_raw %>%
mutate(
Departamento_Inversion = factor(
ifelse(
as.character(Departamento_Inversion) %in% depts_validos,
as.character(Departamento_Inversion), # Si el departamento es válido, conservar
NA # Si no es válido, convertir a NA
),
levels = levels(train_ord$Departamento_Inversion)
# Usar EXACTAMENTE los mismos niveles que en train_ord.
# Esto es obligatorio: polr() falla si test tiene niveles no vistos en train.
)
)
cat("\nDepartamentos retenidos:", paste(depts_validos, collapse = ", "), "\n")##
## Departamentos retenidos: Cauca, Nariño, Valle del Cauca, Other## Obs train: 5035 | Obs test: 2156ESCALADO NUMÉRICO — ajuste SOLO sobre train
# Escalar las variables numéricas usando preProcess de caret, que aprende los
# parámetros de escalado SOLO de train y luego los aplica a ambos conjuntos.
vars_num <- c("cuotas_pactadas", "monto_desembolso", "saldo")
preproc <- preProcess(
train_ord[, vars_num],
method = c("center", "scale")
)
# Resultado: cada variable tendrá media=0 y SD=1 en train (estandarización Z)
train_ord[, vars_num] <- predict(preproc, train_ord[, vars_num])
# Aplicar la transformación a train usando los parámetros aprendidos de train
test_ord[, vars_num] <- predict(preproc, test_ord[, vars_num])
# Aplicar la MISMA transformación a test usando los parámetros de train.ALINEACIÓN DE NIVELES TRAIN → TEST
# polr() fallaría al intentar predecir con un nivel que no conoce.
# Esta función detecta esos niveles y los convierte en NA en test.
alinear_niveles <- function(train_df, test_df, target_col = "target_bancario") {
vars_factor <- setdiff(
names(train_df)[sapply(train_df, is.factor)], # Todas las columnas factor en train
target_col # Excluir el target (no se toca)
)
for (col in vars_factor) {
if (!col %in% names(test_df)) next
# Si la columna no existe en test (caso raro), saltar
extra <- setdiff(levels(test_df[[col]]), levels(train_df[[col]]))
# Niveles que están en test pero NO en train — el modelo no los conoce
if (length(extra) > 0) {
cat("Variable:", col, "— niveles nuevos en test → NA:",
paste(extra, collapse = ", "), "\n")
test_df[[col]][test_df[[col]] %in% extra] <- NA
# Las observaciones con ese nivel desconocido se marcan como NA
}
test_df[[col]] <- factor(test_df[[col]], levels = levels(train_df[[col]]))
# Forzar que los niveles del factor en test sean exactamente los mismos
# que en train, en el mismo orden. Esto es obligatorio para polr().
}
cat("Alineación completada.\n")
return(test_df)
}
test_ord <- alinear_niveles(train_ord, test_ord)## Alineación completada.DIAGNÓSTICO DE SEPARACIÓN PERFECTA
La separación perfecta ocurre cuando un nivel de una variable categórica predice perfectamente una sola clase del target (100% de sus observaciones caen en una única categoría). En ese caso, polr() intenta estimar un coeficiente infinito, lo que produce SE=NA y advertencias de no convergencia.
diagnosticar_separacion <- function(df, target_col) {
vars_cat <- setdiff(names(df)[sapply(df, is.factor)], target_col)
hay_problemas <- FALSE
cat("\n=== Diagnóstico de separación perfecta ===\n")
for (v in vars_cat) {
tab <- table(df[[v]], df[[target_col]])
# Tabla de contingencia: filas = niveles de la variable, columnas = clases del target
prop_max <- apply(tab, 1, function(r) if (sum(r) > 0) max(r) / sum(r) else 0)
# Para cada nivel de la variable (cada fila de la tabla),
# calcular la proporción máxima que cae en una sola clase del target.
problemas <- names(prop_max[prop_max == 1 & rowSums(tab) > 0])
# Identificar qué niveles tienen separación perfecta (con al menos 1 observación)
if (length(problemas) > 0) {
hay_problemas <- TRUE
cat("ADVERTENCIA:", v, ":", paste(problemas, collapse = ", "), "\n")
print(tab[problemas, , drop = FALSE])
# Imprimir la tabla de contingencia solo para los niveles problemáticos
}
}
if (!hay_problemas) cat("Sin separación perfecta detectada.\n")
}
diagnosticar_separacion(train_ord, "target_bancario")##
## === Diagnóstico de separación perfecta ===
## Sin separación perfecta detectada.FÓRMULA COMPARTIDA
Se define una única fórmula que usan AMBOS modelos (sin pesos y con pesos). Tener una sola definición garantiza que cualquier cambio en las variables se propaga automáticamente a los dos modelos, sin riesgo de inconsistencias.
formula_ord <- target_bancario ~ tasa_referencial + tipo_productor_pmg +
Banca_cliente + mo_modalidad +
`Tipo Factor Externo` + genero +
monto_desembolso + saldo +
COMPARATIVO_OCURRENCIA_HECHO +
hecho_victimizante + tipo_de_producto +
Departamento_Inversion
# Índice de filas evaluables en test (sin NA en predictores)
# Se calcula UNA SOLA VEZ y se reutiliza en todos los modelos
idx_eval <- complete.cases(test_ord[, all.vars(formula_ord)[-1]])
cat("\nFilas evaluables:", sum(idx_eval), "/", nrow(test_ord), "\n")##
## Filas evaluables: 2156 / 2156## Filas perdidas por NA: 0Ajustar pesos para cada categoria
# PESOS POR CLASE — PREPARACIÓN
prop_real <- prop.table(table(train_ord$target_bancario))
cat("\nProporciones reales en train:\n")
print(round(prop_real, 4))
prop_objetivo <- setNames(c(0.30, 0.35, 0.35), NIVELES_TARGET)
weights_clase <- prop_objetivo / prop_real
cat("\nPesos por clase:\n")
print(round(weights_clase, 4))
#LÍNEA CRÍTICA: copia explícita ANTES de agregar el peso
train_ordw <- train_ord
train_ordw$w <- as.numeric(weights_clase[as.character(train_ordw$target_bancario)])
if (any(is.na(train_ordw$w))) stop("NAs en pesos — revisar nombres de niveles")
# Verificar separación entre objetos (diagnóstico)
cat("\n— train_ord tiene columna 'w':", "w" %in% names(train_ord),
"(debe ser FALSE)\n")
cat("— train_ordw tiene columna 'w':", "w" %in% names(train_ordw),
"(debe ser TRUE)\n")##
## Suma de pesos por clase:## 1-30 31-90 91+
## 1510.50 1762.25 1762.25FUNCIÓN AUXILIAR: evaluación completa — CORREGIDA para multiclass.roc()
# Predicción robusta para polr() (maneja NAs y formatos irregulares)
predecir_polr <- function(modelo, newdata, niveles) {
probs <- predict(modelo, newdata = newdata, type = "probs")
if (is.vector(probs)) probs <- matrix(probs, nrow = 1)
probs <- as.matrix(probs)
colnames(probs) <- niveles
clase <- factor(
niveles[apply(probs, 1, which.max)],
levels = niveles, ordered = TRUE
)
list(probs = probs, clase = clase)
}
# Evaluación completa multiclase — reutilizada por los 6 modelos
evaluar_modelo <- function(clase_pred, probs_pred, target_real,
idx_eval, niveles, nombre) {
cm <- confusionMatrix(clase_pred[idx_eval], target_real[idx_eval])
probs_eval <- probs_pred[idx_eval, ]
colnames(probs_eval) <- seq_along(niveles) # Requerido por multiclass.roc()
roc_obj <- multiclass.roc(
response = as.numeric(target_real[idx_eval]),
predictor = probs_eval,
quiet = TRUE
)
cat("\n======", nombre, "======\n")
print(cm)
cat("\nAccuracy :", round(cm$overall["Accuracy"], 4), "\n")
cat("Kappa :", round(cm$overall["Kappa"], 4), "\n")
cat("\nBalanced Accuracy por clase:\n")
print(round(cm$byClass[, "Balanced Accuracy"], 4))
cat("Sensitivity por clase:\n")
print(round(cm$byClass[, "Sensitivity"], 4))
cat("\nAUC multiclase (macro):", round(auc(roc_obj), 4), "\n")
list(cm = cm, roc = roc_obj)
}MODELO LOGIT SIN PESO
model_sp <- polr(
formula_ord,
data = train_ord, # Dataset SIN pesos — NO tiene columna w
method = "logistic",
Hess = TRUE
)
coefs_sp <- summary(model_sp)$coefficients
n_na_sp <- sum(is.na(coefs_sp[, "Std. Error"]))
if (n_na_sp > 0) {
cat("ADVERTENCIA:", n_na_sp, "coeficientes con SE=NA — revisar diagnóstico\n")
} else {
cat("Modelo sin pesos convergió correctamente\n")
}## Modelo sin pesos convergió correctamente## Call:
## polr(formula = formula_ord, data = train_ord, Hess = TRUE, method = "logistic")
##
## Coefficients:
## Value Std. Error
## tasa_referencialIBR_SEMESTRAL 0.67929 0.23936
## tasa_referencialIBR_TRIMESTRAL 1.44213 1.33214
## tasa_referencialTASA CERO 1.10945 0.95072
## tasa_referencialOther 1.50789 0.78181
## tipo_productor_pmgMICROFINANZAS 0.21877 1.17684
## tipo_productor_pmgNO AGROPECUARIO -1.51184 0.91359
## tipo_productor_pmgPEQUEÑO PRODUCTOR -0.51811 0.66750
## Banca_clienteMICROFINANZAS -0.02273 0.40299
## Banca_clientePERSONAL 0.32344 1.21769
## mo_modalidadMV -1.46099 0.36057
## mo_modalidadSV -0.31652 0.22668
## mo_modalidadTV -2.41764 1.31614
## `Tipo Factor Externo`Factores Naturales - Volcán -2.17186 0.49143
## `Tipo Factor Externo`Ola Invernal -0.39534 0.09061
## `Tipo Factor Externo`Sequía 1.46533 0.47967
## generoMASCULINO 0.20689 0.05579
## monto_desembolso 0.62748 0.06815
## saldo -0.87662 0.06636
## COMPARATIVO_OCURRENCIA_HECHONo reporta -0.16319 0.20355
## COMPARATIVO_OCURRENCIA_HECHOV-D -0.10633 0.18847
## hecho_victimizanteDesplazamiento y despojo 0.02738 0.27714
## hecho_victimizanteHomicidio - desaparicion -0.26425 0.32214
## hecho_victimizanteNo reporta -0.06567 0.28171
## hecho_victimizanteOther -0.49962 0.39942
## tipo_de_productoINV. VICTIMA CONFLICTO ARMADO INTERNO -0.59132 0.27842
## tipo_de_productoINVERSION - PLANTACION Y MANTENIMIENTO -0.37245 0.25540
## tipo_de_productoINVERSION ORDINARIA FINAGRO -0.50072 0.21836
## tipo_de_productoOther -1.30626 0.43839
## Departamento_InversionNariño -0.66616 0.06489
## Departamento_InversionValle del Cauca 0.14671 0.11843
## Departamento_InversionOther -0.30154 0.67456
## t value
## tasa_referencialIBR_SEMESTRAL 2.83794
## tasa_referencialIBR_TRIMESTRAL 1.08257
## tasa_referencialTASA CERO 1.16696
## tasa_referencialOther 1.92871
## tipo_productor_pmgMICROFINANZAS 0.18589
## tipo_productor_pmgNO AGROPECUARIO -1.65483
## tipo_productor_pmgPEQUEÑO PRODUCTOR -0.77619
## Banca_clienteMICROFINANZAS -0.05640
## Banca_clientePERSONAL 0.26562
## mo_modalidadMV -4.05188
## mo_modalidadSV -1.39633
## mo_modalidadTV -1.83692
## `Tipo Factor Externo`Factores Naturales - Volcán -4.41951
## `Tipo Factor Externo`Ola Invernal -4.36305
## `Tipo Factor Externo`Sequía 3.05485
## generoMASCULINO 3.70811
## monto_desembolso 9.20741
## saldo -13.21016
## COMPARATIVO_OCURRENCIA_HECHONo reporta -0.80174
## COMPARATIVO_OCURRENCIA_HECHOV-D -0.56416
## hecho_victimizanteDesplazamiento y despojo 0.09881
## hecho_victimizanteHomicidio - desaparicion -0.82029
## hecho_victimizanteNo reporta -0.23313
## hecho_victimizanteOther -1.25087
## tipo_de_productoINV. VICTIMA CONFLICTO ARMADO INTERNO -2.12382
## tipo_de_productoINVERSION - PLANTACION Y MANTENIMIENTO -1.45828
## tipo_de_productoINVERSION ORDINARIA FINAGRO -2.29309
## tipo_de_productoOther -2.97970
## Departamento_InversionNariño -10.26671
## Departamento_InversionValle del Cauca 1.23877
## Departamento_InversionOther -0.44701
##
## Intercepts:
## Value Std. Error t value
## 1-30|31-90 -3.3636 0.7780 -4.3233
## 31-90|91+ -1.3610 0.7765 -1.7527
##
## Residual Deviance: 9512.404
## AIC: 9578.404Matriz de confusion
pred_sp <- predecir_polr(model_sp, test_ord, NIVELES_TARGET)
eval_sp <- evaluar_modelo(pred_sp$clase, pred_sp$probs,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "LOGIT ORDINAL SIN PESOS")##
## ====== LOGIT ORDINAL SIN PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 10 4 11
## 31-90 165 190 255
## 91+ 118 607 796
##
## Overall Statistics
##
## Accuracy : 0.462
## 95% CI : (0.4408, 0.4833)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : 0.9979
##
## Kappa : 0.0142
##
## Mcnemar's Test P-Value : <2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.034130 0.23720 0.7495
## Specificity 0.991948 0.69004 0.3373
## Pos Pred Value 0.400000 0.31148 0.5233
## Neg Pred Value 0.867198 0.60479 0.5811
## Prevalence 0.135900 0.37152 0.4926
## Detection Rate 0.004638 0.08813 0.3692
## Detection Prevalence 0.011596 0.28293 0.7055
## Balanced Accuracy 0.513039 0.46362 0.5434
##
## Accuracy : 0.462
## Kappa : 0.0142
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.5130 0.4636 0.5434
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.0341 0.2372 0.7495
##
## AUC multiclase (macro): 0.5991MODELO LOGIT CON PESO
model_pw <- polr(
formula_ord,
data = train_ordw, # Dataset CON pesos — tiene columna w
weights = w,
method = "logistic",
Hess = TRUE
)## Warning in eval(family$initialize): non-integer #successes in a binomial glm!coefs_pw <- summary(model_pw)$coefficients
n_na_pw <- sum(is.na(coefs_pw[, "Std. Error"]))
if (n_na_pw > 0) {
cat("ADVERTENCIA:", n_na_pw, "coeficientes con SE=NA\n")
} else {
cat("Modelo ponderado convergió correctamente\n")
}## Modelo ponderado convergió correctamente## Call:
## polr(formula = formula_ord, data = train_ordw, weights = w, Hess = TRUE,
## method = "logistic")
##
## Coefficients:
## Value Std. Error
## tasa_referencialIBR_SEMESTRAL 0.86559 0.24624
## tasa_referencialIBR_TRIMESTRAL 0.70889 1.21881
## tasa_referencialTASA CERO 0.57678 0.80625
## tasa_referencialOther 1.13863 0.63339
## tipo_productor_pmgMICROFINANZAS 0.57888 1.01875
## tipo_productor_pmgNO AGROPECUARIO -1.24494 0.78216
## tipo_productor_pmgPEQUEÑO PRODUCTOR -0.35001 0.57116
## Banca_clienteMICROFINANZAS 0.33239 0.39859
## Banca_clientePERSONAL -0.22954 1.01759
## mo_modalidadMV -1.90241 0.34429
## mo_modalidadSV -0.68728 0.23330
## mo_modalidadTV -1.86822 1.20688
## `Tipo Factor Externo`Factores Naturales - Volcán -2.34469 0.44203
## `Tipo Factor Externo`Ola Invernal -0.08080 0.08768
## `Tipo Factor Externo`Sequía 1.73158 0.46998
## generoMASCULINO 0.13408 0.05459
## monto_desembolso 0.46307 0.06155
## saldo -0.76005 0.06284
## COMPARATIVO_OCURRENCIA_HECHONo reporta -0.22892 0.20102
## COMPARATIVO_OCURRENCIA_HECHOV-D -0.14772 0.18638
## hecho_victimizanteDesplazamiento y despojo -0.14443 0.27700
## hecho_victimizanteHomicidio - desaparicion -0.30120 0.32173
## hecho_victimizanteNo reporta -0.12003 0.28112
## hecho_victimizanteOther -0.61522 0.39159
## tipo_de_productoINV. VICTIMA CONFLICTO ARMADO INTERNO -0.12549 0.26131
## tipo_de_productoINVERSION - PLANTACION Y MANTENIMIENTO 0.08167 0.23816
## tipo_de_productoINVERSION ORDINARIA FINAGRO -0.03377 0.19475
## tipo_de_productoOther -0.95597 0.39684
## Departamento_InversionNariño -1.10497 0.06233
## Departamento_InversionValle del Cauca 0.30006 0.12157
## Departamento_InversionOther -0.33054 0.56780
## t value
## tasa_referencialIBR_SEMESTRAL 3.5152
## tasa_referencialIBR_TRIMESTRAL 0.5816
## tasa_referencialTASA CERO 0.7154
## tasa_referencialOther 1.7977
## tipo_productor_pmgMICROFINANZAS 0.5682
## tipo_productor_pmgNO AGROPECUARIO -1.5917
## tipo_productor_pmgPEQUEÑO PRODUCTOR -0.6128
## Banca_clienteMICROFINANZAS 0.8339
## Banca_clientePERSONAL -0.2256
## mo_modalidadMV -5.5255
## mo_modalidadSV -2.9459
## mo_modalidadTV -1.5480
## `Tipo Factor Externo`Factores Naturales - Volcán -5.3044
## `Tipo Factor Externo`Ola Invernal -0.9215
## `Tipo Factor Externo`Sequía 3.6843
## generoMASCULINO 2.4562
## monto_desembolso 7.5233
## saldo -12.0944
## COMPARATIVO_OCURRENCIA_HECHONo reporta -1.1388
## COMPARATIVO_OCURRENCIA_HECHOV-D -0.7926
## hecho_victimizanteDesplazamiento y despojo -0.5214
## hecho_victimizanteHomicidio - desaparicion -0.9362
## hecho_victimizanteNo reporta -0.4270
## hecho_victimizanteOther -1.5711
## tipo_de_productoINV. VICTIMA CONFLICTO ARMADO INTERNO -0.4802
## tipo_de_productoINVERSION - PLANTACION Y MANTENIMIENTO 0.3429
## tipo_de_productoINVERSION ORDINARIA FINAGRO -0.1734
## tipo_de_productoOther -2.4089
## Departamento_InversionNariño -17.7268
## Departamento_InversionValle del Cauca 2.4683
## Departamento_InversionOther -0.5821
##
## Intercepts:
## Value Std. Error t value
## 1-30|31-90 -2.0924 0.6831 -3.0631
## 31-90|91+ -0.4082 0.6824 -0.5982
##
## Residual Deviance: 10154.84
## AIC: 10220.84Matriz de confusion
pred_pw <- predecir_polr(model_pw, test_ord, NIVELES_TARGET)
eval_pw <- evaluar_modelo(pred_pw$clase, pred_pw$probs,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "LOGIT ORDINAL CON PESOS")##
## ====== LOGIT ORDINAL CON PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 180 120 216
## 31-90 73 237 328
## 91+ 40 444 518
##
## Overall Statistics
##
## Accuracy : 0.4337
## 95% CI : (0.4126, 0.4549)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0991
##
## Mcnemar's Test P-Value : <2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.61433 0.2959 0.4878
## Specificity 0.81965 0.7041 0.5576
## Pos Pred Value 0.34884 0.3715 0.5170
## Neg Pred Value 0.93110 0.6285 0.5286
## Prevalence 0.13590 0.3715 0.4926
## Detection Rate 0.08349 0.1099 0.2403
## Detection Prevalence 0.23933 0.2959 0.4647
## Balanced Accuracy 0.71699 0.5000 0.5227
##
## Accuracy : 0.4337
## Kappa : 0.0991
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.7170 0.5000 0.5227
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.6143 0.2959 0.4878
##
## AUC multiclase (macro): 0.6608Arbol de decision
tree_model <- rpart(
formula_ord,
data = train_ord, # Dataset SIN pesos
method = "class",
control = rpart.control(cp = 0.01)
)
rpart.plot(tree_model, main = "Árbol de Decisión — Sin Pesos (3 clases)")
El árbol comienza con toda la cartera distribuida en tres clases: 14% al día (1-30), 37% en mora intermedia (31-90) y 49% en mora avanzada (91+), y desde el primer corte usa el saldo como variable decisiva, dividiendo entre créditos con saldo mayor o igual a -0.81 y los que están por debajo de ese umbral. Los que superan ese umbral, que representan el 87% de la cartera, se siguen dividiendo por departamento de inversión, y los que pertenecen a Nariño u Other se subdividen luego por modalidad del crédito: aquí aparece el único nodo del árbol que logra identificar créditos al día (1-30), correspondiente a la modalidad AV combinada con MV/TV, aunque con apenas el 5% de los datos y una pureza media del 49%, lo que evidencia que el modelo tiene serias dificultades para reconocer esta clase. Por el lado derecho, los créditos con saldo inferior a -0.81 se dividen según el tipo de factor externo, separando los afectados por Ola Invernal de los demás, y dentro de esa rama el árbol sigue profundizando a través de la tasa referencial, el saldo nuevamente y el monto de desembolso, hasta llegar a la hoja más pura de todo el árbol: créditos con saldo muy cercano a cero y desembolso bajo, donde el 88% corresponde a mora avanzada 91+.
Matriz de confusion
# Las probabilidades ya vienen como matriz n x 3 con rpart
prob_tree <- predict(tree_model, newdata = test_ord, type = "prob")
colnames(prob_tree) <- NIVELES_TARGET
clase_tree <- factor(
NIVELES_TARGET[apply(prob_tree, 1, which.max)],
levels = NIVELES_TARGET, ordered = TRUE
)
eval_tree <- evaluar_modelo(clase_tree, prob_tree,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "ÁRBOL SIN PESOS")##
## ====== ÁRBOL SIN PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 49 21 37
## 31-90 50 539 293
## 91+ 194 241 732
##
## Overall Statistics
##
## Accuracy : 0.6122
## 95% CI : (0.5913, 0.6329)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : < 2.2e-16
##
## Kappa : 0.3252
##
## Mcnemar's Test P-Value : < 2.2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.16724 0.6729 0.6893
## Specificity 0.96887 0.7469 0.6024
## Pos Pred Value 0.45794 0.6111 0.6272
## Neg Pred Value 0.88092 0.7943 0.6663
## Prevalence 0.13590 0.3715 0.4926
## Detection Rate 0.02273 0.2500 0.3395
## Detection Prevalence 0.04963 0.4091 0.5413
## Balanced Accuracy 0.56805 0.7099 0.6458
##
## Accuracy : 0.6122
## Kappa : 0.3252
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.5681 0.7099 0.6458
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.1672 0.6729 0.6893
##
## AUC multiclase (macro): 0.7324Arbol de decision ponderado
tree_model_w <- rpart(
formula_ord,
data = train_ordw, # Dataset CON pesos
method = "class",
weights = w, # Pesos por observación
control = rpart.control(cp = 0.01)
)
rpart.plot(tree_model_w, main = "Árbol de Decisión — Ponderado (3 clases)")
La figura presenta el árbol de decisión ponderado para la clasificación de la cartera agropecuaria en tres categorías de mora: de 1 a 30 días, de 31 a 90 días y superior a 91 días. El nodo raíz muestra una distribución relativamente equilibrada entre las tres clases, resultado de la aplicación de ponderaciones para corregir el desbalance de datos. La primera división del árbol se realiza a partir de la variable “Departamento_Inversion”, lo que indica que la ubicación geográfica representa uno de los factores más relevantes en la segmentación del riesgo crediticio. Posteriormente, variables como la modalidad del crédito, el saldo, el tipo de factor externo y la tasa referencial continúan refinando la clasificación de las observaciones. Los nodos terminales muestran las probabilidades asociadas a cada categoría de mora y permiten identificar perfiles específicos de riesgo. Por ejemplo, algunos nodos presentan predominancia de la categoría “91+”, asociada a mayores niveles de deterioro de cartera, mientras que otros concentran observaciones en la categoría “1-30” o “31-90”. Asimismo, se observa que variables relacionadas con factores económicos, fenómenos naturales y condiciones financieras influyen significativamente en la probabilidad de mora. En términos generales, el modelo ponderado logra una segmentación más balanceada de las clases y mejora parcialmente la identificación de categorías menos frecuentes, aunque su capacidad predictiva continúa siendo inferior frente a modelos más avanzados como XGBoost. No obstante, el árbol ofrece una representación clara e interpretable de las reglas de decisión asociadas al comportamiento del riesgo crediticio.
Matriz de confusion
prob_tree_w <- predict(tree_model_w, newdata = test_ord, type = "prob")
colnames(prob_tree_w) <- NIVELES_TARGET
clase_tree_w <- factor(
NIVELES_TARGET[apply(prob_tree_w, 1, which.max)],
levels = NIVELES_TARGET, ordered = TRUE
)
eval_tree_w <- evaluar_modelo(clase_tree_w, prob_tree_w,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "ÁRBOL CON PESOS")##
## ====== ÁRBOL CON PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 201 145 263
## 31-90 52 555 362
## 91+ 40 101 437
##
## Overall Statistics
##
## Accuracy : 0.5533
## 95% CI : (0.5321, 0.5745)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : 9.272e-09
##
## Kappa : 0.3259
##
## Mcnemar's Test P-Value : < 2.2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.68601 0.6929 0.4115
## Specificity 0.78100 0.6945 0.8711
## Pos Pred Value 0.33005 0.5728 0.7561
## Neg Pred Value 0.94053 0.7928 0.6039
## Prevalence 0.13590 0.3715 0.4926
## Detection Rate 0.09323 0.2574 0.2027
## Detection Prevalence 0.28247 0.4494 0.2681
## Balanced Accuracy 0.73350 0.6937 0.6413
##
## Accuracy : 0.5533
## Kappa : 0.3259
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.7335 0.6937 0.6413
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.6860 0.6929 0.4115
##
## AUC multiclase (macro): 0.7303Modelo XGBoost
# Extraer predictores de la fórmula (excluye el target)
vars_xgb <- all.vars(formula_ord)[-1]
# One-hot encoding con model.matrix
X_train <- model.matrix(~ . - 1, data = train_ord[, vars_xgb])
X_test <- model.matrix(~ . - 1, data = test_ord[, vars_xgb])
# Alinear columnas (test puede no tener todos los niveles de train)
cols_comunes <- intersect(colnames(X_train), colnames(X_test))
X_train <- X_train[, cols_comunes]
X_test <- X_test[, cols_comunes]
# Etiquetas numéricas 0/1/2 (XGBoost requiere 0-indexado para multiclase)
y_train <- as.numeric(train_ord$target_bancario) - 1 # 1-30→0, 31-90→1, 91+→2
y_test <- as.numeric(test_ord$target_bancario) - 1Ajustamos los hiperparametros
# Hiperparámetros base para ambos modelos XGBoost
params_xgb <- list(
objective = "multi:softprob",
eval_metric = "mlogloss",
num_class = 3,
eta = 0.05,
max_depth = 4,
subsample = 0.6,
colsample_bytree = 0.6,
alpha = 1.0,
lambda = 5.0,
min_child_weight = 15,
gamma = 0.3
)
# Función auxiliar: reordena la salida plana de predict.xgb a matriz n x 3
xgb_a_matriz <- function(prob_vec, n_obs, niveles) {
# predict() con multi:softprob devuelve: [obs1_cl1, obs1_cl2, obs1_cl3, obs2_cl1, ...]
# t() transpone para que quede n_obs filas x 3 columnas
mat <- t(matrix(prob_vec, nrow = length(niveles), ncol = n_obs))
colnames(mat) <- niveles
mat
}Modelo
dtrain <- xgb.DMatrix(data = X_train, label = y_train)
dtest <- xgb.DMatrix(data = X_test, label = y_test)
xgb_model <- xgb.train(
params = params_xgb,
data = dtrain,
nrounds = 800,
evals = list(train = dtrain, test = dtest),
early_stopping_rounds = 20,
verbose = 0
)
cat("\nMejor iteración (sin pesos):", xgb_model$best_iteration, "\n")##
## Mejor iteración (sin pesos):Matriz de confusion
eval_xgb <- evaluar_modelo(clase_xgb, prob_xgb,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "XGBOOST SIN PESOS")##
## ====== XGBOOST SIN PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 110 262 343
## 31-90 95 278 366
## 91+ 88 261 353
##
## Overall Statistics
##
## Accuracy : 0.3437
## 95% CI : (0.3236, 0.3642)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0163
##
## Mcnemar's Test P-Value : <2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.37543 0.3471 0.3324
## Specificity 0.67525 0.6598 0.6810
## Pos Pred Value 0.15385 0.3762 0.5028
## Neg Pred Value 0.87300 0.6309 0.5124
## Prevalence 0.13590 0.3715 0.4926
## Detection Rate 0.05102 0.1289 0.1637
## Detection Prevalence 0.33163 0.3428 0.3256
## Balanced Accuracy 0.52534 0.5034 0.5067
##
## Accuracy : 0.3437
## Kappa : 0.0163
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.5253 0.5034 0.5067
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.3754 0.3471 0.3324
##
## AUC multiclase (macro): 0.508
Modelo XGBoost ponderado
# Preparar matriz desde train_ordw (excluir target y columna w)
vars_xgb_w <- all.vars(formula_ord)[-1] # Mismos predictores, w no está en la fórmula
X_train_w <- model.matrix(~ . - 1, data = train_ordw[, vars_xgb_w])
cols_comunes_w <- intersect(colnames(X_train_w), colnames(X_test))
X_train_w <- X_train_w[, cols_comunes_w]
X_test_w <- X_test[, cols_comunes_w]
y_train_w <- as.numeric(train_ordw$target_bancario) - 1 # 0-indexado igual que arriba
# DMatrix CON pesos por observación
dtrain_w <- xgb.DMatrix(data = X_train_w,
label = y_train_w,
weight = train_ordw$w) # <-- pesos explícitos por fila
dtest_w <- xgb.DMatrix(data = X_test_w, label = y_test)
xgb_model_w <- xgb.train(
params = params_xgb,
data = dtrain_w,
nrounds = 800,
evals = list(train = dtrain_w, test = dtest_w),
early_stopping_rounds = 20,
verbose = 0
)
cat("\nMejor iteración (ponderado):", xgb_model_w$best_iteration, "\n")##
## Mejor iteración (ponderado):prob_raw_xgb_w <- predict(xgb_model_w, newdata = dtest_w)
prob_xgb_w <- xgb_a_matriz(prob_raw_xgb_w, nrow(test_ord), NIVELES_TARGET)
clase_xgb_w <- factor(
NIVELES_TARGET[apply(prob_xgb_w, 1, which.max)],
levels = NIVELES_TARGET, ordered = TRUE
)Matriz de confusion
eval_xgb_w <- evaluar_modelo(clase_xgb_w, prob_xgb_w,
test_ord$target_bancario, idx_eval,
NIVELES_TARGET, "XGBOOST CON PESOS")##
## ====== XGBOOST CON PESOS ======
## Confusion Matrix and Statistics
##
## Reference
## Prediction 1-30 31-90 91+
## 1-30 116 264 351
## 31-90 95 278 367
## 91+ 82 259 344
##
## Overall Statistics
##
## Accuracy : 0.3423
## 95% CI : (0.3223, 0.3628)
## No Information Rate : 0.4926
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0182
##
## Mcnemar's Test P-Value : <2e-16
##
## Statistics by Class:
##
## Class: 1-30 Class: 31-90 Class: 91+
## Sensitivity 0.3959 0.3471 0.3239
## Specificity 0.6699 0.6590 0.6883
## Pos Pred Value 0.1587 0.3757 0.5022
## Neg Pred Value 0.8758 0.6306 0.5119
## Prevalence 0.1359 0.3715 0.4926
## Detection Rate 0.0538 0.1289 0.1596
## Detection Prevalence 0.3391 0.3432 0.3177
## Balanced Accuracy 0.5329 0.5031 0.5061
##
## Accuracy : 0.3423
## Kappa : 0.0182
##
## Balanced Accuracy por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.5329 0.5031 0.5061
## Sensitivity por clase:
## Class: 1-30 Class: 31-90 Class: 91+
## 0.3959 0.3471 0.3239
##
## AUC multiclase (macro): 0.5101
Tabla comparativa
En este apartado se presenta una tabla comparativa que resume las métricas clave de desempeño para cada uno de los modelos evaluados: Logit sin pesos, Logit ponderado, Árbol sin pesos, Árbol ponderado, XGBoost sin pesos y XGBoost ponderado. Las métricas incluidas son AUC-ROC, Accuracy, Sensitivity, Specificity, Precision, F1 Score y Balanced Accuracy. Esta tabla permite una comparación directa entre los modelos para identificar cuál ofrece el mejor rendimiento en la predicción del riesgo de incumplimiento crediticio.
extraer_metricas <- function(eval_obj, nombre) {
cm <- eval_obj$cm
roc_obj <- eval_obj$roc
bal_acc <- cm$byClass[, "Balanced Accuracy"]
sens <- cm$byClass[, "Sensitivity"]
data.frame(
Modelo = nombre,
AUC_macro = round(auc(roc_obj), 4),
Accuracy = round(cm$overall["Accuracy"], 4),
Kappa = round(cm$overall["Kappa"], 4),
BalAcc_1_30 = round(bal_acc["Class: 1-30"], 4),
BalAcc_31_90 = round(bal_acc["Class: 31-90"], 4),
BalAcc_91p = round(bal_acc["Class: 91+"], 4),
Sens_1_30 = round(sens["Class: 1-30"], 4),
Sens_31_90 = round(sens["Class: 31-90"], 4),
Sens_91p = round(sens["Class: 91+"], 4)
)
}
tabla_comp <- rbind(
extraer_metricas(eval_sp, "Logit Ordinal sin pesos"),
extraer_metricas(eval_pw, "Logit Ordinal ponderado"),
extraer_metricas(eval_tree, "Árbol sin pesos"),
extraer_metricas(eval_tree_w, "Árbol ponderado"),
extraer_metricas(eval_xgb, "XGBoost sin pesos"),
extraer_metricas(eval_xgb_w, "XGBoost ponderado")
)
print(tabla_comp)## Modelo AUC_macro Accuracy Kappa BalAcc_1_30
## Accuracy Logit Ordinal sin pesos 0.5991 0.4620 0.0142 0.5130
## Accuracy1 Logit Ordinal ponderado 0.6608 0.4337 0.0991 0.7170
## Accuracy2 Árbol sin pesos 0.7324 0.6122 0.3252 0.5681
## Accuracy3 Árbol ponderado 0.7303 0.5533 0.3259 0.7335
## Accuracy4 XGBoost sin pesos 0.5080 0.3437 0.0163 0.5253
## Accuracy5 XGBoost ponderado 0.5101 0.3423 0.0182 0.5329
## BalAcc_31_90 BalAcc_91p Sens_1_30 Sens_31_90 Sens_91p
## Accuracy 0.4636 0.5434 0.0341 0.2372 0.7495
## Accuracy1 0.5000 0.5227 0.6143 0.2959 0.4878
## Accuracy2 0.7099 0.6458 0.1672 0.6729 0.6893
## Accuracy3 0.6937 0.6413 0.6860 0.6929 0.4115
## Accuracy4 0.5034 0.5067 0.3754 0.3471 0.3324
## Accuracy5 0.5031 0.5061 0.3959 0.3471 0.3239Curva ROC
colores <- c("steelblue", "tomato", "seagreen")
# Un color por clase: azul=1-30, rojo=31-90, verde=91+
# Lista con todos los modelos para iterar de forma ordenada
modelos_lista <- list(
list(probs = pred_sp$probs, nombre = "Logit s/p", lty = 1),
list(probs = pred_pw$probs, nombre = "Logit pond.", lty = 2),
list(probs = prob_tree, nombre = "Árbol s/p", lty = 3),
list(probs = prob_tree_w, nombre = "Árbol pond.", lty = 4),
list(probs = prob_xgb, nombre = "XGB s/p", lty = 5),
list(probs = prob_xgb_w, nombre = "XGB pond.", lty = 6)
)
target_eval <- test_ord$target_bancario[idx_eval]
# Un gráfico por clase para no saturar la visualización
for (i in seq_along(NIVELES_TARGET)) {
obs_bin <- as.numeric(target_eval == NIVELES_TARGET[i])
plot(NULL,
xlim = c(1, 0), ylim = c(0, 1),
xlab = "Especificidad", ylab = "Sensibilidad",
main = paste0("ROC — Clase ", NIVELES_TARGET[i], " (one-vs-rest)"))
abline(a = 0, b = 1, lty = 2, col = "gray60")
leyenda <- character(0)
cols_ley <- character(0)
lty_ley <- numeric(0)
for (j in seq_along(modelos_lista)) {
m <- modelos_lista[[j]]
roc_ij <- roc(obs_bin, m$probs[idx_eval, i], quiet = TRUE)
col_j <- colores[((j - 1) %/% 2) + 1] # Mismo color para sin/con peso de cada algoritmo
lty_j <- ifelse(j %% 2 == 1, 1, 2) # Línea sólida=sin pesos, punteada=ponderado
plot(roc_ij, col = col_j, lwd = 2, lty = lty_j, add = TRUE)
leyenda <- c(leyenda, paste0(m$nombre, " (AUC=", round(auc(roc_ij), 3), ")"))
cols_ley <- c(cols_ley, col_j)
lty_ley <- c(lty_ley, lty_j)
}
legend("bottomright", legend = leyenda, col = cols_ley,
lty = lty_ley, lwd = 2, bty = "n", cex = 0.75)
}
