Actividad 3 - Modelos Lineales G
Yeffer Edilberto Diaz Cuesta - Codigo: 8974592
2023-04-01
Actividad 3 - Modelos Lineales Generalizados
Problema 1 : Rotación de cargo
Planteamiento
Se cuenta con un base de datos de una empresa que muestra 23 variables diferentes que se pueden o no relacionar con la rotación de los empleados, la empresa solicita que se realice un breve estudio análisis que permita identificar si algunas de estas variables influyen en este medida.
Cargue de los datos:
En principio se inicia cargado los datos y librerías necesarias para el desarrollo del proyecto:
devtools::install_github("dgonxalex80/paqueteMOD", force =TRUE)
library(paqueteMOD)
library(tidyverse)
library(patchwork)
library(ggplot2)
library(plotly)
library(CGPfunctions)
library(pROC)
library(caret)
library(table1)
data("rotacion")
data("creditos")names(rotacion)## [1] "Rotación" "Edad"
## [3] "Viaje de Negocios" "Departamento"
## [5] "Distancia_Casa" "Educación"
## [7] "Campo_Educación" "Satisfacción_Ambiental"
## [9] "Genero" "Cargo"
## [11] "Satisfación_Laboral" "Estado_Civil"
## [13] "Ingreso_Mensual" "Trabajos_Anteriores"
## [15] "Horas_Extra" "Porcentaje_aumento_salarial"
## [17] "Rendimiento_Laboral" "Años_Experiencia"
## [19] "Capacitaciones" "Equilibrio_Trabajo_Vida"
## [21] "Antigüedad" "Antigüedad_Cargo"
## [23] "Años_ultima_promoción" "Años_acargo_con_mismo_jefe"Primer requerimiento:
Seleccione 3 variables categóricas (distintas de rotación) y 3 variables cuantitativas, que se consideren estén relacionadas con la rotación.
VARIABLES CATEGORICAS
1. Estado civil: Se espera que las personas solteras se relacionen mas con la rotación debido a que cuentan con menores responsabilidades en comparación a las personas comprometidas o casadas. La hipótesis plateada es que las personas solteras tienen más probabilidad de rotación.
2. Viaje de negocios: Se plantea la hipótesis de que las personas que viajan frecuentemente tienden a rotar menos que las que lo hacen raramente o no viajan, ya que los viajes permiten a los empleados salir de sus espacios de trabajo para distraerse de sus labores comunes.
3. Educación: Se espera que las personas con mayor educación tiendan a tener más acceso a otras oportunidades en términos laborales lo que podría relacionarse con el proceso de rotación. La hipótesis es que las personas profesionales y con posgrado tienen mayor posibilidad de rotar por el acceso a nuevas ofertas laborales.
VARIABLES CUANTITATIVAS
1. Edad: Actualmente las personas más jóvenes tienden a tener mas cambios en términos laborales por razones como su estado emocional y salud mental, búsqueda de nuevas oportunidades, mejores salarios, entre otros. Se plantea la hipótesis de que las personas mayores tienden a rotar menos debido a que probablemente cuentan con mas responsabilidades y buscan una mayor estabilidad.
2. Distancia Casa: Se espera que las personas con mayor distancia a sus casas sean las que mas roten, ya que es muy probable que les disguste el tiempo gastado en el desplazamiento desde y hacia su trabajo.
3. Ingreso mensual: Se crea la hipótesis de que las persona que tienen un mayor ingreso mensual son las que menos tienden a rotar debido a que probablemente se les hace más fácil suplir todas las necesidades económicas.
Segundo requerimiento:
Realiza un análisis univariado (caracterización) de la información contenida en la base de datos rotación.
VARIABLES CATEGORICAS
En un inicio se procede a realizar una tabla resumen de las variables en esta área.
y <- table1::table1(~ Estado_Civil+`Viaje de Negocios`+factor(Educación) | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Estado_Civil | |||
| Casado | 589 (47.8%) | 84 (35.4%) | 673 (45.8%) |
| Divorciado | 294 (23.8%) | 33 (13.9%) | 327 (22.2%) |
| Soltero | 350 (28.4%) | 120 (50.6%) | 470 (32.0%) |
| Viaje de Negocios | |||
| Frecuentemente | 208 (16.9%) | 69 (29.1%) | 277 (18.8%) |
| No_Viaja | 138 (11.2%) | 12 (5.1%) | 150 (10.2%) |
| Raramente | 887 (71.9%) | 156 (65.8%) | 1043 (71.0%) |
| factor(Educación) | |||
| 1 | 139 (11.3%) | 31 (13.1%) | 170 (11.6%) |
| 2 | 238 (19.3%) | 44 (18.6%) | 282 (19.2%) |
| 3 | 473 (38.4%) | 99 (41.8%) | 572 (38.9%) |
| 4 | 340 (27.6%) | 58 (24.5%) | 398 (27.1%) |
| 5 | 43 (3.5%) | 5 (2.1%) | 48 (3.3%) |
Luego de esto, se presentan las gráficas relacionadas a las variables categorías trabajadas en este caso:
fig <- plot_ly(alpha = 0.6)
fig <- fig %>% add_histogram(x = rotacion$Estado_Civil, name = "Estado civil", marker = list(color = "lightblue", opacity = 0.5, line = list(color = 'black', width = 1)))
fig <- fig %>% layout(barmode = "overlay", title = "Histograma del estado civil en empleados")
figfig2 <- plot_ly(alpha = 0.6)
fig2 <- fig2 %>% add_histogram(x = rotacion$`Viaje de Negocios`, name = "Viaje de Negocios", marker = list(color = "green", opacity = 0.5, line = list(color = 'black', width = 1)))
fig2 <- fig2 %>% layout(barmode = "overlay", title = "Histograma del ")
fig2fig3 <- plot_ly(alpha = 0.6)
fig3 <- fig3 %>% add_histogram(x = rotacion$Educación, name = "Vivel de Educación", marker = list(color = "ivory", opacity = 1, line = list(color = 'black', width = 1)))
fig3 <- fig3 %>% layout(barmode = "overlay", title = "Histograma del nivel de educación en los empleados")
fig3 Análisis. A partir de la tabla y las gráficas generadas se pueden inferir valores que permiten realizar análisis a las variables de manera unitaria, por ejemplo en términos del estado civil de los trabajadores de la empresa se obtiene que el porcentaje más grande pertenece a las personas casadas con un 45.8% para un total de 673 trabajadores, por el contrario, el valor mas bajo con tan solo 327 personas son las que se encuentran en estado divorciado los cuales abarcan tan solo un 22.2%, seguido después de las personas solteras con un 32% y total de 470 personas.
Con relación a los viajes realizados por los empleados del negocio, se encontró que más de la mitad viajan muy raramente, con un total de 1043 personas las cuales representan el 71%. Solo 150 empleados que representan el 10.2% no viaja y el restante 18.8% (277 personas) viajan frecuentemente. En términos de educación la gran mayoría de trabajadores cuenta con una educación técnica y tecnológica los cuales representan el 38.9% (572 personas), los empleados con posgrado son el grupo mas pequeño presente en la empresa con tan solo un 3.3% del total con 48 personas.
VARIABLES CUANTITATIVAS
En principio se hace un breve resumen de las variables cuantitativas que son y sus estadísticos principales.
summary(rotacion[, c("Edad","Distancia_Casa","Ingreso_Mensual")])## Edad Distancia_Casa Ingreso_Mensual
## Min. :18.00 Min. : 1.000 Min. : 1009
## 1st Qu.:30.00 1st Qu.: 2.000 1st Qu.: 2911
## Median :36.00 Median : 7.000 Median : 4919
## Mean :36.92 Mean : 9.193 Mean : 6503
## 3rd Qu.:43.00 3rd Qu.:14.000 3rd Qu.: 8379
## Max. :60.00 Max. :29.000 Max. :19999Se realiza una segunda tabla que permita visualizar los resultados obtenidos para las variables cuantitativas.
y <- table1::table1(~ Edad+Distancia_Casa+Ingreso_Mensual | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Edad | |||
| Mean (SD) | 37.6 (8.89) | 33.6 (9.69) | 36.9 (9.14) |
| Median [Min, Max] | 36.0 [18.0, 60.0] | 32.0 [18.0, 58.0] | 36.0 [18.0, 60.0] |
| 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] |
Luego de esto, se presentan las gráficas relacionadas a las variables cuantitativas trabajadas en este caso:
intervalosedad <- cut(rotacion$Edad, breaks = c(0,30,40,50,60), include.lowest = TRUE)
frecuenciaedad <- table(intervalosedad)
fig4 <- plot_ly(labels = names(frecuenciaedad), values = as.numeric(frecuenciaedad), type = "pie", textinfo = "label+percent", insidetextorientation = "radial")
fig4 <- fig4 %>% layout(title = "Gráfica pastel con Rangos de Edad", showlegend = T)
fig4intervalosdistancia <- cut(rotacion$Distancia_Casa, breaks = c(0,10,20,30), include.lowest = TRUE)
frecuenciadistancia <- table(intervalosdistancia)
fig5 <- plot_ly(labels = c("De 0 a 10 kilometros", "De 10 a 20 kilometros", "De 20 a 30 kilometros"), values = as.numeric(frecuenciadistancia), type = "pie", textinfo = "label+percent", insidetextorientation = "radial")
fig5 <- fig5 %>% layout(title = "Rangos de distancia de los trabajadores desde la casa hasta el trabajo", showlegend = T)
fig5intervalosingreso <- cut(rotacion$Ingreso_Mensual,breaks = c(0,3000,7000,12000,20000), include.lowest = TRUE)
frecuenciaingreso <- table(intervalosingreso)
fig6 <- plot_ly(labels = c("De 0 a 3 millones", "De 3 a 7 millones", "De 7 a 12 millones","De 12 a 20 millones"), values = as.numeric(frecuenciaingreso), type = "pie", textinfo = "label+percent", insidetextorientation = "radial")
fig6 <- fig6 %>% layout(title = "Rangos de sueldo recibido por los empleados", showlegend = T)
fig6Análisis. La edad media de los trabajadores de la empresa es de 36.9 años, sin embargo, se cuenta con una desviación estándar muy por encima de 1 la cual alcanza un valor de 9.14, esta dispersión se ve reflejada con la edad mínima de 18 años y máxima de 60 años en el grupo evaluado. En términos generales los empleados de la empresa viven entre los 1 y 29 kilómetros de distancia de la misma (se asume esta medida ya que no se indica exactamente en la base de datos), la media de distancia a la que viven los empleados es de 9.19 kilómetros de la empresa.
Con relación al ingreso mensual obtenido por los trabajadores se tiene que la media general del sueldo es de $6,500,000 sin embargo la desviación estándar que genera ese mismo valor es de 4710 lo que representa una dispersión muy elevada. Esto anterior se corrobora en la revisión del sueldo mínimo $1,010,000 y el máximo $20,000,000, entre los cuales hay un rango considerable.
Tercer requerimiento:
Realiza un análisis de bivariado en donde la variable respuesta sea 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 hipótesis planteada en el punto 2.
Para realización de este punto y de los siguientes, se toma la tabla original “rotacion” y se crea una copia “rotacion_mod” para poder trabajar con esta ultima en adelante, esto con la finalidad de poder llevar un orden y realizar la codificación solicitada (y=1 es si rotación, y=0 es no rotación).
VARIABLES CATEGORICAS
rotacion_mod=rotacion
rotacion_mod$Rotación=as.numeric(rotacion_mod$Rotación=="Si")Una ves codificada la variable Rotacion en la base “rotacion_mod”, se realiza un análisis bivariado a cada una de las variables seleccionadas. Para lo anterior, se grafican las variables teniendo como resultado la variable rotación.
PlotXTabs2(data = rotacion_mod,x = Estado_Civil,y = Rotación)
1. Estado civil: Como se planteó en la hipótesis mas de la mitad de las personas que realizaron el proceso de rotación son las que se encuentran en el grupo de solteros con un 26%. Los casados están por debajo de los solteros, son el grupo intermedio con un 12% de personas las cuales rotan.
PlotXTabs2(data = rotacion_mod,x = `Viaje de Negocios`,y = Rotación)
2. Viaje de negocios: Al contrario de lo que se había planteado, el grupo que menos tuvo rotación con relación a la variable de viajes son las personas que no viajan, esto se puede deber a que tienen mayor permanecía en un mismo sitio lo que probablemente les permite compartir más tiempo con familias, amigos y allegados. Por otro lado, las personas que viajan frecuentemente son las que mayor indice de rotación tienen, con un 25%, esto puede ser a causa del desgaste físico que requiere el estar constantemente viajando o el mental al estar alejado de los seres queridos.
PlotXTabs2(data = rotacion_mod,x = Educación,y = Rotación)
3. Educación: Aunque los profesionales son el segundo grupo en términos de rotación con un porcentaje del 17% con respecto a los que componen este grupo, estos son los que mas numero de personas presenta que rotaron con respecto a todos los integrantes de la empresa con un total de 99 individuos. Sin embargo, se observa que el grupo con mayor rotación en la empresa son los técnicos, tecnólogos y también los bachilleres, esto también se puede deber en gran medida a la alta demanda que actualmente se presenta en estas áreas gracias a que ayuda a las empresas a disminuir el costo de mano de obra, por lo cual es mas probable que tengan mas oportunidades con mejoras en las condiciones.
VARIABLES CUANTITATIVAS
Se realizan las gráficas necesarias para el análisis de las variables cuantitativas, teniendo como resultado la variable de rotación
t.test(rotacion_mod$Edad~rotacion_mod$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion_mod$Edad by rotacion_mod$Rotación
## t = 5.8291, df = 316.94, p-value = 1.371e-08
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## 2.619728 5.289170
## sample estimates:
## mean in group 0 mean in group 1
## 37.56204 33.60759rotacion_mod$Edad_grupo=cut(rotacion_mod$Edad,breaks = c(0,30,40,50,60))
PlotXTabs2(data = rotacion_mod,x = Edad_grupo,y = Rotación)
1. Edad: Como se esperaba, en términos de edad las personas que suelen rotar son más jóvenes en comparación a los que no rotan. La media de las personas que con mayor frecuencia rotan es de 33.6 años, por otro lado, las personas que menos tienden a rotar son mayores con una media de edad de 37.6 años.Las personas menores de 30 años son el grupo que más rotación presenta con un 26% del total de trabajadores con esa edad.
t.test(rotacion_mod$Distancia_Casa~rotacion_mod$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion_mod$Distancia_Casa by rotacion_mod$Rotación
## t = -2.8882, df = 322.72, p-value = 0.004137
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## -2.8870025 -0.5475146
## sample estimates:
## mean in group 0 mean in group 1
## 8.915653 10.632911rotacion_mod$distanciaCasa_grupo=cut(rotacion_mod$Distancia_Casa,breaks = c(0,10,20,30))
PlotXTabs2(data = rotacion_mod,x = distanciaCasa_grupo,y = Rotación)
2. Distancia Casa: Como se había planteado inicialmente entre mayor distancia presenta el empleado desde su casa hasta el lugar de trabajo, mayor casos de rotación se presentan en la empresa. Este caso se muestra en la anterior gráfica, en donde el primer grupo de personas viven máximo a 10 kilómetros de la empresa y su nivel de rotación es el mas bajo con 14%, por el contrario, las personas que viven mas lejos entre los 20 a 30 kilómetros son los que mayor nivel de rotación presentan con un total de 22%.
t.test(rotacion_mod$Ingreso_Mensual~rotacion_mod$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion_mod$Ingreso_Mensual by rotacion_mod$Rotación
## t = 7.4826, df = 412.74, p-value = 4.434e-13
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## 1508.244 2583.050
## sample estimates:
## mean in group 0 mean in group 1
## 6832.740 4787.093rotacion_mod$Ingreso_grupo=cut(rotacion_mod$Ingreso_Mensual,breaks = c(0,3000,7000,12000,20000))
PlotXTabs2(data = rotacion_mod,x = Ingreso_grupo,y = Rotación)
3. Ingreso mensual: Efectivamente las personas que ganan mas de tres salarios mínimos son las personas que menos porcentaje de rotación tienen. Por el contrario, las personas que tienen unos ingresos menores a los tres salarios mínimos son las que mas rotación presentan con un 29% del total de personas que componen ese grupo.
Cuarto requerimiento:
Realiza la estimación de un modelo de regresión logístico 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 en el punto 1. Interprete los coeficientes del modelo y la significancia de los parámetros.
Para la estimación del modelo se utiliza el método tradicional trabajado en clase, a continuación se presenta el desarrollo del mismo:
modelo = glm(Rotación~Estado_Civil+factor(`Viaje de Negocios`)+Educación+Edad+Distancia_Casa+Ingreso_Mensual,data = rotacion_mod,family = "binomial")
summary(modelo)##
## Call:
## glm(formula = Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) +
## Educación + Edad + Distancia_Casa + Ingreso_Mensual, family = "binomial",
## data = rotacion_mod)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.2935 -0.6315 -0.4725 -0.2920 2.8762
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.673e-01 3.920e-01 -0.427 0.669515
## Estado_CivilDivorciado -2.293e-01 2.225e-01 -1.030 0.302780
## Estado_CivilSoltero 7.973e-01 1.636e-01 4.873 1.10e-06 ***
## factor(`Viaje de Negocios`)No_Viaja -1.401e+00 3.411e-01 -4.109 3.98e-05 ***
## factor(`Viaje de Negocios`)Raramente -6.235e-01 1.713e-01 -3.640 0.000272 ***
## Educación 1.321e-02 7.431e-02 0.178 0.858874
## Edad -2.866e-02 9.986e-03 -2.870 0.004100 **
## Distancia_Casa 3.057e-02 8.790e-03 3.478 0.000506 ***
## Ingreso_Mensual -9.334e-05 2.429e-05 -3.842 0.000122 ***
## ---
## 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: 1173.2 on 1461 degrees of freedom
## AIC: 1191.2
##
## Number of Fisher Scoring iterations: 5Análisis. A partir del anterior modelo se pueden interpretar los siguientes coeficientes:
Persona casada: Con un coeficiente negativo de -1.673e-01 representa que hay poca probabilidad en que una persona en este estado civil tienda rotar.
Persona divorciada: Con un coeficiente negativo de -2.293e-01 representa que hay poca probabilidad en que una persona en este estado civil tienda rotar. La probabilidad es menor en comparación a los casados.
Persona soltera: Con un coeficiente positivo de 7.973e-01 representa que hay alta probabilidad que una persona en este estado civil si tienda rotar en comparación a los estados de casados y divorciados.
Viaje de negocios (No viaja): En la variable viaje de negocios, el estado “No viaja” es el que representa una menor probabilidad de influencia en la rotación por parte de los empleados con el coeficiente mas bajo -1.401e+00.
Viaje de negocios (Raramente): El estado “Raramente” es el que representa una probabilidad media de influencia en la rotación por parte de los empleados con el coeficiente negativo de -6.235e-01.
Viaje de negocios (Frecuentemente): El estado “Frecuentemente” es el estado que presenta mayor influencia en la decisión de que un empleado rote, siendo esta la categoría de referencia y, por lo tanto, su coeficiente es implícitamente cero.
Educación: Con un coeficiente positivo de 1.321e-02, este valor representa que a mayor nivel de educación mayor debería ser la rotación en las personas. Sin embargo, este coeficiente tiene el menor nivel de significancia con lo cual no es verídico la influencia de esta variable del modelo, esto también se ve reflejado en los análisis de tipo bivariado en donde se evidencio que el comportamiento de la variable no es así, ya que no necesariamente a mayor nivel de educación mayor era la rotación en las personas.
Edad: Con un coeficiente negativo de -2.866e-02 representa que a mayor edad las personas tienen menos probabilidad (signo negativo del coeficiente) de que se retiren de la empresa.
Distancia_Casa: Con un coeficiente positivo de 3.057e-02 representa que a mayor distancia entre la casa y el trabajo de las personas tienen mas probabilidad (signo positivo del coeficiente) de que roten de la empresa.
Ingreso_Mensual: Con un coeficiente negativo de -9.334e-05 representa que a mayor sueldo de los empleados, estos tienen menos probabilidad (signo negativo del coeficiente) de que roten de la empresa.
Sin embargo, debido al nivel de significancia de algunos coeficientes se procede a hacer el ajuste para crear el modelo final.
Para un proceso de validación y mejora en los resultados se utiliza un ajuste del modelo con metodología de estimación de manera gradual con procesos de paso a paso como el que se realiza a continuación:
mod_final1=step(modelo,direction = "backward")## Start: AIC=1191.23
## Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) + Educación +
## Edad + Distancia_Casa + Ingreso_Mensual
##
## Df Deviance AIC
## - Educación 1 1173.3 1189.3
## <none> 1173.2 1191.2
## - Edad 1 1181.9 1197.9
## - Distancia_Casa 1 1185.0 1201.0
## - Ingreso_Mensual 1 1189.9 1205.9
## - factor(`Viaje de Negocios`) 2 1196.5 1210.5
## - Estado_Civil 2 1207.3 1221.3
##
## Step: AIC=1189.27
## Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) + Edad +
## Distancia_Casa + Ingreso_Mensual
##
## Df Deviance AIC
## <none> 1173.3 1189.3
## - Edad 1 1182.1 1196.1
## - Distancia_Casa 1 1185.1 1199.1
## - Ingreso_Mensual 1 1189.9 1203.9
## - factor(`Viaje de Negocios`) 2 1196.5 1208.5
## - Estado_Civil 2 1207.4 1219.4mod_final1##
## Call: glm(formula = Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) +
## Edad + Distancia_Casa + Ingreso_Mensual, family = "binomial",
## data = rotacion_mod)
##
## Coefficients:
## (Intercept) Estado_CivilDivorciado
## -1.435e-01 -2.292e-01
## Estado_CivilSoltero factor(`Viaje de Negocios`)No_Viaja
## 7.978e-01 -1.401e+00
## factor(`Viaje de Negocios`)Raramente Edad
## -6.232e-01 -2.829e-02
## Distancia_Casa Ingreso_Mensual
## 3.057e-02 -9.319e-05
##
## Degrees of Freedom: 1469 Total (i.e. Null); 1462 Residual
## Null Deviance: 1299
## Residual Deviance: 1173 AIC: 1189Análisis. A partir del anterior ajuste se toman las variables finales para generar un segundo modelo que permita mejorar la medida de predicción, este proceso se presenta a continuación:
modelo2=glm(formula = Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) + Edad + Distancia_Casa + Ingreso_Mensual, family = "binomial", data = rotacion_mod)
summary(modelo2)##
## Call:
## glm(formula = Rotación ~ Estado_Civil + factor(`Viaje de Negocios`) +
## Edad + Distancia_Casa + Ingreso_Mensual, family = "binomial",
## data = rotacion_mod)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.2816 -0.6335 -0.4720 -0.2907 2.8735
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.435e-01 3.682e-01 -0.390 0.696683
## Estado_CivilDivorciado -2.292e-01 2.225e-01 -1.030 0.302920
## Estado_CivilSoltero 7.978e-01 1.636e-01 4.876 1.08e-06 ***
## factor(`Viaje de Negocios`)No_Viaja -1.401e+00 3.411e-01 -4.107 4.01e-05 ***
## factor(`Viaje de Negocios`)Raramente -6.232e-01 1.713e-01 -3.639 0.000274 ***
## Edad -2.829e-02 9.754e-03 -2.900 0.003726 **
## Distancia_Casa 3.057e-02 8.788e-03 3.479 0.000504 ***
## Ingreso_Mensual -9.319e-05 2.426e-05 -3.841 0.000123 ***
## ---
## 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: 1173.3 on 1462 degrees of freedom
## AIC: 1189.3
##
## Number of Fisher Scoring iterations: 5Análisis. En el ultimo modelo “modelo2” que se extrae a partir de la metodológica de estimación de manera gradual con procesos de paso a paso se elimina la variable “Educación”, como se explica anteriormente este coeficiente tiene el menor nivel de significancia con lo cual no es verídico la influencia de esta variable del modelo, esto también se ve reflejado en los análisis de tipo bivariado en donde se evidencio que el comportamiento de la variable no es así, ya que no necesariamente a mayor nivel de educación mayor era la rotación en las personas.
Las demás variables permanecen con los mismos coeficientes y el mismo valor explicado antes bajo el primer modelo.
Quinto requerimiento:
Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.
Para el proceso de medir el poder predictivo del modelo se debe segmentar la data en dos partes (train y test) que permitan construir la curva ROC y el AUC de modelo.
Se procede a dividir la data en dos partes:
- train con el 60% de los registros
- test con el 40% de los registro
train <- nrow(rotacion_mod)*0.6
test <- nrow(rotacion_mod)*0.4
set.seed(123)
index_train <- sample(1:nrow(rotacion_mod),size = train)
train.dat <- rotacion_mod[index_train,] # muestra de entrenamiento
test.dat <- rotacion_mod[-index_train,] # muestra de pruebaLuego de la realiza la separación del set de datos, presentando la curva ROC y su área bajo la curva AUC.
valor_pronosticado <- predict(modelo2,test.dat,type = "response")
niveles_pronosticados <- factor(ifelse(valor_pronosticado >0.5, "Si","No"))
curva_ROC <- roc(test.dat$Rotación, valor_pronosticado)## Setting levels: control = 0, case = 1## Setting direction: controls < casesauc<- round(auc(curva_ROC, levels =c(0,1), direction = "<"),4)
#Se realiza la curva con la funcion ggplot
ggroc(curva_ROC, colour = "#FF7F00", size=1) + ggtitle(paste0("Curva ROC ", "(AUC = ", auc, ")")) + xlab("Especificidad") + ylab("Sensibilidad") 
Análisis. Con la curva ROC se logra evaluar la capacidad predictiva del modelo de clasificación binaria que se crea anteriormente con nombre “modelo2” mediante el calculo del área bajo la curva denominado AUC, para este caso en especifico el valor del área bajo la curva ROC con un AUC > 0.5 (AUC del modelo igual a 0.68) lo que se traduce en una clasificación excelente que se presenta cuando la curva ROC pasa cerca del punto (0,1), indicando que el modelo tienen una alta capacidad para clasificar correctamente los valores positivos del modelo y los verdaderos negativos.
Sexto requerimiento:
Realiza una predicción la probabilidad de que un individuo (hipotético) rote y defina un corte para decidir si se debe intervenir a este empleado o no (posible estrategia para motivar al empleado).
Se asume un individuo con las siguientes características:
- Persona en estado civil “Divorciado”
- Viaje de Negocios “Frecuentemente”
- Edad: 32
- Distancia de la casa 17 km
- Ingreso mensual 2900
Y se hace la predicción con estos valores.
predict(modelo2,list(Estado_Civil="Divorciado",`Viaje de Negocios`="Frecuentemente",Edad=32,Distancia_Casa=17,Ingreso_Mensual=2900),type="response")## 1
## 0.2633634Análisis. Con las características definidas previamente, se tiene que el individuo presenta una probabilidad alta del 26% de rotar de la empresa. En este caso se podría intervenir al individuo mejorando las características que están dentro del alcance de la empresa, como por ejemplo se podría proponer lo siguiente:
- La disminución en la frecuencia de los viajes de negocios (pasar de “Frecuentemente” a “Raramente”).
- El cambio del vivienda del empleado a una que le quede mas cerca de la empresa (por ejemplo a 4 kilómetros)’
- Y por ultimo el aumento del salario sobre los tres sueldos mínimos (en este caso se pone como ejemplo un total de 3.500.000)
Una ves realizados estos ajustes se puede volver a calcular el modelo y evaluar el cambio del porcentaje, como se muestra a continuación:
#Modelo con los ajustes propuestos anteriormente
predict(modelo2,list(Estado_Civil="Divorciado",`Viaje de Negocios`="Raramente",Edad=32,Distancia_Casa=4,Ingreso_Mensual=3500),type="response")## 1
## 0.1086015Conclusión. Con los ajustes realizados se logra motivar al trabajador y disminuir considerablemente la probabilidad de rotación que pueda llegar a tener este, pasando a quedar en un 10% de probabilidad de rotar y logrando restar un 16% del 26% que se obtuvo inicialmente.
Séptimo requerimiento:
En las conclusiones adicione una discusión sobre cuál sería la estrategia para disminuir la rotación en la empresa (con base en las variables que resultaron significativas en el punto 3).
Estrategias para la reducción de rotación:
En conclusión, se recomendaría a la empresa abarcar principalmente sus esfuerzos en dos áreas que son especialmente cruciales. La primera es fomentar acciones que permitan llamar la atención y permanencia de las personas jóvenes; se pueden implementar estrategias muy utilizadas en la actualidad en términos de bienestar, diversión y salud ocupacional en trabajadores, si se trata de una empresa presencial se puede gestionar zonas de descanso para que los trabajadores en sus pausas activas puedan tomarse un respiro, también puede crearse espacios de juegos con actividades tradicionales como mesas de Ping-Pong, zonas de juegos de mesa, áreas de vídeo juegos, canchas (fútbol, basquetbol, entre otros.), por ultimo otro posible espacio son las zonas de lunch gratuito en donde las personas puedan ir a comer o tomar algo sin necesidad de salir de sus espacios de trabajo y sin costo alguno. Si se tratase de una empresa con trabajo remoto, pueden mirar la opción de regalar bonos, realizar sorteos en donde premien a los trabajadores, dar cursos de crecimiento personal y profesional, enviar mercados o lunch sorpresa, entre otros. Todas estas opciones se podrían evaluar en la medida que el presupuesto lo permita, ya que las anteriores estrategias se han ido implementando en varias empresas, especialmente las de tecnología y han dado excelentes resultados, precisamente esto permite la continuidad de muchas personas jóvenes las cuales ven su espacio de trabajo no como una obligación si no como una segunda casa.
La segunda área que se puede fortalecer y en donde se presenta una gran deserción, son los trabajadores que ganan menos de los tres salarios mínimos ($3,000,000). En este caso podría plantearse la idea del aumento salarial por debajo de ese valor, pero por encima del que tengan actualmente los trabajadores de este grupo en específico, es importante tener en cuenta que el grupo de personas que componen los trabajadores que ganan menos de este sueldo, esta por debajo del 30% total de empleados de la empresa. Otra solución, mas económica podría ser plantear bonos de dinero en fechas especiales o poniendo ciertas metas de cumplimiento en donde se les reconozca económicamente si estas se llegan a cumplir.
Problema 2 : Crédito
Planteamiento
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 o de no pago 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.
#Se crea la variable DEUDA que se espera evaluar en términos de significacia en el modelo
creditos$deuda=round(creditos$cuota/creditos$ingresos*100,1)
names(creditos)## [1] "default" "antiguedad" "edad" "cuota" "ingresos"
## [6] "deuda"#Se crea el modelo logístico que permita predecir el riesgo default
modelo3=glm(default~antiguedad+edad+ingresos+deuda,data = creditos,family = "binomial")
summary(modelo3)##
## Call:
## glm(formula = default ~ antiguedad + edad + ingresos + deuda,
## family = "binomial", data = creditos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.1914 -0.3510 -0.2791 -0.2177 2.9418
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -4.173e+00 9.911e-01 -4.211 2.54e-05 ***
## antiguedad -4.441e-02 2.288e-02 -1.941 0.052239 .
## edad 2.084e-02 1.913e-02 1.089 0.275984
## ingresos -2.787e-08 8.537e-08 -0.326 0.744068
## deuda 4.444e-02 1.160e-02 3.830 0.000128 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 309.68 on 779 degrees of freedom
## Residual deviance: 287.97 on 775 degrees of freedom
## AIC: 297.97
##
## Number of Fisher Scoring iterations: 6Aunque ya se tiene un modelo propuesto, para mejorar su exactitud se re calcula para tener en cuenta un método de evaluación por medio de validación cruzada con la metodología aprendida en clase en base a la librería Caret, como se muestra a continuación:
table1(~deuda|default,data = creditos)## Warning in table1.formula(~deuda | default, data = creditos): Terms to the
## right of '|' in formula 'x' define table columns and are expected to be factors
## with meaningful labels.| 0 (N=741) |
1 (N=39) |
Overall (N=780) |
|
|---|---|---|---|
| deuda | |||
| Mean (SD) | 17.0 (11.9) | 26.7 (21.8) | 17.4 (12.7) |
| Median [Min, Max] | 15.3 [0, 85.8] | 23.1 [0.800, 130] | 15.6 [0, 130] |
control=trainControl(method = "cv",number = 10,p = 0.2)
mod_caret=train(default ~ antiguedad + edad + ingresos + deuda,data=creditos,method="glm",family="binomial",trControl=control)## Warning in train.default(x, y, weights = w, ...): You are trying to do
## regression and your outcome only has two possible values Are you trying to do
## classification? If so, use a 2 level factor as your outcome column.summary(mod_caret)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.1914 -0.3510 -0.2791 -0.2177 2.9418
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -4.173e+00 9.911e-01 -4.211 2.54e-05 ***
## antiguedad -4.441e-02 2.288e-02 -1.941 0.052239 .
## edad 2.084e-02 1.913e-02 1.089 0.275984
## ingresos -2.787e-08 8.537e-08 -0.326 0.744068
## deuda 4.444e-02 1.160e-02 3.830 0.000128 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 309.68 on 779 degrees of freedom
## Residual deviance: 287.97 on 775 degrees of freedom
## AIC: 297.97
##
## Number of Fisher Scoring iterations: 6varImp(mod_caret)## glm variable importance
##
## Overall
## deuda 100.00
## antiguedad 46.09
## edad 21.78
## ingresos 0.00plot(varImp(mod_caret))
mod_caret$finalModel##
## Call: NULL
##
## Coefficients:
## (Intercept) antiguedad edad ingresos deuda
## -4.173e+00 -4.441e-02 2.084e-02 -2.787e-08 4.444e-02
##
## Degrees of Freedom: 779 Total (i.e. Null); 775 Residual
## Null Deviance: 309.7
## Residual Deviance: 288 AIC: 298Análisis. A partir del anterior modelo y teniendo como premisa que el valor 0 son las personas que si cumplieron en el pago y el valor 1 son las que no lo hicieron, se pueden interpretar los siguientes coeficientes:
Antigüedad: Con un coeficiente negativo de -4.441e-02 representa que a mayor antigüedad en la vida crediticia del individuo estudiado, las personas tienen menos probabilidad (signo negativo del coeficiente) de incumplir en el pago de sus cuotas. La significancia de esta variable en el modelo es media - baja, con un valor de (0.1 “.”).
Edad: Con un coeficiente positivo de 2.084e-02 representa que a mayor edad tenga el individuo estudiado, las personas tienen mas probabilidad (signo positivo del coeficiente) de incumplir en el pago de sus cuotas. Esto es un valor irregular que debería evaluarse al detalle, ya que normalmente las personas con mayor edad son las que tienen mas experiencia en el manejo de sus finanzas, esta hipótesis se corrobora con la significancia de esta variable en el modelo la cual es baja, con un valor de ” “.
Ingresos: Con un coeficiente negativo de -2.787e-08 representa que a mayor entrada de ingresos tenga el individuo estudiado tiene menos probabilidad (signo negativo del coeficiente) de incumplir en el pago de sus cuotas. La significancia de esta variable en el modelo es baja, con un valor de ” “.
Deuda: Con un coeficiente positivo de 4.444e-02 representa que a mayor deuda tenga el individuo estudiado, las personas tienen mas probabilidad (signo positivo del coeficiente) de incumplir en el pago de sus cuotas. Esta variable es la que mayor significancia presenta con un valor de “***“.
Todo lo anterior se corrobora con los procesos de validación cruzada, en donde las variables mas discriminantes del set de datos son la deuda con un valor de 100, seguido por la antigüedad con un valor de 46, esto se representa en la tabla y gráfica anterior.
Para un proceso de validación y mejora en los resultados se utiliza un ajuste del modelo con metodología de estimación de manera gradual con procesos de paso a paso como el que se realiza a continuación:
mod_final2=step(modelo3,direction = "backward")## Start: AIC=297.97
## default ~ antiguedad + edad + ingresos + deuda
##
## Df Deviance AIC
## - ingresos 1 288.08 296.08
## - edad 1 289.12 297.12
## <none> 287.97 297.97
## - antiguedad 1 291.67 299.67
## - deuda 1 304.34 312.34
##
## Step: AIC=296.08
## default ~ antiguedad + edad + deuda
##
## Df Deviance AIC
## - edad 1 289.20 295.20
## <none> 288.08 296.08
## - antiguedad 1 292.73 298.73
## - deuda 1 305.50 311.50
##
## Step: AIC=295.2
## default ~ antiguedad + deuda
##
## Df Deviance AIC
## <none> 289.20 295.20
## - antiguedad 1 293.32 297.32
## - deuda 1 306.00 310.00mod_final2##
## Call: glm(formula = default ~ antiguedad + deuda, family = "binomial",
## data = creditos)
##
## Coefficients:
## (Intercept) antiguedad deuda
## -3.36240 -0.03070 0.04416
##
## Degrees of Freedom: 779 Total (i.e. Null); 777 Residual
## Null Deviance: 309.7
## Residual Deviance: 289.2 AIC: 295.2Con lo anterior se ajusta el modelo dejando las variables mas importantes y con mayor significancia que son antigüedad y deuda.
modelo4=glm(default~antiguedad+deuda,data = creditos,family = "binomial")
summary(modelo4)##
## Call:
## glm(formula = default ~ antiguedad + deuda, family = "binomial",
## data = creditos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.2053 -0.3589 -0.2802 -0.2192 2.9259
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.36240 0.37751 -8.907 < 2e-16 ***
## antiguedad -0.03070 0.01572 -1.954 0.0508 .
## deuda 0.04416 0.01132 3.903 9.5e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 309.68 on 779 degrees of freedom
## Residual deviance: 289.20 on 777 degrees of freedom
## AIC: 295.2
##
## Number of Fisher Scoring iterations: 6Luego se evalúa el poder predictivo del modelo con base en la curva ROC y el AUC. Para el proceso de medir el poder predictivo del modelo se debe segmentar la data en dos partes (train y test) que permitan construir la curva ROC y el AUC de modelo.
Se procede a dividir la data en dos partes:
- train2 con el 80% de los registros
- test2 con el 20% de los registro
train2 <- nrow(creditos)*0.8
test2 <- nrow(creditos)*0.2
set.seed(123)
index_train2 <- sample(1:nrow(creditos),size = train2)
train.dat2 <- creditos[index_train2,] # muestra de entrenamiento
test.dat2 <- creditos[-index_train2,] # muestra de pruebaLuego de la realiza la separación del set de datos, presentando la curva ROC y su área bajo la curva AUC.
valor_pronosticado2 <- predict(modelo4,test.dat2,type = "response")
niveles_pronosticados2 <- factor(ifelse(valor_pronosticado2 >0.5, "Si","No"))
curva_ROC2 <- roc(test.dat2$default, valor_pronosticado2)## Setting levels: control = 0, case = 1## Setting direction: controls < casesauc2<- round(auc(curva_ROC2, levels =c(0,1), direction = "<"),4)
#Se realiza la curva con la funcion ggplot
ggroc(curva_ROC2, colour = "#FF7F00", size=1) + ggtitle(paste0("Curva ROC 2 ", "(AUC = ", auc2, ")")) + xlab("Especificidad") + ylab("Sensibilidad") 
Análisis final. Con la curva ROC se logra evaluar la capacidad predictiva del modelo de clasificación binaria que se crea anteriormente con nombre “modelo4” mediante el calculo del área bajo la curva denominado AUC, para este caso en especifico el valor del área bajo la curva ROC es un AUC > 0.5 (AUC del modelo igual a 0.75) lo que se traduce en una clasificación excelente que se presenta cuando la curva ROC pasa cerca del punto (0,1), indicando que el modelo tienen una alta capacidad para clasificar correctamente los valores positivos del modelo y los verdaderos negativos.