Unidad

Primer punto

install.packages("doMC", repos="http://R-Forge.R-project.org")
library(readxl)
library(doMC)
library(readxl)
library(foreign)
library(Factoshiny)
library(factoextra)
library(corrplot)
library(biplotbootGUI)
library(dynBiplotGUI)
library(psych)
library(ggplot2)
library(dplyr)
library(recipes)
library(knitr)
library(kernlab)
library(caret)
library(randomForest)
datos <- read_excel("C:/Users/elcantorh/Downloads/Datos_Rotación.xlsx")

datos$`Viaje de Negocios`<-as.factor(datos$`Viaje de Negocios`)
datos$Departamento<-as.factor(datos$Departamento)
datos$Campo_Educación<-as.factor(datos$Campo_Educación)
datos$Genero<-as.factor(datos$Genero)
datos$Cargo<-as.factor(datos$Cargo)
datos$Estado_Civil<-as.factor(datos$Estado_Civil)
datos$Horas_Extra<-as.factor(datos$Horas_Extra)
summary(datos)

##    Rotación              Edad            Viaje de Negocios Departamento
##  Length:1470        Min.   :18.00   Frecuentemente: 277    IyD   :961  
##  Class :character   1st Qu.:30.00   No_Viaja      : 150    RH    : 63  
##  Mode  :character   Median :36.00   Raramente     :1043    Ventas:446  
##                     Mean   :36.92                                      
##                     3rd Qu.:43.00                                      
##                     Max.   :60.00                                      
##                                                                        
##  Distancia_Casa     Educación        Campo_Educación Satisfacción_Ambiental
##  Min.   : 1.000   Min.   :1.000   Ciencias   :606    Min.   :1.000         
##  1st Qu.: 2.000   1st Qu.:2.000   Humanidades: 27    1st Qu.:2.000         
##  Median : 7.000   Median :3.000   Mercadeo   :159    Median :3.000         
##  Mean   : 9.193   Mean   :2.913   Otra       : 82    Mean   :2.722         
##  3rd Qu.:14.000   3rd Qu.:4.000   Salud      :464    3rd Qu.:4.000         
##  Max.   :29.000   Max.   :5.000   Tecnicos   :132    Max.   :4.000         
##                                                                            
##  Genero                      Cargo     Satisfación_Laboral     Estado_Civil
##  F:588   Ejecutivo_Ventas       :326   Min.   :1.000       Casado    :673  
##  M:882   Investigador_Cientifico:292   1st Qu.:2.000       Divorciado:327  
##          Tecnico_Laboratorio    :259   Median :3.000       Soltero   :470  
##          Director_Manofactura   :145   Mean   :2.729                       
##          Representante_Salud    :131   3rd Qu.:4.000                       
##          Gerente                :102   Max.   :4.000                       
##          (Other)                :215                                       
##  Ingreso_Mensual Trabajos_Anteriores Horas_Extra Porcentaje_aumento_salarial
##  Min.   : 1009   Min.   :0.000       No:1054     Min.   :11.00              
##  1st Qu.: 2911   1st Qu.:1.000       Si: 416     1st Qu.:12.00              
##  Median : 4919   Median :2.000                   Median :14.00              
##  Mean   : 6503   Mean   :2.693                   Mean   :15.21              
##  3rd Qu.: 8379   3rd Qu.:4.000                   3rd Qu.:18.00              
##  Max.   :19999   Max.   :9.000                   Max.   :25.00              
##                                                                             
##  Rendimiento_Laboral Años_Experiencia Capacitaciones  Equilibrio_Trabajo_Vida
##  Min.   :3.000       Min.   : 0.00    Min.   :0.000   Min.   :1.000          
##  1st Qu.:3.000       1st Qu.: 6.00    1st Qu.:2.000   1st Qu.:2.000          
##  Median :3.000       Median :10.00    Median :3.000   Median :3.000          
##  Mean   :3.154       Mean   :11.28    Mean   :2.799   Mean   :2.761          
##  3rd Qu.:3.000       3rd Qu.:15.00    3rd Qu.:3.000   3rd Qu.:3.000          
##  Max.   :4.000       Max.   :40.00    Max.   :6.000   Max.   :4.000          
##                                                                              
##    Antigüedad     Antigüedad_Cargo Años_ultima_promoción
##  Min.   : 0.000   Min.   : 0.000   Min.   : 0.000       
##  1st Qu.: 3.000   1st Qu.: 2.000   1st Qu.: 0.000       
##  Median : 5.000   Median : 3.000   Median : 1.000       
##  Mean   : 7.008   Mean   : 4.229   Mean   : 2.188       
##  3rd Qu.: 9.000   3rd Qu.: 7.000   3rd Qu.: 3.000       
##  Max.   :40.000   Max.   :18.000   Max.   :15.000       
##                                                         
##  Años_acargo_con_mismo_jefe
##  Min.   : 0.000            
##  1st Qu.: 2.000            
##  Median : 3.000            
##  Mean   : 4.123            
##  3rd Qu.: 7.000            
##  Max.   :17.000            
##

Punto 1: Seleccionar 3 variables categóricas (distintas de rotación) y 3 variables cuantitativas, que consideren estén relacionadas con la rotación. Nota: Justificar por que estas variables están relacionadas y que tipo de relación se espera (Hipótesis). Ejemplo: Se espera que las horas extra se relacionen con la rotación ya que las personas podrían desgastarse mas al trabajar horas extra y descuidan aspectos personales. La hipótesis es que las personas que trabajan horas extra tienen mayor posibilidad de rotar que las que no trabajan extra. (serian 6, una por variable).

Cualitativas

Estado_Civil: Se espera que el estado civil de las personas tenga relación con la rotación, ya que esto podría influir en la cantidad de responsabilidad que una persona podría tener en su hogar para tomar decisiones respecto a si continuar o no en un trabajo. La hipótesis es que se espera que las personas solteras tengan mayor posibilidad de rotar que el resto de personas con otro estado civil.

