Informe 3

Primer Punto

library(readxl)
library(dplyr)

data <- read_excel("C:/Users/Andre/Downloads/Rotacion.xlsx")
glimpse (data)

Rows: 1,470
Columns: 24
$ Rotación                    <chr> "Si", "No", "Si", "No", "No", "No", "No", …
$ Edad                        <dbl> 41, 49, 37, 33, 27, 32, 59, 30, 38, 36, 35…
$ `Viaje de Negocios`         <chr> "Raramente", "Frecuentemente", "Raramente"…
$ Departamento                <chr> "Ventas", "IyD", "IyD", "IyD", "IyD", "IyD…
$ Distancia_Casa              <dbl> 1, 8, 2, 3, 2, 2, 3, 24, 23, 27, 16, 15, 2…
$ Educación                   <dbl> 2, 1, 2, 4, 1, 2, 3, 1, 3, 3, 3, 2, 1, 2, …
$ Campo_Educación             <chr> "Ciencias", "Ciencias", "Otra", "Ciencias"…
$ Satisfacción_Ambiental      <dbl> 2, 3, 4, 4, 1, 4, 3, 4, 4, 3, 1, 4, 1, 2, …
$ Genero                      <chr> "F", "M", "M", "F", "M", "M", "F", "M", "M…
$ Cargo                       <chr> "Ejecutivo_Ventas", "Investigador_Cientifi…
$ Satisfación_Laboral         <dbl> 4, 2, 3, 3, 2, 4, 1, 3, 3, 3, 2, 3, 3, 4, …
$ Estado_Civil                <chr> "Soltero", "Casado", "Soltero", "Casado", …
$ Ingreso_Mensual             <dbl> 5993, 5130, 2090, 2909, 3468, 3068, 2670, …
$ Trabajos_Anteriores         <dbl> 8, 1, 6, 1, 9, 0, 4, 1, 0, 6, 0, 0, 1, 0, …
$ Horas_Extra                 <chr> "Si", "No", "Si", "Si", "No", "No", "Si", …
$ Porcentaje_aumento_salarial <dbl> 11, 23, 15, 11, 12, 13, 20, 22, 21, 13, 13…
$ Rendimiento_Laboral         <dbl> 3, 4, 3, 3, 3, 3, 4, 4, 4, 3, 3, 3, 3, 3, …
$ Años_Experiencia            <dbl> 8, 10, 7, 8, 6, 8, 12, 1, 10, 17, 6, 10, 5…
$ Capacitaciones              <dbl> 0, 3, 3, 3, 3, 2, 3, 2, 2, 3, 5, 3, 1, 2, …
$ Equilibrio_Trabajo_Vida     <dbl> 1, 3, 3, 3, 3, 2, 2, 3, 3, 2, 3, 3, 2, 3, …
$ Antigüedad                  <dbl> 6, 10, 0, 8, 2, 7, 1, 1, 9, 7, 5, 9, 5, 2,…
$ Antigüedad_Cargo            <dbl> 4, 7, 0, 7, 2, 7, 0, 0, 7, 7, 4, 5, 2, 2, …
$ Años_ultima_promoción       <dbl> 0, 1, 0, 3, 2, 3, 0, 0, 1, 7, 0, 0, 4, 1, …
$ Años_acargo_con_mismo_jefe  <dbl> 5, 7, 0, 0, 2, 6, 0, 0, 8, 7, 3, 8, 3, 2, …

table(sapply(data, typeof))

character    double 
        8        16 

El dataset original integrado por 1.470 observaciones y 24 variables. De estas últimas, ocho se reconocen como variables cualitativas y dieciséis, cuantitativas. Se considera necesario recodificar algunas variables para que representen más apropiadamente la naturaleza del fenómeno que describen. Así mismo, se considera conveniente renombrar algunas variables para evitar, entre otros, problemas con los caracteres especiales.

Numeral 1. Selección de Variables

A continuación se presenta la selección inicial de variables que se intuye que podrían estar relacionadas con la rotación.

1.1. Edad Categorizada. Tipo: cualitativo. Justificación: se considera que las dinámicas de vida cambian en función de rangos de edades, así que sería mejor crear tres categorías de edades, una para los más jóvenes, otra para los adultos en edad intermedia, y otra para los más grandes. Hipótesis: los colaboradores más jóvenes son más propensos a irse de la compañía.

1.2. Equilibrio Trabajo Vida. Tipo: Cualitativo. Justificación: se considera que si un colaborador percibe que su trabajo desestabiliza las demás dimensiones de su vida, tendrá más motivos para desertar. Hipótesis: las calificaciones más bajas del “equilibrio trabajo - vida” corresponden a los niveles más altos de rotación.

1.3. Satisfacción Ambiental. Tipo: Cualitativo. Justificación: se precisa que se interpreta esta variable como una percepción del colaborador sobre su contexto laboral inmediato, es decir, cuán a gusto se siente con su equipo de trabajo, incluyendo a su jefe y sus compañeros. Hipótesis: entre peor calificado sea este aspecto, el colaborador estará más propenso a irse de la empresa.

