Regresión Logística - Caso Rotación
Juan Pablo Mejia
2023-04-02
library(paqueteMOD)
library(caret)## Loading required package: ggplot2## Loading required package: latticelibrary(ggplot2)
library(table1)##
## Attaching package: 'table1'## The following objects are masked from 'package:base':
##
## units, units<-require(ggpubr)## Loading required package: ggpubrlibrary(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.1 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ lubridate 1.9.2 ✔ tibble 3.2.1
## ✔ purrr 1.0.1 ✔ tidyr 1.3.0## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ✖ purrr::lift() masks caret::lift()
## ℹ Use the ]8;;http://conflicted.r-lib.org/conflicted package]8;; to force all conflicts to become errorslibrary(ROSE)## Loaded ROSE 0.0-4library(pROC)## Type 'citation("pROC")' for a citation.
##
## Attaching package: 'pROC'
##
## The following objects are masked from 'package:stats':
##
## cov, smooth, varrequire(CGPfunctions)## Loading required package: CGPfunctionsdata("rotacion")
names(rotacion)[names(rotacion)=="Viaje de Negocios"] <- "Viaje_Negocios"
rotacion$Rotación = factor(rotacion$Rotación)
#names(rotacion)
glimpse(rotacion)## Rows: 1,470
## Columns: 24
## $ Rotación <fct> Si, No, Si, No, No, No, No, No, No, No, No…
## $ Edad <dbl> 41, 49, 37, 33, 27, 32, 59, 30, 38, 36, 35…
## $ Viaje_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, …A continuación se presentan las variables seleccionadas de acuerdo con la instrucción:
Categóricas:
Educación
Relación: Se considera que la educación está relacionada con la rotación ya que personas con mayor cualificación tendrán más interes en asumir nuevos retos que no le ofrece su empleo actual.
Hipótesis: Entre mayor sea el nivel de educación, mayor será la probabilidad de rotación.
Estado Civil
Relación: Se espera que el estado civil tenga relación con la rotación, ya que las personas que están solteras suelen tomar mayores riesgos a la hora de cambiar de sitio de trabajo y por ende su rotación es mayor.
Hipótesis:Las personas solteras tienen mayor probabilidad de rotar que las personas casadas.
Satisfacción laboral
Relación: Independiente del nivel del desempeño laboral, un factor que afecta el proceso de rotación es la satisfacción laboral. Entre menor sea la satisfacción laboral de una persona, menor interés tendrá en permanecer en un trabajo, lo que incitará a buscar nuevas oportunidades en otros lugares que le ofrezcan mayor bienestar.
Hipótesis: Entre mayor sea la satisfacción laboral, menor será la probabilidad de rotar.
Cuantitativas:
Distancia Casa
Relación: Se espera que la Distancia a Casa esté relacionada con la rotación, porque las personas que residan más lejos del trabajo deben destinar más tiempo en desplazamiento y al gastar más tiempo en sus movimientos al día, podrían ver su bienestar afectado y querer moverse a una compañía más cercana o con flexibilidad en el trabajo remoto.
Hipótesis: Entre mayor sea la distancia a casa, mayor será la probabilidad de rotar.
Porcentaje aumento salarial
Relación: Si las personas consideran que su trabajo no es recompensado y presentan un aumento salarial igual o por debajo del promedio de la empresa, podría servir de motivación para rotar más, puesto que considera que no se les valora lo suficiente su trabajo.
Hipótesis: Entre menor sea el porcentaje de aumento salarial, mayor será la probabilidad de rotar.
Ingreso mensual
Relación: Se espera que el ingreso mensual esté asociado a la rotación, ya que entre menor sea el ingreso de una persona podría mostrar más interés en nuevas oportunidades que ofrezcan mayor ingreso.
Hipótesis: Entre menor sea el ingreso mensual, mayor será la probabilidad de que roten de trabajo.
Realiza un análisis univariado (caracterización) de la información contenida en la base de datos rotacion. Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuantitativas o cualitativas). Incluir interpretaciones de la variable rotacion.
Análisis univariado para las variables
Cuantitativas
- Ingreso mensual
g3=ggplot(rotacion,aes(x=Ingreso_Mensual))+geom_histogram(binwidth = 1000)+theme_bw()
ggarrange(g3,labels = c("Ingreso Mensual"),ncol = 1, nrow = 1)
boxplot(rotacion$Ingreso_Mensual)
summary(rotacion$Ingreso_Mensual)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1009 2911 4919 6503 8379 19999sd(rotacion$Ingreso_Mensual)## [1] 4707.957- Porcentaje de Aumento Salarial
g2=ggplot(rotacion,aes(x=Porcentaje_aumento_salarial))+geom_bar(show.legend = TRUE)+theme_bw()
ggarrange(g2,labels = c("Porcentaje Aumento Salarial"),ncol = 1, nrow = 1)
boxplot(rotacion$Porcentaje_aumento_salarial)
summary(rotacion$Porcentaje_aumento_salarial)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 11.00 12.00 14.00 15.21 18.00 25.00sd(rotacion$Porcentaje_aumento_salarial)## [1] 3.659938- Distancia de Casa
g1=ggplot(rotacion,aes(x=Distancia_Casa))+geom_histogram(binwidth = 10)+theme_bw()+scale_fill_gradient("Count", low = "green", high = "red")
ggarrange(g1,labels = c("Distancia Casa"),ncol = 1, nrow = 1)
boxplot(rotacion$Distancia_Casa)
summary(rotacion$Distancia_Casa)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 7.000 9.193 14.000 29.000sd(rotacion$Distancia_Casa)## [1] 8.106864Cualitativas
- Educación
prop.table(table(rotacion$Educación, rotacion$Rotación),2)*100##
## No Si
## 1 11.273317 13.080169
## 2 19.302514 18.565401
## 3 38.361719 41.772152
## 4 27.575020 24.472574
## 5 3.487429 2.109705| Código | Etiqueta | Código | Etiqueta |
|---|---|---|---|
| 1 | Colegio incompleto | 4 | Maestría |
| 2 | Colegio completo | 5 | Doctorado |
| 3 | Universidad |
- Estado Civil
prop.table(table(rotacion$Estado_Civil, rotacion$Rotación),2)*100##
## No Si
## Casado 47.76967 35.44304
## Divorciado 23.84428 13.92405
## Soltero 28.38605 50.63291- Satisfacción laboral
prop.table(table(rotacion$Satisfación_Laboral, rotacion$Rotación),2)*100##
## No Si
## 1 18.08597 27.84810
## 2 18.97810 19.40928
## 3 29.92701 30.80169
## 4 33.00892 21.94093| Código | Etiqueta | Código | Etiqueta |
|---|---|---|---|
| 1 | Baja | 3 | Alta |
| 2 | Media | 4 | Muy alta |
Análisis Bivariado para las variables seleccionadas
rotacion$rota=as.numeric(rotacion$Rotación=="Si")
tendencias <- table1::table1(~ Distancia_Casa+Ingreso_Mensual+Porcentaje_aumento_salarial | Rotación, data = rotacion)
tendencias| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Distancia_Casa | |||
| Mean (SD) | 8.92 (8.01) | 10.6 (8.45) | 9.19 (8.11) |
| Median [Min, Max] | 7.00 [1.00, 29.0] | 9.00 [1.00, 29.0] | 7.00 [1.00, 29.0] |
| Ingreso_Mensual | |||
| Mean (SD) | 6830 (4820) | 4790 (3640) | 6500 (4710) |
| Median [Min, Max] | 5200 [1050, 20000] | 3200 [1010, 19900] | 4920 [1010, 20000] |
| Porcentaje_aumento_salarial | |||
| Mean (SD) | 15.2 (3.64) | 15.1 (3.77) | 15.2 (3.66) |
| Median [Min, Max] | 14.0 [11.0, 25.0] | 14.0 [11.0, 25.0] | 14.0 [11.0, 25.0] |
rotacion$Distancia_Casa_grupo=cut(rotacion$Distancia_Casa,breaks = c(0,5,10,15,30))
PlotXTabs2(data = rotacion,x = Distancia_Casa_grupo,y = Rotación)
rotacion$Ingreso_Mensual_grupo=cut((rotacion$Ingreso_Mensual)/1000,breaks = c(0,4,8,12,16,20))
PlotXTabs2(data = rotacion,x = Ingreso_Mensual_grupo,y = Rotación)
rotacion$Porcentaje_Aumento_Salarial_grupo=cut(rotacion$Porcentaje_aumento_salarial,breaks = c(10, 13, 16,19,22,25))
PlotXTabs2(data = rotacion , x = Porcentaje_Aumento_Salarial_grupo,y = Rotación)
Estimación inicial del modelo e interpretación de coeficientes y significancia
rotacion$rotacion=as.numeric(rotacion$Rotación=="Si")
modelo_rotacion=glm(rotacion ~ Estado_Civil
+ Educación
+ Satisfación_Laboral
+ Distancia_Casa
+ Ingreso_Mensual
+ Porcentaje_aumento_salarial ,
family = binomial(link="logit"),
data=rotacion)
summary(modelo_rotacion)##
## Call:
## glm(formula = rotacion ~ Estado_Civil + Educación + Satisfación_Laboral +
## Distancia_Casa + Ingreso_Mensual + Porcentaje_aumento_salarial,
## family = binomial(link = "logit"), data = rotacion)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.3585 -0.6297 -0.4824 -0.2992 2.9147
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -4.347e-01 4.447e-01 -0.978 0.328313
## Estado_CivilDivorciado -2.676e-01 2.217e-01 -1.207 0.227514
## Estado_CivilSoltero 8.586e-01 1.623e-01 5.292 1.21e-07 ***
## Educación -3.879e-02 7.281e-02 -0.533 0.594251
## Satisfación_Laboral -2.858e-01 6.637e-02 -4.307 1.66e-05 ***
## Distancia_Casa 2.961e-02 8.756e-03 3.382 0.000719 ***
## Ingreso_Mensual -1.234e-04 2.226e-05 -5.543 2.98e-08 ***
## Porcentaje_aumento_salarial -1.517e-02 2.056e-02 -0.738 0.460482
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 1298.6 on 1469 degrees of freedom
## Residual deviance: 1185.4 on 1462 degrees of freedom
## AIC: 1201.4
##
## Number of Fisher Scoring iterations: 5estadistico_X2 = modelo_rotacion$null.deviance - modelo_rotacion$deviance
estadistico_X2## [1] 113.1701gl = modelo_rotacion$df.null - modelo_rotacion$df.residual
chi_result=pchisq(estadistico_X2, df = gl, lower.tail = FALSE)
chi_result## [1] 2.017736e-211-chi_result## [1] 1Observando los coeficientes del modelo, es posible observar con su signo algunos datos interesantes. Entre ellos, y confirmando la dirección de algunas de las hipótesis, se puede ver que una persona que tenga mayor nivel salarial o mayor ingreso mensual puede tener menor probabilidad de rotación que una persona con condiciones desfavorables en estos dos items. Adicionalmente, el nivel de significancia en estas dos variables nos confirma la importancia de estos items para que la base de empleados reduzca su nivel de rotación. Si la empresa quiere evitar esta rotación, se debe trabajar alrededor de estos factores para reducir la probabilidad de rotación de cualquier empleado.
Evaluación del poder predictivo del modelo con base en la curva ROC y el AUC.
n_train <- nrow(rotacion)*0.6
n_test <- nrow(rotacion)*0.4
set.seed(123)
index_train<-sample(1:nrow(rotacion),size = n_train)
#Entrenamiento
train<-rotacion[index_train,]
# Test
test<-rotacion[-index_train,]
#Revisión de balanceo de los datos en los sets de train y test
prop.table(table(train$Rotación))##
## No Si
## 0.8435374 0.1564626prop.table(table(test$Rotación))##
## No Si
## 0.8316327 0.1683673#Balanceo por oversampling
train_b=ovun.sample(Rotación~., data = train,
p = 0.5, seed = 1,
method = "over")$data
test_b=ovun.sample(Rotación~., data = test,
p = 0.5, seed = 1,
method = "over")$data
#train_b$rota=as.numeric(train_b$Rotación=="Si")
#Datos Balanceados
prop.table(table(train_b$Rotación))##
## No Si
## 0.5138122 0.4861878Entrenamiento del modelo con set balanceado por oversampling
modelo_rotacion_train=glm(Rotación ~ Estado_Civil
+ Educación
+ Satisfación_Laboral
+ Distancia_Casa
+ Ingreso_Mensual
+ Porcentaje_aumento_salarial ,
family = binomial(link="logit"),
data=train_b)Matriz de Confusión
# Matriz de Confusión para evaluación de desempeño
valor_pronosticado.b <- predict(modelo_rotacion_train,test_b,type = "response")
niveles_pronosticados.b <- ifelse(valor_pronosticado.b > 0.5, "Si","No")
niveles_pronosticados.b <-factor(niveles_pronosticados.b)
rendimiento_data <- data.frame(observados = test_b$Rotación,
predicciones =niveles_pronosticados.b)
Positivos <- sum(rendimiento_data$observados == "Si")
Negativos <- sum(rendimiento_data$observados == "No")
Positivos_pronosticados <- sum(rendimiento_data$predicciones == "Si")
Negativos_pronosticados <- sum(rendimiento_data$predicciones == "No")
Total <- nrow(rendimiento_data)
VP <- sum(rendimiento_data$observados == "Si" & rendimiento_data$predicciones == "Si")
VN <- sum(rendimiento_data$observados == "No" & rendimiento_data$predicciones == "No")
FP <- sum(rendimiento_data$observados == "No" & rendimiento_data$predicciones == "Si")
FN <- sum(rendimiento_data$observados == "Si" & rendimiento_data$predicciones == "No")
matriz_confusion = matrix(c(VP, FP, FN,VN), nrow = 2)
rownames(matriz_confusion) = c(" Si ", " No ")
colnames(matriz_confusion) = c("Si", "No")
matriz_confusion## Si No
## Si 306 165
## No 179 310Curva ROC
curva_ROC <- roc(test_b$Rotación, valor_pronosticado.b)## Setting levels: control = No, case = Si## Setting direction: controls < casesauc<- round(auc(curva_ROC, levels =c(0,1), direction = "<"),4) # 0.9177
ggroc(curva_ROC, colour = "#FF7F00", size=1)+
ggtitle(paste0("Curva ROC ", "(AUC = ", auc, ")"))+
xlab("Especificidad")+
ylab("Sensibilidad") 
Se puede considerar que el modelo tiene una alta capacidad de clasificar correctamente los valores positivos para la rotación, así como los valores negativos. El AUC corresponde a 0.695.
Predicción de la probabilidad de rotación de un individuo hipotético
predict(modelo_rotacion_train,list(Educación=3,
Estado_Civil="Soltero",
Satisfación_Laboral=2,
Distancia_Casa=3,
Ingreso_Mensual=6000,
Porcentaje_aumento_salarial=5),type="response")## 1
## 0.6477315A este empleado(hipotético) se le debería intervenir, teniendo en cuenta sus características como estado civil, su ingreso mensual y su ubicación. Ofrecerle alternativas como un trabajo remoto, un plan de incremento sustancial en su ingreso en base a su perfil profesional y difundirlo a personas con un perfil, por ejemplo, soltero. Esto con el fin de mostrar ventajas de mantenerse en la organización y progresar dentro de ella, evitando la fuga de talento a competidores u organizaciones externas. Incluso, se puede contemplar la posibilidad de rotación interna en la empresa.
Conclusiones
Teniendo en cuenta lo observado con el anterior análisis y el modelo que se plantea, se proponen cuatro estrategias para que la empresa evita la rotación dentro de su base de empleados.
- Se propone que se desarrolle un programa de flexibilidad en la oficina, que permita trabajar desde casa algunos días de la semana o de manera remota totalmente.
- Desarrollar un mecanismo que relacione aumentos salariales con desarrollo profesional de las personas, incentivando la diversificación y crecimiento de habilidades en un empleado
- Generar espacios que le permitan al empleado rotar a otras áreas de la empresa, evitando que estas personas salgan de la organización buscando enfoques diferentes.
- Promover un sistema de reconocimientos tangibles de acuerdo a los logros del empleado, con el fin de elevar la satisfacción laboral del empleado y reducir el riesgo de rotación