Modelos Estadisticos para la toma de decisiones - Modelo de Regresión Lineal Múltiple

ACTIVIDAD: INFORME REGRESION GENERALIZADA MULTIPLE

A.- CASO ROTACION LABORAL

# Librerías necesarias
library(readxl)
library(psych)
require(ggplot2)
require(plotly)
require(CGPfunctions)
require(ggpubr)



# Cargue de los datos
rotacion <- read_excel("Datos_Rotacion.xlsx")
attach(rotacion)

#Exploración de indicadores estadísticos de los datos

summary(rotacion)

##    Rotacion              Edad       Viaje de Negocios  Departamento      
##  Length:1470        Min.   :18.00   Length:1470        Length:1470       
##  Class :character   1st Qu.:30.00   Class :character   Class :character  
##  Mode  :character   Median :36.00   Mode  :character   Mode  :character  
##                     Mean   :36.92                                        
##                     3rd Qu.:43.00                                        
##                     Max.   :60.00                                        
##  Distancia_Casa     Educación     Campo_Educacion    Satisfacción_Ambiental
##  Min.   : 1.000   Min.   :1.000   Length:1470        Min.   :1.000         
##  1st Qu.: 2.000   1st Qu.:2.000   Class :character   1st Qu.:2.000         
##  Median : 7.000   Median :3.000   Mode  :character   Median :3.000         
##  Mean   : 9.193   Mean   :2.913                      Mean   :2.722         
##  3rd Qu.:14.000   3rd Qu.:4.000                      3rd Qu.:4.000         
##  Max.   :29.000   Max.   :5.000                      Max.   :4.000         
##     Genero             Cargo           Satisfación_Laboral Estado_Civil      
##  Length:1470        Length:1470        Min.   :1.000       Length:1470       
##  Class :character   Class :character   1st Qu.:2.000       Class :character  
##  Mode  :character   Mode  :character   Median :3.000       Mode  :character  
##                                        Mean   :2.729                         
##                                        3rd Qu.:4.000                         
##                                        Max.   :4.000                         
##  Ingreso_Mensual Trabajos_Anteriores Horas_Extra       
##  Min.   : 1009   Min.   :0.000       Length:1470       
##  1st Qu.: 2911   1st Qu.:1.000       Class :character  
##  Median : 4919   Median :2.000       Mode  :character  
##  Mean   : 6503   Mean   :2.693                         
##  3rd Qu.: 8379   3rd Qu.:4.000                         
##  Max.   :19999   Max.   :9.000                         
##  Porcentaje_aumento_salarial Rendimiento_Laboral Años_Experiencia
##  Min.   :11.00               Min.   :3.000       Min.   : 0.00   
##  1st Qu.:12.00               1st Qu.:3.000       1st Qu.: 6.00   
##  Median :14.00               Median :3.000       Median :10.00   
##  Mean   :15.21               Mean   :3.154       Mean   :11.28   
##  3rd Qu.:18.00               3rd Qu.:3.000       3rd Qu.:15.00   
##  Max.   :25.00               Max.   :4.000       Max.   :40.00   
##  Capacitaciones  Equilibrio_Trabajo_Vida   Antiguedad     Antiguedad_Cargo
##  Min.   :0.000   Min.   :1.000           Min.   : 0.000   Min.   : 0.000  
##  1st Qu.:2.000   1st Qu.:2.000           1st Qu.: 3.000   1st Qu.: 2.000  
##  Median :3.000   Median :3.000           Median : 5.000   Median : 3.000  
##  Mean   :2.799   Mean   :2.761           Mean   : 7.008   Mean   : 4.229  
##  3rd Qu.:3.000   3rd Qu.:3.000           3rd Qu.: 9.000   3rd Qu.: 7.000  
##  Max.   :6.000   Max.   :4.000           Max.   :40.000   Max.   :18.000  
##  Años_ultima_promoción Años_acargo_con_mismo_jefe
##  Min.   : 0.000        Min.   : 0.000            
##  1st Qu.: 0.000        1st Qu.: 2.000            
##  Median : 1.000        Median : 3.000            
##  Mean   : 2.188        Mean   : 4.123            
##  3rd Qu.: 3.000        3rd Qu.: 7.000            
##  Max.   :15.000        Max.   :17.000

describe(rotacion)

	vars	n	mean	sd	median	trimmed	mad	min	max	range	skew	kurtosis	se