1.4. Ingreso Mensual. Tipo: Cuantitativo. Justificación: el salario es una variable que se intuye que es determinante para la atracción y retención de los colaboradores. Hipótesis: los colaboradores con menor salario tienden a irse de la compañía más frecuentemente.

1.5. Años desde la última promoción. Tipo: Cuantitativo. Justificación: llevar mucho tiempo en una misma posición puede conducir a la monotonía y el aburrimiento. Hipóteis: entre más tiempo haya pasado un colaborador en el mismo cargo, más propenso es a irse.

1.6. Capacitaciones. Tipo: Cuantitativo. Justificación: cuando un colaborador no percibe interés de la empresa por desarrollar sus competenciasa, puede contempla más fácilmente la posibilidad de irse. Hipótesis: a menor participación en capacitaciones, mayor será la disposición a irse de la compañía.

Ahora, se procede a manipular los datos para recodificar las variables, según lo indicado.

data_2 <- data[,c(1,2,8,13,19,20,23)]

library(dplyr)
data_2 <- data_2 %>%
  rename(
          "Rotacion"="Rotación",
          "Trab_vida"="Equilibrio_Trabajo_Vida",
          "Satisf_amb"="Satisfacción_Ambiental",
          "Ingreso_mes"="Ingreso_Mensual",
          "Ultima_prom"="Años_ultima_promoción"
        )

Numeral 2. Análisis Univariado

A continuación se presenta el análisis individual de las variables.

2.1. Se calcula el nivel del rotación general de la empresa, como insumo para el análisis de los factores que valdría la pena tener en cuenta para una intervención.

round(prop.table(table(data_2$Rotacion)),3)*100 

  No   Si 
83.9 16.1 

La tabla anterior indica que el nivel de rotación general en la empresa es de 16.1%, toda vez que de los 1.470 colaboradores registrados en el dataset, 237 dejaron su rol en la compañía.

A continuación, se procede a realizar una caracterización de las variables seleccionadas.

2.2. Variable “Edad”

Edad2=cut(data_2$"Edad", 3, labels = c("Jovenes","Intermedia","Mayores"))
data_2=data.frame(data_2, Edad2)

library(ggplot2)
#Edad Categorizada
g1=ggplot(data_2,aes(x=Edad2))+geom_bar()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Edad")
g1 

jovenes = data_2 %>%
  filter(Edad2=="Jovenes")

intermedia = data_2 %>%
  filter(Edad2=="Intermedia")

mayores = data_2 %>%
  filter(Edad2=="Mayores")

Edad_min = c(min(jovenes$Edad), min(intermedia$Edad), min(mayores$Edad))
Edad_max = c(max(jovenes$Edad), max(intermedia$Edad), max(mayores$Edad))

tbl = table(data_2$"Edad2")
cbind(tbl,round(prop.table(tbl),3)*100, Edad_min, Edad_max)

           tbl      Edad_min Edad_max
Jovenes    516 35.1       18       32
Intermedia 714 48.6       33       46
Mayores    240 16.3       47       60

• Los “jóvenes” tienen entre 18 y 32 años.
• Los adultos en edad “intermedia” tienen entre 33 y 46 años.
• Los “mayores” tienen entre 47 y 60 años.

Con la información provista por la gráfica y la tabla anterior, se tiene que:

• La mayoría de los colaboradores son adultos en edad “intermedia”, con un 48.6% del total.
• El segundo segmento más grande es el de los “jóvenes”, que alcanza el 35.1% de los colaboradores.
• El subset más pequeño es el de “mayores”, que alcanzan sólo el 16.3% de los colaboradores.

2.3. Variable “Equilibrio Trabajo-Vida”

g2=ggplot(data_2,aes(x=Trab_vida))+geom_bar()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Eq. Trabajo-Vida")
g2

tbl3=table(data_2$Trab_vida)
cbind(tbl3,round(prop.table(tbl3),3)*100)

  tbl3     
1   80  5.4
2  344 23.4
3  893 60.7
4  153 10.4

Para esta variable se asume que los valores 3 y 4 corresponden a percepciones positivas en relación con sus condiciones laborales; y que los valores 1 y 2 corresponden a percepciones negativas. Así, considerando la información de la gráfica y la tabla anterior, se puede afirmar que:

• La mayoría de los colaboradores tienen una percepción positiva sobre el Equilibrio Trabajo-Vida. Esto es, 1.046 de los 1.470 colaboradores, es decir, el 71.1% del total.
• El 10.4% reporta la más alta de las valoraciones para esta variable.
• Entre los 424 colaboradores que tienen una percepción negativa, 80 seleccionaron la más baja de las opciones. Estos últimos equivalen al 5.4% del total de los colaboradores.