Departamento: Se espera que el departamento de las personas tenga relación con la rotación, ya que los cargos de nivel comercial (ubicado en Ventas) normalmente rotan más en el mercado laboral por diferentes motivos como la carga laboral, el salario, el conocimiento, etc. La hipótesis es que se espera que las personas que el Departamento de Ventas roten más que en el resto de Departamentos de la empresa.

Viaje de Negocios: Se espera que las personas que viajan frecuentemente tenga relación con la rotación, pues cuando un empleado debe viajar puede presentar mayor carga laboral ya que debe invertir tiempo en desplazamientos y cumplir todas sus actividades laborales de forma puntual. La hipótesis es que se espera que las personas que viajan frecuentemente por negocios tengan mayor posibilidad de rotar que el resto de empleados.

Cuantitativas

Edad: Se espera que las personas más jóvenes tengan relación con la rotación, ya que los más jóvenes buscan siempre mejorar sus condiciones laborales y ampliar aprendizajes. La hipótesis es que se espera que las personas más jóvenes tengan mayor posibilidad de rotar que los más adultos.

Ingreso_Mensual: Se espera que las personas que tienen menores ingresos mensuales en la empresa tengan relación con la rotación, ya que pueden buscar activamente otros empleos con mejores remuneraciones. La hipótesis es que se espera que las personas de menor ingreso mensual roten más que las personas que tienen mayores ingresos mensuales.

Trabajos_Anteriores: Se espera que las personas que han tenido más trabajos en el pasado tenga relación con la rotación, pues puede tratarse de personas que no logran sentirse a gusto fácilmente en un empleo y que buscan otro tipo de oportunidades. La hipótesis es que se espera que las personas que han tenido mayor número de trabajos en el pasado roten más que las personas que han tenido menor cantidad de empleos antes.

Punto 2: Realizar un análisis univariado (caracterización). Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuanti o cuali). Incluir interpretaciones de la rotación.

require(ggplot2)
require(ggpubr)

g1=ggplot(datos,aes(x=`Viaje de Negocios`))+geom_bar()+theme_bw()
g2=ggplot(datos,aes(x=Departamento))+geom_bar()+theme_bw()
g3=ggplot(datos,aes(x=Estado_Civil))+geom_bar()+theme_bw()
g4=ggplot(datos,aes(x=Edad))+geom_histogram()+theme_bw()
g5=ggplot(datos,aes(x=Ingreso_Mensual))+geom_histogram()+theme_bw()
g6=ggplot(datos,aes(x=Trabajos_Anteriores))+geom_histogram()+theme_bw()
ggarrange(g1, g2, g3, g4, g5, g6,labels = c("A", "B","C","D","E","F"),ncol = 2, nrow = 3)

promedio_edad = mean(datos$Edad)
mediana_edad = median(datos$Edad)

resultado=data.frame(promedio_edad, mediana_edad)
resultado

##   promedio_edad mediana_edad
## 1      36.92381           36

promedio_ingresos = mean(datos$Ingreso_Mensual)
mediana_ingresos = median(datos$Ingreso_Mensual)

resultado2=data.frame(promedio_ingresos, mediana_ingresos)
resultado2

##   promedio_ingresos mediana_ingresos
## 1          6502.931             4919

promedio_trabajos = mean(datos$Trabajos_Anteriores)
mediana_trabajos = median(datos$Trabajos_Anteriores)

resultado3=data.frame(promedio_trabajos, mediana_trabajos)
resultado3

##   promedio_trabajos mediana_trabajos
## 1          2.693197                2

Interpretaciones

De acuerdo con la información representada en las gráficas, se evidencia que la mayor cantidad de empleados viajan raramente; la empresa concentra la mayoría de sus empleados en el Departamento de IyD y que una gran cantidad de personas se encuentran casadas.

Adicionalmente, se evidencia que los empleados tienen una edad entre 30 y 40 años de acuerdo con el histograma de la variable “Edad”, sin embargo, en promedio los empleados tienen una edad de aproximadamente 37 años; en relación con los ingresos mensuales, la mayor proporción de empleados no gana más de 5 millones, en promedio podrían ganar 6.5 millones pero esta medida está afectada por los salrios más altos.

Finalmente, se sabe que el 50% de los empleados han trabajado en al menos 2 empresas anteriormente y que en promedio han tenido 3 empleos.

Punto 3: Realizar un análisis de bivariado en donde la variable respuesta sea la rotación codificada de la siguiente manera (y=1 es si rotación, y=0 es no rotación), con base en estos resultados identifique cuales son las variables determinantes de la rotación e interpretar el signo del coeficiente estimado. Compare estos resultados con la hipotesis planteada en el punto 2.

require(CGPfunctions)

g1=PlotXTabs2(datos, `Viaje de Negocios`, Rotación , plottype = "percent")
g2=PlotXTabs2(datos, Estado_Civil, Rotación , plottype = "percent")
g3=PlotXTabs2(datos, Departamento, Rotación , plottype = "percent")
g1

g2

g3

Interpretaciones

Interpretación Viaje de Negocios: De acuerdo con la gráfica el 25% de los empleados que frecuentemente viajan por negocios rotan apoyando la hipótesis inicialmente planteada.

Interpretación Estado_Civil: De acuerdo con la gráfica el 26% de los empleados solteros rotan apoyando la hipótesis inicialmente planteada, en una menor proporción se evidencia que los casados y divorciados roten.Confirmando la hipotesis inicialmente planteada para esta varible.

Interpretación Departamento: De acuerdo con la gráfica el 21% de los empleados que pertenecen al Departamento de Venta rotan apoyando la hipótesis inicialmente planteada; asimismo, se evidencia que los empleados del Departamento de RH tambien tienen un alto porcentaje de rotación por lo que sería importante genrar planes de acción para ambos Departamentos. Confirmando la hipotesis inicialmente planteada para esta varible.