Rotacion*	1	1470	1.161225	0.3678630	1	1.076531	0.0000	1	2	1	1.8406038	1.3887685	0.0095946
Edad	2	1470	36.923809	9.1353735	36	36.471088	8.8956	18	60	42	0.4124432	-0.4103776	0.2382691
Viaje de Negocios*	3	1470	2.521088	0.7917401	3	2.651361	0.0000	1	3	2	-1.2082798	-0.3187275	0.0206502
Departamento*	4	1470	1.649660	0.9137684	1	1.562075	0.0000	1	3	2	0.7466022	-1.3851156	0.0238329
Distancia_Casa	5	1470	9.192517	8.1068644	7	8.084184	7.4130	1	29	28	0.9561635	-0.2319182	0.2114435
Educación	6	1470	2.912925	1.0241649	3	2.975340	1.4826	1	5	4	-0.2890902	-0.5646107	0.0267123
Campo_Educacion*	7	1470	3.113605	1.9451337	3	3.029762	2.9652	1	6	5	0.0542201	-1.7062999	0.0507330
Satisfacción_Ambiental	8	1470	2.721769	1.0930822	3	2.777211	1.4826	1	4	3	-0.3209983	-1.2049578	0.0285098
Genero*	9	1470	1.600000	0.4900647	2	1.625000	0.0000	1	2	1	-0.4078318	-1.8349201	0.0127819
Cargo*	10	1470	5.061224	2.5366597	5	5.019558	2.9652	1	9	8	0.2682117	-1.1774465	0.0661612
Satisfación_Laboral	11	1470	2.728571	1.1028461	3	2.785714	1.4826	1	4	3	-0.3289995	-1.2245363	0.0287645
Estado_Civil*	12	1470	1.861905	0.8712044	2	1.827381	1.4826	1	3	2	0.2703490	-1.6301341	0.0227228
Ingreso_Mensual	13	1470	6502.931293	4707.9567831	4919	5667.240646	3260.2374	1009	19999	18990	1.3670224	0.9923007	122.7930538
Trabajos_Anteriores	14	1470	2.693197	2.4980090	2	2.361395	1.4826	0	9	9	1.0243772	0.0020117	0.0651531
Horas_Extra*	15	1470	1.282993	0.4506065	1	1.228741	0.0000	1	2	1	0.9625214	-1.0742819	0.0117527
Porcentaje_aumento_salarial	16	1470	15.209524	3.6599377	14	14.801871	2.9652	11	25	14	0.8194530	-0.3073229	0.0954586
Rendimiento_Laboral	17	1470	3.153742	0.3608235	3	3.067177	0.0000	3	4	1	1.9179623	1.6797233	0.0094110
Años_Experiencia	18	1470	11.279592	7.7807817	10	10.368197	5.9304	0	40	40	1.1148929	0.9057509	0.2029386
Capacitaciones	19	1470	2.799320	1.2892706	3	2.721088	1.4826	0	6	6	0.5519959	0.4844864	0.0336268
Equilibrio_Trabajo_Vida	20	1470	2.761224	0.7064758	3	2.769558	0.0000	1	4	3	-0.5513533	0.4093130	0.0184263
Antiguedad	21	1470	7.008163	6.1265252	5	5.985544	4.4478	0	40	40	1.7609300	3.9086474	0.1597922
Antiguedad_Cargo	22	1470	4.229252	3.6231370	3	3.854592	4.4478	0	18	18	0.9154918	0.4669978	0.0944988
Años_ultima_promoción	23	1470	2.187755	3.2224303	1	1.482993	1.4826	0	15	15	1.9802422	3.5873464	0.0840475
Años_acargo_con_mismo_jefe	24	1470	4.123129	3.5681361	3	3.768708	4.4478	0	17	17	0.8317508	0.1620914	0.0930642

1.- Exploración de los datos: Variables Categóricas y Cuantitativas

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).

Variables Categóricas

\(\text{Equilibrio_Trabajo_Vida}\): Es posible que los empleados sientan insatisfacción laboral, personal y familiar, al no encontrar que la empresa brinde posibilidades de equilibrio entre estos factores .
Hipótesis: Los empleados que muestran bajo nivel de equilibrio entre trabajo y vida, presentan mayor nivel de rotación.

\(\text{Campo_Educacion}\): Es posible que el campo de educación puede ser un factor de rotación pues el empleado puede estar ejerciendo un cargo no relevante para el área de conocimiento central de la empresa.
Hipótesis: Los empleados con formación educativa no relacionada con el área de negocio de la empresa presentan mayor nivel de rotación.

\(\text{Estado_civil}\): Es posible que el estado civil constituya un factor de rotación, pues esta situación puede influir en la toma de decisiones laborales.
Hipótesis: Los empelados solteros presentan mayor nivel de rotación.

Variables Cuantitativas

\(\text{Ingreso_Mensual}\): El ingreso mensual probablemente sea una variable relacionada directamente con la rotación.
Hipótesis: Empleados con ingresos bajos presentan mayor nivel de rotación.

\(\text{Antigüedad}\): Poco tiempo de antigüedad posiblemente no genere arraigo en la empresa, favoreciendo la rotación.
Hipótesis: Empleados con menor antigüedad presentan mayor nivel de rotación.

\(\text{Edad}\): Posiblemente esta variable esté relacionada con la Rotación laboral pues para un empleado mas joven generalmente es mas fácil el cambio laboral .
Hipótesis: Empleados con menor edad presentan mayor nivel de rotación.

2.- Análisis Univariado

Realizar un análisis univariado (caracterización). Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuantitativa o cualitativa). Incluir interpretaciones de la rotación.