2.4. Variable “Satisfacción Ambiental”

g3=ggplot(data_2,aes(x=Satisf_amb))+geom_bar()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Satisfacción Amb.")
g3

tbl4=table(data_2$Satisf_amb)
cbind(tbl4,round(prop.table(tbl4),3)*100)

  tbl4     
1  284 19.3
2  287 19.5
3  453 30.8
4  446 30.3

En este caso se asumió que los valores 1 y 2 corresponden a satisfacción baja; y 3 y 4, satisfacción alta. Así, considerando la información de la gráfica y la tabla 4, se puede afirmar que:

• La mayoría de los colaboradores reporta una satisfacción laboral alta. Esto es, 899 de los 1.470 colaboradores, es decir, el 61.1% del total.
• El 30.3% del total de los colaboradores reporta la más alta de las valoraciones para esta variable.
• Entre los 571 colaboradores que reportan una satisfacción laboral baja, 284 seleccionaron la más baja de las opciones. Estos últimos equivalen al 19.3% del total de los colaboradores.

2.5. Variable “Ingreso Mensual”

grafica=ggplot(data_2, aes(x=Ingreso_mes))+geom_density()+theme_bw()
g4=grafica + geom_vline(aes(xintercept=mean(Ingreso_mes)), color="blue", linetype="dashed", size=1)+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Ingreso Mes")
g4

summary(data_2$Ingreso_mes)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   1009    2911    4919    6503    8379   19999 

Según lo observado en la gráfica y la tabla anterior, la variable “Ingreso_Mensual” presenta una distribución asimétrica, con un rango que va desde 1.009.000 hasta 6.503.000; una mediana de 4.919.000 y una media de 6.503.000. El 75% de los colaboradores se tienen un ingreso mensual de hasta 8.379.000.

2.6. Variable “Años desde la Última Promoción”

g5=ggplot(data_2,aes(x=Ultima_prom))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Última Promoción")
g5

summary(data_2$Ultima_prom)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   0.000   1.000   2.188   3.000  15.000 

Según lo observado en la gráfica y la tabla anterior, la variable “Años desde la Última Promoción” también presenta una distribución asimétrica, con un rango que va desde 0 hasta 15 años; una mediana de 1 año y una media de 2.19 años. Para el 75% de los colaboradores, han pasado hasta 3 años desde su última propoción.

2.7. Variable “Capacitaciones”

g6=ggplot(data_2,aes(x=Capacitaciones))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())+ggtitle("Capacitaciones")
g6

summary(data_2$Capacitaciones)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   2.000   3.000   2.799   3.000   6.000 

Según lo observado en la gráfica y la tabla anterior, la variable “Capacitaciones” se aproxima mucho más a una distribución normal, con un rango que va desde 0 hasta 6 capacitaciones; una mediana de 3 y una media de 2.8 capacitaciones. El 75% de los colaboradores ha recibido hasta 3 capacitaciones.

Numeral 3. Análisis Bivariado

A continuación, se codifica la variable “Rotación” en términos de 1 y 0.

data_2$Rotacion <- as.factor(gsub("Si",1, data_2$Rotacion))
data_2$Rotacion <- as.factor(gsub("No",0, data_2$Rotacion))

Ahora, se procede a explorar la relación entre las variables seleccionadas y la Rotación.

par(mfrow=c(1,3))

tabla3 <- table(data_2$Rotacion, data_2$Edad2)
mosaicplot(tabla3,
           col=c("#faf0ca","#0d3b66"),
           las=1,
           main = "Edad VS. Rotación")

tabla1 <- table(data_2$Rotacion, data_2$Satisf_amb)
mosaicplot(tabla1,
           col=c("#faf0ca","#0d3b66"),
           las=1,
           main = "Satisfacción Amb. VS. Rotación")

tabla2 <- table(data_2$Rotacion, data_2$Trab_vida)
mosaicplot(tabla2,
           col=c("#faf0ca","#0d3b66"),
           las=1,
           main = "Eq. Trabajo-Vida VS. Rotación")

3.1. Considerando la información de la gráfica, se evidencia que la categoría de los “jóvenes”, está relacionada con los niveles más altos de rotación. Esto parece hacerle eco a la hipótesis planteada para esta variable.

3.2. La variable “Satisfacción Ambiental” también tuvo resultados importantes. En este caso, los colaboradores que reportaron la peor calificación tienen el mayor nivel de rotación relativa. Esto también apunta a la hipótesis inicial que se tenía para esta variable.

3.3. En cuanto a la variable “Equilibrio Trabajo-Vida, la gráfica indica que los colaboradores que tiene la peor percepción en esta materia (calificación = 1), tienen el nivel de rotación relativo más elevado. Esto parece apuntar hacia la hipótesis planteada para esta variable.

g10 = ggplot(data_2,aes(x=Rotacion, y=Ingreso_mes,fill=Rotacion))+geom_boxplot()+theme_bw()