g4=ggplot(datos,aes(x=Rotación,y= Edad,fill=Rotación))+geom_boxplot()+theme_bw()
g5=ggplot(datos,aes(x=Rotación,y= Ingreso_Mensual,fill=Rotación))+geom_boxplot()+theme_bw()
g6=ggplot(datos,aes(x=Rotación,y= Trabajos_Anteriores,fill=Rotación))+geom_boxplot()+theme_bw()

require(plotly)

ggplotly(g4)

ggplotly(g5)

ggplotly(g6)

Interpretaciones

Interpretación Edad: Se evidencia que la personas menores de 32 años rotan más que las personas más adultas. Confirmando la hipotesis inicialmente planteada para esta varible.

Interpretación Ingresos_Mensuales: Se evidencia que la personas con menores ingresos mensuales en la empresa rotan, aproximadamente la diferencia salarial entre los que rotan y no rotan es de 2 millones. Confirmando la hipotesis inicialmente planteada para esta varible.

Interpretación Trabajos_Anteriores: Se evidencia que al menos el 75% de las personas que rotan han tenido 5 trabajos anteriores, por lo que las personas que más trabajos han tenido rotan con mayor frecuencia. Confirmando la hipotesis inicialmente planteada para esta varible.

Punto 4: Realizar la estimación de un modelo de regresión logistico en el cual la variable respuesta es rotación (y=1 es si rotación, y=0 es no rotación) y las covariables las 6 seleccionadas. Interprete los coeficientes del modelo y la significancia de los parametros.

set.seed(123)
# Se crean los índices de las observaciones de entrenamiento
train <- createDataPartition(y = datos$Rotación, p = 0.8, list = FALSE, times = 1)
datos_train <- datos[train, ]
datos_test  <- datos[-train, ]

prop.table(table(datos_train$Rotación))

## 
##        No        Si 
## 0.8385726 0.1614274

prop.table(table(datos_test$Rotación))

## 
##        No        Si 
## 0.8395904 0.1604096

# PARALELIZACIÓN DE PROCESO
#===============================================================================

registerDoMC(cores = 4)

# HIPERPARÁMETROS, NÚMERO DE REPETICIONES Y SEMILLAS PARA CADA REPETICIÓN
#===============================================================================
particiones  <- 10
repeticiones <- 5

# Hiperparámetros
hiperparametros <- data.frame(parameter = "none")

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  seeds[[i]] <- sample.int(1000, nrow(hiperparametros))
}
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

# DEFINICIÓN DEL ENTRENAMIENTO
#===============================================================================
control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "final", verboseIter = FALSE,
                              allowParallel = TRUE)

# AJUSTE DEL MODELO
# ==============================================================================
set.seed(342)
modelo_logistic <- train(Rotación ~ ., data = datos_train,
                         method = "glm",
                         tuneGrid = hiperparametros,
                         metric = "Accuracy",
                         trControl = control_train,
                         family = "binomial")
modelo_logistic

## Generalized Linear Model 
## 
## 1177 samples
##   23 predictor
##    2 classes: 'No', 'Si' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 5 times) 
## Summary of sample sizes: 1059, 1059, 1059, 1060, 1060, 1059, ... 
## Resampling results:
## 
##   Accuracy   Kappa    
##   0.8683051  0.4074121

summary(modelo_logistic$finalModel)

## 
## Call:
## NULL
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -1.9399  -0.5051  -0.2724  -0.0967   3.2339  
## 
## Coefficients:
##                                      Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                         1.076e-01  1.743e+00   0.062 0.950771    
## Edad                               -3.286e-02  1.534e-02  -2.142 0.032205 *  
## `\\`Viaje de Negocios\\`No_Viaja`  -2.025e+00  4.739e-01  -4.274 1.92e-05 ***
## `\\`Viaje de Negocios\\`Raramente` -9.146e-01  2.347e-01  -3.898 9.72e-05 ***
## DepartamentoRH                     -1.384e+01  6.852e+02  -0.020 0.983882    
## DepartamentoVentas                  4.029e-01  1.138e+00   0.354 0.723251    
## Distancia_Casa                      4.707e-02  1.203e-02   3.912 9.14e-05 ***
## Educación                          -7.084e-02  9.680e-02  -0.732 0.464264    
## Campo_EducaciónHumanidades          6.914e-01  9.524e-01   0.726 0.467879    
## Campo_EducaciónMercadeo             4.217e-01  3.504e-01   1.204 0.228741    
## Campo_EducaciónOtra                -1.444e-01  4.492e-01  -0.321 0.747928    
## Campo_EducaciónSalud               -1.850e-01  2.394e-01  -0.773 0.439560    
## Campo_EducaciónTecnicos             8.165e-01  3.387e-01   2.411 0.015927 *  
## Satisfacción_Ambiental             -4.141e-01  9.058e-02  -4.572 4.83e-06 ***
## GeneroM                             4.083e-01  2.042e-01   2.000 0.045523 *  
## CargoDirector_Manofactura           1.155e+00  1.022e+00   1.130 0.258539    
## CargoEjecutivo_Ventas               1.813e+00  1.504e+00   1.205 0.228142    
## CargoGerente                        5.489e-01  1.137e+00   0.483 0.629315    
## CargoInvestigador_Cientifico        1.932e+00  1.083e+00   1.784 0.074462 .  
## CargoRecursos_Humanos               1.600e+01  6.852e+02   0.023 0.981372    
## CargoRepresentante_Salud            1.138e+00  1.001e+00   1.137 0.255644    
## CargoRepresentante_Ventas           2.972e+00  1.615e+00   1.840 0.065797 .  
## CargoTecnico_Laboratorio            2.910e+00  1.074e+00   2.709 0.006753 ** 
## Satisfación_Laboral                -4.402e-01  9.013e-02  -4.884 1.04e-06 ***
## Estado_CivilDivorciado             -4.938e-01  2.898e-01  -1.704 0.088379 .  
## Estado_CivilSoltero                 1.030e+00  2.189e-01   4.708 2.50e-06 ***
## Ingreso_Mensual                     8.438e-05  6.673e-05   1.265 0.206005    
## Trabajos_Anteriores                 1.705e-01  4.260e-02   4.001 6.30e-05 ***
## Horas_ExtraSi                       1.848e+00  2.109e-01   8.764  < 2e-16 ***
## Porcentaje_aumento_salarial        -2.229e-02  4.237e-02  -0.526 0.598757    
## Rendimiento_Laboral                 6.857e-02  4.341e-01   0.158 0.874492    
## Años_Experiencia                   -8.560e-02  3.209e-02  -2.668 0.007639 ** 
## Capacitaciones                     -1.019e-01  7.916e-02  -1.287 0.198095    
## Equilibrio_Trabajo_Vida            -3.589e-01  1.351e-01  -2.657 0.007894 ** 
## Antigüedad                          1.079e-01  4.392e-02   2.456 0.014059 *  
## Antigüedad_Cargo                   -1.662e-01  4.966e-02  -3.348 0.000815 ***
## Años_ultima_promoción               1.753e-01  4.623e-02   3.791 0.000150 ***
## Años_acargo_con_mismo_jefe         -1.383e-01  5.189e-02  -2.665 0.007703 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 1040.54  on 1176  degrees of freedom
## Residual deviance:  707.45  on 1139  degrees of freedom
## AIC: 783.45
## 
## Number of Fisher Scoring iterations: 15

