Librerias necesarias
library(readxl) # Importar datos de excel
library(skimr) # Resumen estadísticos
library(readr) # Importar datos csv
library(caret) # Dividir en conjunto de entrenamiento y prueba
library(partykit) # Arboles de decisión
library(e1071) # Matriz de confusión
library(ROCR) # Curva ROC
library(rpart) # Arbol de decision Particionamiento recursivo
library(rpart.plot) # Graficos para rpart
library(randomForest) # Para modelos de bosques aleatorios
library(dplyr) # Manipulacion de datos
library(ggplot2) # Visualizacion de datos
library(xgboost) #Para modelos xgboostEl obejetivo de este documento es cubrir la construcion y evaluacion de un modelo XGBoost. Para ello, es importante que cubramos algunos apsectos iportantes del modelo:
El modelo de aumento de gradiente extremo XGBoost
(eXtreme Gradient Boosting) es un algoritmo de aprendizaje automático
basado en árboles de decisión que es ampliamente utilizado por su
velocidad, precisión y versatilidad. Este modelo es supervisado y se
utiliza para tareas como clasificación, regresión y ranking, entre
otras.
A continuación, te explico las diferencias principales de XGBoost respecto a otros modelos, junto con sus ventajas, desventajas y cuándo deberías usarlo:
XGBoost es una implementación optimizada del algoritmo de gradient boosting. Gradient boosting es una técnica de aprendizaje en la que se combinan múltiples modelos débiles (como árboles de decisión pequeños) para crear un modelo fuerte. XGBoost mejora esta técnica con optimizaciones adicionales en la eficiencia computacional y el manejo de datos.
¿Cuándo deberías usar XGBoost?
Es ideal cuando necesitas maximizar la precisión en problemas complejos de aprendizaje supervisado.
XGBoost es particularmente poderoso en datos tabulares (en contraposición a datos como imágenes o texto).
Útil cuando hay relaciones no lineales entre las variables y el resultado.
Funciona bien en datos que no sean extremadamente grandes (donde escalar se vuelva un problema).
Si puedes invertir tiempo en ajustar los hiperparámetros y evaluar el rendimiento.
| Variable | Ejemplo | Descripción |
|---|---|---|
| ID | 1 | Identificador único de cada registro. |
| Program.Code | HD | Código granular que describe el destino y las actividades del viaje (por ejemplo, “HD” para un programa de historia). |
| FromGrade | 8 | El grado más bajo en la escuela de un participante en el programa. |
| ToGrade | 8 | El grado más alto en la escuela de un participante en el programa. |
| GroupState | IN | Abreviatura del estado donde se ubica la escuela de origen. “OTHER” se usa para geografías raras. |
| IsNonAnnual | 1 | Indica si el grupo de esta escuela típicamente salta un año entre programas. |
| Days | 3 | Número de días que el grupo estuvo en el programa con uno de los instructores. |
| TransportType | A | Modo de transporte desde la ubicación de origen al punto de inicio (A = Avión, B = Bus, T = Tren). |
| SpecialPay | NA | Indica si el maestro recauda todo el dinero para remitirlo a EduTravel en lugar de hacerlo individualmente. |
| Price | 1174 | Precio pagado por participante para asistir al programa. |
| FRP.Active | 72 | Número de participantes que compraron seguro de cancelación del viaje. |
| Income.Level | P | Indicador del nivel de ingresos de los padres (A = bajo, Q = alto, Z = no clasificado). |
| EZ.Pay | 0.2286 | Porcentaje de participantes que se inscriben en un plan de pago automático. |
| School.Sponsor | 0 | Indicador binario de si la escuela patrocinó oficialmente el viaje. |
| Product.Type | East Coast | Nivel de agrupación del tipo de programa turístico. |
| New.Existing | EXISTING | Indica si el grupo ha viajado previamente con EduTravel (“NEW” si no lo ha hecho antes). |
| FPP | 105 | Número total de participantes que pagaron completamente para asistir al programa. |
| Group.Revenue | 125735.4 | Monto total pagado por todos los participantes del grupo. |
| Meetings | 0 | Número de reuniones con los padres antes del viaje. |
| GradeLow | Elementary | Tipo de grado más bajo de la escuela. |
| GradeHigh | Elementary | Tipo de grado más alto de la escuela. |
| DepartureMonth | January | Mes de partida. |
| Poverty.Code | A | Código de pobreza del área de origen (A = bajo porcentaje bajo la línea de pobreza, D = alto). |
| CRM Segment | 1 | Tipo de segmento de cliente definido en el sistema CRM (números entre 1 y 11). |
| SchoolType | PUBLIC | Indica si la escuela es pública o privada. |
| Meeting.Flag | 1 | Indica si hubo una reunión con los padres, señalando compromiso con el viaje. |
| Low.Grade | 7 | Grado más bajo en la escuela de origen. |
| High.Grade | 8 | Grado más alto en la escuela de origen. |
| School.Enrollment | 955 | Total de estudiantes inscritos en la escuela. |
| MajorProgramCode | H | Agregación del código del programa; la primera letra del código granular del programa. |
| SingleGrade | 1 | Indicador de si el viaje incluye estudiantes del mismo grado. |
| FPP.enrollment | 0.06346 | Proporción de participantes en el programa respecto al total de la inscripción escolar. |
| FPP.PAX | 0.93650794 | Proporción de participantes que pagaron completamente en comparación con el total de pasajeros. |
| Size | L | Tamaño de la escuela (S, M, L, S-M, M-L) por quintiles de tamaño. |
| Retained.in.2020 | 1 | Indicador de éxito (1/0): ¿el grupo volvió al año siguiente? |
edutravel$Program.Code <- as.factor(edutravel$Program.Code)
edutravel$FromGrade <- as.factor(edutravel$FromGrade)
edutravel$ToGrade <- as.factor(edutravel$ToGrade)
edutravel$GroupState <- as.factor(edutravel$GroupState)
edutravel$IsNonAnnual <- as.factor(edutravel$IsNonAnnual)
edutravel$Days <- as.factor(edutravel$Days)
edutravel$TransportType <- as.factor(edutravel$TransportType)
edutravel$SpecialPay <- as.factor(edutravel$SpecialPay)
edutravel$Poverty.Code <- as.factor(edutravel$Poverty.Code)
edutravel$Region <- as.factor(edutravel$Region )
edutravel$CRMSegment <- as.factor(edutravel$CRMSegment)
edutravel$SchoolType <- as.factor(edutravel$SchoolType)
edutravel$Meeting.Flag <- as.factor(edutravel$Meeting.Flag)
edutravel$Income.Level <- as.factor(edutravel$Income.Level)
edutravel$Product.Type <- as.factor(edutravel$Product.Type)
edutravel$New.Existing <- as.factor(edutravel$New.Existing)
edutravel$GradeLow <- as.factor(edutravel$GradeLow)
edutravel$GradeHigh <- as.factor(edutravel$GradeHigh)
edutravel$DepartureMonth <- as.factor(edutravel$DepartureMonth)
edutravel$Meetings <- as.factor(edutravel$Meetings)
edutravel$AggregatedCode <- as.factor(edutravel$AggregatedCode)
edutravel$SingleGrade <- as.factor(edutravel$SingleGrade)
edutravel$Size <- as.factor(edutravel$Size)
edutravel$Low.Grade <- as.factor(edutravel$Low.Grade)
edutravel$Low.High <- as.factor(edutravel$High.Grade)
edutravel$Retained.in.2020 <- as.factor(edutravel$Retained.in.2020) # definimos funcion
FillNAs<-function(data_frame){
fill_number<-0
fill_factor<-"NA_filled"
fill_character<-"NA_filled"
fill_date<-as.Date("1900-01-01")
# Make a loop in the columns of the data frame and according to the
# data type, fill the respective value and create a surrogate column
for (i in 1 : ncol(data_frame)){
if (class(data_frame[,i]) %in% c("numeric","integer")) {
if (any(is.na(data_frame[,i]))){
data_frame[,paste0(colnames(data_frame)[i],"_filledNA")]<- as.factor(ifelse(is.na(data_frame[,i]),"1","0"))
data_frame[is.na(data_frame[,i]),i]<-fill_number
}
} else
if (class(data_frame[,i]) %in% c("factor")) {
if (any(is.na(data_frame[,i]))){
data_frame[,i]<-as.character(data_frame[,i])
data_frame[,paste0(colnames(data_frame)[i],"_filledNA")]<-as.factor(ifelse(is.na(data_frame[,i]),"1","0"))
data_frame[is.na(data_frame[,i]),i]<-fill_factor
data_frame[,i]<-as.factor(data_frame[,i])
}
} else {
if (class(data_frame[,i]) %in% c("character")) {
if (any(is.na(data_frame[,i]))){
data_frame[,paste0(colnames(data_frame)[i],"_filledNA")]<- as.factor(ifelse(is.na(data_frame[,i]),"1","0"))
data_frame[is.na(data_frame[,i]),i]<-afill_character
}
} else {
if (class(data_frame[,i]) %in% c("Date")) {
if (any(is.na(data_frame[,i]))){
data_frame[,paste0(colnames(data_frame)[i],"_filledNA")]<-as.factor(ifelse(is.na(data_frame[,i]),"1","0"))
data_frame[is.na(data_frame[,i]),i]<-fill_date
}
}
}
}
}
return(data_frame)
}
# aplicamos función
edutravelNA <-FillNAs(edutravel)
# combinamos categoríasEl propósito de esta función, en un contexto práctico, es simplificar y mejorar la calidad de los análisis de datos categóricos, especialmente en situaciones donde:
Reducción de complejidad en las categorías:
En un dataset con muchas categorías, algunas pueden tener muy pocas observaciones, lo que hace que los análisis sean menos significativos y más complejos de interpretar. Combinar estas categorías poco representadas en una genérica llamada “Others” ayuda a reducir el ruido en los datos y enfocar los análisis en las categorías principales. Facilitar la visualización de datos:
Al crear gráficos (por ejemplo, gráficos de barras, de pastel o tablas resumen), un exceso de categorías hace que la visualización sea desordenada y difícil de leer. Agrupar las categorías con pocos datos bajo “Others” mejora la claridad visual y destaca las categorías más relevantes. Mejorar los modelos estadísticos o de machine learning:
En modelos de regresión, clasificación o cualquier algoritmo que utilice variables categóricas, demasiadas categorías con baja frecuencia pueden llevar a problemas de sobreajuste (overfitting) o resultados inestables. Agrupar las categorías pequeñas en “Others” permite que los modelos se centren en las categorías más significativas, mejorando su rendimiento. Normalización de los datos para reportes:
En informes o reportes donde se presenten resultados agrupados, es común agrupar valores menores en una categoría “Otros” para que los resultados sean más concisos y comprensibles. Análisis exploratorio de datos:
Durante el análisis inicial de un dataset, agrupar categorías poco representadas facilita la identificación de patrones significativos en las categorías principales sin distracciones innecesarias.
### Combining Categories
# Definimos funcion
CombineCategories <-function(data_frame,mincount){
for (i in 1 : ncol(data_frame)){
a<-data_frame[,i]
replace <- names(which(table(a) < mincount))
levels(a)[levels(a) %in% replace] <- paste("Others",colnames(data_frame)[i],sep=".")
data_frame[,i]<-a }
return(data_frame)
}
# aplicamos funcion
# dataframe with a mincount of 10
#head(CombineCategories(edutravelNA, 10))# indicamos semilla para consistencia
set.seed(2021)
# separamos datos (80% entrenamiento y 20% prueba)
Partition <- createDataPartition(y = edutravelNA$Retained.in.2020,
p = 0.8, # porcentaje de entrenamiento.
list = FALSE)
# sepramos en objetos
training <- edutravelNA[ Partition,]
testing <- edutravelNA[ -Partition,]
# En el modelo tomamos la variable dependiente de retención e independntes todas menos "GroupState"
training.x <-model.matrix(Retained.in.2020~ .-GroupState # Indicamos las variables
, data = training # Indicamos conjunto de datos
)
testing.x <-model.matrix(Retained.in.2020~ .-GroupState, # Indicamos las variables
data = testing # Indicamos conjunto de datos
)Si observamos el conjunto de entrenamiento podemos observar como todas las variables han sido transformadas a variables dicotomicas
head(training.x,2)## (Intercept) Program.CodeCD Program.CodeCN Program.CodeCVP Program.CodeFN
## 1 1 0 0 0 0
## 2 1 0 0 0 0
## Program.CodeHC Program.CodeHD Program.CodeHF Program.CodeHG Program.CodeHH
## 1 0 0 0 0 0
## 2 1 0 0 0 0
## Program.CodeHIS Program.CodeHN Program.CodeHO Program.CodeHP Program.CodeHS
## 1 0 0 0 0 1
## 2 0 0 0 0 0
## Program.CodeHVP Program.CodeHW Program.CodeHX Program.CodeHY Program.CodeHZ
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## Program.CodeIC Program.CodeIK Program.CodeSC Program.CodeSD Program.CodeSG
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## Program.CodeSK Program.CodeSM Program.CodeST FromGrade11 FromGrade12
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## FromGrade3 FromGrade4 FromGrade5 FromGrade6 FromGrade7 FromGrade8 FromGrade9
## 1 0 1 0 0 0 0 0
## 2 0 0 0 0 0 1 0
## FromGradeNA_filled ToGrade11 ToGrade12 ToGrade3 ToGrade4 ToGrade5 ToGrade6
## 1 0 0 0 0 1 0 0
## 2 0 0 0 0 0 0 0
## ToGrade7 ToGrade8 ToGrade9 ToGradeNA_filled IsNonAnnual1 Days2 Days3 Days4
## 1 0 0 0 0 0 0 0 0
## 2 0 1 0 0 0 0 0 0
## Days5 Days6 Days7 Days8 Days9 Days10 Days11 Days12 TransportTypeB
## 1 0 0 0 0 0 0 0 0 0
## 2 0 0 1 0 0 0 0 0 0
## TransportTypeN TransportTypeT SpecialPayFR SpecialPayNA_filled SpecialPaySA
## 1 0 0 0 1 0
## 2 0 0 0 0 0
## Price FRP.Active FRP.Cancelled FRP.Percentage Cancelled.Pax Extra.Pax
## 1 424 25 3 0.424 3 4
## 2 2350 9 9 0.409 11 3
## Poverty.CodeA Poverty.CodeB Poverty.CodeC Poverty.CodeD Poverty.CodeE
## 1 0 1 0 0 0
## 2 0 0 1 0 0
## Poverty.CodeNA_filled RegionHouston RegionNorthern California RegionOther
## 1 0 0 0 0
## 2 0 0 0 1
## RegionPacific Northwest RegionSouthern California CRMSegment10 CRMSegment11
## 1 0 1 0 0
## 2 0 0 1 0
## CRMSegment2 CRMSegment3 CRMSegment4 CRMSegment5 CRMSegment6 CRMSegment7
## 1 0 0 1 0 0 0
## 2 0 0 0 0 0 0
## CRMSegment8 CRMSegment9 CRMSegmentNA_filled SchoolTypeCHD
## 1 0 0 0 0
## 2 0 0 0 0
## SchoolTypePrivate non-Christian SchoolTypePUBLIC Meeting.Flag1 Low.Grade10
## 1 0 1 1 0
## 2 0 1 1 0
## Low.Grade2 Low.Grade3 Low.Grade4 Low.Grade5 Low.Grade6 Low.Grade7 Low.Grade8
## 1 0 0 0 0 0 0 0
## 2 0 0 0 0 0 1 0
## Low.Grade9 Low.GradeK Low.GradeNA_filled Low.GradePK High.Grade
## 1 0 1 0 0 5
## 2 0 0 0 0 8
## School.Enrollment Income.LevelB Income.LevelC Income.LevelD Income.LevelE
## 1 927 0 0 0 0
## 2 850 0 0 0 0
## Income.LevelF Income.LevelG Income.LevelH Income.LevelI Income.LevelJ
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## Income.LevelK Income.LevelL Income.LevelM Income.LevelN Income.LevelNA_filled
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## Income.LevelO Income.LevelP Income.LevelP1 Income.LevelP3 Income.LevelP4
## 1 0 0 0 0 0
## 2 0 0 0 0 0
## Income.LevelP5 Income.LevelQ Income.LevelZ EZ.Pay School.Sponsor
## 1 0 1 0 0.170 1
## 2 0 0 0 0.091 0
## Product.TypeCosta Rica Product.TypeEast Coast Product.TypeIL History
## 1 0 0 0
## 2 0 1 0
## Product.TypeInternational Product.TypeScience New.ExistingNEW FPP
## 1 0 0 0 59
## 2 0 0 0 22
## Group.Revenue Meetings1 Meetings2 FirstMeeting LastMeeting GradeLowHigh
## 1 424 1 0 155 155 0
## 2 2350 0 1 423 140 0
## GradeLowMiddle GradeLowUndefined GradeHighHigh GradeHighMiddle
## 1 0 0 0 0
## 2 1 0 0 1
## GradeHighUndefined DepartureMonthFebruary DepartureMonthJanuary
## 1 0 0 1
## 2 0 0 1
## DepartureMonthJune DepartureMonthMarch DepartureMonthMay AggregatedCodeH
## 1 0 0 0 1
## 2 0 0 0 1
## AggregatedCodeI AggregatedCodeS SingleGrade1 FPP.Enrollment FPP.Pax SizeM-L
## 1 0 0 1 0.06364617 0.9365079 0
## 2 0 0 1 0.02588235 0.8800000 0
## SizeNA_filled SizeS SizeS-M Low.High10 Low.High11 Low.High12 Low.High2
## 1 0 0 0 0 0 0 0
## 2 0 0 0 0 0 0 0
## Low.High3 Low.High4 Low.High5 Low.High6 Low.High7 Low.High8 Low.High9
## 1 0 0 1 0 0 0 0
## 2 0 0 0 0 0 1 0
## Low.HighNA_filled FromGrade_filledNA1 ToGrade_filledNA1 SpecialPay_filledNA1
## 1 0 0 0 1
## 2 0 0 0 0
## Poverty.Code_filledNA1 CRMSegment_filledNA1 Low.Grade_filledNA1
## 1 0 0 0
## 2 0 0 0
## High.Grade_filledNA1 School.Enrollment_filledNA1 Income.Level_filledNA1
## 1 0 0 0
## 2 0 0 0
## FirstMeeting_filledNA1 LastMeeting_filledNA1 FPP.Enrollment_filledNA1
## 1 0 0 0
## 2 0 0 0
## Size_filledNA1 Low.High_filledNA1
## 1 0 0
## 2 0 0datadata.matrix o dgCMatrix).labeldata.eta (Tasa de aprendizaje)(0, 1). Valor
predeterminado = 0.3.eta requiere
aumentar el número de iteraciones (nround).max_depth (Profundidad máxima del
árbol)(1, infinito). Valor
predeterminado = 6.nround (Número de iteraciones)100.objective (Función objetivo)"reg:linear": Regresión lineal."binary:logistic": Clasificación binaria que devuelve
probabilidades."multi:softmax": Clasificación multiclase que devuelve
etiquetas de clase."multi:softprob": Clasificación multiclase que devuelve
probabilidades para cada clase.gamma[0, infinito). Valor
predeterminado = 0.subsample(0, 1]. Valor
predeterminado = 1.colsample_bytree(0, 1]. Valor
predeterminado = 1.lambda y alpha
(Regularización)lambda (Regularización L2): Penaliza
pesos altos para evitar sobreajuste.
[0, infinito). Valor
predeterminado = 1.alpha (Regularización L1): Penaliza el
número de características seleccionadas.
[0, infinito). Valor
predeterminado = 0.# Implementamos modelo
model.XGB<-xgboost(data = data.matrix(training.x[,-1]), # Indicamos todas las filas y todas las columnas menos la primera (El intercepto)
label= as.numeric(as.character(training$Retained.in.2020)), # INdiccamos las ettiquetas de las variable dependite
eta = 0.2, # Parametro por defecto para la tasa de apredizaje
max_depth = 5, # Prametro para defiir la profundidad del arbol (por defecto 6)
nround=50, # Parametro para el numero maximo de iteraciones
objective = "binary:logistic" # Indicamos modelo logistico de clasificacio
)## [1] train-logloss:0.609544
## [2] train-logloss:0.552049
## [3] train-logloss:0.510557
## [4] train-logloss:0.480147
## [5] train-logloss:0.455290
## [6] train-logloss:0.435698
## [7] train-logloss:0.419243
## [8] train-logloss:0.401542
## [9] train-logloss:0.388883
## [10] train-logloss:0.378889
## [11] train-logloss:0.367400
## [12] train-logloss:0.358583
## [13] train-logloss:0.348847
## [14] train-logloss:0.341961
## [15] train-logloss:0.335725
## [16] train-logloss:0.331436
## [17] train-logloss:0.327514
## [18] train-logloss:0.318423
## [19] train-logloss:0.313637
## [20] train-logloss:0.308587
## [21] train-logloss:0.302375
## [22] train-logloss:0.299103
## [23] train-logloss:0.296640
## [24] train-logloss:0.290020
## [25] train-logloss:0.285271
## [26] train-logloss:0.282510
## [27] train-logloss:0.279795
## [28] train-logloss:0.273876
## [29] train-logloss:0.267571
## [30] train-logloss:0.265960
## [31] train-logloss:0.263775
## [32] train-logloss:0.260317
## [33] train-logloss:0.258807
## [34] train-logloss:0.256492
## [35] train-logloss:0.253918
## [36] train-logloss:0.252900
## [37] train-logloss:0.247089
## [38] train-logloss:0.245864
## [39] train-logloss:0.244026
## [40] train-logloss:0.241112
## [41] train-logloss:0.236192
## [42] train-logloss:0.234098
## [43] train-logloss:0.230730
## [44] train-logloss:0.229527
## [45] train-logloss:0.224364
## [46] train-logloss:0.222045
## [47] train-logloss:0.220630
## [48] train-logloss:0.217125
## [49] train-logloss:0.215884
## [50] train-logloss:0.214483Primero, identificamos el punto de corte. Para ello, calculamos el promedio de la tasa de retencion
edutravelNA %>%
mutate(Retained.in.2020 = as.numeric(as.character(Retained.in.2020))) %>% # Conversiond de variable
summarise(media_retencion = mean(Retained.in.2020, na.rm = TRUE)) # calculamos el promedio## media_retencion
## 1 0.6073671Obtenemos que la probabilidad media de ser retenido es 0.607, que es lo que usaremos como valor de corte
# Predecimos y evaluamos el modelo
prediction.XGB<-predict(model.XGB, # Indicamos el modelo
newdata=testing.x[,-1], # Excluimos la columna 1 (Ya que es el intercepto en los datos)
type="prob" # Indicamos la probabilidad
)
# Creamos matriz de confusion
confusionMatrix(as.factor(ifelse(prediction.XGB>0.607,1,0)), # indicamos umbral para ceros y unos
testing$Retained.in.2020, # Indicamos variable dependiente, en el cojunto de prueba
positive = "1" # Indicamos cuales son los positivos
) ## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 156 74
## 1 31 216
##
## Accuracy : 0.7799
## 95% CI : (0.74, 0.8163)
## No Information Rate : 0.608
## P-Value [Acc > NIR] : 9.519e-16
##
## Kappa : 0.5563
##
## Mcnemar's Test P-Value : 4.153e-05
##
## Sensitivity : 0.7448
## Specificity : 0.8342
## Pos Pred Value : 0.8745
## Neg Pred Value : 0.6783
## Prevalence : 0.6080
## Detection Rate : 0.4528
## Detection Prevalence : 0.5178
## Balanced Accuracy : 0.7895
##
## 'Positive' Class : 1
## Podemos observar coo el modelo tiene una efectividad del 77%.