g11 = ggplot(data_2,aes(x=Rotacion, y=Ultima_prom,fill=Rotacion))+geom_boxplot()+theme_bw()

g12 = ggplot(data_2,aes(x=Rotacion,y=Capacitaciones,fill=Rotacion))+geom_boxplot()+theme_bw()

require(ggpubr)
ggarrange(g10, g11, g12, labels = c("A","B", "C"), ncol = 3, nrow=1, font.label = (size=8), common.legend = TRUE)

Considerando las gráficas A, B y C, lo primero que se puede resaltar es que la variable en que parece más prometedora es “Ingreso_Mensual”, porque presenta un comportamiento aparentemente diferente entre los colaboradores que rotan y los que no. Este fenómeto no parece ser el mismo con las otras dos parejas.

Numeral 4. Estimación

Antes de realizar la modelación, se realiza una partición del dataset como estrategia para el proceso de evaluación del modelo.

data_2 <- data_2[,-2]
data_2$Satisf_amb <- as.factor(data_2$Satisf_amb)
data_2$Trab_vida <- as.factor(data_2$Trab_vida)


set.seed(1234)
n=1470
train <- sample(1:n, 0.8*n)
data_train <- data_2[train,]
data_test <- data_2[-train,]

Ahora se procede a estimar el modelo logit.

modelo1 <- glm(Rotacion ~ ., data = data_train, family = "binomial")
summary(modelo1)

Call:
glm(formula = Rotacion ~ ., family = "binomial", data = data_train)

Deviance Residuals: 
    Min       1Q   Median       3Q      Max  
-1.2787  -0.6242  -0.4821  -0.3242   2.6881  

Coefficients:
                  Estimate Std. Error z value Pr(>|z|)    
(Intercept)      9.638e-01  4.064e-01   2.371  0.01772 *  
Satisf_amb2     -6.797e-01  2.425e-01  -2.803  0.00506 ** 
Satisf_amb3     -9.716e-01  2.303e-01  -4.219 2.45e-05 ***
Satisf_amb4     -8.927e-01  2.271e-01  -3.932 8.43e-05 ***
Ingreso_mes     -1.140e-04  2.704e-05  -4.215 2.49e-05 ***
Capacitaciones  -1.819e-01  6.656e-02  -2.733  0.00627 ** 
Trab_vida2      -4.618e-01  3.441e-01  -1.342  0.17952    
Trab_vida3      -6.760e-01  3.223e-01  -2.098  0.03594 *  
Trab_vida4      -2.667e-01  3.877e-01  -0.688  0.49161    
Ultima_prom      3.892e-02  3.075e-02   1.266  0.20560    
Edad2Intermedia -7.501e-01  1.867e-01  -4.019 5.85e-05 ***
Edad2Mayores    -3.165e-01  2.765e-01  -1.145  0.25240    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 1030.25  on 1175  degrees of freedom
Residual deviance:  946.29  on 1164  degrees of freedom
AIC: 970.29

Number of Fisher Scoring iterations: 5

exp(modelo1$coefficients)

    (Intercept)     Satisf_amb2     Satisf_amb3     Satisf_amb4     Ingreso_mes 
      2.6215599       0.5067493       0.3784853       0.4095355       0.9998860 
 Capacitaciones      Trab_vida2      Trab_vida3      Trab_vida4     Ultima_prom 
      0.8336777       0.6301281       0.5086430       0.7659271       1.0396850 
Edad2Intermedia    Edad2Mayores 
      0.4722985       0.7287090 

Antes de realizar una interpretación, habiendo evidenciado la significacia de algunos parámetros, se recurre a la comparación de alternativas para obtener el mejor modelo posible.

step(modelo1, direction="backward")

Start:  AIC=970.29
Rotacion ~ Satisf_amb + Ingreso_mes + Capacitaciones + Trab_vida + 
    Ultima_prom + Edad2

                 Df Deviance    AIC
- Ultima_prom     1   947.84 969.84
- Trab_vida       3   952.18 970.18
<none>                946.29 970.29
- Capacitaciones  1   954.05 976.05
- Edad2           2   963.07 983.07
- Satisf_amb      3   967.81 985.81
- Ingreso_mes     1   966.87 988.87

Step:  AIC=969.84
Rotacion ~ Satisf_amb + Ingreso_mes + Capacitaciones + Trab_vida + 
    Edad2

                 Df Deviance    AIC
- Trab_vida       3   953.66 969.66
<none>                947.84 969.84
- Capacitaciones  1   955.52 975.52
- Edad2           2   963.91 981.91
- Satisf_amb      3   968.77 984.77
- Ingreso_mes     1   966.87 986.87

Step:  AIC=969.66
Rotacion ~ Satisf_amb + Ingreso_mes + Capacitaciones + Edad2

                 Df Deviance    AIC