VARIABLE: CARGO

g1=ggplot(rotacion,aes(x=`Equilibrio_Trabajo_Vida`))+geom_bar(fill = "#336699")+theme_bw()+theme(axis.text.x = element_text(angle = 90))
ggplotly(g1)

VARIABLE: CAMPO_EDUCACION

g2=ggplot(rotacion,aes(x=`Campo_Educacion`))+geom_bar(fill = "#336699")+theme_bw()+theme(axis.text.x = element_text(angle = 90))
ggplotly(g2)

VARIABLE: ESTADO_CIVIL

g3=ggplot(rotacion,aes(x=`Estado_Civil`))+geom_bar(fill = "#336699")+theme_bw()
ggplotly(g3)

VARIABLE: INGRESO MENSUAL

#g5=ggplot(rotacion,aes(x=`Ingreso_Mensual`))+geom_histogram(fill = "#336699")+theme_bw()
#ggplotly(g5)

hist(Ingreso_Mensual, probability=TRUE, breaks=32, col="#336699", ylab="Frecuencia", xlab="Ingreso_Mensual", main="Histograma Ingreso Mensual")
x = seq(min(Ingreso_Mensual), max(Ingreso_Mensual), length = 40)
f = dnorm(x, mean = mean(Ingreso_Mensual), sd = sd(Ingreso_Mensual))
lines(x,f, col="black", lwd=3)
l_media = mean(Ingreso_Mensual)
abline(v=l_media, col="red", lwd=3)

qqnorm(Ingreso_Mensual, main = "Ingreso Mensual", col = "blue")
qqline(Ingreso_Mensual)

ks.test(Ingreso_Mensual,pnorm, mean(Ingreso_Mensual), sd(Ingreso_Mensual))

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  Ingreso_Mensual
## D = 0.16892, p-value < 2.2e-16
## alternative hypothesis: two-sided

VARIABLE: ANTIGÜEDAD

#g5=ggplot(rotacion,aes(x=`Antigüedad`))+geom_histogram(fill = "#336699")+theme_bw()
#ggplotly(g5)

hist(Antiguedad, probability=TRUE, breaks=32, col="#336699", ylab="Frecuencia", xlab="Antigüedad", main="Histograma Antigüedad")
x = seq(min(Antiguedad), max(Antiguedad), length = 40)
f = dnorm(x, mean = mean(Antiguedad), sd = sd(Antiguedad))
lines(x,f, col="black", lwd=3)
l_media = mean(Antiguedad)
abline(v=l_media, col="red", lwd=3)

qqnorm(Antiguedad, main = "Antigüedad", col = "blue")
qqline(Antiguedad)

ks.test(Antiguedad,pnorm, mean(Antiguedad), sd(Antiguedad))

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  Antiguedad
## D = 0.15635, p-value < 2.2e-16
## alternative hypothesis: two-sided

VARIABLE: EDAD

g6=ggplot(rotacion,aes(x=`Edad`))+geom_histogram(fill = "#336699")+theme_bw()
ggplotly(g6)

hist(Edad, probability=TRUE, breaks=32, col="#336699", ylab="Frecuencia", xlab="Edad", main="Histograma Edad")
x = seq(min(Edad), max(Edad), length = 40)
f = dnorm(x, mean = mean(Edad), sd = sd(Edad))
lines(x,f, col="black", lwd=3)
l_media = mean(Edad)
abline(v=l_media, col="red", lwd=3)

qqnorm(Edad, main = "Edad", col = "blue")
qqline(Edad)

ks.test(Edad,pnorm, mean(Edad), sd(Edad))

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  Edad
## D = 0.083131, p-value = 3e-09
## alternative hypothesis: two-sided

2.1.- Análisis

