# Instalación y cargue de librerías
library(paqueteMODELOS)
library(plotly)
library(dplyr)
library(ggplot2)
library(pROC)El presente ejercicio tiene como objetivo busca perfilar aquellos empleados más propensos a renunciar en una compañia que sirvan como insumo para el diseño e implementación de estrategias organizacionales que promuevan la retención de personal. La información base con la que se cuenta responde a variables (a) demográficas y profesionales del individuo y (b) relativas a su relación con la empresa. El modelo a emplear será una regresión logística.
Se priorizarán 6 variables para este análisis: 3 categóricas y 3 cuantitativas partir del siguiente dataframe:
Así, priorizando las variables descritas, se trabaja sobre la siguiente base de datos con ningún valor nulo:
Sus frecuencias son:
| Var1 | Freq |
|---|---|
| Director_Investigación | 80 |
| Director_Manofactura | 145 |
| Ejecutivo_Ventas | 326 |
| Gerente | 102 |
| Investigador_Cientifico | 292 |
| Recursos_Humanos | 52 |
| Representante_Salud | 131 |
| Representante_Ventas | 83 |
| Tecnico_Laboratorio | 259 |
grb_cargo <- ggplot(rotacion, aes(x = Cargo)) +
geom_bar(fill = "skyblue", color = "black", aes(y = ..count..)) +
geom_text(aes(y = ..count.., label = scales::percent(..count../sum(..count..))), stat="count", position = position_dodge(0.9), vjust = -0.5) +
labs(title = "Gráfico de barras para Cargo", x = "Cargo", y = "Frecuencia") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(grb_cargo)Cómo se puede ver, la mayoría de cargos responden a procesos que requieren mayor mano de obra al soportar procesos de la cadena de valor del producto y no tanto gerencial o de estrategia de negocio.
Sus frecuencias son:
| Var1 | Freq |
|---|---|
| Casado | 673 |
| Divorciado | 327 |
| Soltero | 470 |
grb_ec <- ggplot(rotacion, aes(x = Estado_Civil)) +
geom_bar(fill = "skyblue", color = "black", aes(y = ..count..)) +
geom_text(aes(y = ..count.., label = scales::percent(..count../sum(..count..))), stat="count", position = position_dodge(0.9), vjust = -0.5) +
labs(title = "Gráfico de barras para Estado Civil", x = "Estado_Civil", y = "Frecuencia") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(grb_ec)La mayoría de personas que trabajan en la empresa están casadas, lo que podría deberse a la modalidad de contratación de la empresa o características del sector.
Sus frecuencias son:
| Var1 | Freq |
|---|---|
| IyD | 961 |
| RH | 63 |
| Ventas | 446 |
grb_dep <- ggplot(rotacion, aes(x = Departamento)) +
geom_bar(fill = "skyblue", color = "black", aes(y = ..count..)) +
geom_text(aes(y = ..count.., label = scales::percent(..count../sum(..count..))), stat="count", position = position_dodge(0.9), vjust = -0.5) +
labs(title = "Gráfico de barras para Departamento", x = "Departamento", y = "Frecuencia") +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
print(grb_dep)Como se puede observar, la empresa prioriza la innovación en el producto al contar con un personal marcadamente mayoritario en el área de Investigación y Desarrollo.
kable(df %>%
summarise(Media = mean(Ingreso_Mensual),
Mediana = median(Ingreso_Mensual),
Desv_Estandar = sd(Ingreso_Mensual),
Minimo = min(Ingreso_Mensual),
Maximo = max(Ingreso_Mensual)))| Media | Mediana | Desv_Estandar | Minimo | Maximo |
|---|---|---|---|---|
| 6502.931 | 4919 | 4707.957 | 1009 | 19999 |
Teniendo un máximo de $ 20.000 y un mínimo de 1.000, una desviación estándar de 4700 y una media de 6503, se puede observar una alta variabilidad en los salarios, lo que puede incidir en las percepciones que desarrolle el individuo frente a su posición en la empresa.
plot_ly(data = rotacion, x = ~Ingreso_Mensual, type = "histogram",
marker = list(color = "skyblue")) %>%
layout(title = "Histograma de Ingreso Mensual",
xaxis = list(title = "Ingreso Mensual"),
yaxis = list(title = "Frecuencia"))bx_ingresos <- ggplot(df, aes(x = "", y = df$Ingreso_Mensual)) +
geom_boxplot() +
stat_summary(fun.data = function(y) {
cuartiles <- quantile(y)
return(data.frame(
y = cuartiles[c(2, 3, 4)],
label = c(paste("Q1:", round(cuartiles[2], 2)),
paste("Mediana:", round(cuartiles[3], 2)),
paste("Q3:", round(cuartiles[4], 2)))
))
}, geom = "text", vjust = -0.5, color = "red") +
labs(title = "Boxplot de Variable", y = "Valores") +
theme_minimal()
print(bx_ingresos)kable(df %>%
summarise(Media = mean(Edad),
Mediana = median(Edad),
Desv_Estandar = sd(Edad),
Minimo = min(Edad),
Maximo = max(Edad)))| Media | Mediana | Desv_Estandar | Minimo | Maximo |
|---|---|---|---|---|
| 36.92449 | 36 | 9.135938 | 18 | 60 |
Cómo se puede ver se trata de una empresa con una fuerza laboral relativamente joven con un promedio de 36 años, pero con una gran cantidad de personas entre los 25 y 35 años, respecto a la cantidad de personas mayores de 40 años.
plot_ly(data = rotacion, x = ~Edad, type = "histogram",
marker = list(color = "skyblue")) %>%
layout(title = "Histograma de Edad",
xaxis = list(title = "Edad"),
yaxis = list(title = "Frecuencia"))bx_edad <- ggplot(df, aes(x = "", y = df$Edad)) +
geom_boxplot() +
stat_summary(fun.data = function(y) {
cuartiles <- quantile(y)
return(data.frame(
y = cuartiles[c(2, 3, 4)],
label = c(paste("Q1:", round(cuartiles[2], 2)),
paste("Mediana:", round(cuartiles[3], 2)),
paste("Q3:", round(cuartiles[4], 2)))
))
}, geom = "text", vjust = -0.5, color = "red") +
labs(title = "Boxplot de Variable", y = "Valores") +
theme_minimal()
print(bx_edad)kable(df %>%
summarise(Media = mean(Porcentaje_aumento_salarial),
Mediana = median(Porcentaje_aumento_salarial),
Desv_Estandar = sd(Porcentaje_aumento_salarial),
Minimo = min(Porcentaje_aumento_salarial),
Maximo = max(Porcentaje_aumento_salarial)))| Media | Mediana | Desv_Estandar | Minimo | Maximo |
|---|---|---|---|---|
| 15.20952 | 14 | 3.659938 | 11 | 25 |
Dadas las características de la variable, se puede observar que la empresa tiene una política de aumento salarial en la que la mayoría percibe aumentos bajos y unos pocos aumentos más altos. Sin embargo, en términos reales, al tener como máximo el 25% y un promedio de 15% con una desviación estándar de 3.7%, se puede inferir que nadie percibe este beneficio de manera desproporcionada.
plot_ly(data = rotacion, x = ~Porcentaje_aumento_salarial, type = "histogram",
marker = list(color = "skyblue")) %>%
layout(title = "Histograma de Porcentaje de aumento salarial",
xaxis = list(title = "Porcentaje de aumento salarial"),
yaxis = list(title = "Frecuencia"))bx_aumento <- ggplot(df, aes(x = "", y = df$Porcentaje_aumento_salarial)) +
geom_boxplot() +
stat_summary(fun.data = function(y) {
cuartiles <- quantile(y)
return(data.frame(
y = cuartiles[c(2, 3, 4)],
label = c(paste("Q1:", round(cuartiles[2], 2)),
paste("Mediana:", round(cuartiles[3], 2)),
paste("Q3:", round(cuartiles[4], 2)))
))
}, geom = "text", vjust = -0.5, color = "red") +
labs(title = "Boxplot de Variable", y = "Valores") +
theme_minimal()
print(bx_aumento)# codificación
df$Rotación<-ifelse(df$Rotación=="Si",1,0)
# Modelo Cargo
modelo_cargo <- glm(Rotación ~ Cargo, data = df, family = binomial)
round(summary(modelo_cargo)$coefficients,2)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.66 0.72 -5.12 0.00
## CargoDirector_Manofactura 1.06 0.79 1.35 0.18
## CargoEjecutivo_Ventas 2.11 0.73 2.89 0.00
## CargoGerente 0.70 0.85 0.82 0.41
## CargoInvestigador_Cientifico 2.01 0.73 2.74 0.01
## CargoRecursos_Humanos 2.46 0.79 3.12 0.00
## CargoRepresentante_Salud 1.06 0.80 1.33 0.18
## CargoRepresentante_Ventas 3.25 0.75 4.33 0.00
## CargoTecnico_Laboratorio 2.51 0.73 3.43 0.00
El cargo más propenso a rotar en la empresa es el de Representante de ventas.
modelo_ec <- glm(Rotación ~ Estado_Civil, data = df, family = binomial)
round(summary(modelo_ec)$coefficients,2)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.95 0.12 -16.70 0.00
## Estado_CivilDivorciado -0.24 0.22 -1.10 0.27
## Estado_CivilSoltero 0.88 0.16 5.57 0.00
Las personas solteras muestran una tendencia mucho mayor a rotar de empleo.
modelo_dep <- glm(Rotación ~ Departamento, data = df, family = binomial)
round(summary(modelo_dep)$coefficients,2)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.83 0.09 -19.58 0.00
## DepartamentoRH 0.38 0.33 1.14 0.25
## DepartamentoVentas 0.48 0.15 3.21 0.00
Las personas que trabajan en Investigación y Desarrollo tienden a rotar en mucha menor medida que los demás departamentos.
modelo_im <- glm(Rotación ~ Ingreso_Mensual, data = df, family = binomial)
round(summary(modelo_im)$coefficients,5)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -0.92911 0.12920 -7.19113 0
## Ingreso_Mensual -0.00013 0.00002 -5.87934 0
Un aumento en los ingresos mensuales está asociado con una ligera disminución en la probabilidad de renuncia
modelo_ed <- glm(Rotación ~ Edad, data = df, family = binomial)
round(summary(modelo_ed)$coefficients,2)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.21 0.31 0.67 0.5
## Edad -0.05 0.01 -6.01 0.0
A medida que la edad de la persona aumenta, las probabilidades de rotación disminuyen.
modelo_pas <- glm(Rotación ~ Porcentaje_aumento_salarial, data = df, family = binomial)
round(summary(modelo_pas)$coefficients,2)## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.50 0.30 -4.91 0.00
## Porcentaje_aumento_salarial -0.01 0.02 -0.52 0.61
Las personas que más aumento salarial perciben, menor probabilidad tienen de dejar la empresa.
modelo_log <- glm(Rotación ~ Cargo + Estado_Civil + Departamento + Ingreso_Mensual + Edad + Porcentaje_aumento_salarial , data = df, family = binomial)
summary(modelo_log)##
## Call:
## glm(formula = Rotación ~ Cargo + Estado_Civil + Departamento +
## Ingreso_Mensual + Edad + Porcentaje_aumento_salarial, family = binomial,
## data = df)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.033e+00 1.056e+00 -2.874 0.00406 **
## CargoDirector_Manofactura 1.079e+00 8.683e-01 1.243 0.21405
## CargoEjecutivo_Ventas 2.146e+00 1.256e+00 1.708 0.08758 .
## CargoGerente 8.906e-01 9.354e-01 0.952 0.34102
## CargoInvestigador_Cientifico 1.955e+00 9.081e-01 2.153 0.03134 *
## CargoRecursos_Humanos 1.534e+01 4.322e+02 0.035 0.97168
## CargoRepresentante_Salud 1.117e+00 8.738e-01 1.278 0.20109
## CargoRepresentante_Ventas 3.142e+00 1.333e+00 2.358 0.01838 *
## CargoTecnico_Laboratorio 2.496e+00 9.053e-01 2.757 0.00583 **
## Estado_CivilDivorciado -2.050e-01 2.227e-01 -0.921 0.35712
## Estado_CivilSoltero 7.890e-01 1.643e-01 4.802 1.57e-06 ***
## DepartamentoRH -1.274e+01 4.322e+02 -0.029 0.97649
## DepartamentoVentas -5.932e-02 9.449e-01 -0.063 0.94995
## Ingreso_Mensual 2.380e-05 4.360e-05 0.546 0.58510
## Edad -2.516e-02 9.827e-03 -2.560 0.01047 *
## Porcentaje_aumento_salarial -8.014e-03 2.077e-02 -0.386 0.69958
## ---
## 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: 1165.9 on 1454 degrees of freedom
## AIC: 1197.9
##
## Number of Fisher Scoring iterations: 14
De acuerdo a los niveles de significancia de cada categoria, se puede decir que las características que más influyen para que una persona tome la decisión de dejar la empresa son: tener el cargo de Investigador Científico, de Representante de Ventas y Técnico de Laboratorio, en mayor medida. Así mismo, el estar soltero y la edad (mientras más edad menos probabilidad de rotación)
predicciones <- predict(modelo_log, type = "response")
curva_roc <- roc(df$Rotación, predicciones)
plot(curva_roc, main="Curva ROC", col="purple", lwd=2)
abline(h=0, v=1, col="blue")## Area under the curve: 0.723
De acuerdo al valor del Área Bajo la Curva, se puede concluir que el modelo tiene una capacidad de predicción aceptable frente a la probabilidad de rotación en una empresa.
#Predicciones
empleado_1 <- data.frame(
`Cargo` = "Gerente",
`Estado_Civil` = "Casado",
`Departamento` = "Ventas",
`Ingreso_Mensual` = 15000,
`Edad` = 32,
`Porcentaje_aumento_salarial` = 1
)
prediccion_e1 <- predict(modelo_log, newdata = empleado_1, type = "response")
print(prediccion_e1)## 1
## 0.06550227
Este empleado tiene una muy baja probabilidad de rotar, ya que se encuentra en un cargo gerencial, con menor disponibilidad de mano de obra en el mercado y un muy buen salario. Esto, a pesar de no percibir aumentos salariales significativos, por lo que no será necesario crear políticas o incentivos particulares para empleados similares a este perfil.
empleado_2 <- data.frame(
`Cargo` = "Tecnico_Laboratorio",
`Estado_Civil` = "Soltero",
`Departamento` = "IyD",
`Ingreso_Mensual` = 2000,
`Edad` = 25,
`Porcentaje_aumento_salarial` = 8
)
prediccion_e2 <- predict(modelo_log, newdata = empleado_2, type = "response")
print(prediccion_e2)## 1
## 0.4028651
El segundo empleado, en contraste, muestra una alta probabilidad de rotar, ya que tiene características que se han identificado como determinantes para dicho escenario, como lo es el estar Soltero, el trabajar como Técnico de Laboratorio y ser joven. Además de contar con un salario relativamente bajo y poco aumento salarial.
Según lo observado, la empresa deberá adelantar estrategias de retención pensando en los siguientes perfiles de empleados:
Solteros: beneficios en el manejo del tiempo libre, flexibilidad de horarios o modalidades, eventos de integración.
Por cargo: debe promoverse incentivos intelectuales y profesionales a las personas que se encuentran en cargos específicos y que son más propensos a tener rotación, como los Técnicos de Laboratorio o Representantes de Ventas.
Por edad: promover incentivos para que las personas identifiquen posibilidades de crecimiento personal y profesional en la empresa y logren proyectarlas y materializarlas.