<none>                953.66 969.66
- Capacitaciones  1   961.63 975.63
- Edad2           2   970.08 982.08
- Satisf_amb      3   975.49 985.49
- Ingreso_mes     1   973.07 987.07

Call:  glm(formula = Rotacion ~ Satisf_amb + Ingreso_mes + Capacitaciones + 
    Edad2, family = "binomial", data = data_train)

Coefficients:
    (Intercept)      Satisf_amb2      Satisf_amb3      Satisf_amb4  
       0.452522        -0.669403        -0.967910        -0.899293  
    Ingreso_mes   Capacitaciones  Edad2Intermedia     Edad2Mayores  
      -0.000105        -0.183541        -0.734585        -0.297070  

Degrees of Freedom: 1175 Total (i.e. Null);  1168 Residual
Null Deviance:      1030 
Residual Deviance: 953.7    AIC: 969.7

A pesar de los resultados obtenidos con el primer modelo, Step indica que la mejor alternativa es excluir la variable “ingreso mensual”. A continuación se presenta los resultados.

modelo2 <- glm(Rotacion ~ . -Ingreso_mes, data = data_train, family = "binomial")
summary(modelo2)

Call:
glm(formula = Rotacion ~ . - Ingreso_mes, family = "binomial", 
    data = data_train)

Deviance Residuals: 
    Min       1Q   Median       3Q      Max  
-1.2579  -0.6374  -0.4721  -0.3871   2.5083  

Coefficients:
                 Estimate Std. Error z value Pr(>|z|)    
(Intercept)      0.541648   0.390160   1.388 0.165055    
Satisf_amb2     -0.625994   0.240043  -2.608 0.009111 ** 
Satisf_amb3     -0.919889   0.227542  -4.043 5.28e-05 ***
Satisf_amb4     -0.831820   0.224086  -3.712 0.000206 ***
Capacitaciones  -0.177149   0.066230  -2.675 0.007479 ** 
Trab_vida2      -0.489928   0.340735  -1.438 0.150475    
Trab_vida3      -0.712906   0.319352  -2.232 0.025592 *  
Trab_vida4      -0.333349   0.383577  -0.869 0.384819    
Ultima_prom     -0.002539   0.028620  -0.089 0.929323    
Edad2Intermedia -0.940219   0.181992  -5.166 2.39e-07 ***
Edad2Mayores    -0.856673   0.253447  -3.380 0.000725 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 1030.25  on 1175  degrees of freedom
Residual deviance:  966.87  on 1165  degrees of freedom
AIC: 988.87

Number of Fisher Scoring iterations: 5

exp(modelo2$coefficients)

    (Intercept)     Satisf_amb2     Satisf_amb3     Satisf_amb4  Capacitaciones 
      1.7188364       0.5347296       0.3985634       0.4352563       0.8376553 
     Trab_vida2      Trab_vida3      Trab_vida4     Ultima_prom Edad2Intermedia 
      0.6126706       0.4902175       0.7165202       0.9974647       0.3905423 
   Edad2Mayores 
      0.4245725 

Considerando los coeficientes del modelo mejorado y la significancia de sus parámetros, las variables que inciden en la rotación de personal y sus respectivos efectos son: - Satisfacción ambiental. A menor satisfacción ambiental, mayor probabilidad de rotación. - Capacitaciones. A menor número de capacitaciones, mayor probabilidad de rotación. - Equilibrio Trabajo-Vida. A menor equilibrio entre el trabajo y la vida, mayor probabilidad de rotación. - Edad. A mayor edad, menor probabilidad de rotación.

Así mismo, se puede afirmar que la variable “Años desde la última promoción” no inicide sobre la rotación de personal.

Numeral 5. Evaluación

pred1 <- predict.glm(modelo2, newdata = data_test, type = "response")
result1 <- table(data_test$Rotacion, ifelse(pred1>0.4, 1,0))
result1

   
      0   1
  0 238   6
  1  47   3

Pseudo_R2 <- (result1[1,1]+result1[2,2])/sum(result1)*100
Pseudo_R2

[1] 81.97279

Utilizando el subconjunto de datos reservado para la evaluación del modelo, se comprueba su bondad de ajuste, evidenciando que clasificó correctamente el 82% de las observaciones. Esto es un desempeño aceptable.

library(InformationValue)
plotROC(data_test$Rotacion, pred1)

De acuerdo con la gráfica, tanto la convexidad de la curva ROC, que tiende hacia el vértice superior izquierdo, como el resultado del AUC (llamado en este caso AUROC), que es superior a 0.5, sugieren un nivel desempeño aceptable de parte del modelo, y permiten afirmar que el modelo tiene capacidad discriminatoria. En general, el 69,5% de las veces, el modelo clasificaría correctamente a un colaborador evaluado en función de su probabilidad de rotación.

Numeral 6. Predicción