1.- Variable [Equilibrio_Trabajo_Vida]: El mayor grupo (893 empleados) califica con 3 la variable Equilibrio_Trabajo_Vida. Esta calificación se destaca entre el resto de valores calificados, es decir es dominante.
2.- Variable [Campo_Educación]: Los principales valores son Ciencias (606 empleados) y Salud (464 empleados). Es decir, estos son los campos de educación que mayor cantidad de empleados concentran; y permiten inferir que el área de negocio de la empresa esta en el Sector Salud.
3.- Variable [Estado_Civil]: El principal valor es Casado (673 empleados). Sin embargo, no es un valor notoriamente dominante.
4.- Variable [Ingreso_Mensual]: El promedio del Ingreso Mensual 6502.93 y la mediana es 4919. Se puede observar que estos parámetros no difieren mucho entre si. Por otro lado, se observa que el rango aproximado entre 1900 y 6500 de ingreso mensual, concentra la mayor parte de empleados. Sin embargo, la Desviación Estándar es alta presentando un valor de 4707.95; Se procedió a realizar un diagrama Q-Q de Normalidad y se obtuvo una distribución que se aleja notablemente de la Normal. Ante estos hallazgos, se ejecutó un test de normalidad de Kolmogorov-Smirnov dado que la muestra es mayor a 50, y se obtuvo un P-Valor que permite rechazar la Hipótesis Nula (\(H0\)) de normalidad y posiblemente la variable no es coherente con una Distribución Normal.
5.- Variable [Antigüedad]: El promedio es 7 años y la mediana es 5 años. Se puede observar que estos parámetros no difieren mucho entre si. Por otro lado, se observa que el rango aproximado entre 1 y 10 años de antigüedad, concentra la mayor parte de empleados. Sin embargo, la Desviación Estándar es alta con un valor de 6.12. Se procedió a realizar un diagrama Q-Q de Normalidad y se obtuvo una distribución que se aleja notablemente de la Normal. Ante estos hallazgos, se ejecutó un test de normalidad de Kolmogorov-Smirnov, y se obtuvo un P-Valor que permite rechazar la Hipótesis Nula (\(H0\)) de normalidad y posiblemente la variable no es coherente con una Distribución Normal.
6.- Variable [Edad]: El promedio es 36.92 años y la mediana es 36 años. Se puede observar que estos parámetros no difieren mucho entre si. Por otro lado, se observa que la Desviación Estándar es 9.13. Se procedió a realizar un diagrama Q-Q de Normalidad y se encontró que también se aleja de la Normal. Se ejecutó un test de normalidad de Kolmogorov-Smirnov, y se obtuvo un P-Valor que aunque es mas alto que en las variables anteriores, también permite rechazar la Hipótesis Nula (\(H0\)) de normalidad y posiblemente la variable no es coherente con una Distribución Normal

3.- Análisis Bivariado

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 hipótesis planteada en el punto 2.

rotacion$Rotacion <- factor(ifelse(rotacion$Rotacion == "Si", 1, 0))

EQUILIBRIO_TRABAJO_VIDA vs ROTACION

gb1=PlotXTabs2(rotacion, `Equilibrio_Trabajo_Vida`, Rotacion, plottype="percent",x.axis.orientation="vertical")
gb1

CAMPO_EDUCACION vs ROTACION

gb2=PlotXTabs2(rotacion,`Campo_Educacion`,Rotacion,plottype="percent",x.axis.orientation="vertical")
gb2

ESTADO_CIVIL vs ROTACION

gb3=PlotXTabs2(rotacion,`Estado_Civil`,Rotacion,plottype="percent")
gb3

INGRESO_MENSUAL vs ROTACION

gb4 = ggplot(rotacion,aes(x=Rotacion,y= Ingreso_Mensual,fill=Rotacion))+geom_boxplot()+theme_bw()
ggplotly(gb4)

ANTIGÛEDAD vs ROTACION

gb5 = ggplot(rotacion,aes(x=Rotacion,y= Antiguedad,fill=Rotacion))+geom_boxplot()+theme_bw()
ggplotly(gb5)

EDAD vs ROTACION

gb6 = ggplot(rotacion,aes(x=Rotacion,y=Edad,fill=Rotacion))+geom_boxplot()+theme_bw()
ggplotly(gb6)

3.1.- Análisis

1.- Variables Equilibrio_trabajo_Vida y Rotación: Se observa que el resultado apoya la hipótesis, pues empelados que indican bajo nivel en el equilibrio entre Trabajo y Vida son los que presentan mayor rotación.
2.- Variables Campo_Educación y Rotación: Se observa que el resultado apoya la hipótesis, pues los campos de formación educativa que mas presentan rotación son Humanidades, Mercadeo y Técnico.
3.- Variables Estado_Civil y Rotación: Se observa que el resultado apoya la hipótesis, pues los empleados solteros presentan mas rotación que los casados y divorciados.
4.- Variables Ingreso_Mensual y Rotación: Se observa que el resultado apoya la hipótesis, pues los empleados con salarios mas bajos presenta mayor rotación.
5.- Variables Antigüedad y Rotación: Se observa que el resultado apoya la hipótesis, pues los empleados con menor antigüedad son los que presentan mayor rotación.
6.- Variables Edad y Rotación: Se observa que el resultado apoya la hipótesis, pues los empleados con menor edad son los que presentan mayor rotación.

4.- Estimación del modelo

Realizar 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. Interprete los coeficientes del modelo y la significancia de los parámetros.

A continuación, se plantea el modelo de regresión generalizado con las variables anteriormente analizadas.

modelo_rot=glm(Rotacion~Ingreso_Mensual+Antiguedad+Edad+Equilibrio_Trabajo_Vida+Campo_Educacion+Estado_Civil,data = rotacion,family = binomial(link="logit"))
summary(modelo_rot)