Interpretaciones

Estado civil: Se evidencia que las personas solteras son estadisticamente significativas para el modelo y que pueden rotar más que las personas con otros estados civiles. Adicionalmente, ser soltero aumenta la probabilidad de rotación en la empresa.

2.Departamento: Se evidencia que dentro del modelo el Departamento no resultó siendo estadisticamente significativo para la preidcción de rotación.

Viaje de Negocios: Se evidencia que las personas que no viajan o que viajan raramente son estadisticamente significativas para el modelo y que pueden rotar más que otras personas. Adicionalmente, no viajar o viajar raramente disminuye la probabilidad de rotación, es decir, que las personas que viajan frecuentemente probablemente podrían rotar con mayor facilidad.
Edad: Se evidencia que la edad es estadisticamente significativa para el modelo. Adicionalmente, dicha variable disminiuye la probabilidad de rotación, por lo que por un aumento en la variable edad significaría una disminución en la posibilidad de rotación.
Ingreso_Mensual: Se evidencia que el ingreso mensual no es estadisticamente significativo para el modelo.
Trabajos_Anteriores: Se evidencia que la cantidad de trabajos anteriores de las personas es estadisticamente significativa para el modelo y que haber tenido mayor cantidad de trabajos anterior puede aumentar la probabilidad de rotación en la empresa.

Punto 5: Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.

# PARALELIZACIÓN DE PROCESO
#===============================================================================

registerDoMC(cores = 4)

# HIPERPARÁMETROS, NÚMERO DE REPETICIONES Y SEMILLAS PARA CADA REPETICIÓN
#===============================================================================
particiones  <- 10
repeticiones <- 5

# Hiperparámetros
hiperparametros <- data.frame(parameter = "none")

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  seeds[[i]] <- sample.int(1000, nrow(hiperparametros))
}
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

# DEFINICIÓN DEL ENTRENAMIENTO
#===============================================================================
control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "final", verboseIter = FALSE,
                              summaryFunction = twoClassSummary,
                              classProbs = TRUE,
                              allowParallel = TRUE)

# AJUSTE DEL MODELO
# ==============================================================================
set.seed(342)
modelo_logistic <- train(Rotación ~ ., data = datos_train,
                         method = "glm", tuneGrid = hiperparametros,
                         trControl = control_train, family = "binomial")
modelo_logistic

## Generalized Linear Model 
## 
## 1177 samples
##   23 predictor
##    2 classes: 'No', 'Si' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 5 times) 
## Summary of sample sizes: 1059, 1059, 1059, 1060, 1060, 1059, ... 
## Resampling results:
## 
##   ROC        Sens       Spec     
##   0.8226344  0.9633313  0.3747368

library(pROC)
# Se obtienen las probabilidades predichas para cada clase
predicciones <- predict(object = modelo_logistic,
                        newdata = datos_test,
                        type = "prob")
# Cálculo de la curva
curva_roc <- roc(response = datos_test$Rotación, 
                 predictor = predicciones$Si) 

# Gráfico de la curva
plot(curva_roc)

# Área bajo la curva AUC
auc(curva_roc)

## Area under the curve: 0.8341

# Intervalo de confianza de la curva
ci.auc(curva_roc, conf.level = 0.95)

## 95% CI: 0.7673-0.9009 (DeLong)

Análisis

El área bajo la curva (AUC) de nuestro modelo es de 0.8201, lo que a consideración es catalogado como un buen ajuste de diagnostico predictivo.

Punto 6: Predeccir la probabilida de que un individuo (hipotetico) rote y defina un corte para decidir si se debe intervenir a este empleado o no (posible estrategia para motivar al empleado).

Caracteristicas individuo:

Edad: 30 Viaje de negocios: Raramente Distancia casa: 20 Campo educación: Ciencias Satisfacción ambiental: 1 Genero: M Cargo: Investigador Cientifico SatisfAacción laboral:3 Estado civil: Soltero Trabajos anteriores: 2 Horas extras: Si Años experiencia: 8 Capactiaciones: 2 Equilibrio trabajo - vida: 3 Antiguedad cargo: 5 Años ultima promoción: 0 Años a cargo mismo jefe: 2

Corte para intervenir: >= 70% ya que se podría esperar que el empleado renuncie a la compañia