test <- data.frame("Satisf_amb"=c("4"),
                    "Ingreso_mes"=c(7000),
                    "Capacitaciones"=c(5),
                    "Trab_vida"=c("4"),
                    "Ultima_prom"=c(0),
                    "Edad2"=c("Mayores"))

resultado <- predict.glm(modelo2, newdata = test, type = "response")
resultado

         1 
0.08580731 

En este caso, el colaborador tiene un alto nivel de satisfacción ambiental, tiene un salario superior al promedio, ha recibido varias capacitaciones, considera que su trabajo le permite un alto nivel de equilibrio con las demás dimensiones de su vida, su más reciente promoción fue hace menos de un año, y corresponde al grupo de edad de los “mayores”. Con todos los insights explorados hasta ahora, es consistente que el modelo le prediga que este colaborador tiene una probabilidad muy baja de rotación, que es del 0.08.

Para establecer un valor de referencia para un programa de intervención de los empleados, valdría la pena considerar lo que prediciría el modelo para un empleado hipotético que tenga datos al otro lado del espectro:

test2 <- data.frame("Satisf_amb"=c("1"),
                    "Ingreso_mes"=c(1000),
                    "Capacitaciones"=c(0),
                    "Trab_vida"=c("1"),
                    "Ultima_prom"=c(5),
                    "Edad2"=c("Jovenes"))

resultado <- predict.glm(modelo2, newdata = test2, type = "response")
resultado

        1 
0.6292393 

Desde esta perspectiva, parece que el rango de valores de probabilidad no es tan grande como podría haberse previsto. Así las cosas, se sugeriría tener en cuenta para intervención a los colaboradores cuya probabilidad de rotación sea superior el 40%, priorizando aquellos que desempeñan cargos críticos. Este claramente no es el caso del colaborador descrito al inicio de este numeral.

Numeral 7. Conclusiones

Como se pudo observar previamente tanto en la estimación como en la evaluación del modelo, la significancia de los parámetros y los resultados de todas las métricas utilizadas señalan que el modelo logra explicar, en buena medida, el comportamiento de la rotación de personal en función de las variables predictoras elegidas, permitiendo hablar de un desempeño moderadamente alto. Todo esto reafirma la potencia predictiva del modelo desarrollado.

Teniendo esto en cuenta, se puede emplear este modelo para la toma de decisiones organizacionales desde una perspectiva data-driven, de tal forma que, para aquellos colaboradores con una baja probabilidad de rotación, se busque mantener los niveles positivos de sus variables de interés y así mantener en un valor bajo el riesgo de rotar.

Por otra parte, frente a los colaboradores con alta probabilidad de rotación, se deben desarrollar iniciativas que permitan mejorar su grado de adherencia con la organización, con el fin de optimizar los costos asociados a la contratación de nuevo personal para cubrir las vacantes causadas por la rotación.

Además, para complementar el modelo, sería de interés agregar en el futuro una variable temporal, que permita estimar el tiempo en que los colaboradores podrían rotar, y así disponer de estrategias para mitigar los impactos asociados.

En términos prácticos, con todo lo considerado hasta ahora, y teniendo en cuenta especialmente la cantidad de colaboradores implicados, se propone a la compañía una estrategia que incluya los siguientes frentes de trabajo:

Primero, emprender, de forma prioritaria, una exploración que permita reconocer las motivaciones principales de los colaboradores más jóvenes de la empresa, a fin de detectar qué acciones específicas deben realizarse para alinear las condiciones laborales y la oferta de beneficios de la empresa con los intereses de este nicho, de modo que se pueda retener a un mayor número de ellos. Las acciones relacionadas con esta iniciativa podrían incluir: programas para fomentar el sentido de pertenencia, diseñar e implementar un plan de desarrollo profesional para los colaboradores, diseñar un plan carrera, ajustar el programa de beneficios de la compañía para apoyar las metas profesionales y personales que más frecuentemente tienen los colaboradores más jóvenes, entre otras acciones.

Segundo, realizar acciones para mejorar la satisfacción ambiental en los equipos de trabajo. En este caso también se debería comenzar por individualizar los factores neurálgicos que están afectando la valoración de esta variable por parte de los colaboradores. Para ello, se podría hacer uso de técnicas como los grupos focales. Según la comprensión de esta variable expuesta desde el principio de este reporte, las acciones a considerar podrían incluir: cursos para fortalecer el perfil de los lideres de la compañía a fin de que ejercen una influencia más positiva sobre sus equipos de trabajo, programas de construcción de confianza entre los equipos, programas de desarrollo de equipos de alto desempeño, programas de desarrollo personal y profesional para los colaboradores, realizar una medición periódica del clima laboral y realizar los cambios que se identifiquen necesarios, entre otros.

Segundo Punto

Exploración inicial

library(readxl)
library(dplyr)

data2 <- read_excel("C:/Users/Andre/Downloads/Creditos.xlsx")
glimpse(data2)

Rows: 780
Columns: 5
$ DEFAULT     <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1…
$ 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…