## 
## Call:
## glm(formula = Rotacion ~ Ingreso_Mensual + Antiguedad + Edad + 
##     Equilibrio_Trabajo_Vida + Campo_Educacion + Estado_Civil, 
##     family = binomial(link = "logit"), data = rotacion)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -1.2385  -0.6256  -0.4731  -0.3004   2.9244  
## 
## Coefficients:
##                              Estimate Std. Error z value Pr(>|z|)    
## (Intercept)                 2.274e-01  4.491e-01   0.506  0.61257    
## Ingreso_Mensual            -7.217e-05  2.602e-05  -2.774  0.00555 ** 
## Antiguedad                 -4.107e-02  1.849e-02  -2.221  0.02633 *  
## Edad                       -2.532e-02  9.655e-03  -2.622  0.00874 ** 
## Equilibrio_Trabajo_Vida    -2.654e-01  1.027e-01  -2.585  0.00974 ** 
## Campo_EducacionHumanidades  1.038e+00  4.764e-01   2.178  0.02938 *  
## Campo_EducacionMercadeo     6.831e-01  2.352e-01   2.904  0.00368 ** 
## Campo_EducacionOtra        -1.333e-01  3.535e-01  -0.377  0.70600    
## Campo_EducacionSalud       -1.033e-01  1.846e-01  -0.559  0.57592    
## Campo_EducacionTecnicos     5.863e-01  2.458e-01   2.385  0.01708 *  
## Estado_CivilDivorciado     -2.448e-01  2.222e-01  -1.102  0.27068    
## Estado_CivilSoltero         8.100e-01  1.645e-01   4.925 8.43e-07 ***
## ---
## 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: 1176.4  on 1458  degrees of freedom
## AIC: 1200.4
## 
## Number of Fisher Scoring iterations: 5

Los resultados son coherentes con el análisis previo, pues muestran que las variables son significativas y tienen peso en el modelo. Por otro lado, dentro de las variables categóricas Campo_Educacion y Estado_Civil, algunas categorías presentan mayor significancia como era lo previsible (Campo_Educación-Humanidades,Campo_Educacion-Mercadeo,Campo_Educacion-Tecnicos,Estado_Civil-Soltero)
El modelo y significancia de las variables, confirman las hipótesis planteadas.

5.- Evaluación del poder predictivo del modelo

Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.
El Análisis ROC (Receiver Operating Characteristic - Característica Operativa del Receptor) permite evaluar el poder predictivo del modelo, mediante la observación de la sensibilidad frente a la especificidad de una prueba de clasificación. El Área bajo la Curva (AUC -Area Under Curve-) aporta un “valioso indicador estadístico que representa la probabilidad de que la predicción esté en el orden correcto cuando se observa una variable de prueba”.[1][2]

library(pROC)

predic_modrot=predict(modelo_rot,list(Ingreso_Mensual=rotacion$Ingreso_Mensual, Antiguedad=rotacion$ Antiguedad,Edad=rotacion$Edad,Equilibrio_Trabajo_Vida=rotacion$Equilibrio_Trabajo_Vida,Campo_Educacion=rotacion$Campo_Educacion, Estado_Civil=rotacion$Estado_Civil),type = "response")

ROC_modrot=roc(rotacion$Rotacion~predic_modrot, percent = T, ci=T)
ROC_modrot

## 
## Call:
## roc.formula(formula = rotacion$Rotacion ~ predic_modrot, percent = T,     ci = T)
## 
## Data: predic_modrot in 1233 controls (rotacion$Rotacion 0) < 237 cases (rotacion$Rotacion 1).
## Area under the curve: 71.12%
## 95% CI: 67.34%-74.9% (DeLong)

plot(ROC_modrot,print.auc=T,print.thres = "best",col="red"
         ,xlab = "Specificity", ylab = "Sensitivity")

Los resultados de la curva ROC indica que el modelo tiene un poder predictivo de aproximadamente el 71.1% de clasificar correctamente la Rotación para un determinado individuo con las variables predictorias elegidas.

6.- Predicción con el modelo

Predecir 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).

Para este ejercicio se establece el punto de corte en 0.5. A continuación, se plantean valores para el modelo, con el fin de predecir la probabilidad de Rotación para un empleado con determinadas características.

# EMPLEADO # 1
predict(modelo_rot,list(Ingreso_Mensual=2500,Antiguedad=2, Edad=23, Equilibrio_Trabajo_Vida=1,Campo_Educacion="Humanidades",Estado_Civil="Soltero"),type="response")

##         1 
## 0.7240859

# EMPLEADO # 2
predict(modelo_rot,list(Ingreso_Mensual=6000,Antiguedad=2, Edad=27, Equilibrio_Trabajo_Vida=1,Campo_Educacion="Salud",Estado_Civil="Soltero"),type="response")

##         1 
## 0.3705249

# EMPLEADO # 3
predict(modelo_rot,list(Ingreso_Mensual=2000,Antiguedad=2, Edad=20, Equilibrio_Trabajo_Vida=1,Campo_Educacion="Tecnicos",Estado_Civil="Soltero"),type="response")

##         1 
## 0.6514712

De acuerdo con los resultados obtenidos:
La probabilidad de rotación para el Empleado #1 es del 72.4%. Lo que implica que empleados con similares características, pueden ser objeto de atención y mejora de condiciones laborales
La probabilidad de rotación para el Empleado #2 es del 37%. Lo que implica que empleados con similares características, por el momento no requieren atención especial
La probabilidad de rotación para el Empleado #3 es del 65.14%. Lo que implica que empleados con similares características, pueden ser objeto de atención y mejora de condiciones laborales