z = -0.7156-0.02816*(30)-2.353*(0)-0.8997*(1)+0.04556*(20)+0.8087*(0)-0.4697*(1)+0.4695*(1)+2.53*(0)+2.674*(1)+3.832*(0)-0.4308*(3)+1.34*(1)+0.1344*(2)+1.824*(1)-0.07405*(8)-0.1704*(2)-0.3424*(3)-0.1621*(5)+0.1781*(0)-0.1298*(2)
z

## [1] 0.2348

predic_indiv= 1 / (1 + exp(-z))
predic_indiv

## [1] 0.5584318

Analisis

El individuo tiene una probabilidad de rotar del 55.84% de acuerdo con las caracteristicas dadas inicialmente. Por lo tanto y de acuerdo con la politica definida no es un empleado de consideración para aplicar políticas de retención de personal.

Punto 7: En las conclusiones se discute sobre cual seria la estrategia para disminuir la rotación en la empresa (con base en las variables que resultaron significativas en el punto 3). Ejemplo: Mejorar el ambiente laboral, los incentivos económicos, distribuir la carga de horas extra (menos turnos y mas personal).

Estrategias

Se recomienda que la empresa genere planes de acción por medio de políticas de personal para los empleados que viajan por negocios frecuentemente, reconociendo algún tipo de bonificación en especie o no pero que impacten la percepción en este grupo de que su esfuerzo es reconocido por la compañia.

Asimismo, para las personas que pertenecen al Departamento de Ventas e inclusive para los del Departamento de RH es importante incentivar su estadía en la empresa, por medio de plane de capacitación e incentivos no monetarios que impacten en la retención de estos talentos.

Para los empleados más jovenes y/o solteros se recomienda la implementación de espacios de trabajo modernos, ambiente laboral comodo e inclusive la adaptación en la compañia de tendencias modernas como el home office u horarios flexibles que aporten al ocio y la calidad de vida los empleados, esto podrá aportar a que otro segmentos de empleados no roten.

Finalmente, es importante que dentro de la compañia se establezcan politicas salariales, tal vez por medio de curvas salariales de acuerdo al tiempo de permanencia o el reconocimiento de incentivos por quinquenios, esto motivaría a los empleados a permanecer en la empresa y adicionalmente, se recomienda implementar convenios con psicologos o profesionales en coaching para que los empleados que deseen usen este beneficio y obtengan recomendaciones para sus planes de vida, esta idea es con el fin de impactar a los empleados que han tenido varios empleos en el pasado y aportar a la construcción de su proyecto de vida.

Segundo punto

Con base en los datos de créditos proponga un modelo de regresión logístico múltiple que permita predecir el riesgo de default en función de las covariables que considere importantes y seleccionándolas de acuerdo con un proceso adecuado. Tenga en cuenta realizar una evaluación de la significancia de los parámetros, interpretación y proponga un método de evaluación por medio de validación cruzada. Presente métricas apropiadas como el AUC y la curva ROC.

library(readxl)
library(foreign)
library(Factoshiny)
library(factoextra)
library(corrplot)
library(biplotbootGUI)
library(dynBiplotGUI)
library(psych)
library(ggplot2)
library(dplyr)
library(recipes)
library(knitr)
library(kernlab)
library(caret)
library(doMC)
library(randomForest)

datos <- read_excel("C:/Users/elcantorh/Downloads/Datos_Creditos.xlsx")
attach(datos)
datos$DEFAULT <- if_else(datos$DEFAULT == 1, "Si", "No")
glimpse(datos)

## Rows: 780
## Columns: 5
## $ DEFAULT     <chr> "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si"~
## $ ANTIUEDAD   <dbl> 37.317808, 37.317808, 30.978082, 9.728767, 8.443836, 6.605~
## $ EDAD        <dbl> 76.98356, 73.77534, 78.93699, 51.52877, 38.96986, 44.87945~
## $ CUOTA_TOTAL <dbl> 3020519, 1766552, 1673786, 668479, 1223559, 3517756, 13047~
## $ INGRESOS    <dbl> 8155593, 6181263, 4328075, 5290910, 5333818, 2710736, 3169~

# Tabla de frecuencias 
table(datos$DEFAULT)

## 
##  No  Si 
## 741  39

prop.table(table(datos$DEFAULT)) %>% round(digits = 2)

## 
##   No   Si 
## 0.95 0.05

Metodo para la seleccion de variables:

Se utilizara el metodo de variables con varianza proxima a cero, debido a que no se debe incluir en un modelo variables o predictores que contengan cero-varianza ya que no aportaran informacion relevante.

datos %>% select(ANTIUEDAD, EDAD, CUOTA_TOTAL,INGRESOS) %>%
          nearZeroVar(saveMetrics = TRUE)

##             freqRatio percentUnique zeroVar   nzv
## ANTIUEDAD    4.076923      59.61538   FALSE FALSE
## EDAD         1.000000      97.43590   FALSE FALSE
## CUOTA_TOTAL  1.000000      99.61538   FALSE FALSE
## INGRESOS     1.200000      95.38462   FALSE FALSE

Análisis

En el calculo anterior se ve que dentro de los predictores incluidos en el modelo, no se detecta ninguno con varianza cero o proxima a cero, por lo que se procedera a realizar el modelo con esas 4 variables.

#datos$ANTIUEDAD <- as.factor(datos$ANTIUEDAD)
#datos$EDAD <- as.factor(datos$EDAD)
#datos$CUOTA_TOTAL <- as.factor(datos$CUOTA_TOTAL)
#datos$INGRESOS <- as.factor(datos$INGRESOS)
glimpse(datos)

## Rows: 780
## Columns: 5
## $ DEFAULT     <chr> "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si", "Si"~
## $ ANTIUEDAD   <dbl> 37.317808, 37.317808, 30.978082, 9.728767, 8.443836, 6.605~
## $ EDAD        <dbl> 76.98356, 73.77534, 78.93699, 51.52877, 38.96986, 44.87945~
## $ CUOTA_TOTAL <dbl> 3020519, 1766552, 1673786, 668479, 1223559, 3517756, 13047~
## $ INGRESOS    <dbl> 8155593, 6181263, 4328075, 5290910, 5333818, 2710736, 3169~