attach(data2)

data2$DEFAULT <- as.factor(data2$DEFAULT)
data2$CUOTA_TOTAL <- data2$CUOTA_TOTAL/1000
data2$INGRESOS <- data2$INGRESOS/1000

Se tiene una base de datos con 780 registros y 5 variables. De estas últimas, todas son reconocidas como variables cuantitativas. La variable Default es discreta y las demás son continuas.

prop.table(table(data2$DEFAULT))

   0    1 
0.95 0.05 

library(ggplot2)

g2_1=ggplot(data2,aes(x=ANTIUEDAD))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())
g2_1 = g2_1 + geom_vline(aes(xintercept=mean(ANTIUEDAD)), color="blue", linetype="dashed", size=1)+ggtitle("Antigüedad")


g2_2=ggplot(data2,aes(x=EDAD))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())
g2_2 = g2_2 + geom_vline(aes(xintercept=mean(EDAD)), color="blue", linetype="dashed", size=1)+ggtitle("Edad")

g2_3=ggplot(data2,aes(x=CUOTA_TOTAL))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())
g2_3 = g2_3 + geom_vline(aes(xintercept=mean(CUOTA_TOTAL)), color="blue", linetype="dashed", size=1)+ggtitle("Cuota Total")

g2_4=ggplot(data2,aes(x=INGRESOS))+geom_histogram()+theme_bw()+theme(axis.title.x=element_blank(), axis.ticks.x=element_blank())+ theme(panel.border = element_blank())
g2_4 = g2_4 + geom_vline(aes(xintercept=mean(INGRESOS)), color="blue", linetype="dashed", size=1)+ggtitle("Ingresos")

require(ggpubr)
ggarrange(g2_1, g2_2, g2_3, g2_4, ncol=2, nrow =2, legend="bottom")

summary(data2)

 DEFAULT   ANTIUEDAD            EDAD        CUOTA_TOTAL          INGRESOS      
 0:741   Min.   : 0.2548   Min.   :26.61   Min.   :   0.387   Min.   :  633.8  
 1: 39   1st Qu.: 7.3767   1st Qu.:48.18   1st Qu.: 328.516   1st Qu.: 3583.3  
         Median :15.1192   Median :57.92   Median : 694.460   Median : 5039.0  
         Mean   :18.0353   Mean   :56.99   Mean   : 885.206   Mean   : 5366.4  
         3rd Qu.:30.6637   3rd Qu.:66.19   3rd Qu.:1244.126   3rd Qu.: 6844.1  
         Max.   :37.3178   Max.   :92.43   Max.   :6664.588   Max.   :22197.0  

Considerando la variable Default, se puede advertir que el dataset tiene un comportamiento desbalanceado, ya que el 95% de los registros corresponden al valor “0”. A partir de este insight se comienza a considerar la conveniencia de desarrollar una estrategia de balanceo para el entrenamiento del modelo.

A falta de un diccionario de datos, aunque no sin cierto recelo debido a valores que podrían ser considerados atípicos, la exploración de los datos de resumen del dataset conducen a formularse las siguientes ideas en términos del significado de los registros para cada variable.

• Antigüedad: Es el número de meses que el tomador del crédito ha sido cliente de la institución financiera.
• Edad: Es la edad en años del tomador del Crédito.
• Cuota Total: Es el monto total de la factura mensual. Se recodificó en Miles de pesos [$000].
• Ingresos: Es el monto total de los ingresos mensuales del tomador del crédito. Se recodificó en miles de pesos [$000].

library(GGally)
ggpairs(data2, lower = list(continuous = "smooth"),
        diag = list(continuous = "barDiag"), axisLabels = "none")

En términos de identificación preliminar de la relación entre las demás variables disponibles en el dataset con el default, pareciera que hay algún nivel de diferenciación entre la conducta diferenciada en las variables Antigüedad, Edad y quizás Cuota Total.

Balanceo

Ahora se presentan la estrategia que se consideró conveniente para el balanceo de los datos que serían la base para las siguientes secciones del ejercicio. En primer lugar, se filtraron los Default positivos. Luego, se obtuvo, de forma aleatoria, el mismo número de registros de la contraparte negativa. Se creó un nuevo dataset balanceado, y este se particionó en dos, para disponer de datos para el entrenamiento y la evaluación del modelo.

data2_1 <- data2 %>%
  filter(DEFAULT==1)

data2_0 <- data2 %>%
  filter(DEFAULT==0)


set.seed(1234)
n=39
sample_0 <- sample(1:n, 1*n)
sample_0 <- data2_0[sample_0,]

data2_fixed <- data.frame(
                rbind(data2_1, sample_0)
                )

set.seed(1234)
n=78
train_2 <- sample(1:n, 0.8*n)
data2_train <- data2_fixed[train_2,]
data2_test <- data2_fixed[-train_2,]

Estimación del Modelo