7.- Conclusiones

En las conclusiones se discute sobre cual sería 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).
De acuerdo con los resultados del modelo de regresión planteado, a continuación se propone las siguientes recomendaciones para evitar la Rotación en la empresa:
1.- Distribuir las jornadas laborales, posiblemente mediante la implementación de teletrabajo, de tal modo que se mejore el Equilibrio entre Trabajo y Vida. 2.- Diseñar programas especiales (Torneos Deportivos, comisiones, visitas técnicas a empresas externas, etc) e incentivos laborales (Capacitación y formación) para los empleados jóvenes. 3.- Resaltar y promover la importancia del trabajo de empleados de las áreas Humanidades, Mercadeo y Técnicos. Proveer para ellos incentivos y propuestas encaminadas a mejorar el ambiente laboral.

B.- CASO RIESGO CREDITICIO (DEFAULT)

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.

# Cargue de los datos
creditos <- read_excel("Datos_Creditos.xlsx")
attach(creditos)

# Exploración de los indicadores estadísticos de los datos
summary(creditos)

##     DEFAULT       ANTIGUEDAD           EDAD        CUOTA_TOTAL     
##  Min.   :0.00   Min.   : 0.2548   Min.   :26.61   Min.   :    387  
##  1st Qu.:0.00   1st Qu.: 7.3767   1st Qu.:48.18   1st Qu.: 328516  
##  Median :0.00   Median :15.1192   Median :57.92   Median : 694460  
##  Mean   :0.05   Mean   :18.0353   Mean   :56.99   Mean   : 885206  
##  3rd Qu.:0.00   3rd Qu.:30.6637   3rd Qu.:66.19   3rd Qu.:1244126  
##  Max.   :1.00   Max.   :37.3178   Max.   :92.43   Max.   :6664588  
##     INGRESOS       
##  Min.   :  633825  
##  1st Qu.: 3583324  
##  Median : 5038962  
##  Mean   : 5366430  
##  3rd Qu.: 6844098  
##  Max.   :22197021

describe(creditos)

	vars	n	mean	sd	median	trimmed	mad	min	max	range	skew	kurtosis	se
DEFAULT	1	780	5.000000e-02	2.180848e-01	0.000000e+00	0.000000e+00	0.000000e+00	0.000000e+00	1.000000e+00	1.000000e+00	4.1215444	15.0063725	7.808700e-03
ANTIGUEDAD	2	780	1.803525e+01	1.193930e+01	1.511918e+01	1.763579e+01	1.478538e+01	2.547945e-01	3.731781e+01	3.706301e+01	0.2911285	-1.3953827	4.274956e-01
EDAD	3	780	5.698502e+01	1.250531e+01	5.791918e+01	5.720743e+01	1.357493e+01	2.661370e+01	9.243288e+01	6.581918e+01	-0.1201768	-0.5559846	4.477619e-01
CUOTA_TOTAL	4	780	8.852059e+05	7.402123e+05	6.944605e+05	7.881392e+05	6.726245e+05	3.870000e+02	6.664588e+06	6.664201e+06	1.5794364	5.1862069	2.650385e+04
INGRESOS	5	780	5.366430e+06	2.652186e+06	5.038962e+06	5.149139e+06	2.399040e+06	6.338250e+05	2.219702e+07	2.156320e+07	1.6428550	6.4598838	9.496349e+04

creditos$DEFAULT = as.factor(creditos$DEFAULT)

1.- Análisis Bivariado

La variable DEFAULT indica si una personas a la que se le ha otorgado un crédito presenta o ha presentado una mora en su obligación crediticia. Así pues, la variable DEFAULT adquiere los valores 1 (Mora) y 0 (Cumple).
A continuación se presenta el análisis bivariado de la variable DEFAULT versus las otras variables de la data

ANTIGUEDAD vs DEFAULT

gc1 = ggplot(creditos,aes(x=DEFAULT,y= ANTIGUEDAD,fill=DEFAULT))+geom_boxplot()+theme_bw()
ggplotly(gc1)

creditos$ANTIGUEDAD=cut(creditos$ANTIGUEDAD,breaks=c(0,5,10,15,20,25,30,35,40))
PlotXTabs2(data=creditos,x="ANTIGUEDAD",y="DEFAULT")

EDAD vs DEFAULT

gc1 = ggplot(creditos,aes(x=DEFAULT,y=EDAD,fill=DEFAULT))+geom_boxplot()+theme_bw()
ggplotly(gc1)

creditos$EDAD=cut(creditos$EDAD,breaks = c(0,10,20,30,40,50,60,70,80,90,100))
PlotXTabs2(data=creditos,x="EDAD",y="DEFAULT")

CUOTA TOTAL vs DEFAULT