set.seed(123)
# Se crean los índices de las observaciones de entrenamiento
train <- createDataPartition(y = datos$DEFAULT, p = 0.8, list = FALSE, times = 1)
datos_train <- datos[train, ]
datos_test  <- datos[-train, ]

prop.table(table(datos_train$DEFAULT))

## 
##     No     Si 
## 0.9488 0.0512

prop.table(table(datos_test$DEFAULT))

## 
##         No         Si 
## 0.95483871 0.04516129

Realizacion del Modelo:

# PARALELIZACIÓN DE PROCESO
#===============================================================================
library(doMC)
registerDoMC(cores = 4)

# HIPERPARÁMETROS, NÚMERO DE REPETICIONES Y SEMILLAS PARA CADA REPETICIÓN
#===============================================================================
particiones  <- 10
repeticiones <- 5

# Hiperparámetros
hiperparametros <- data.frame(parameter = "none")

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  seeds[[i]] <- sample.int(1000, nrow(hiperparametros))
}
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

# DEFINICIÓN DEL ENTRENAMIENTO
#===============================================================================
control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "final", verboseIter = FALSE,
                              allowParallel = TRUE)

# AJUSTE DEL MODELO
# ==============================================================================
set.seed(342)
modelo_logistic <- train(DEFAULT ~ ., data = datos_train,
                         method = "glm",
                         tuneGrid = hiperparametros,
                         metric = "Accuracy",
                         trControl = control_train,
                         family = "binomial")
modelo_logistic

## Generalized Linear Model 
## 
## 625 samples
##   4 predictor
##   2 classes: 'No', 'Si' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 5 times) 
## Summary of sample sizes: 563, 563, 561, 563, 563, 563, ... 
## Resampling results:
## 
##   Accuracy   Kappa     
##   0.9504429  0.04669959

summary(modelo_logistic$finalModel)

## 
## Call:
## NULL
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -0.9431  -0.3785  -0.2783  -0.1701   3.2874  
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -2.476e+00  1.032e+00  -2.399   0.0164 *  
## ANTIUEDAD   -4.971e-02  2.761e-02  -1.800   0.0718 .  
## EDAD         1.083e-02  2.223e-02   0.487   0.6262    
## CUOTA_TOTAL  1.217e-06  3.047e-07   3.993 6.52e-05 ***
## INGRESOS    -3.099e-07  1.259e-07  -2.461   0.0138 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 252.54  on 624  degrees of freedom
## Residual deviance: 228.79  on 620  degrees of freedom
## AIC: 238.79
## 
## Number of Fisher Scoring iterations: 7

Análisis

Empleando este modelo de regresión logística se consigue un accuracy promedio de validación del 95%. De igual manera se observa que de las 4 variables la que menos tiene significancia es la Edad.

\(Default = -2.476 - 0.04971*Antiguedad + 0.000001217*Cuotatotal - 0.0000003099*Ingresos\)

Entrenamiento del modelo:

modelo_svmlineal <- train(DEFAULT ~ ., method = "svmLinear", data = datos_train)
modelo_svmlineal$finalModel

## Support Vector Machine object of class "ksvm" 
## 
## SV type: C-svc  (classification) 
##  parameter : cost C = 1 
## 
## Linear (vanilla) kernel function. 
## 
## Number of Support Vectors : 70 
## 
## Objective Function Value : -64 
## Training error : 0.0512

Análisis

Aqui se muestra el tipo de modelo creado y se puede observar que el error de entrenamiento o training error, corresponde con el error que comete el modelo al predecir las mismas observaciones con las que se ha entrenado, un 5% en este caso.

Se ajusta de nuevo una máquina vector soporte lineal, esta vez con validación cruzada repetida para estimar su error.

# PARALELIZACIÓN DE PROCESO
#===============================================================================
# Se paraleliza para que sea más rápido. El número de cores activados depende del
# las características del ordenador donde se ejecute el código.
library(doMC)
registerDoMC(cores = 4)

# NÚMERO DE REPETICIONES Y SEMILLAS PARA CADA REPETICIÓN
#===============================================================================
# Es este caso se recurre a validación cruzada repetida como método de validación.
# Número de particiones y repeticiones
particiones  <- 10
repeticiones <- 5

# Las semillas solo son necesarias si se quiere asegurar la reproducibilidad de
# los resultados, ya que la validación cruzada y el bootstrapping implican selección
# aleatoria. Las semillas se almacenan en una lista con B+1 elementos donde B depende
# del método de validación empleado:
# 
#   "cv": B es el número total de particiones
#   "repeatedcv": B es el número de particiones por el número de repeticiones.
#   "boot": B es el número de resamples.
#   "LOGOCV":   B es el número de repeticiones.
#   
# Los primeros B elementos deben ser vectores formados por M números enteros,
# donde M es el número de modelos ajustados en cada partición o repetición,
# es decir, el total de hiperparámetros comparados. El último elemento (B+1) solo
# necesita un único número para ajustar el modelo final.

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  # Cada elemento de la lista, excepto el último tiene que tener tantas semillas
  # como hiperparámetros analizados. En este caso, se emplea el valor por 
  # defecto C = 1, por lo que cada elemento de seeds está formada por un
  # único valor.
  seeds[[i]] <- sample.int(1000, 1) 
}
# La última semilla se emplea para ajustar el modelo final con todas las observaciones.
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

# DEFINICIÓN DEL ENTRENAMIENTO
#===============================================================================
control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "all", verboseIter = FALSE,
                              allowParallel = TRUE)

# AJUSTE DEL MODELO
# ==============================================================================
set.seed(342)
modelo_svmlineal <- train(DEFAULT ~ ., data = datos_train,
                          method = "svmLinear",
                          metric = "Accuracy",
                          trControl = control_train)
modelo_svmlineal