A continuación se presenta el primer modelo estimado.

modelo2_1 <- glm(DEFAULT ~ ., data = data2_train, family = "binomial")
summary(modelo2_1)

Call:
glm(formula = DEFAULT ~ ., family = "binomial", data = data2_train)

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-2.15847  -0.55292  -0.07345   0.72289   2.02074  

Coefficients:
              Estimate Std. Error z value Pr(>|z|)   
(Intercept)  3.9934661  1.8881223   2.115   0.0344 * 
ANTIUEDAD   -0.0613210  0.0438503  -1.398   0.1620   
EDAD        -0.0517420  0.0364924  -1.418   0.1562   
CUOTA_TOTAL  0.0022340  0.0006847   3.263   0.0011 **
INGRESOS    -0.0003397  0.0001887  -1.801   0.0717 . 
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 85.950  on 61  degrees of freedom
Residual deviance: 52.422  on 57  degrees of freedom
AIC: 62.422

Number of Fisher Scoring iterations: 5

exp(modelo2_1$coefficients)

(Intercept)   ANTIUEDAD        EDAD CUOTA_TOTAL    INGRESOS 
 54.2425728   0.9405212   0.9495738   1.0022365   0.9996603 

Antes de entrar en los detalles de interpretación, se validó si hay alguna oportunidad de mejora en su desempeño a partir de la exclusión de variables.

step(modelo2_1, direction="backward")

Start:  AIC=62.42
DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS

              Df Deviance    AIC
<none>             52.422 62.422
- ANTIUEDAD    1   54.460 62.460
- EDAD         1   54.689 62.689
- INGRESOS     1   56.033 64.033
- CUOTA_TOTAL  1   71.291 79.291

Call:  glm(formula = DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS, 
    family = "binomial", data = data2_train)

Coefficients:
(Intercept)    ANTIUEDAD         EDAD  CUOTA_TOTAL     INGRESOS  
  3.9934661   -0.0613210   -0.0517420    0.0022340   -0.0003397  

Degrees of Freedom: 61 Total (i.e. Null);  57 Residual
Null Deviance:      85.95 
Residual Deviance: 52.42    AIC: 62.42

En efecto, se validó que hay una posibilidad de mejora basado en la exclusión de la “Cuota Total”. Inicialmente, esta medida parecía contraintuitiva, pero se avanzó en esa dirección.

modelo2_2 <- glm(DEFAULT ~ . -CUOTA_TOTAL, data = data2_train, family = "binomial")
summary(modelo2_2)

Call:
glm(formula = DEFAULT ~ . - CUOTA_TOTAL, family = "binomial", 
    data = data2_train)

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-1.95159  -0.97154   0.01159   0.92296   1.72049  

Coefficients:
              Estimate Std. Error z value Pr(>|z|)   
(Intercept)  4.9256798  1.7806958   2.766  0.00567 **
ANTIUEDAD   -0.0020536  0.0361063  -0.057  0.95464   
EDAD        -0.0700736  0.0347994  -2.014  0.04405 * 
INGRESOS    -0.0001276  0.0001472  -0.867  0.38586   
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 85.950  on 61  degrees of freedom
Residual deviance: 71.291  on 58  degrees of freedom
AIC: 79.291

Number of Fisher Scoring iterations: 4

exp(modelo2_2$coefficients)

(Intercept)   ANTIUEDAD        EDAD    INGRESOS 
137.7829759   0.9979485   0.9323252   0.9998724 

El nuevo modelo indica que la variable “Edad” incide de manera significativa sobre la probabilidad de default, de modo que, en general, a mayor edad, menor riesgo de impago.

Evaluación del Modelo

Continuando con la estrategia seleccionada para la evaluación del modelo a través de datos que no hayan sido utilizados para su entrenamiento, se tiene lo siguente.

pred_2 <- predict.glm(modelo2_2, newdata = data2_test, type = "response")
result_2 <- table(data2_test$DEFAULT, ifelse(pred_2>0.5, 1,0))
result_2

   
    0 1
  0 8 0
  1 3 5

Pseudo_R2_2 <- (result_2[1,1]+result_2[2,2])/sum(result_2)*100
Pseudo_R2_2

[1] 81.25

El modelo clasificó correctamente el 81,25% de las observaciones disponibles en el dataset de testing. Esto habla bien de la bondad de ajuste del modelo.

library(InformationValue)
plotROC(data2_test$DEFAULT, pred_2)

De acuerdo con la gráfica, tanto la convexidad de la curva ROC, que tiende hacia el vértice superior izquierdo, como el resultado del AUC (llamado en este caso AUROC), que es bastante superior a 0.5, sugieren un nivel desempeño aceptable de parte del modelo, y permiten afirmar que el modelo tiene una buena capacidad discriminatoria. En general, el 77% de las veces, el modelo clasificaría correctamente a un cliente potencial interesado en un crédito en función de su riesgo de default.