gc1 = ggplot(creditos,aes(x=DEFAULT,y=CUOTA_TOTAL,fill=DEFAULT))+geom_boxplot()+theme_bw()
ggplotly(gc1)

INGRESOS vs DEFAULT

gc1 = ggplot(creditos,aes(x=DEFAULT,y=INGRESOS,fill=DEFAULT))+geom_boxplot()+theme_bw()
ggplotly(gc1)

De acuerdo con la exploración gráfica de las variables, todas se traslapan notablemente y no es muy evidente su comportamiento frente a la VARIABLE respuesta DEFAULT. Quizá se observa sutilmente que la variable CUOTA_TOTAL presenta mayor DEFAULT a medida que es mas grande la cuota. Tambien se observa que existen rangos de edad que no presentan DEFAULT (20-30 años y 80 a 100 años)

MATRIZ DE CORRELACIONES
Para complementar el análisis gráfico, a continuacion se plantea una matriz para observar el nivel de correlación entre las distintas variables predictoras y la variable respuesta.

library(GGally)

datos_subcred <- transform(creditos,ANTIGUEDAD=as.numeric(ANTIGUEDAD),EDAD=as.numeric(EDAD),CUOTA_TOTAL=as.numeric(CUOTA_TOTAL),INGRESOS=as.numeric(INGRESOS),DEFAULT=as.numeric(DEFAULT))

round(cor(x = datos_subcred, method = "pearson"), 3)

##             DEFAULT ANTIGUEDAD   EDAD CUOTA_TOTAL INGRESOS
## DEFAULT       1.000     -0.074 -0.035       0.097   -0.062
## ANTIGUEDAD   -0.074      1.000  0.733       0.270    0.476
## EDAD         -0.035      0.733  1.000       0.157    0.356
## CUOTA_TOTAL   0.097      0.270  0.157       1.000    0.361
## INGRESOS     -0.062      0.476  0.356       0.361    1.000

ggpairs(datos_subcred, lower = list(continuous = "smooth"),
        diag = list(continuous = "barDiag"), axisLabels = "none")

#correlacion<-cor(creditos)
#correlacion

Según el resultado obtenido, el coeficiente de correlación \(R\) tampoco es muy notable entre las variables. Sin embargo, es necesario considerar que la variable respuesta es de naturaleza categórica y el modelo de regresión es de tipo logístico, que estimará una probabilidad de clasificación frente a la variable respuesta.

2.- Estimación del Modelo de Regresión

A continuación se plantea el modelo de regresión generalizado para las variables analizadas anteriormente.

modelo_cred=glm(DEFAULT~ANTIGUEDAD+EDAD+CUOTA_TOTAL+INGRESOS,data=creditos,family = binomial(link="logit"))
summary(modelo_cred)

## 
## Call:
## glm(formula = DEFAULT ~ ANTIGUEDAD + EDAD + CUOTA_TOTAL + INGRESOS, 
##     family = binomial(link = "logit"), data = creditos)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -1.1266  -0.3624  -0.2645  -0.1585   3.1255  
## 
## Coefficients:
##                     Estimate Std. Error z value Pr(>|z|)    
## (Intercept)       -1.825e+01  2.649e+03  -0.007   0.9945    
## ANTIGUEDAD(5,10]  -3.011e-01  5.004e-01  -0.602   0.5473    
## ANTIGUEDAD(10,15] -7.550e-01  5.807e-01  -1.300   0.1935    
## ANTIGUEDAD(15,20] -1.781e+00  8.755e-01  -2.034   0.0420 *  
## ANTIGUEDAD(20,25] -1.190e+00  8.769e-01  -1.357   0.1749    
## ANTIGUEDAD(25,30] -1.636e+01  8.463e+02  -0.019   0.9846    
## ANTIGUEDAD(30,35] -1.190e+00  8.643e-01  -1.377   0.1686    
## ANTIGUEDAD(35,40] -1.019e+00  1.019e+00  -1.000   0.3172    
## EDAD(30,40]        1.592e+01  2.649e+03   0.006   0.9952    
## EDAD(40,50]        1.588e+01  2.649e+03   0.006   0.9952    
## EDAD(50,60]        1.673e+01  2.649e+03   0.006   0.9950    
## EDAD(60,70]        1.622e+01  2.649e+03   0.006   0.9951    
## EDAD(70,80]        1.668e+01  2.649e+03   0.006   0.9950    
## EDAD(80,90]        1.400e+00  3.103e+03   0.000   0.9996    
## EDAD(90,100]       7.642e-01  5.304e+03   0.000   0.9999    
## CUOTA_TOTAL        1.015e-06  2.547e-07   3.986 6.71e-05 ***
## INGRESOS          -2.603e-07  1.077e-07  -2.417   0.0157 *  
## ---
## 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: 275.18  on 763  degrees of freedom
## AIC: 309.18
## 
## Number of Fisher Scoring iterations: 17

De acuerdo con los resultados, las variables que tienen significancia en el modelos son ANTIGÜEDAD, CUOTA TOTAL E INGRESOS. La EDAD no tiene peso significativo en el modelo.
Asi pues a continuacion se plantea un modelo mejorado