## Support Vector Machines with Linear Kernel 
## 
## 625 samples
##   4 predictor
##   2 classes: 'No', 'Si' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 5 times) 
## Summary of sample sizes: 563, 563, 561, 563, 563, 563, ... 
## Resampling results:
## 
##   Accuracy   Kappa
##   0.9488402  0    
## 
## Tuning parameter 'C' was held constant at a value of 1

Análisis

Una validación cruzada con 10 particiones y 5 repeticiones, implica ajustar y evaluar el modelo 10 x 5 = 50 veces, cada vez con una partición distinta, más un último ajuste con todos los datos de entrenamiento para crear el modelo final. En este caso se muestra información sobre el algoritmo empleado, el método de resampling y el valor promedio de las métricas de validación. Además, si se indica en el control de entrenamiento returnResamp = “all”, se almacenan los resultados obtenidos en cada una de las iteraciones, lo que permite un análisis más detallado.

# Valores de validación (Accuracy y Kappa) obtenidos en cada partición y repetición.
modelo_svmlineal$resample %>% head(10)

##     Accuracy Kappa C    Resample
## 1  0.9516129     0 1 Fold01.Rep1
## 2  0.9516129     0 1 Fold02.Rep1
## 3  0.9375000     0 1 Fold03.Rep1
## 4  0.9516129     0 1 Fold04.Rep1
## 5  0.9516129     0 1 Fold05.Rep1
## 6  0.9516129     0 1 Fold06.Rep1
## 7  0.9516129     0 1 Fold07.Rep1
## 8  0.9375000     0 1 Fold08.Rep1
## 9  0.9523810     0 1 Fold09.Rep1
## 10 0.9516129     0 1 Fold10.Rep1

summary(modelo_svmlineal$resample$Accuracy)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.9365  0.9516  0.9516  0.9488  0.9516  0.9524

library(ggpubr)

p1 <- ggplot(data = modelo_svmlineal$resample, aes(x = Accuracy)) +
      geom_density(alpha = 0.5, fill = "gray50") +
      geom_vline(xintercept = mean(modelo_svmlineal$resample$Accuracy),
                 linetype = "dashed") +
      theme_bw() 
p2 <- ggplot(data = modelo_svmlineal$resample, aes(x = 1, y = Accuracy)) +
      geom_boxplot(outlier.shape = NA, alpha = 0.5, fill = "gray50") +
      geom_jitter(width = 0.05) +
      labs(x = "") +
      theme_bw() +
      theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())
  
final_plot <- ggarrange(p1, p2)
final_plot <- annotate_figure(
                final_plot,
                top = text_grob("Accuracy obtenido en la validación", size = 15))
final_plot

#### Análisis

El accuracy promedio estimado mediante validación cruzada repetida es de 0.94, el modelo predice correctamente el riesgo de default en un 94% de las veces.

Prediccion

predicciones_raw <- predict(modelo_svmlineal, newdata = datos_test,
                            type = "raw")
predicciones_raw

##   [1] No No No No No No No No No No No No No No No No No No No No No No No No No
##  [26] No No No No No No No No No No No No No No No No No No No No No No No No No
##  [51] No No No No No No No No No No No No No No No No No No No No No No No No No
##  [76] No No No No No No No No No No No No No No No No No No No No No No No No No
## [101] No No No No No No No No No No No No No No No No No No No No No No No No No
## [126] No No No No No No No No No No No No No No No No No No No No No No No No No
## [151] No No No No No
## Levels: No Si

# El algoritmo svmLinear no calcula de forma nativa probabilidades, para obtenerlas
# se reajusta el modelo indicando `classProbs = TRUE`.
particiones  <- 10
repeticiones <- 5
hiperparametros <- expand.grid(C = c(1))

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  seeds[[i]] <- sample.int(1000, nrow(hiperparametros)) 
}
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "all", verboseIter = FALSE,
                              classProbs = TRUE, allowParallel = TRUE)

set.seed(342)
modelo_svmlineal <- train(DEFAULT ~ ., data = datos_train,
                          method = "svmLinear",
                          tuneGrid = hiperparametros,
                          metric = "Accuracy",
                          trControl = control_train)

## maximum number of iterations reached 0.0002381068 0.0002380933maximum number of iterations reached 0.000992626 0.0009918959maximum number of iterations reached -0.000423977 -0.0004240379maximum number of iterations reached 0.0009149521 0.0009143777maximum number of iterations reached 0.000382641 0.0003826077maximum number of iterations reached 0.0005052279 0.0005050972maximum number of iterations reached 1.111792e-05 1.111871e-05maximum number of iterations reached 0.0002581109 0.0002580955maximum number of iterations reached 0.0006104187 0.0006103399maximum number of iterations reached 0.0005485713 0.000548542maximum number of iterations reached -0.0003320407 -0.0003320883maximum number of iterations reached -0.0003546219 -0.0003548478maximum number of iterations reached 0.0009295435 0.0009291127maximum number of iterations reached 0.0005806252 0.0005803419maximum number of iterations reached -0.000466217 -0.0004663769maximum number of iterations reached 0.0001334182 0.0001334187maximum number of iterations reached 0.0003430262 0.0003430192maximum number of iterations reached 0.0006397049 0.0006395388maximum number of iterations reached 0.001277778 0.001276153maximum number of iterations reached -0.0002747883 -0.0002747903maximum number of iterations reached 0.001437441 0.001435027maximum number of iterations reached 0.0003171718 0.0003171524maximum number of iterations reached 0.0007656285 0.0007638271maximum number of iterations reached 0.0005956441 0.0005950769maximum number of iterations reached 0.0004100318 0.000409948maximum number of iterations reached 0.0008615347 0.0008609493maximum number of iterations reached 0.0002287508 0.0002287183maximum number of iterations reached 0.0006804534 0.0006803299maximum number of iterations reached -0.0001025455 -0.0001025555maximum number of iterations reached 4.182992e-05 4.183015e-05maximum number of iterations reached 0.001092028 0.001090029maximum number of iterations reached 4.976597e-05 4.976197e-05maximum number of iterations reached -0.0001678085 -0.0001678249maximum number of iterations reached 0.0002855738 0.0002855457maximum number of iterations reached 0.0008267507 0.0008263084maximum number of iterations reached -0.0003077795 -0.0003078608maximum number of iterations reached 0.0006828279 0.0006823864maximum number of iterations reached 0.001321375 0.00132062maximum number of iterations reached -0.0002980532 -0.0002980774maximum number of iterations reached 0.0004354547 0.0004351911maximum number of iterations reached -0.0003076142 -0.00030767maximum number of iterations reached 0.0009828671 0.0009818359maximum number of iterations reached 0.0003156456 0.0003149537maximum number of iterations reached 0.0001221206 0.0001221213maximum number of iterations reached 0.0003415366 0.0003415019maximum number of iterations reached 0.0007484085 0.0007478731maximum number of iterations reached 0.0002573587 0.0002573249maximum number of iterations reached 0.0005716597 0.0005709572maximum number of iterations reached -0.0007224102 -0.0007225534maximum number of iterations reached 0.001529129 0.001527067

