Unidad 3 - Informe regresión generalizada múltiple
Francisco Javier Bejarano Fagua
Punto 1:Con base en los datos de rotación realizar los puntos 1 a 7.
library(readxl)
library(ggplot2)
library(plotly)
library(leaflet)
require(ggpubr)
require(ggplot2)
datos <- read_excel("C:/Users/PACHO/Downloads/Datos_RotaciOn.xlsx")
head(datos)## # A tibble: 6 × 24
## Rotación Edad Viaje de…¹ Depar…² Dista…³ Educa…⁴ Campo…⁵ Satis…⁶ Genero Cargo
## <chr> <dbl> <chr> <chr> <dbl> <dbl> <chr> <dbl> <chr> <chr>
## 1 Si 41 Raramente Ventas 1 2 Cienci… 2 F Ejec…
## 2 No 49 Frecuente… IyD 8 1 Cienci… 3 M Inve…
## 3 Si 37 Raramente IyD 2 2 Otra 4 M Tecn…
## 4 No 33 Frecuente… IyD 3 4 Cienci… 4 F Inve…
## 5 No 27 Raramente IyD 2 1 Salud 1 M Tecn…
## 6 No 32 Frecuente… IyD 2 2 Cienci… 4 M Tecn…
## # … with 14 more variables: Satisfación_Laboral <dbl>, Estado_Civil <chr>,
## # Ingreso_Mensual <dbl>, Trabajos_Anteriores <dbl>, Horas_Extra <chr>,
## # Porcentaje_aumento_salarial <dbl>, Rendimiento_Laboral <dbl>,
## # Años_Experiencia <dbl>, Capacitaciones <dbl>,
## # Equilibrio_Trabajo_Vida <dbl>, Antigüedad <dbl>, Antigüedad_Cargo <dbl>,
## # Años_ultima_promoción <dbl>, Años_acargo_con_mismo_jefe <dbl>, and
## # abbreviated variable names ¹`Viaje de Negocios`, ²Departamento, …datos$'Viaje de Negocios'<-as.character(datos$`Viaje de Negocios`)
datos$Departamento<-as.factor(datos$Departamento)
datos$Campo_Educación<-as.factor(datos$Campo_Educación)
datos$Genero<-as.factor(datos$Genero)
datos$Cargo<-as.factor(datos$Cargo)
datos$Estado_Civil<-as.factor(datos$Estado_Civil)
datos$Horas_Extra<-as.factor(datos$Horas_Extra)
summary(datos)## Rotación Edad Viaje de Negocios Departamento
## Length:1470 Min. :18.00 Length:1470 IyD :961
## Class :character 1st Qu.:30.00 Class :character RH : 63
## Mode :character Median :36.00 Mode :character Ventas:446
## Mean :36.92
## 3rd Qu.:43.00
## Max. :60.00
##
## Distancia_Casa Educación Campo_Educación Satisfacción_Ambiental
## Min. : 1.000 Min. :1.000 Ciencias :606 Min. :1.000
## 1st Qu.: 2.000 1st Qu.:2.000 Humanidades: 27 1st Qu.:2.000
## Median : 7.000 Median :3.000 Mercadeo :159 Median :3.000
## Mean : 9.193 Mean :2.913 Otra : 82 Mean :2.722
## 3rd Qu.:14.000 3rd Qu.:4.000 Salud :464 3rd Qu.:4.000
## Max. :29.000 Max. :5.000 Tecnicos :132 Max. :4.000
##
## Genero Cargo Satisfación_Laboral Estado_Civil
## F:588 Ejecutivo_Ventas :326 Min. :1.000 Casado :673
## M:882 Investigador_Cientifico:292 1st Qu.:2.000 Divorciado:327
## Tecnico_Laboratorio :259 Median :3.000 Soltero :470
## Director_Manofactura :145 Mean :2.729
## Representante_Salud :131 3rd Qu.:4.000
## Gerente :102 Max. :4.000
## (Other) :215
## Ingreso_Mensual Trabajos_Anteriores Horas_Extra Porcentaje_aumento_salarial
## Min. : 1009 Min. :0.000 No:1054 Min. :11.00
## 1st Qu.: 2911 1st Qu.:1.000 Si: 416 1st Qu.:12.00
## Median : 4919 Median :2.000 Median :14.00
## Mean : 6503 Mean :2.693 Mean :15.21
## 3rd Qu.: 8379 3rd Qu.:4.000 3rd Qu.:18.00
## Max. :19999 Max. :9.000 Max. :25.00
##
## Rendimiento_Laboral Años_Experiencia Capacitaciones Equilibrio_Trabajo_Vida
## Min. :3.000 Min. : 0.00 Min. :0.000 Min. :1.000
## 1st Qu.:3.000 1st Qu.: 6.00 1st Qu.:2.000 1st Qu.:2.000
## Median :3.000 Median :10.00 Median :3.000 Median :3.000
## Mean :3.154 Mean :11.28 Mean :2.799 Mean :2.761
## 3rd Qu.:3.000 3rd Qu.:15.00 3rd Qu.:3.000 3rd Qu.:3.000
## Max. :4.000 Max. :40.00 Max. :6.000 Max. :4.000
##
## Antigüedad Antigüedad_Cargo Años_ultima_promoción
## Min. : 0.000 Min. : 0.000 Min. : 0.000
## 1st Qu.: 3.000 1st Qu.: 2.000 1st Qu.: 0.000
## Median : 5.000 Median : 3.000 Median : 1.000
## Mean : 7.008 Mean : 4.229 Mean : 2.188
## 3rd Qu.: 9.000 3rd Qu.: 7.000 3rd Qu.: 3.000
## Max. :40.000 Max. :18.000 Max. :15.000
##
## Años_acargo_con_mismo_jefe
## Min. : 0.000
## 1st Qu.: 2.000
## Median : 3.000
## Mean : 4.123
## 3rd Qu.: 7.000
## Max. :17.000
## 1.Seleccionar 3 variables categóricas (distintas de rotación) y 3 variables cuantitativas, que consideren estén relacionadas con la rotación. Nota: Justificar por que estas variables están relacionadas y que tipo de relación se espera (Hipótesis). Ejemplo: Se espera que las horas extra se relacionen con la rotación ya que las personas podrían desgastarse mas al trabajar horas extra y descuidan aspectos personales. La hipótesis es que las personas que trabajan horas extra tienen mayor posibilidad de rotar que las que no trabajan extra. (serian 6, una por variable).
g2=ggplot(datos,aes(x=`Viaje de Negocios`))+geom_bar()+theme_bw()
g6=ggplot(datos,aes(x=Estado_Civil))+geom_bar()+theme_bw()
g7=ggplot(datos,aes(x=Horas_Extra))+geom_bar()+theme_bw()
ggarrange(g2, g6, g7,labels = c("A", "B", "C"),ncol = 3, nrow = 1)
Seleccionar 3 variables categóricas (distintas de rotación) y 3 variables cuantitativas
Variables Categóricas:
Como variables categóricas para el estudio se pueden establecer aquellas que solo pueden tomar un numero limitado de valores o categorías, para nuestro caso podríamos considerar las siguientes:
Viaje de Negocios: Esta puede ser una variable que tenga un efecto en los factores de rotación de la compañia, puede que las personas que viejen mas frecuentemente presenten agotamiento y busquen pasar mas tiempo en familia y gastar menos tiempo en viajes.
Estado_Civil: Consideramos que el estado civil se encuentra asociado con la rotación, es probable que las personas solteras se sientan menos comprometidas con la empresa, mientras que las personas casadas buscan mayor estabilidad por lo que pueden tratar de encontrar opciones estables de trabajo.
Horas_Extra: Una posibilidad esta en que las personas que tengas que realizar horas extras se sientan menos valoradas en su trabajo y por lo tanto tenga un impacto como factor de rotación
Variables cuantitativas:
Dentro de las variables cuantitativas que consideramos para el modelo definimos las siguientes por su relevancia:
Edad: COnsideramos la edad como un factor que puede tener un impacto significativo en la ritación de personal, como hipotesis consideramos que las personas más jóvenes o menores de 30 años tienden a rotar más que las personas mayores.
ingreso mensual: Este es un factor que puede ser altamente relevante como causal de rotación de personal ya que las personas generalmente estan en búsqueda de mejorar sus ingresos.
distancia casa: En muchas ocasiones este es un factor desicivo para cambiar de trabajo, por lo tanto consideramos esta como una variable a evaluar como factor de rotación.
2.Realizar un análisis univariado (caracterización). Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuanti o cuali). Incluir interpretaciones de la rotación.
ga=ggplot(datos,aes(x=`Viaje de Negocios`))+geom_bar()+theme_bw()
gb=ggplot(datos,aes(x=Horas_Extra))+geom_bar()+theme_bw()
gc=ggplot(datos,aes(x=Estado_Civil))+geom_bar()+theme_bw()
gd=ggplot(datos,aes(x=Edad))+geom_histogram()+theme_bw()
ge=ggplot(datos,aes(x=Ingreso_Mensual))+geom_histogram()+theme_bw()
gf=ggplot(datos,aes(x=Distancia_Casa))+geom_histogram()+theme_bw()
ggarrange(ga, gb, gc, gd, ge, gf,labels = c("A", "B","C","D","E","F"),ncol = 3, nrow = 2)
require(table1)## Loading required package: table1##
## Attaching package: 'table1'## The following objects are masked from 'package:base':
##
## units, units<-datos$Edad_1=cut(datos$Edad,breaks = c(0,30,40,50,60))
AU1 <- table1::table1(~ Edad+`Viaje de Negocios`+Estado_Civil+Ingreso_Mensual+Distancia_Casa+Horas_Extra | Rotación, data = datos)
AU1| 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] |
| 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%) |
| 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%) |
| Ingreso_Mensual | |||
| Mean (SD) | 6830 (4820) | 4790 (3640) | 6500 (4710) |
| Median [Min, Max] | 5200 [1050, 20000] | 3200 [1010, 19900] | 4920 [1010, 20000] |
| 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] |
| Horas_Extra | |||
| No | 944 (76.6%) | 110 (46.4%) | 1054 (71.7%) |
| Si | 289 (23.4%) | 127 (53.6%) | 416 (28.3%) |
t.test(datos$Edad~datos$Rotación)##
## Welch Two Sample t-test
##
## data: datos$Edad by datos$Rotación
## t = 5.828, df = 316.93, p-value = 1.38e-08
## alternative hypothesis: true difference in means between group No and group Si is not equal to 0
## 95 percent confidence interval:
## 2.618930 5.288346
## sample estimates:
## mean in group No mean in group Si
## 37.56123 33.60759Análisis
Como podemos observar en las gráficas la mayor parte de los empleados se encuentra entre los 30 y 40 años de edad, es decir en una media 36.9 años, adicionalmente podemos identificar que un alto porcentaje de ellos raramente viaja, en promedio apenas el 18% de los empleados viaja frecuentemente mientras que el 71% los hace raramente, Asi mismo, cerca de la mistad de los mismos se encuentran casados y como elemento importante tambien evidenciamos que la mediana es decir, la mayoria de salarios esta en el orden de los 4,9 millones. No nos guiamos por la media ya que puede estar afectada por los salarios más altos. Finalmente encontramos que la mayoría de empleados viven cerca de la compañía, a una media de 9.19 minutos y en su mayoría no realizan horas extra.
3.Realizar un análisis de bivariado en donde la variable respuesta sea la 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 hipotesis planteada en el punto 2.
require(CGPfunctions)## Loading required package: CGPfunctions## Registered S3 method overwritten by 'performance':
## method from
## plot.check_clusterstructure parameters#Grafica para categoricas
PlotXTabs2(data = datos,x = Estado_Civil,y = Rotación)
PlotXTabs2(data = datos,x = `Viaje de Negocios`,y = Rotación)
PlotXTabs2(data = datos,x = Horas_Extra,y = Rotación)
Variables Categóricas - Análisis
Estado Civil: Como podemos identificar en la gráfica existe mayor probabilidad de rotación entre las personas solteras con un 26% de este factor presente en este grupo de personas, mientras que entre el grupo de personas casadas o divorciadas el indicador de rotación es de apenas 10% lo cual confirma nuestra hipótesis en cuanto a que este grupo busca mayor estabilidad. Un indicador importante y útil sería identificar si tienen hijos o no.
Viaje de Negocios: Tal como lo planteamos en nuestra hipótesis las personas que viajan frecuentemente tienen mayor probabilidad de rotar. Tal vez por agotamiento o falta de tiempo, es algo para determinar en un analisis más profundo.
Horas Extra: Es altamente relevante que un factor de rotación es sin duda el hecho que el empleado tenga que realizar horas extra en su trabajo.
#Grafica para cuantitativas
g9=ggplot(data=datos,mapping = aes(x=Rotación,y=Edad, fill=Rotación))+geom_boxplot()+theme_bw()+
geom_smooth(method = "lm")
g8=ggplot(data=datos,mapping = aes(x=Rotación,y=Ingreso_Mensual, fill=Rotación))+geom_boxplot()+theme_bw()+
geom_smooth(method = "lm")
g7=ggplot(data=datos,mapping = aes(x=Rotación,y=Distancia_Casa, fill=Rotación))+geom_boxplot()+theme_bw()+
geom_smooth(method = "lm")
ggarrange(g9, g8, g7 + rremove("x.text"),
labels = c("Edad", "Ingreso", "Distancia"),
ncol = 2, nrow = 2)## `geom_smooth()` using formula 'y ~ x'
## `geom_smooth()` using formula 'y ~ x'
## `geom_smooth()` using formula 'y ~ x'
Variables Cuantitativas - Análisis
Edad: Podemos evidenciar que las personas más jóvenes (menores de 40) tienen mayor tendencia a rotar más, lo cual valida nuestra hipótesis. Ingreso Mensual: Las personas con ingresos menores a la media de la compañía tienen a presentar un mayor nivel de rotación, es decir personas con ingresos menores a 5 millones. Distancia Casa: Las personas que viven a mayor distancia de la oficina presentan mayor nivel de rotación lo cual confirma nuestra hipótesis.
4.Realizar la estimación de un modelo de regresión logistico 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. Interprete los coeficientes del modelo y la significancia de los parametros.
# Observaciones de entrenamiento
library(caret)
set.seed(1460)
train <- createDataPartition(y = datos$Rotación, p = 0.8, list = FALSE, times = 1)
datos_entrena <- datos[train, ]
datos_prueba <- datos[-train, ]
atrain <- datos$Rotación[train]
dtrain <- datos$Rotación[-train]
prop.table(table(datos_entrena$Rotación))##
## No Si
## 0.8385726 0.1614274library(tidyverse)## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
## ✔ tibble 3.1.8 ✔ dplyr 1.0.10
## ✔ tidyr 1.2.1 ✔ stringr 1.4.1
## ✔ readr 2.1.3 ✔ forcats 0.5.2
## ✔ purrr 0.3.4
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks plotly::filter(), stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ✖ purrr::lift() masks caret::lift()library(table1)
datos2 <- datos_entrena %>%
select(Rotación) %>%
mutate(Rotación = recode(Rotación,
"No" = 0,
"Si" = 1))
#head(datos_entrena)
prop.table(table(datos2$Rotación))##
## 0 1
## 0.8385726 0.1614274table(datos_entrena$Rotación)##
## No Si
## 987 190datos_entrena$Rotación <- ifelse(datos2$Rotación==1,1,0)
table(datos_entrena$Rotación) # Si = 1 / No = 0##
## 0 1
## 987 190m1 <- glm(Rotación ~ Estado_Civil + `Viaje de Negocios` + Horas_Extra + Edad_1 + Ingreso_Mensual + Distancia_Casa , family = binomial, data= datos_entrena)
summary(m1)##
## Call:
## glm(formula = Rotación ~ Estado_Civil + `Viaje de Negocios` +
## Horas_Extra + Edad_1 + Ingreso_Mensual + Distancia_Casa,
## family = binomial, data = datos_entrena)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.6465 -0.5849 -0.3959 -0.2250 2.9877
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.284e+00 2.907e-01 -4.416 1.01e-05 ***
## Estado_CivilDivorciado -3.687e-01 2.657e-01 -1.388 0.165192
## Estado_CivilSoltero 9.517e-01 1.920e-01 4.957 7.18e-07 ***
## `Viaje de Negocios`No_Viaja -1.286e+00 3.898e-01 -3.299 0.000970 ***
## `Viaje de Negocios`Raramente -6.428e-01 2.031e-01 -3.165 0.001550 **
## Horas_ExtraSi 1.472e+00 1.793e-01 8.211 < 2e-16 ***
## Edad_1(30,40] -6.597e-01 2.054e-01 -3.212 0.001317 **
## Edad_1(40,50] -8.300e-01 2.746e-01 -3.023 0.002505 **
## Edad_1(50,60] -1.171e-01 3.550e-01 -0.330 0.741585
## Ingreso_Mensual -1.081e-04 2.755e-05 -3.924 8.70e-05 ***
## Distancia_Casa 3.480e-02 1.043e-02 3.335 0.000854 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 1040.54 on 1176 degrees of freedom
## Residual deviance: 863.99 on 1166 degrees of freedom
## AIC: 885.99
##
## Number of Fisher Scoring iterations: 5Variables significativas
sig.var<- summary(m1)$coeff[-1,4] <0.01
names(sig.var)[sig.var == TRUE]## [1] "Estado_CivilSoltero" "`Viaje de Negocios`No_Viaja"
## [3] "`Viaje de Negocios`Raramente" "Horas_ExtraSi"
## [5] "Edad_1(30,40]" "Edad_1(40,50]"
## [7] "Ingreso_Mensual" "Distancia_Casa"Con predict podemos predecir con el modelo logístico el conjunto de test.
pred1<- predict.glm(m1,newdata = datos_prueba, type="response")
result1<- table(dtrain, floor(pred1+0.5))
result1##
## dtrain 0 1
## No 240 6
## Si 37 10error1<- sum(result1[1,2], result1[2,1])/sum(result1)
error1## [1] 0.1467577Análisis
Podemos evidenciar a través de la regresión logaritmica que las variables más significativas relacionadas a las que elegimos inicialmente para plantear nuestras hipótesis son:
Categóricas
Estado Civil: (“Estado_CivilSoltero”) las personas solteras son las que mayor probabilidad tienend e rotar segun el modelo, Viaje de Negocios:En cuanto a los viajes encontramos que existe una mayor significancia en el modelo en aquellas personas que no viajan frente a aquellas que viajan frecuentemente lo que de cierta forma desvirtua la hipótesis planteada. Horas extra: Como lo planteamos efectivamente las horas extra si son un factor relevante dentro del modelo para explicar la rotación de personal.
Cuantitativas
Edad: Podemos evidenciar que entre mayor edad menor es la propabilidad de rotación, adicional identificamos esta como una variable significativa en el modelo. Ingreso Mensual: Segun el resultado del análisis este factor presenta un nivel de significancia alto dentro del modelo Distancia Casa: No se considera como un elemento relevante dentro del modelo.
5. Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.
library(plotROC)
library(ROCR)
pred = ROCR::prediction(pred1,dtrain)
perf <- performance(pred, "tpr", "fpr")
plot(perf)
AUCLog1=performance(pred, measure = "auc")@y.values[[1]]
cat("AUC: ",AUCLog1,"n")## AUC: 0.765871 nAnálisis
En nuestro modelo el área bajo la curva ROC es de 0.76, lo que significa que el modelo presenta una buena capacidad de predicción.
6.Predeccir la probabilida de que un individuo (hipotetico) rote y defina un corte para decidir si se debe intervenir a este empleado o no (posible estrategia para motivar al empleado).
head(datos)## # A tibble: 6 × 25
## Rotación Edad Viaje de…¹ Depar…² Dista…³ Educa…⁴ Campo…⁵ Satis…⁶ Genero Cargo
## <chr> <dbl> <chr> <fct> <dbl> <dbl> <fct> <dbl> <fct> <fct>
## 1 Si 41 Raramente Ventas 1 2 Cienci… 2 F Ejec…
## 2 No 49 Frecuente… IyD 8 1 Cienci… 3 M Inve…
## 3 Si 37 Raramente IyD 2 2 Otra 4 M Tecn…
## 4 No 33 Frecuente… IyD 3 4 Cienci… 4 F Inve…
## 5 No 27 Raramente IyD 2 1 Salud 1 M Tecn…
## 6 No 32 Frecuente… IyD 2 2 Cienci… 4 M Tecn…
## # … with 15 more variables: Satisfación_Laboral <dbl>, Estado_Civil <fct>,
## # Ingreso_Mensual <dbl>, Trabajos_Anteriores <dbl>, Horas_Extra <fct>,
## # Porcentaje_aumento_salarial <dbl>, Rendimiento_Laboral <dbl>,
## # Años_Experiencia <dbl>, Capacitaciones <dbl>,
## # Equilibrio_Trabajo_Vida <dbl>, Antigüedad <dbl>, Antigüedad_Cargo <dbl>,
## # Años_ultima_promoción <dbl>, Años_acargo_con_mismo_jefe <dbl>,
## # Edad_1 <fct>, and abbreviated variable names ¹`Viaje de Negocios`, …Edad 36 Viaje de Negocios Frecuentemente Departamento IyD Distancia_Casa 3 Educación 2 Campo_Educación Salud Satisfacción_Ambiental 4 Genero M Cargo Tecnico_Laboratorio Satisfación_Laboral 2 Estado_Civil Soltero Ingreso_Mensual 2088 Trabajos_Anteriores 4 Horas_Extra No Porcentaje_aumento_salarial 12 Rendimiento_Laboral 3 Años_Experiencia 13 Capacitaciones 3 Equilibrio_Trabajo_Vida 2 Antigüedad 8 Antigüedad_Cargo 7 Años_ultima_promoción 7 Años_acargo_con_mismo_jefe 2
Intervención 80%
datos_entrena$Rotación <- ifelse(datos2$Rotación==1,1,0)
table(datos_entrena$Rotación) # Si = 1 / No = 0##
## 0 1
## 987 190m2 <- glm(Rotación ~ Estado_Civil + Horas_Extra + Edad + Ingreso_Mensual + Distancia_Casa , family = binomial, data= datos_entrena)
newdata = data.frame(Estado_Civil = 'Soltero', Horas_Extra = 'No', Edad = 36, Ingreso_Mensual = 2088, Distancia_Casa = 4)
predict(object = m2, newdata = newdata, type = 'response')## 1
## 0.1918785Análisis Según estas características, podemos estimar que esta persona tiene una probabilidad de rotación de alrededor de 19%.
estrategia para disminuir la rotación en la empresa
7.En las conclusiones se discute sobre cual seria la estrategia para disminuir la rotación en la empresa (con base en las variables que resultaron significativas en el punto 3). Ejemplo: Mejorar el ambiente laboral, los incentivos económicos, distribuir la carga de horas extra (menos turnos y mas personal)
Para disminuir la rotación en la compañia se pueden buscar las siguientes estrategias de acuerdo con los datos obtenidos:
1- Buscar incentivos de formacion y promoción a las personas más jovenes asi como incentivos de viajes. 2- A las personas que viajan frecuentemente les pueden ofrecer incentivos de tiempo compensatorio para alivianar la carga laboral a la cual se somenten por sus viajes. 3- Establecer rutas para las personas que viven mas lejos de la compañia o un modelo de teletrabajo o esquema hibrido aliviaria significativamente el estres de estas personas y su deseo de salir de la compañía. 4 - A las personas solteras se puede buscar un vincularlas mas a aquellos cargos que tienen mayor carga de viajes mientras que a los casados ubicarlos en cargos más de base.
Punto 2: 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 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.
library(readxl)
Datos_Creditos <- read_excel("C:/Users/PACHO/Downloads/Datos_Creditos.xlsx",
col_types = c("numeric", "numeric", "numeric",
"numeric", "numeric"))
Datos_Creditos$DEFAULT = as.factor(Datos_Creditos$DEFAULT)
head(Datos_Creditos)## # A tibble: 6 × 5
## DEFAULT ANTIUEDAD EDAD CUOTA_TOTAL INGRESOS
## <fct> <dbl> <dbl> <dbl> <dbl>
## 1 1 37.3 77.0 3020519 8155593
## 2 1 37.3 73.8 1766552 6181263
## 3 1 31.0 78.9 1673786 4328075
## 4 1 9.73 51.5 668479 5290910
## 5 1 8.44 39.0 1223559 5333818
## 6 1 6.61 44.9 3517756 2710736str(Datos_Creditos)## tibble [780 × 5] (S3: tbl_df/tbl/data.frame)
## $ DEFAULT : Factor w/ 2 levels "0","1": 2 2 2 2 2 2 2 2 2 2 ...
## $ ANTIUEDAD : num [1:780] 37.32 37.32 30.98 9.73 8.44 ...
## $ EDAD : num [1:780] 77 73.8 78.9 51.5 39 ...
## $ CUOTA_TOTAL: num [1:780] 3020519 1766552 1673786 668479 1223559 ...
## $ INGRESOS : num [1:780] 8155593 6181263 4328075 5290910 5333818 ...El dataset para la creación del modelo cuenta con 5 columnas o variables ( default, Antiguedad, edad, cuota total e ingresos), siendo la variable default la variable dependiente, que refleja la probabilidad de que una persona pague su cuota o no (1= default, 0= no default).
summary(Datos_Creditos)## DEFAULT ANTIUEDAD EDAD CUOTA_TOTAL INGRESOS
## 0:741 Min. : 0.2548 Min. :26.61 Min. : 387 Min. : 633825
## 1: 39 1st Qu.: 7.3767 1st Qu.:48.18 1st Qu.: 328516 1st Qu.: 3583324
## Median :15.1192 Median :57.92 Median : 694460 Median : 5038962
## Mean :18.0353 Mean :56.99 Mean : 885206 Mean : 5366430
## 3rd Qu.:30.6637 3rd Qu.:66.19 3rd Qu.:1244126 3rd Qu.: 6844098
## Max. :37.3178 Max. :92.43 Max. :6664588 Max. :22197021table(Datos_Creditos$DEFAULT)##
## 0 1
## 741 39prop.table(table(Datos_Creditos$DEFAULT))##
## 0 1
## 0.95 0.05Del total de observaciones, en 741 casos (95%) las personas cumplen con su obligación y en 39 casos (39%) no lo hacen.
#Creación del modelo de regresión logística múltiple
mod_credito = glm(DEFAULT~., data = Datos_Creditos, family = "binomial" )
summary(mod_credito)##
## Call:
## glm(formula = DEFAULT ~ ., family = "binomial", data = Datos_Creditos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.9181 -0.3672 -0.2873 -0.1917 3.1332
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.193e+00 9.306e-01 -3.431 0.000601 ***
## ANTIUEDAD -4.616e-02 2.353e-02 -1.961 0.049849 *
## EDAD 2.229e-02 1.932e-02 1.154 0.248641
## CUOTA_TOTAL 1.013e-06 2.473e-07 4.098 4.16e-05 ***
## INGRESOS -2.615e-07 1.057e-07 -2.474 0.013348 *
## ---
## 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.49 on 775 degrees of freedom
## AIC: 297.49
##
## Number of Fisher Scoring iterations: 6Del primer moedelo realizado (mod_credito), se observa que la variable más siginificativa es la cuota_total, y le siguen la antiguedad y los ingresos. Por último, también se puede decir que la edad no es una variable significativa. A continuación revisaremos las correlaciones entre cada una de las variables para revisar si puede existir multicolinealidad, que pueda influir en el desempeño del modelo.
datos.cuanti = Datos_Creditos[,c(2,3,4,5)]
correlacion = round(cor(datos.cuanti), digits=2)
correlacion## ANTIUEDAD EDAD CUOTA_TOTAL INGRESOS
## ANTIUEDAD 1.00 0.75 0.27 0.48
## EDAD 0.75 1.00 0.15 0.36
## CUOTA_TOTAL 0.27 0.15 1.00 0.36
## INGRESOS 0.48 0.36 0.36 1.00library('corrplot')
corrplot(correlacion, method="number", type="upper")
De acuerdo con el anterior gráfico de correlación, existe una correlación positiva alta entre la variable edad y antiguedad (0.75), lo cual al momento de la implementación del modelo puede conllevar problemas de multicolinealidad. Por tal razón es necesario revisar otras opciones de modelos que nos puedan ayudar a evitar esta situación utilizando la función step.
#Uso de la función step para obtener un mejor modelo.
mod_credito_mejorado = step(mod_credito)## Start: AIC=297.49
## DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS
##
## Df Deviance AIC
## - EDAD 1 288.79 296.79
## <none> 287.49 297.49
## - ANTIUEDAD 1 291.28 299.28
## - INGRESOS 1 294.76 302.76
## - CUOTA_TOTAL 1 304.34 312.34
##
## Step: AIC=296.78
## DEFAULT ~ ANTIUEDAD + CUOTA_TOTAL + INGRESOS
##
## Df Deviance AIC
## <none> 288.79 296.79
## - ANTIUEDAD 1 291.37 297.37
## - INGRESOS 1 295.61 301.61
## - CUOTA_TOTAL 1 304.95 310.95summary(mod_credito_mejorado)##
## Call:
## glm(formula = DEFAULT ~ ANTIUEDAD + CUOTA_TOTAL + INGRESOS, family = "binomial",
## data = Datos_Creditos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.8147 -0.3724 -0.2868 -0.1938 3.1088
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.244e+00 3.933e-01 -5.707 1.15e-08 ***
## ANTIUEDAD -2.817e-02 1.803e-02 -1.562 0.1183
## CUOTA_TOTAL 9.860e-07 2.456e-07 4.014 5.96e-05 ***
## INGRESOS -2.542e-07 1.059e-07 -2.400 0.0164 *
## ---
## 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: 288.78 on 776 degrees of freedom
## AIC: 296.78
##
## Number of Fisher Scoring iterations: 6Con el ajuste en el modelo, ya no aparece la variable edad y la variable antiguedad toma poca significancia para el modelo. Con base, en los coeficientes obtenidos se puede afirmar que :
-Entre mayor sea el valor de los ingresos, disminuye la probabilidad de default.
-Entre mayor antiguedad, disminuye la probabilidad de de default.
-Entre mas alta sea la cuota, la probabilidad de default aumenta.
ROC y AUC
library(ROCR)
prediccion_credito= predict.glm(mod_credito_mejorado, newdata = Datos_Creditos, type = "response")
resultado_cre=table(Datos_Creditos$DEFAULT, ifelse(prediccion_credito>0.2,1,0))
resultado_cre##
## 0 1
## 0 738 3
## 1 38 1prediccion_default= ROCR::prediction(prediccion_credito,Datos_Creditos$DEFAULT)
perf_credito= performance(prediction.obj = prediccion_default, "tpr", "fpr")
plot(perf_credito)
abline(a = 0, b = 1,col="blue")
grid()
AUC= performance(prediccion_default,measure = "auc")@y.values[[1]]
cat("AUC: ",AUC,"n")## AUC: 0.6922385 nDe acuerdo con la anterior curva ROC, el área bajo la curva es de 0.69, lo que indica que el modelo tiene un bajo poder de discrimnación, para distinguir entre una clase positiva o negativa.