mod_cred_v = step(modelo_cred)

## Start:  AIC=309.18
## DEFAULT ~ ANTIGUEDAD + EDAD + CUOTA_TOTAL + INGRESOS
## 
##               Df Deviance    AIC
## - EDAD         7   281.45 301.45
## - ANTIGUEDAD   7   286.16 306.16
## <none>             275.18 309.18
## - INGRESOS     1   281.98 313.98
## - CUOTA_TOTAL  1   291.49 323.49
## 
## Step:  AIC=301.45
## DEFAULT ~ ANTIGUEDAD + CUOTA_TOTAL + INGRESOS
## 
##               Df Deviance    AIC
## - ANTIGUEDAD   7   291.37 297.37
## <none>             281.45 301.45
## - INGRESOS     1   287.38 305.38
## - CUOTA_TOTAL  1   297.94 315.94
## 
## Step:  AIC=297.37
## DEFAULT ~ CUOTA_TOTAL + INGRESOS
## 
##               Df Deviance    AIC
## <none>             291.37 297.37
## - INGRESOS     1   303.62 307.62
## - CUOTA_TOTAL  1   306.24 310.24

De acuerdo con los resultados el modelo mejorado, incorpora los predictores INGRESOS y CUOTA TOTAL como los que tiene realmente peso significativo en el comportamiento de la variable respuesta DEFAULT.
Así pues, el modelo mejorado queda del siguiente modo:

modelo_cred_1=glm(DEFAULT~CUOTA_TOTAL+INGRESOS,data=creditos,family = binomial(link="logit"))
summary(modelo_cred_1)

## 
## Call:
## glm(formula = DEFAULT ~ CUOTA_TOTAL + INGRESOS, family = binomial(link = "logit"), 
##     data = creditos)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -0.6901  -0.3648  -0.2928  -0.2113   2.9753  
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -2.353e+00  3.966e-01  -5.933 2.97e-09 ***
## CUOTA_TOTAL  9.341e-07  2.404e-07   3.885 0.000102 ***
## INGRESOS    -3.134e-07  1.005e-07  -3.119 0.001817 ** 
## ---
## 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: 291.37  on 777  degrees of freedom
## AIC: 297.37
## 
## Number of Fisher Scoring iterations: 6

3.- Evaluación del poder predictivo (ROC y AUC)

A continuación se evalua el poder predictivo mediante la estimación de la Curva ROC y el área bajo la curva (AUC).

predic_modcred=predict(modelo_cred_1,list(CUOTA_TOTAL=creditos$CUOTA_TOTAL, INGRESOS=creditos$INGRESOS),type = "response")

ROC_modcred=roc(creditos$DEFAULT~predic_modcred, percent = T, ci=T)
ROC_modcred

## 
## Call:
## roc.formula(formula = creditos$DEFAULT ~ predic_modcred, percent = T,     ci = T)
## 
## Data: predic_modcred in 741 controls (creditos$DEFAULT 0) < 39 cases (creditos$DEFAULT 1).
## Area under the curve: 67.91%
## 95% CI: 58.77%-77.05% (DeLong)

plot(ROC_modcred,print.auc=T,print.thres = "best",col="red"
         ,xlab = "Specificity", ylab = "Sensitivity")

De acuerdo con los resultados obtenidos con el análisis ROC, el modelo tiene un poder predictivo de aproximadamente el 67.9% de clasificar correctamente el DEFAULT para un cliente, con las variables predictoras elegidas.

4.- Predicción con el modelo

Para este ejercicio se establece el punto de corte en 0.2, como un valor que vamos a suponer que el Banco asume como máximo riesgo razonable; es decir que a un cliente con una probabilidad superior al 20% de entrar en DEFAULT en algún momento, NO se le otorga un crédito. A continuación, se plantean valores para el modelo:

# CLIENTE # 1
predict(modelo_cred_1,list(CUOTA_TOTAL=2300000, INGRESOS=4500000),type="response")

##        1 
## 0.165904

# CLIENTE # 2
predict(modelo_cred_1,list(CUOTA_TOTAL=2700000, INGRESOS=4000000),type="response")

##         1 
## 0.2526439

# CLIENTE # 3
predict(modelo_cred_1,list(CUOTA_TOTAL=900000, INGRESOS=1600000),type="response")

##         1 
## 0.1177635

Así pues, de acuerdo con los resultados obtenidos, al CLIENTE #2 no es recomendable otorgarle un crédito que tenga una CUOTA TOTAL = 2700000.

BIBLIOGRAFIA

[1] IBM. 2021. “Análisis ROC”. Recurso disponible en: https://www.ibm.com/docs/es/spss-statistics/beta?topic=features-roc-analysis. Consultado en octubre de 2022.
[2] Hospital Universitario Ramón y Cajal.Comunidad de Madrid. 2022. “Curvas ROC”. Recurso disponible en: http://www.hrc.es/bioest/roc_1.html. Consultado en octubre de 2022.