Actividad 3
Cristian Ortega
2024-04-08
Punto 1
Cuantitativas
Edad, Distancia_Casa, Ingreso_Mensual
Categoricas
Educación, Estado_Civil, Equilibrio_Trabajo_Vida
Hipótesis
El principal incentivo para el trabajo es la remuneración, dado que esta no solo es necesaria para la supervivencia del individuo sino para su disfrute, si bien en instancias ejecutivas o altamente cualificadas esto puede ser acompañado de otros factores, sigue siendo al ingreso laboral la principal causa por la que se trabaja. Acompañado de la remuneración mensual se añaden otros factores como la distancia como símil de tiempo que se toman los individuos para llegar a su lugar de trabajo y la edad como medidor de riesgo. En la edad media, de 20 a 40 años los individuos están más propensos a cambiar de trabajo por mejora de sus condiciones, dado que en esta edad los individuos cuentan de media con una amplia experiencia laboral, a su vez que son aún “jóvenes” y están dispuestos a arriesgar para mejorar sus condiciones en t+1. Las variables anteriormente mencionadas, junto con la educación, que puede medir la seguridad de encontrar un nuevo trabajo después de dejar el actual, el estado civil, como un control al riesgo que se está dispuesto a tomar. Y el equilibrio entre el trabajo y la vida laboral, puede predecir de forma eficiente la posibilidad que un individuo cambie de trabajo.
Punto 2
Como observamos en el gráfico la mayoría de la muestra no ha tomado la decisión de cambiar su trabajo. Esto puede presentar una dificultad el momento de correr el modelo predictivo. Dado que nuestro objetivo es indentificar las probabilidades de la rotación dado una serie de variables.
barplot(table(rotacion$Rotación))
## Análisis Categóricas.
Como en el primer analisis podemos observar que apenas un 16% de la muestra decidió cambiar de trabajo, sin embargo podemos por medio de los procentajes con respecto a la misma variable observar algunas generalidades.
- Quienes frecuentemente viajan superan ampliamente la rotación repecto a los que no viajan o raramente lo hacen.
- En investigación y desarrollo raramente rotan respecto a las demás categórias.
- Las humanidades, el Mercadeo y los técnicos rotan aproximadamente el doble que los campos de Ciencias y Salud.
- Las mujeres rotan levemente más que los hombres.
- Con recpecto al Cargo que se ejerce, existe una alta rotación en representante de Ventas, técnico de laboratorio y recursos humanos.
- Los solteros rotan considerablemente más que los casados y divorciados.
- Por ultimo, quienes hacen horas extra rotan al menos tres veces más que los que no.
rotacion_categoricas <- subset(rotacion, select = sapply(rotacion, is.character))
tabla_frecuencia_variable1 <- lapply(rotacion_categoricas, function(x) table(x, rotacion$Rotación))
for (col in names(tabla_frecuencia_variable1)) {
cat("Tabla de frecuencia para", col, "con respecto a Rotación:\n")
print(tabla_frecuencia_variable1[[col]])
cat("\n")
}## Tabla de frecuencia para Rotación con respecto a Rotación:
##
## x No Si
## No 1233 0
## Si 0 237
##
## Tabla de frecuencia para Viaje de Negocios con respecto a Rotación:
##
## x No Si
## Frecuentemente 208 69
## No_Viaja 138 12
## Raramente 887 156
##
## Tabla de frecuencia para Departamento con respecto a Rotación:
##
## x No Si
## IyD 828 133
## RH 51 12
## Ventas 354 92
##
## Tabla de frecuencia para Campo_Educación con respecto a Rotación:
##
## x No Si
## Ciencias 517 89
## Humanidades 20 7
## Mercadeo 124 35
## Otra 71 11
## Salud 401 63
## Tecnicos 100 32
##
## Tabla de frecuencia para Genero con respecto a Rotación:
##
## x No Si
## F 501 87
## M 732 150
##
## Tabla de frecuencia para Cargo con respecto a Rotación:
##
## x No Si
## Director_Investigación 78 2
## Director_Manofactura 135 10
## Ejecutivo_Ventas 269 57
## Gerente 97 5
## Investigador_Cientifico 245 47
## Recursos_Humanos 40 12
## Representante_Salud 122 9
## Representante_Ventas 50 33
## Tecnico_Laboratorio 197 62
##
## Tabla de frecuencia para Estado_Civil con respecto a Rotación:
##
## x No Si
## Casado 589 84
## Divorciado 294 33
## Soltero 350 120
##
## Tabla de frecuencia para Horas_Extra con respecto a Rotación:
##
## x No Si
## No 944 110
## Si 289 127tabla_frecuencia_variable1 <- lapply(rotacion_categoricas, function(x) {
tabla <- table(x, rotacion$Rotación)
prop.table(tabla, margin = 1) * 100
})
for (col in names(tabla_frecuencia_variable1)) {
cat("Tabla de frecuencia para", col, "con respecto a Rotación (%):\n")
print(tabla_frecuencia_variable1[[col]])
cat("\n")
}## Tabla de frecuencia para Rotación con respecto a Rotación (%):
##
## x No Si
## No 100 0
## Si 0 100
##
## Tabla de frecuencia para Viaje de Negocios con respecto a Rotación (%):
##
## x No Si
## Frecuentemente 75.09025 24.90975
## No_Viaja 92.00000 8.00000
## Raramente 85.04314 14.95686
##
## Tabla de frecuencia para Departamento con respecto a Rotación (%):
##
## x No Si
## IyD 86.16025 13.83975
## RH 80.95238 19.04762
## Ventas 79.37220 20.62780
##
## Tabla de frecuencia para Campo_Educación con respecto a Rotación (%):
##
## x No Si
## Ciencias 85.31353 14.68647
## Humanidades 74.07407 25.92593
## Mercadeo 77.98742 22.01258
## Otra 86.58537 13.41463
## Salud 86.42241 13.57759
## Tecnicos 75.75758 24.24242
##
## Tabla de frecuencia para Genero con respecto a Rotación (%):
##
## x No Si
## F 85.20408 14.79592
## M 82.99320 17.00680
##
## Tabla de frecuencia para Cargo con respecto a Rotación (%):
##
## x No Si
## Director_Investigación 97.500000 2.500000
## Director_Manofactura 93.103448 6.896552
## Ejecutivo_Ventas 82.515337 17.484663
## Gerente 95.098039 4.901961
## Investigador_Cientifico 83.904110 16.095890
## Recursos_Humanos 76.923077 23.076923
## Representante_Salud 93.129771 6.870229
## Representante_Ventas 60.240964 39.759036
## Tecnico_Laboratorio 76.061776 23.938224
##
## Tabla de frecuencia para Estado_Civil con respecto a Rotación (%):
##
## x No Si
## Casado 87.51857 12.48143
## Divorciado 89.90826 10.09174
## Soltero 74.46809 25.53191
##
## Tabla de frecuencia para Horas_Extra con respecto a Rotación (%):
##
## x No Si
## No 89.56357 10.43643
## Si 69.47115 30.52885Análisis Númericas
La edad media la muestra son los 36 años, esto nos indica que la variable edad puede no ser el mejor predictor de la rotación. El promedio la distancia a al hogar es de 9 Kilometros, podemos esperar que esta variable sea determinante en la variable respuesta. De media los empleados son ténicos o tecnologos, con el grado mámixo en posgrado. En la media los empleados están satisfechos con el ambiente, y a su vez están satisfechos con su trabajo. El ingreso medio es 6503 y la media ha tenido 3 trabajos antes que el actual. El rendimiento laboral es alto y la media cuenta con 4 años en el cargo, mismo tiempo aproximado que han estado con el mismo jefe.
summary_stats <- sapply(rotacion, summary)
print(summary_stats)## $Rotación
## Length Class Mode
## 1470 character character
##
## $Edad
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 18.00 30.00 36.00 36.92 43.00 60.00
##
## $`Viaje de Negocios`
## Length Class Mode
## 1470 character character
##
## $Departamento
## Length Class Mode
## 1470 character character
##
## $Distancia_Casa
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 7.000 9.193 14.000 29.000
##
## $Educación
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 3.000 2.913 4.000 5.000
##
## $Campo_Educación
## Length Class Mode
## 1470 character character
##
## $Satisfacción_Ambiental
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 3.000 2.722 4.000 4.000
##
## $Genero
## Length Class Mode
## 1470 character character
##
## $Cargo
## Length Class Mode
## 1470 character character
##
## $Satisfación_Laboral
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 3.000 2.729 4.000 4.000
##
## $Estado_Civil
## Length Class Mode
## 1470 character character
##
## $Ingreso_Mensual
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1009 2911 4919 6503 8379 19999
##
## $Trabajos_Anteriores
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 1.000 2.000 2.693 4.000 9.000
##
## $Horas_Extra
## Length Class Mode
## 1470 character character
##
## $Porcentaje_aumento_salarial
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 11.00 12.00 14.00 15.21 18.00 25.00
##
## $Rendimiento_Laboral
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 3.000 3.000 3.000 3.154 3.000 4.000
##
## $Años_Experiencia
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00 6.00 10.00 11.28 15.00 40.00
##
## $Capacitaciones
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 2.000 3.000 2.799 3.000 6.000
##
## $Equilibrio_Trabajo_Vida
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 2.000 3.000 2.761 3.000 4.000
##
## $Antigüedad
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 3.000 5.000 7.008 9.000 40.000
##
## $Antigüedad_Cargo
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 2.000 3.000 4.229 7.000 18.000
##
## $Años_ultima_promoción
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 0.000 1.000 2.188 3.000 15.000
##
## $Años_acargo_con_mismo_jefe
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.000 2.000 3.000 4.123 7.000 17.000Punto 3
Categóricas
En la prueba Chi Cuadrado encontramos las variables que hemos seleccionado para el análisís están altamente correlacionadas con la variable a predecir, sin embargo se muestran resultados prometedores para las variables: Viaje de negocios y horas extra.
rotacion$Rotación <- ifelse(rotacion$Rotación == "Si", 1, 0)
table(rotacion$Rotación)##
## 0 1
## 1233 237rotacion$Educación <- as.character(rotacion$Educación)
rotacion$Equilibrio_Trabajo_Vida <- as.character(rotacion$Equilibrio_Trabajo_Vida)
rotacion_categoricas <- subset(rotacion, select = sapply(rotacion, is.character))
resultados_chi_cuadrado <- list()
for (col in names(rotacion_categoricas)) {
tabla_contingencia <- table(rotacion_categoricas[[col]], rotacion$Rotación)
resultado <- chisq.test(tabla_contingencia)
resultados_chi_cuadrado[[col]] <- resultado
}## Warning in chisq.test(tabla_contingencia): Chi-squared approximation may be
## incorrectprint(resultados_chi_cuadrado)## $`Viaje de Negocios`
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 24.182, df = 2, p-value = 5.609e-06
##
##
## $Departamento
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 10.796, df = 2, p-value = 0.004526
##
##
## $Educación
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 3.074, df = 4, p-value = 0.5455
##
##
## $Campo_Educación
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 16.025, df = 5, p-value = 0.006774
##
##
## $Genero
##
## Pearson's Chi-squared test with Yates' continuity correction
##
## data: tabla_contingencia
## X-squared = 1.117, df = 1, p-value = 0.2906
##
##
## $Cargo
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 86.19, df = 8, p-value = 2.752e-15
##
##
## $Estado_Civil
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 46.164, df = 2, p-value = 9.456e-11
##
##
## $Horas_Extra
##
## Pearson's Chi-squared test with Yates' continuity correction
##
## data: tabla_contingencia
## X-squared = 87.564, df = 1, p-value < 2.2e-16
##
##
## $Equilibrio_Trabajo_Vida
##
## Pearson's Chi-squared test
##
## data: tabla_contingencia
## X-squared = 16.325, df = 3, p-value = 0.0009726Númericas
Los resultados para las correlaciones númericas muestran resultados prometedores para las tres variables seleccionadas, sin embargo muestran tambien qur otras variables podrían ser seleccionadas en su lugar o que incluso variables como Distancia_casa debería ser remplazada.
rotacion_numericas <- subset(rotacion, select = sapply(rotacion, is.numeric))
correlaciones <- cor(rotacion_numericas, rotacion$Rotación)
print(correlaciones)## [,1]
## Rotación 1.000000000
## Edad -0.159227826
## Distancia_Casa 0.077923583
## Satisfacción_Ambiental -0.103368978
## Satisfación_Laboral -0.103481126
## Ingreso_Mensual -0.159839582
## Trabajos_Anteriores 0.043493739
## Porcentaje_aumento_salarial -0.013478202
## Rendimiento_Laboral 0.002888752
## Años_Experiencia -0.171063246
## Capacitaciones -0.059477799
## Antigüedad -0.134392214
## Antigüedad_Cargo -0.160545004
## Años_ultima_promoción -0.033018775
## Años_acargo_con_mismo_jefe -0.156199316Punto 4
Primero codificaremos la variable Estado_Civil
rotacion2 <- subset(rotacion, select = c("Rotación", "Edad", "Distancia_Casa", "Ingreso_Mensual", "Educación", "Estado_Civil", "Equilibrio_Trabajo_Vida"))
head(rotacion2)## # A tibble: 6 × 7
## Rotación Edad Distancia_Casa Ingreso_Mensual Educación Estado_Civil
## <dbl> <dbl> <dbl> <dbl> <chr> <chr>
## 1 1 41 1 5993 2 Soltero
## 2 0 49 8 5130 1 Casado
## 3 1 37 2 2090 2 Soltero
## 4 0 33 3 2909 4 Casado
## 5 0 27 2 3468 1 Casado
## 6 0 32 2 3068 2 Soltero
## # ℹ 1 more variable: Equilibrio_Trabajo_Vida <chr>table(rotacion$Estado_Civil)##
## Casado Divorciado Soltero
## 673 327 470rotacion2$Estado_Civil <- factor(rotacion2$Estado_Civil, levels = c("Soltero", "Casado", "Divorciado"))
rotacion2$Estado_Civil <- as.numeric(rotacion2$Estado_Civil)
head(rotacion2)## # A tibble: 6 × 7
## Rotación Edad Distancia_Casa Ingreso_Mensual Educación Estado_Civil
## <dbl> <dbl> <dbl> <dbl> <chr> <dbl>
## 1 1 41 1 5993 2 1
## 2 0 49 8 5130 1 2
## 3 1 37 2 2090 2 1
## 4 0 33 3 2909 4 2
## 5 0 27 2 3468 1 2
## 6 0 32 2 3068 2 1
## # ℹ 1 more variable: Equilibrio_Trabajo_Vida <chr>table(rotacion2$Estado_Civil)##
## 1 2 3
## 470 673 327Modelo
Se observa que a medida que aumenta la distancia a casa y existe un alto equilibrio trabajo y vida aumenta la rotación. Si disminuye el ingreso mensual aumenta la rotación, y si el Estado Civil es Casado o Divorciado disminuye de manera considerable la probabilidad de rotación. Por otro lado, la edad y la educación no parecen tener un efecto significativo en el modelo. El modelo tiene un buen ajuste según el criterio de información de Akaike (AIC), lo que sugiere que es una representación razonable de los datos observados. Variables significativas como Distancia a la casa y Equilibrio Trabajo-Vida pueden ser remplazadas por otras que ajusten mejor el modelo, como horas extra o la frecuencia en que se viaja.
rotacion2<- as.data.frame(lapply(rotacion2, as.numeric))
set.seed(123)
split <- sample.split(rotacion2$Rotación, SplitRatio = 0.7)
datos_entrenamiento <- subset(rotacion2, split == TRUE)
datos_prueba <- subset(rotacion2, split == FALSE)
modelo <- glm(Rotación ~ ., data = datos_entrenamiento, family = "binomial")
summary(modelo)##
## Call:
## glm(formula = Rotación ~ ., family = "binomial", data = datos_entrenamiento)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.258e+00 5.618e-01 2.240 0.025088 *
## Edad -1.918e-02 1.129e-02 -1.699 0.089270 .
## Distancia_Casa 2.456e-02 1.036e-02 2.371 0.017726 *
## Ingreso_Mensual -1.032e-04 2.877e-05 -3.587 0.000334 ***
## Educación -8.062e-03 8.784e-02 -0.092 0.926873
## Estado_Civil -5.928e-01 1.279e-01 -4.634 3.59e-06 ***
## Equilibrio_Trabajo_Vida -2.912e-01 1.217e-01 -2.392 0.016750 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 909.34 on 1028 degrees of freedom
## Residual deviance: 840.05 on 1022 degrees of freedom
## AIC: 854.05
##
## Number of Fisher Scoring iterations: 5Punto 5
El AUC es 0.715531. Esto sugiere que el modelo tiene un buen poder discriminativo para clasificar las instancias positivas y negativas en el conjunto de datos de prueba, aunque no es un rendimiento excelente. En general, un AUC de 0.7 se considera aceptable, lo que indica que el modelo tiene cierta capacidad predictiva, pero puede haber margen para mejorar.
predicciones <- predict(modelo, newdata = datos_prueba, type = "response")
prediccion_roc <- prediction(predicciones, datos_prueba$Rotación)
rendimiento <- performance(prediccion_roc, "tpr", "fpr")
area_bajo_curva <- performance(prediccion_roc, "auc")
valor_auc <- as.numeric(area_bajo_curva@y.values)
plot(rendimiento, main = "Curva ROC del Modelo Logístico",
col = "blue", lwd = 2, lty = 1,
xlab = "Tasa de Falsos Positivos",
ylab = "Tasa de Verdaderos Positivos")
abline(a = 0, b = 1, col = "red", lwd = 2, lty = 2)
legend("bottomright", legend = paste("AUC =", round(valor_auc, 3)),
col = "blue", lty = 1, lwd = 2, bty = "n")
cat("El AUC es:", valor_auc, "\n")## El AUC es: 0.715531Punto 6
El modelo aunque tiene un buen nivel de preducción aunque se deben probar a posteriori otros conjuntos de variables para ajustar el modelo a un AUC de al menos 0.9. La estrategía que puede seguir la empresa, siendo la más obvia la subida general de salarios, tambien puede ser priorizar la contratación de personas Casadas y disminuir la distancia del trabajo al hogar.