Regresion Logistica Rotación
Wilfredo Gomez
2022-10-02
library(readxl)
library(ggplot2)
library(CGPfunctions)
library(sqldf)
library(pROC)
library(vtable)
library(readxl)
library(plotly)
library(caret)
library(glmnet)
library(MASS)
library(car)
library(pROC)
library(vcd)
library(PerformanceAnalytics)PUNTO 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).
Hipotesis 1: Se espera que la gente con menor Antigüedad rote en mayor proporcion ya que a medida que adquieren experiencia buscan nuevas oportunidades.
Hipotesis 2: Se espera que a mayor edad se presente menor Rotación ya que las personas maduras requieren mayor estabilidad.
Hipotesis 3: Se espera que exista una mayor incidencia de Rotación en personas con baja satisfacción laboral
Hipotesis 4: Se espera que la gente con menor Ingreso Mensual rote en mayor proporcion ya que pueden buscar mejor asignaciones en otros lugares.
Hipotesis 5: Se espera que exista una diferenciacion de Rotación en empleados segun su estado civil, donde personas casadas que cuentan con familia tienden a tener mayor estabilidad.
Hipotesis 6: Se espera que exista una mayor incidencia de Rotación en empleados con horas extras, ya que esto implica que posiblemente no estan acordes con su salario y tiene que buscar mas ingresos finalmente se termina produciendo una carga excesiva de trabajo.
PUNTO 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.
datos = read_excel("C:/Users/Wilfredo Gomez/iCloudDrive/Downloads/Maestria/Segundo Semestre/Metodos Estadistica/datos_Rotación (1).xlsx")
head(datos)## # A tibble: 6 x 24
## Rotación Edad Viaje de~1 Depar~2 Dista~3 Educa~4 Campo~5 Satis~6 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 1: `Viaje de Negocios`, 2: Departamento, ...summary(datos)## Rotación 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_Educación 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 Antigüedad Antigüedad_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.000ggplot(datos,aes(x=Rotación))+geom_bar()+theme_bw()
st( data.frame( datos$Rotación ))| Variable | N | Percent |
|---|---|---|
| datos.Rotación | 1470 | |
| … No | 1233 | 83.9% |
| … Si | 237 | 16.1% |
ggplot(datos,aes(x=Edad))+geom_histogram()+theme_bw()
st( data.frame( datos$Edad ))| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|
| datos.Edad | 1470 | 36.924 | 9.135 | 18 | 30 | 43 | 60 |
ggplot(datos,aes(x=Ingreso_Mensual))+geom_histogram()+theme_bw()
st( data.frame( datos$Ingreso_Mensual ))| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|
| datos.Ingreso_Mensual | 1470 | 6502.931 | 4707.957 | 1009 | 2911 | 8379 | 19999 |
#Grafico Antigüedad
ggplot(datos,aes(x=Antigüedad))+geom_histogram()+theme_bw()
st( data.frame( datos$Antigüedad ))| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|
| datos.Antigüedad | 1470 | 7.008 | 6.127 | 0 | 3 | 9 | 40 |
#Grafico Genero
ggplot(datos,aes(x=Satisfación_Laboral))+geom_bar()+theme_bw()
st( data.frame( datos$Satisfación_Laboral ))| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|
| datos.Satisfación_Laboral | 1470 | 2.729 | 1.103 | 1 | 2 | 4 | 4 |
ggplot(datos,aes(x=Horas_Extra))+geom_bar()+theme_bw()
st( data.frame( datos$Horas_Extra ))| Variable | N | Percent |
|---|---|---|
| datos.Horas_Extra | 1470 | |
| … No | 1054 | 71.7% |
| … Si | 416 | 28.3% |
ggplot(datos,aes(x=Estado_Civil))+geom_bar()+theme_bw()
st( data.frame( datos$Horas_Extra ))| Variable | N | Percent |
|---|---|---|
| datos.Horas_Extra | 1470 | |
| … No | 1054 | 71.7% |
| … Si | 416 | 28.3% |
Se pueden observar algunos comportamientos relacionados a las variables seleccionadas, inicialmente son mas los trabajadores que no realizaron rotación, hay una mayor presencia de trabajadores casados, menos trabajadores realizaron horas extras, existe una población en general mas satisfecha laboralmente, la mayor concentración de antiguedad se encuentra entre los 0 y 10 años, y la mayor concentración de ingreso se encuentra entre los 0 y 5000
PUNTO 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.
boxplot(datos$Edad~datos$Rotación,
xlab = 'Rotación',
ylab = 'Edad',
main= 'Rotación vs Edad',
col= 'green')
Rotasi=datos[datos$Rotación == "Si",]
Rotano=datos[datos$Rotación == "No",]
st( data.frame( Rotasi$Edad ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotasi.Edad | 237 | 33.608 | 9.689 | 18 | 28 | 32 | 39 | 58 |
st( data.frame( Rotano$Edad ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotano.Edad | 1233 | 37.561 | 8.888 | 18 | 31 | 36 | 43 | 60 |
Se puede observar que hay alineación con la hipotesis al ver que la media mas baja para los que rotaron, es decir se presenta en personas mas jovenes
boxplot(datos$Antigüedad~datos$Rotación,
xlab = 'Rotación',
ylab = 'Antigüedad',
main= 'Rotación vs Antigüedad',
col= 'green')
Rotasi=datos[datos$Rotación == "Si",]
Rotano=datos[datos$Rotación == "No",]
st( data.frame( Rotasi$Antigüedad ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotasi.Antigüedad | 237 | 5.131 | 5.95 | 0 | 1 | 3 | 7 | 40 |
st( data.frame( Rotano$Antigüedad ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotano.Antigüedad | 1233 | 7.369 | 6.096 | 0 | 3 | 6 | 10 | 37 |
Se observa alineación con la hipótesis que indica que las personas con menor antiguedad tienden a tener mayor rotación, en la grafica se observa una media alrededor de 5 años para los que rotaron y superior a 7 para los que no
boxplot(datos$Ingreso_Mensual~datos$Rotación,
xlab = 'Rotación',
ylab = 'Ingreso Mensual',
main= 'Rotación vs Ingreso Mensual',
col= 'green')
Rotasi=datos[datos$Rotación == "Si",]
Rotano=datos[datos$Rotación == "No",]
st( data.frame( Rotasi$Ingreso_Mensual ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotasi.Ingreso_Mensual | 237 | 4787.093 | 3640.21 | 1009 | 2373 | 3202 | 5916 | 19859 |
st( data.frame( Rotano$Ingreso_Mensual ), add.median = TRUE)| Variable | N | Mean | Std. Dev. | Min | Pctl. 25 | Pctl. 50 | Pctl. 75 | Max |
|---|---|---|---|---|---|---|---|---|
| Rotano.Ingreso_Mensual | 1233 | 6832.74 | 4818.208 | 1051 | 3211 | 5204 | 8834 | 19999 |
Se observa alineación con la hipótesis que indica que las personas con menor ingreso mensual tienden a tener mayor rotación, se observa una media inferior de 4800 para los que rotaron y superior a 6800 para aquellos que no.
PlotXTabs(datos, Rotación, Satisfación_Laboral, "percent")
tabla=prop.table(table(data.frame(datos$Satisfación_Laboral, datos$Horas_Extra)),2)
tabla## datos.Horas_Extra
## datos.Satisfación_Laboral No Si
## 1 0.1944972 0.2019231
## 2 0.2001898 0.1658654
## 3 0.3045541 0.2908654
## 4 0.3007590 0.3413462Se observa alineación con la hipótesis que indica que las personas con menor Satisfacción laboral tienden a rotar mas, se puede ver una relación directa pero inversa que las categorias mas bajas de satisfacción tienden a tener las proporciones mas altas de rotación
PlotXTabs(datos, Rotación, Horas_Extra, "percent")
tabla=prop.table(table(data.frame(datos$Rotación, datos$Horas_Extra)),2)
tabla## datos.Horas_Extra
## datos.Rotación No Si
## No 0.8956357 0.6947115
## Si 0.1043643 0.3052885Se observa alineación con la hipótesis que indica que las personas con horas extras tienen mayor proporción de personas que tuvieron rotación cercana a 3 veces es la relación entre las que tenian horas extras y las que no.
PlotXTabs(datos, Rotación, Estado_Civil, "percent")
tabla=prop.table(table(data.frame(datos$Rotación, datos$Estado_Civil)),2)
tabla## datos.Estado_Civil
## datos.Rotación Casado Divorciado Soltero
## No 0.8751857 0.8990826 0.7446809
## Si 0.1248143 0.1009174 0.2553191Se observa alineación con la hipótesis que indica que las personas solteras tienden a tener mayor rotación, incluso se observa que es el doble de la proporción de personas casadas y un porcentaje aun mayor frente a las personas divorciadas
PUNTO 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.
datos$Rotación[datos$Rotación=="Si"] = 1
datos$Rotación[datos$Rotación=="No"] = 0
head(datos)## # A tibble: 6 x 24
## Rotación Edad Viaje de~1 Depar~2 Dista~3 Educa~4 Campo~5 Satis~6 Genero Cargo
## <chr> <dbl> <chr> <chr> <dbl> <dbl> <chr> <dbl> <chr> <chr>
## 1 1 41 Raramente Ventas 1 2 Cienci~ 2 F Ejec~
## 2 0 49 Frecuente~ IyD 8 1 Cienci~ 3 M Inve~
## 3 1 37 Raramente IyD 2 2 Otra 4 M Tecn~
## 4 0 33 Frecuente~ IyD 3 4 Cienci~ 4 F Inve~
## 5 0 27 Raramente IyD 2 1 Salud 1 M Tecn~
## 6 0 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 1: `Viaje de Negocios`, 2: Departamento, ...datos$Rotación=as.factor(datos$Rotación)
mod_glm1 <- glm(Rotación ~ Edad + Antigüedad + Ingreso_Mensual + Satisfación_Laboral +
Horas_Extra + Estado_Civil,
data = datos, family = "binomial")
summary(mod_glm1)##
## Call:
## glm(formula = Rotación ~ Edad + Antigüedad + Ingreso_Mensual +
## Satisfación_Laboral + Horas_Extra + Estado_Civil, family = "binomial",
## data = datos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.7131 -0.5803 -0.4068 -0.2492 3.3021
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 1.410e-02 3.895e-01 0.036 0.97113
## Edad -2.795e-02 1.007e-02 -2.775 0.00552 **
## Antigüedad -3.651e-02 1.843e-02 -1.981 0.04764 *
## Ingreso_Mensual -7.863e-05 2.658e-05 -2.958 0.00309 **
## Satisfación_Laboral -3.200e-01 6.904e-02 -4.635 3.57e-06 ***
## Horas_ExtraSi 1.511e+00 1.583e-01 9.543 < 2e-16 ***
## Estado_CivilDivorciado -3.260e-01 2.292e-01 -1.422 0.15492
## Estado_CivilSoltero 8.474e-01 1.706e-01 4.966 6.83e-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: 1090.9 on 1462 degrees of freedom
## AIC: 1106.9
##
## Number of Fisher Scoring iterations: 5En general la mayoria de covariables empleadas en el modelo se puede indicar que tienen significancias interesantes, siendo mas destacadas las significancias de las covariables como Satisfacción Laboral, Horas extras, y Estado Civil, todas variables categoricas, posterior significancias medias podemos encontrar covariables como el Ingreso mensual y la edad y finalemente una significancia baja a una variable cuantitativa como es la Antiguedad. El modelo en general es correspondiente a los análisis presentados anteriormente.
PUNTO 5
Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.
Rotación_prob <- predict(mod_glm1, type = "response")
ROC <- roc(datos$Rotación, Rotación_prob)## Setting levels: control = 0, case = 1## Setting direction: controls < casesplot(ROC, col = "red")
auc(ROC)## Area under the curve: 0.7747Al observar el grafico de AUC, se puede observar un modelo con area bajo la curva es aceptable y con caracterisiticas minimas para su utilización en un proceso predictivo.
PUNTO 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).
predict(mod_glm1,list(
Edad=25,
Antigüedad=1,
Ingreso_Mensual=1500,
Satisfación_Laboral=1,
Horas_Extra="Si",
Estado_Civil="Soltero"),
interval="confidence",
level=0.95,
type = "response")## 1
## 0.7683996Se estructura un escenario de prueba correspondiente a las hipotesis planteadas, utilizando una persona joven, con poca antiguedad, con un ingreso mesual bajo, con muy mala satisfacción laboral, que ha recibido horas extras y de estado civil soltero, bajo esta configuración se obtiene como resultado una probabilidad de rotación superior al 76% que es consecuente con los analisis realizados anteriormente. Se estima que una persona con un probabilidad superior al 50% requeriria un seguimiento preliminar por parte del area de talento humano, sin embargo personas con una probabilidad del 75% debería priorizarse para una intervención en donde se puedan establecer como riesgos importantes las variables de mayor significancia.
PUNTO 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).
Se plantean estrategias prioritarias la inclusión de estimulos que puedan mejorar la satisfacción laboral, mezclando incentivos economicos por metas u objetivos y complementando con estimulos emocionales, de igual manera para reforzar la creación de un ambiente laboral adecuado se plantea el desarrollo de actividades que faciliten la interacción entre los colaboradores, quizas enfatizando espacios en el que los solteros puedan interacturar y puedan encontrar en la compañia un lugar para compartir con otras personas, favoreciendo su fidelización con la compañia. Por otra parte se plantean estrategias que equilibren las asignaciones de horas extras acorde a las cargas laborales y a otros factores de riesgo presentes en algunos trabajadores acorde a los análisis realizados.
PARTE 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.
DatosCreditos <- read_excel("C:/Users/Wilfredo Gomez/iCloudDrive/Downloads/Maestria/Segundo Semestre/Metodos Estadistica/Datos_Creditos (1).xlsx")
View(DatosCreditos)
summary(DatosCreditos)## DEFAULT ANTIUEDAD 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. :22197021df<-data.frame(DatosCreditos$ANTIUEDAD ,DatosCreditos$EDAD,DatosCreditos$CUOTA_TOTAL,DatosCreditos$INGRESOS )
chart.Correlation(df)
Se plantea una validación de correlaciones entre variables, donde se destaca la correlación de las variables Edad y Antiguedad
nrow(DatosCreditos)## [1] 780ntrain <- nrow(DatosCreditos)*0.8
ntest <- nrow(DatosCreditos)*0.2
c(ntrain,ntest)## [1] 624 156- Se establecen los conjuntos de entrenamiento y de prueba
set.seed(740)
index_train<-sample(1:nrow(DatosCreditos),size = ntrain)
train<-DatosCreditos[index_train,]
test<-DatosCreditos[-index_train,]
summary(train)## DEFAULT ANTIUEDAD EDAD CUOTA_TOTAL
## Min. :0.00000 Min. : 0.2548 Min. :26.61 Min. : 387
## 1st Qu.:0.00000 1st Qu.: 7.4884 1st Qu.:47.65 1st Qu.: 329083
## Median :0.00000 Median :14.8616 Median :57.05 Median : 658548
## Mean :0.04968 Mean :17.8888 Mean :56.58 Mean : 874371
## 3rd Qu.:0.00000 3rd Qu.:30.4431 3rd Qu.:65.82 3rd Qu.:1233921
## Max. :1.00000 Max. :37.3178 Max. :92.43 Max. :6664588
## INGRESOS
## Min. : 701758
## 1st Qu.: 3494622
## Median : 4964190
## Mean : 5317859
## 3rd Qu.: 6817749
## Max. :22197021summary(test)## DEFAULT ANTIUEDAD EDAD CUOTA_TOTAL
## Min. :0.00000 Min. : 0.5041 Min. :28.97 Min. : 24115
## 1st Qu.:0.00000 1st Qu.: 6.8897 1st Qu.:49.80 1st Qu.: 315632
## Median :0.00000 Median :16.6069 Median :59.22 Median : 827354
## Mean :0.05128 Mean :18.6212 Mean :58.62 Mean : 928545
## 3rd Qu.:0.00000 3rd Qu.:31.5562 3rd Qu.:68.52 3rd Qu.:1363527
## Max. :1.00000 Max. :37.3178 Max. :91.64 Max. :3788917
## INGRESOS
## Min. : 633825
## 1st Qu.: 3782509
## Median : 5213904
## Mean : 5560716
## 3rd Qu.: 6902757
## Max. :19548379- Planteamiento del Modelo Entrenamiento
modtrain <- glm(DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS,
data = train, family = "binomial")
summary(modtrain)##
## Call:
## glm(formula = DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS,
## family = "binomial", data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.7367 -0.3624 -0.2963 -0.2186 2.9830
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.890e+00 1.058e+00 -2.730 0.006328 **
## ANTIUEDAD -2.555e-02 2.635e-02 -0.970 0.332199
## EDAD 1.116e-02 2.249e-02 0.496 0.619871
## CUOTA_TOTAL 8.541e-07 2.583e-07 3.307 0.000944 ***
## INGRESOS -2.258e-07 1.142e-07 -1.977 0.048017 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 246.57 on 623 degrees of freedom
## Residual deviance: 233.82 on 619 degrees of freedom
## AIC: 243.82
##
## Number of Fisher Scoring iterations: 6Se observan que las covariables del modelo con mayor significancia corresponden a CUOTA_TOTAL posterior se encuentra con una significacia baja INGRESOS, el resto de covariables no le aportan al modelo reforzando lo visto con el análisis de correlación
- Mejora del Modelo Entrenamiento
step_train<- stepAIC(modtrain, direction="both")## Start: AIC=243.82
## DEFAULT ~ ANTIUEDAD + EDAD + CUOTA_TOTAL + INGRESOS
##
## Df Deviance AIC
## - EDAD 1 234.06 242.06
## - ANTIUEDAD 1 234.74 242.74
## <none> 233.82 243.82
## - INGRESOS 1 238.32 246.32
## - CUOTA_TOTAL 1 244.34 252.34
##
## Step: AIC=242.06
## DEFAULT ~ ANTIUEDAD + CUOTA_TOTAL + INGRESOS
##
## Df Deviance AIC
## - ANTIUEDAD 1 234.81 240.81
## <none> 234.06 242.06
## + EDAD 1 233.82 243.82
## - INGRESOS 1 238.44 244.44
## - CUOTA_TOTAL 1 244.40 250.40
##
## Step: AIC=240.81
## DEFAULT ~ CUOTA_TOTAL + INGRESOS
##
## Df Deviance AIC
## <none> 234.81 240.81
## + ANTIUEDAD 1 234.06 242.06
## + EDAD 1 234.74 242.74
## - INGRESOS 1 241.90 245.90
## - CUOTA_TOTAL 1 244.69 248.69- Validación predicción Modelo Entrenamiento ROC
defaultprobT <- predict(step_train, type = "response", newdata = test)
ROC <- roc(test$DEFAULT, defaultprobT)
plot(ROC, col = "red")
auc(ROC)## Area under the curve: 0.7745Se obtiene un modelo consistente, se hace un mejoramiento con la reducción de variables por medio de step, obteniendo un AUC de 77% con una capacidad predictiva aceptable.
predicciones <- ifelse(test = step_train$fitted.values > 0.04, yes = 1, no = 0)
matriz <- table(step_train$model$DEFAULT, predicciones,
dnn = c("observaciones", "predicciones"))
matriz## predicciones
## observaciones 0 1
## 0 242 351
## 1 9 22summary(step_train)##
## Call:
## glm(formula = DEFAULT ~ CUOTA_TOTAL + INGRESOS, family = "binomial",
## data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.6720 -0.3578 -0.2964 -0.2285 2.8994
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.488e+00 4.425e-01 -5.622 1.89e-08 ***
## CUOTA_TOTAL 8.197e-07 2.552e-07 3.212 0.00132 **
## INGRESOS -2.602e-07 1.070e-07 -2.431 0.01506 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 246.57 on 623 degrees of freedom
## Residual deviance: 234.81 on 621 degrees of freedom
## AIC: 240.81
##
## Number of Fisher Scoring iterations: 6Se observan que las covariables del modelo mejorado seleccionadas como CUOTA_TOTAL e INGRESOS presentan alta significancia evidenciado un modelo con buena capacidad descriptiva con una mínima cantidad de variables
- Distribución Probabilidades
hist(step_train$fitted.values, main = "Distribucion de las probabilidades calculadas",
xlab = "Probabilidad")
Se observa que la mayor concetración de probabilidades calculadas se encuentra ente 0 y 0,1
- Validación Exactitud
n = sum(matriz)
nc = nrow(matriz)
diag = diag(matriz)
rowsums = apply(matriz, 1, sum)
colsums = apply(matriz, 2, sum)
p = rowsums / n
q = colsums / n
accuracy = sum(diag) / n
accuracy ## [1] 0.4230769Se observa una baja exactitud aún del solo 52%, por lo tanto se recomienda seguir realizando ajustes al mismo