predicciones_prob <- predict(modelo_svmlineal, newdata = datos_test,
                             type = "prob")
predicciones_prob %>% head()

##          No         Si
## 1 0.9483057 0.05169427
## 2 0.9481048 0.05189524
## 3 0.9481267 0.05187329
## 4 0.9481760 0.05182401
## 5 0.9481831 0.05181692
## 6 0.9480152 0.05198479

Análisis

Obtener las probabilidades para cada clase es más informativo, ya que, además de conocer la clase predicha (la que tiene mayor probabilidad), se puede cuantificar la confianza de dicha predicción. Se tiene mucha más seguridad de que la predicción es correcta si las probabilidades son 0.9 - 1.

predicciones <- extractPrediction(
                  models = list(svm = modelo_svmlineal),
                  testX = datos_test %>% select(-DEFAULT),
                  testY = datos_test$DEFAULT
                  )
predicciones %>% head()

##   obs pred     model dataType object
## 1  Si   No svmLinear Training    svm
## 2  Si   No svmLinear Training    svm
## 3  Si   No svmLinear Training    svm
## 4  Si   No svmLinear Training    svm
## 5  Si   No svmLinear Training    svm
## 6  Si   No svmLinear Training    svm

Metricas AUC y la curva ROC.

# PARALELIZACIÓN DE PROCESO
#===============================================================================
library(doMC)
registerDoMC(cores = 4)

# HIPERPARÁMETROS, NÚMERO DE REPETICIONES Y SEMILLAS PARA CADA REPETICIÓN
#===============================================================================
particiones  <- 10
repeticiones <- 5

# Hiperparámetros
hiperparametros <- data.frame(parameter = "none")

set.seed(123)
seeds <- vector(mode = "list", length = (particiones * repeticiones) + 1)
for (i in 1:(particiones * repeticiones)) {
  seeds[[i]] <- sample.int(1000, nrow(hiperparametros))
}
seeds[[(particiones * repeticiones) + 1]] <- sample.int(1000, 1)

# DEFINICIÓN DEL ENTRENAMIENTO
#===============================================================================
control_train <- trainControl(method = "repeatedcv", number = particiones,
                              repeats = repeticiones, seeds = seeds,
                              returnResamp = "final", verboseIter = FALSE,
                              summaryFunction = twoClassSummary,
                              classProbs = TRUE,
                              allowParallel = TRUE)

# AJUSTE DEL MODELO
# ==============================================================================
set.seed(342)
modelo_logistic <- train(DEFAULT ~ ., data = datos_train,
                         method = "glm", tuneGrid = hiperparametros,
                         trControl = control_train, family = "binomial")
modelo_logistic

## Generalized Linear Model 
## 
## 625 samples
##   4 predictor
##   2 classes: 'No', 'Si' 
## 
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 5 times) 
## Summary of sample sizes: 563, 563, 561, 563, 563, 563, ... 
## Resampling results:
## 
##   ROC        Sens  Spec      
##   0.6929685  1     0.03166667

library(pROC)
# Se obtienen las probabilidades predichas para cada clase
predicciones <- predict(object = modelo_logistic,
                        newdata = datos_test,
                        type = "prob")
# Cálculo de la curva
curva_roc <- roc(response = datos_test$DEFAULT, 
                 predictor = predicciones$Si) 

# Gráfico de la curva
plot(curva_roc)

# Área bajo la curva AUC
auc(curva_roc)

## Area under the curve: 0.5492

# Intervalo de confianza de la curva
ci.auc(curva_roc, conf.level = 0.95)

## 95% CI: 0.3819-0.7166 (DeLong)

Análisis

El resultado de la curva nos muestra que el test que utilizamos no es el mejor, debido a que el valor calculado fue de 0.54.

Unidad_3

Elkin Cantor

2022-09-26

Primer punto

Cualitativas

Cuantitativas

Punto 2: Realizar un análisis univariado (caracterización). Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuanti o cuali). Incluir interpretaciones de la rotación.

Interpretaciones

Interpretaciones

Interpretaciones

Punto 4: Realizar la estimación de un modelo de regresión logistico en el cual la variable respuesta es rotación (y=1 es si rotación, y=0 es no rotación) y las covariables las 6 seleccionadas. Interprete los coeficientes del modelo y la significancia de los parametros.

Interpretaciones

Punto 5: Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.

Análisis

Punto 6: Predeccir la probabilida de que un individuo (hipotetico) rote y defina un corte para decidir si se debe intervenir a este empleado o no (posible estrategia para motivar al empleado).

Analisis

Estrategias

Segundo punto

Metodo para la seleccion de variables:

Análisis

Realizacion del Modelo:

Análisis

Entrenamiento del modelo:

Análisis

Análisis

Prediccion

Análisis

Metricas AUC y la curva ROC.

Análisis