Actividad 3
Oscar Muñoz - Alejandro Valencia
2023-04-01
Importacion del set de datos
#install.packages("devtools") # solo la primera vez
devtools::install_github("dgonxalex80/paqueteMOD", force =TRUE)## WARNING: Rtools is required to build R packages, but is not currently installed.
##
## Please download and install Rtools 4.2 from https://cran.r-project.org/bin/windows/Rtools/ or https://www.r-project.org/nosvn/winutf8/ucrt3/.## Downloading GitHub repo dgonxalex80/paqueteMOD@HEAD## cli (3.6.0 -> 3.6.1) [CRAN]
## fs (1.6.0 -> 1.6.1) [CRAN]
## cachem (1.0.6 -> 1.0.7) [CRAN]
## fastmap (1.1.0 -> 1.1.1) [CRAN]
## htmltools (0.5.4 -> 0.5.5) [CRAN]
## httpuv (1.6.8 -> 1.6.9) [CRAN]
## xfun (0.36 -> 0.38 ) [CRAN]## Installing 7 packages: cli, fs, cachem, fastmap, htmltools, httpuv, xfun## Installing packages into 'C:/Users/oscar/AppData/Local/R/win-library/4.2'
## (as 'lib' is unspecified)## package 'cli' successfully unpacked and MD5 sums checked
## package 'fs' successfully unpacked and MD5 sums checked
## package 'cachem' successfully unpacked and MD5 sums checked
## package 'fastmap' successfully unpacked and MD5 sums checked
## package 'htmltools' successfully unpacked and MD5 sums checked
## package 'httpuv' successfully unpacked and MD5 sums checked
## package 'xfun' successfully unpacked and MD5 sums checked
##
## The downloaded binary packages are in
## C:\Users\oscar\AppData\Local\Temp\RtmpIr5PBU\downloaded_packages
## ── R CMD build ─────────────────────────────────────────────────────────────────## WARNING: Rtools is required to build R packages, but is not currently installed.
##
## Please download and install Rtools 4.2 from https://cran.r-project.org/bin/windows/Rtools/ or https://www.r-project.org/nosvn/winutf8/ucrt3/.##
checking for file 'C:\Users\oscar\AppData\Local\Temp\RtmpIr5PBU\remotes1774ce4a64bb\dgonxalex80-paqueteMOD-2949bb5/DESCRIPTION' ...
checking for file 'C:\Users\oscar\AppData\Local\Temp\RtmpIr5PBU\remotes1774ce4a64bb\dgonxalex80-paqueteMOD-2949bb5/DESCRIPTION' ...
✔ checking for file 'C:\Users\oscar\AppData\Local\Temp\RtmpIr5PBU\remotes1774ce4a64bb\dgonxalex80-paqueteMOD-2949bb5/DESCRIPTION'
##
─ preparing 'paqueteMOD':
## checking DESCRIPTION meta-information ...
✔ checking DESCRIPTION meta-information
##
─ checking for LF line-endings in source and make files and shell scripts
##
─ checking for empty or unneeded directories
##
─ building 'paqueteMOD_0.0.0.1.tar.gz'
##
## ## Installing package into 'C:/Users/oscar/AppData/Local/R/win-library/4.2'
## (as 'lib' is unspecified)library(paqueteMOD)
data("rotacion")
data("creditos")###Librerias necesarias
#install.packages("PlotXTabs2")
#install.packages("ROCR")
library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(ggplot2)
library(ggpubr)
library(table1)##
## Attaching package: 'table1'## The following objects are masked from 'package:base':
##
## units, units<-library(CGPfunctions)
library(knitr)
library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats 1.0.0 ✔ stringr 1.5.0
## ✔ lubridate 1.9.2 ✔ tibble 3.2.1
## ✔ purrr 1.0.1 ✔ tidyr 1.3.0
## ✔ readr 2.1.4## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the ]8;;http://conflicted.r-lib.org/conflicted package]8;; to force all conflicts to become errorsProblema 1 :
Rotación de cargo
Punto 1:
Seleccione 3 variables categóricas (distintas de rotación) y 3 variables cuantitativas, que se consideren estén relacionadas con la rotación.Nota: Debes justificar porque estas variables están relacionadas y que tipo de relación se espera entre ellas (Hipótesis).
summary(rotacion)## 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.000Variables Categorias:
Cargo: Variable categorica Ordinal
Estado_Civil: Variable Categorica Nominal
Viaje de Negocios: Variable Categorica Nominal
Hipotesis Variables Categoricas
Cargo: Las personas con cargos directivos o gerenciales podrían tener menor rotación en sus trabajos por que la oferta laboral en este campo es más baja que en los de las áreas técnicas, comerciales y de recursos humanos.
Estado_Civil: Las personas que están casadas o divorciadas podrían buscar una mayor estabilidad y continuidad en sus trabajos frente a las personas solteros.
Viaje de Negocios: Las personas que realizan viajes de negocios frecuentemente podrían tener una mayor deserción puesto que tienen que salir de su residencia y cambiar sus hábitos.
Variables Cuantitativas
Edad: Variable cuantitativa discreta
Porcentaje_aumento_salarial: Variable Cuantitativa discreta
Antigüedad_Cargo: Variable Cuantitativa discreta
Hipotesis Variables Cuantitativas
Edad: Las personas con mayor edad podrían tener menor rotación por que buscarían conservar sus empleos puesto que muchas empresas tienen como criterio de exclusión la edad de los aspirantes.
Porcentaje_aumento_salarial: Las personas con mayores porcentajes de aumento salarial van a sentir mayor satisfacción y valoración de su trabajo por lo que deberían tener mayor continuidad, frente a empleados con menores porcentajes de bonificación.
Antigüedad_Cargo: Se espera que las personas con mayor antigüedad en el cargo deberían tener menor rotación dado que cuentan con mayor experiencia en el puesto y conocen bien sus funciones, frente a personas que comienzan sus labores o llevan pocos años.
Punto 2 :
Realiza un análisis univariado (caracterización) de la información contenida en la base de datos rotacion. Nota: Los indicadores o gráficos se usan dependiendo del tipo de variable (cuantitativas o cualitativas). Incluir interpretaciones de la variable rotacion.
Cargo
De acuerdo con la gráfica se identifica que los cargos de Ejecutivo de ventas, Investigador científico y Técnico de laboratorio cuentan con la mayor cantidad de representantes con un total de 877 empleados equivalente al 59.7% del personal de la compañía.
df1 <- rotacion %>%
group_by(Cargo) %>%
summarise(Total=n()) %>%
dplyr::mutate(Porcentaje = round(Total/sum(Total)*100, 1))
ggplot(df1, aes(x=`Cargo`, y=Total,fill=Cargo) ) +
theme(axis.text.x = element_blank(),axis.ticks.x = element_blank())+
geom_bar(width = 0.9, stat="identity", position = position_dodge())+
geom_text(aes(label=paste0(Total," ", "", "(", Porcentaje, "%",")")),
vjust=-0.9,
color="black",
hjust=0.5,
position = position_dodge(0.9),
angle=0,
size=3.0
)
A continuación, revisamos el comportamiento de esta variable frente a la
rotación de personal:
y <- table1::table1(~ Cargo | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Cargo | |||
| Director_Investigación | 78 (6.3%) | 2 (0.8%) | 80 (5.4%) |
| Director_Manofactura | 135 (10.9%) | 10 (4.2%) | 145 (9.9%) |
| Ejecutivo_Ventas | 269 (21.8%) | 57 (24.1%) | 326 (22.2%) |
| Gerente | 97 (7.9%) | 5 (2.1%) | 102 (6.9%) |
| Investigador_Cientifico | 245 (19.9%) | 47 (19.8%) | 292 (19.9%) |
| Recursos_Humanos | 40 (3.2%) | 12 (5.1%) | 52 (3.5%) |
| Representante_Salud | 122 (9.9%) | 9 (3.8%) | 131 (8.9%) |
| Representante_Ventas | 50 (4.1%) | 33 (13.9%) | 83 (5.6%) |
| Tecnico_Laboratorio | 197 (16.0%) | 62 (26.2%) | 259 (17.6%) |
De esta forma se puede identificar que los cargos con mayor demanda son los que cuentan a su vez con mayor rotación de personal, esto se evidencia en la diferencia porcentual de la columna de rotación que deben tener los directores de investigación frente a los técnicos de laboratorio, con una diferencia mayor al 25%.
Estado_Civil
Podemos ver que la población de la empresa se distribuye mayoritariamente en personas casadas siendo un 45.8%, seguidos por los solteros con un 32% y por ultimo los divorciados con 22.2%.
df2 <- rotacion %>%
group_by(Estado_Civil) %>%
summarise(Total=n()) %>%
dplyr::mutate(Porcentaje = round(Total/sum(Total)*100, 1))
ggplot(df2, aes(x=`Estado_Civil`, y=Total,fill=Estado_Civil) ) +
theme(axis.text.x = element_blank(),axis.ticks.x = element_blank())+
geom_bar(width = 0.9, stat="identity", position = position_dodge())+
geom_text(aes(label=paste0(Total," ", "", "(", Porcentaje, "%",")")),
vjust=2,
color="black",
hjust=0.5,
position = position_dodge(0.9),
angle=0,
size=4.0
)
A continuación, revisamos el comportamiento de esta variable frente a la
rotación de personal:
y <- table1::table1(~ Estado_Civil | 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%) |
De las personas casadas, divorciadas y solteras 237 se han retirado de manera voluntaria de la compañía, siendo esto un 16.1% de las 1470 personas. Además, el grupo que tiene mayor rotación es el de solteros con 120 personas, representando un 50.6% de las personas que han abandonado.
Viaje de Negocios
Se puede inferir que una tendencia dentro de la empresa es que la mayoría de los cargos no realizan viajes de negocios como sus actividades frecuentes, esto se evidencia en que solo el 18.8% del total de empleados se cataloga como un usuario frecuente de viaje de negocios.
df3 <- rotacion %>%
group_by(`Viaje de Negocios`) %>%
summarise(Total=n()) %>%
dplyr::mutate(Porcentaje = round(Total/sum(Total)*100, 1))
ggplot(df3, aes(x=`Viaje de Negocios`, y=Total,fill=`Viaje de Negocios`) ) +
theme(axis.text.x = element_blank(),axis.ticks.x = element_blank())+
geom_bar(width = 0.9, stat="identity", position = position_dodge())+
geom_text(aes(label=paste0(Total," ", "", "(", Porcentaje, "%",")")),
vjust=2,
color="black",
hjust=0.5,
position = position_dodge(0.9),
angle=0,
size=4.0
)
A continuación, revisamos el comportamiento de esta variable frente a la
rotación de personal:
y <- table1::table1(~ `Viaje de Negocios` | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| 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%) |
Por lo observado en la tabla podemos concluir que a pesar de que la mayoría de las personas no frecuentan viajes de negocios, esta actividad es bastante determinante a la hora de hablar de rotación, esto se evidencia en que el 94.9% del personal que ha rotado si realizan viajes dentro de sus labores.
Edad
La mayoría de los empleados de la empresa se encuentran en el rango de edad entre los 30 y 40 años, esto nos demuestra que en esta empresa las edades menos frecuentes son las más alejadas a este rango de edad donde sus valores extremos son de 18 y 60 años.
ggplot(rotacion,aes(x=Edad,fill = factor(Edad)))+geom_histogram()+theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
A continuación, revisamos el comportamiento de esta variable frente a la
rotación de personal:
rotacion$Edad_grupo=cut(rotacion$Edad,breaks = c(0,30,40,50,60))
y <- table1::table1(~ Edad | 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] |
De acuerdo con la tabla se observa que la media y mediana del personal que no rota supera en 4 unidades frente a la media y mediana del personal que si presenta rotación. Lo que nos demuestra que los empleados con menor edad tienden a cambiar frecuentemente su trabajo dentro de esta empresa.
Porcentaje_aumento_salarial
La mayoria de empleados que pertenecen a la empresa reciben bonificacione salariales entre el 11 y el 15 %, esto nos representa un decrecimiento lineal del porcentaje de aumento salarial frente a la cantidad de empleados.
ggplot(rotacion,aes(x=Porcentaje_aumento_salarial,fill = factor(Porcentaje_aumento_salarial)))+geom_histogram()+theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
A continuación, revisamos el comportamiento de esta variable frente a la
rotación de personal:
rotacion$Porcentaje_aumento_salarial_grupo=cut(rotacion$Porcentaje_aumento_salarial,breaks = c(0,5,10,15,20,25))
y <- table1::table1(~ Porcentaje_aumento_salarial | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Porcentaje_aumento_salarial | |||
| Mean (SD) | 15.2 (3.64) | 15.1 (3.77) | 15.2 (3.66) |
| Median [Min, Max] | 14.0 [11.0, 25.0] | 14.0 [11.0, 25.0] | 14.0 [11.0, 25.0] |
Aproximadamente la mitad de los empleados reciben un aumento salarial menor o igual al 15%, y tenemos aumentos de hasta el 25% que bonifica la menor cantidad de personas. Esto se evidencia en su media de 15.2 y mediana de 14. Cabe resaltar que la media de los empleados que no rotan frente a los que si rotan, solo se superan en 0.1 unidades y la mediana es la misma lo que nos indica que esta variable no estan determinante.
Antigüedad_Cargo
Podemos evidenciar que la mayoria de empleados, tienen menos de 5 años de antiguedad en su cargo demostrado en un decrecimiento lineal donde los empleados con mas de 6 años de antiguedad son un grupo muy pequeño, a pesar de tener un pico de mas de 200 personas con de 7 años de permanencia en la empresa.
ggplot(rotacion,aes(x=Antigüedad_Cargo,fill = factor(Antigüedad_Cargo)))+geom_histogram()+theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
A continuación, revisamos el comportamiento de esta variable frente a la rotación de personal:
rotacion$Antigüedad_Cargo_grupo=cut(rotacion$Antigüedad_Cargo,breaks = c(0,4,8,12,16,20))
y <- table1::table1(~ Antigüedad_Cargo | Rotación, data = rotacion)
y| No (N=1233) |
Si (N=237) |
Overall (N=1470) |
|
|---|---|---|---|
| Antigüedad_Cargo | |||
| Mean (SD) | 4.48 (3.65) | 2.90 (3.17) | 4.23 (3.62) |
| Median [Min, Max] | 3.00 [0, 18.0] | 2.00 [0, 15.0] | 3.00 [0, 18.0] |
” ”
Teniendo un rango de entre 0 y 18 años de antigüedad en el cargo, los valores obtenidos en moda y mediana son bastante bajos dentro de este contexto y si lo asociamos a los empleados que si rotan, se evidencia que las personas con menos años de antigüedad tienden a rotar con mayor frecuencia.
Punto 3:
Realiza un análisis de bivariado en donde la variable respuesta sea rotacion 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.
Primero vamos a codificar la variable Rotación:
rotacion$Rotación <- ifelse(rotacion$Rotación == "Si", 1, 0)
head(rotacion)## # A tibble: 6 × 27
## Rotación Edad `Viaje de Negocios` Departamento Distancia_Casa Educación
## <dbl> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 41 Raramente Ventas 1 2
## 2 0 49 Frecuentemente IyD 8 1
## 3 1 37 Raramente IyD 2 2
## 4 0 33 Frecuentemente IyD 3 4
## 5 0 27 Raramente IyD 2 1
## 6 0 32 Frecuentemente IyD 2 2
## # ℹ 21 more variables: Campo_Educación <chr>, Satisfacción_Ambiental <dbl>,
## # Genero <chr>, Cargo <chr>, 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>, …Cargo
En los cargos de Director de investigación, Director de manufactura y Gerente presentan mayor estabilidad con un porcentaje 93% o superior de continuidad en su cargo, a diferencia de cargos como Representante de ventas que tiene una rotación del 40% o el personal de Recursos humanos y técnicos de laboratorio que tienen rotaciones de 23 y 24% respectivamente. Esto comprueba nuestra hipótesis donde esperamos la menor rotación en los cargos directivos o gerenciales.
q <- PlotXTabs2(data = rotacion,x = Cargo,y = Rotación)
q + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
Estado_Civil
El porcentaje de solteros superan en más de 100% al grupo de casados y divorciados que cambian de trabajo, comprobando nuestra hipótesis en donde afirmamos que las personas casadas y divorciadas buscan tener mayor continuidad en sus trabajos.
PlotXTabs2(data = rotacion,x = Estado_Civil,y = Rotación)
#### Viaje de Negocios
Se tiene una continuidad del 92% en las personas que nunca viajan este porcentaje disminuye a un 85% cuando el empleado viaja raramente y el menor porcentaje presentado es del 75% para los empleados que viajan frecuentemente, lo que nos indica una tendencia de rotación entre mayor frecuencia haya en sus viajes. Comprobando nuestra hipótesis en la que afirmamos que las personas que viajan frecuentemente pueden tener mayor deserción.
PlotXTabs2(data = rotacion,x = `Viaje de Negocios`,y = Rotación)
Edad
En el grupo que se presenta la mayor rotación es en el de menores de 30 años con un 26% superando en gran porcentaje a los grupos que se encuentran en el rango de edades mayores de 30 y hasta 60 años los cuales no tienen rotaciones mayores al 14%. Comprobando nuestra hipótesis donde sustentábamos que las personas con mayor edad buscarían tener mayor continuidad.
t.test(rotacion$Edad~rotacion$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion$Edad by rotacion$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.60759PlotXTabs2(data = rotacion,x = Edad_grupo,y = Rotación)
Porcentaje_aumento_salarial
En los diferentes grupos de porcentaje de aumento salarial se puede notar una igualdad en los porcentajes de rotación con un 16, 15 y 18% para cada rango lo que demuestra que el porcentaje de aumento salarial no es una variable representativa a la hora de hablar de rotación. Esto refuta nuestra hipótesis donde pensamos que la mayor rotación se daría en los menores porcentajes de aumento salarial y por el contrario el porcentaje más alto de rotación se encuentra en el rango de 20 a 25% de bonificación.
t.test(rotacion$Porcentaje_aumento_salarial~rotacion$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion$Porcentaje_aumento_salarial by rotacion$Rotación
## t = 0.50424, df = 326.11, p-value = 0.6144
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## -0.3890709 0.6572652
## sample estimates:
## mean in group 0 mean in group 1
## 15.23114 15.09705PlotXTabs2(data = rotacion,x = Porcentaje_aumento_salarial_grupo,y = Rotación)
#### Antigüedad_Cargo
Se puede observar que el porcentaje más alto de rotación se encuentra en el grupo de 0 a 4 años de antigüedad con un 16% y la rotación en las antigüedades mayores a 4 y menores a 16 son bastantes igualadas rondando el 10% de rotación y en el último rango no se presenta ningún caso de rotación. Esto comprueba nuestra hipótesis donde afirmamos que las mayores antigüedades en un cargo presentan mayor estabilidad y conocimiento de su puesto.
t.test(rotacion$Antigüedad_Cargo~rotacion$Rotación)##
## Welch Two Sample t-test
##
## data: rotacion$Antigüedad_Cargo by rotacion$Rotación
## t = 6.8471, df = 366.57, p-value = 3.187e-11
## alternative hypothesis: true difference in means between group 0 and group 1 is not equal to 0
## 95 percent confidence interval:
## 1.127107 2.035355
## sample estimates:
## mean in group 0 mean in group 1
## 4.484185 2.902954PlotXTabs2(data = rotacion,x = Antigüedad_Cargo_grupo,y = Rotación)
Punto 4:
Realiza la estimación de un modelo de regresión logístico en el cual la variable respuesta es rotacion (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.
attach(rotacion)rotacion$Rotación <- factor(rotacion$Rotación)
modelo1 <-
glm(Rotación ~ Cargo + Estado_Civil + `Viaje de Negocios` + Edad + Porcentaje_aumento_salarial + Antigüedad_Cargo, family = binomial(link = "logit"), data = rotacion)
summary(modelo1)##
## Call:
## glm(formula = Rotación ~ Cargo + Estado_Civil + `Viaje de Negocios` +
## Edad + Porcentaje_aumento_salarial + Antigüedad_Cargo, family = binomial(link = "logit"),
## data = rotacion)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.3167 -0.6216 -0.4371 -0.2460 3.1183
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.798136 0.904626 -1.988 0.046844 *
## CargoDirector_Manofactura 0.781968 0.796522 0.982 0.326234
## CargoEjecutivo_Ventas 1.841472 0.739582 2.490 0.012779 *
## CargoGerente 0.848865 0.858395 0.989 0.322713
## CargoInvestigador_Cientifico 1.473861 0.747099 1.973 0.048521 *
## CargoRecursos_Humanos 2.111543 0.802389 2.632 0.008499 **
## CargoRepresentante_Salud 0.818095 0.803660 1.018 0.308696
## CargoRepresentante_Ventas 2.424182 0.772656 3.137 0.001704 **
## CargoTecnico_Laboratorio 2.005944 0.744045 2.696 0.007018 **
## Estado_CivilDivorciado -0.207443 0.225130 -0.921 0.356823
## Estado_CivilSoltero 0.761951 0.167053 4.561 5.09e-06 ***
## `Viaje de Negocios`No_Viaja -1.369423 0.345632 -3.962 7.43e-05 ***
## `Viaje de Negocios`Raramente -0.627514 0.176063 -3.564 0.000365 ***
## Edad -0.020791 0.009442 -2.202 0.027670 *
## Porcentaje_aumento_salarial -0.005383 0.021082 -0.255 0.798460
## Antigüedad_Cargo -0.100757 0.026910 -3.744 0.000181 ***
## ---
## 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: 1131.8 on 1454 degrees of freedom
## AIC: 1163.8
##
## Number of Fisher Scoring iterations: 6c = exp(modelo1$coefficients)/(exp(modelo1$coefficients) +1)
c## (Intercept) CargoDirector_Manofactura
## 0.1420782 0.6861041
## CargoEjecutivo_Ventas CargoGerente
## 0.8631227 0.7003289
## CargoInvestigador_Cientifico CargoRecursos_Humanos
## 0.8136435 0.8920200
## CargoRepresentante_Salud CargoRepresentante_Ventas
## 0.6938318 0.9186528
## CargoTecnico_Laboratorio Estado_CivilDivorciado
## 0.8814197 0.4483244
## Estado_CivilSoltero `Viaje de Negocios`No_Viaja
## 0.6817772 0.2027131
## `Viaje de Negocios`Raramente Edad
## 0.3480744 0.4948023
## Porcentaje_aumento_salarial Antigüedad_Cargo
## 0.4986543 0.4748319El coeficiente del intercepto (-1.798136) indica el logaritmo de odds de que un empleado con el valor de referencia para todas las variables explicativas tenga una probabilidad de rotación del 14.2%.
CargoDirector_Manofactura (0.781968): los empleados con el cargo de director de manufactura tienen una probabilidad 2.18 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoEjecutivo_Ventas (1.841472): los empleados con el cargo de ejecutivo de ventas tienen una probabilidad 6.29 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoGerente (0.848865): los empleados con el cargo de gerente tienen una probabilidad 2.34 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
-CargoInvestigador_Cientifico (1.473861): los empleados con el cargo de investigador científico tienen una probabilidad 4.36 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoRecursos_Humanos (2.111543): los empleados con el cargo de recursos humanos tienen una probabilidad 7.38 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoRepresentante_Salud (0.818095): los empleados con el cargo de representante de salud tienen una probabilidad 2.27 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoRepresentante_Ventas (2.424182): los empleados con el cargo de representante de ventas tienen una probabilidad 11.3 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
CargoTecnico_Laboratorio (2.005944): los empleados con el cargo de técnico de laboratorio tienen una probabilidad 7.44 veces mayor de rotación que los empleados con el cargo de referencia, manteniendo constantes las demás variables.
Estado_CivilDivorciado (-0.207443): los empleados que están divorciados tienen una probabilidad 18% menor de rotación que los empleados casados, manteniendo constantes las demás variables.
Estado_CivilSoltero (0.761951): los empleados solteros tienen una probabilidad 2.14 veces mayor de rotación que los empleados casados, manteniendo constantes las demás variables.
Viaje de Negocios No_Viaja (-1.369423): los empleados que no viajan por negocios tienen una probabilidad 3.93 veces menor de rotación que los empleados que viajan frecuentemente por negocios, manteniendo constantes las demás variables.
Viaje de NegociosRaramente (-0.627514): los empleados que viajan por negocios raramente tienen una probabilidad 1.87 veces menor de rotación que los empleados que viajan frecuentemente por negocios, manteniendo constantes las demás variables.
Edad (-0.020791): por cada año adicional de edad, la probabilidad de rotación disminuye en un 2.1%, manteniendo constantes las demás variables.
El coeficiente de Porcentaje_aumento_salarial (-0.005383) indica que por cada unidad de aumento en el porcentaje salarial, se espera que la probabilidad de rotación disminuya en un 0.54%.
El coeficiente de Antigüedad_Cargo (-0.100757) indica que por cada unidad de aumento en la antigüedad en el cargo, se espera que la probabilidad de rotación disminuya en un 9.7%.
En este caso, los coeficientes con valores p menores a 0.05 son considerados significativos, lo que significa que las variables de “Cargo”, “Estado_Civil”, “Viaje de Negocios”, “Antigüedad_Cargo”, “Edad” y “Viaje de Negocios” son estadísticamente significativas.
Punto 5:
Evaluar el poder predictivo del modelo con base en la curva ROC y el AUC.
prediccion1= predict(modelo1,list( Cargo=rotacion$Cargo, Estado_Civil=rotacion$Estado_Civil, `Viaje de Negocios` = rotacion$`Viaje de Negocios`, Edad = rotacion$Edad, Porcentaje_aumento_salarial = rotacion$Porcentaje_aumento_salarial, Antigüedad_Cargo = rotacion$Antigüedad_Cargo ),type = "response")require(pROC)## Loading required package: pROC## Warning: package 'pROC' was built under R version 4.2.3## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varROC_rotacion= roc(rotacion$Rotación~prediccion1, percent = T, ci=T)## Setting levels: control = 0, case = 1## Setting direction: controls < casesROC_rotacion##
## Call:
## roc.formula(formula = rotacion$Rotación ~ prediccion1, percent = T, ci = T)
##
## Data: prediccion1 in 1233 controls (rotacion$Rotación 0) < 237 cases (rotacion$Rotación 1).
## Area under the curve: 74.94%
## 95% CI: 71.52%-78.35% (DeLong)plot(ROC_rotacion,print.auc=T,print.thres = "best",col="red"
,xlab = "Specificity", ylab = "Sensitivity")
El AUC es del 74.94%, lo que indica que el modelo tiene un buen rendimiento para distinguir entre los empleados que tienen una probabilidad alta de rotación y aquellos que no la tienen. Además, el intervalo de confianza del 95% indica que existe una alta probabilidad de que el verdadero AUC esté entre el 71.52% y el 78.35%.
Punto 6:
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).
(predict(modelo1,list(Cargo="Ejecutivo_Ventas", Estado_Civil= "Soltero", `Viaje de Negocios` = "Raramente", Edad = 41, Porcentaje_aumento_salarial = 11, Antigüedad_Cargo = 4 ),type = "response"))*100## 1
## 24.28863Una empleado con las caracteristica anteriores tiene la probabilidad de rotar un 24.29%.
Teniendo en cuenta que la probabilidad de rotacion base es de 14.20% y este empleado supera en 10% este promedio, sin embargo no es alta teniendo en cuenta las caracteristicas que tiene, resaltando su estado civil ya que al estar soltero y segun el analisis realizado las probabilidades de rotacion son mayores cuando se presenta este estado, lo sin embargo si se desea reducir este valor, se deben ofrecer garantias en variables como el porcentaje salarial y la frecuencia de los viajes de negocios.
Punto 7:
En las conclusiones adicione una discució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).
- Teniendo en cuenta los resultados obtenidos de la realización de viajes de negocios con respecto a la rotación, se evidencia una importancia alta para los empleados y una causal para cambiar de trabajo, para mejorar esta situación se puede priorizar las reuniones virtuales y el teletrabajo en los casos en que sea aplicable y para las situaciones en el que los viajes son necesarios se propone aplicar bonos de trabajo en campo o reconocimientos a las personas que deben viajar frecuentemente.
-Observando los resultados obtenidos en el análisis de la edad y antigüedad, se identifica una correlación entre estas variables, donde el núcleo común son las oportunidades de crecimiento, como también el desarrollo personal y profesional de los empleados. Para esto se propone implementar planes de carrera ofreciendo cursos y capacitaciones para empleados que buscan crecer dentro de la empresa. Otra propuesta es la de implementar mentorías y coaching que permite identificar al personal sus áreas de mejora y el desarrollo de habilidades blandas.
-Teniendo en cuenta los resultados obtenidos del Porcentaje de aumento salarial se presenta como un valor no determinante a la hora de hablar de rotación de personal. En este caso concluimos que la empresa debe enfocarse en brindar bienestar y acompañamiento para lo cual se debería ofrecer apoyo en cuestiones de salud mental, seguridad y salud en el trabajo, entretenimiento y hábitos saludables como también la integración entre empleados, celebración de fechas especiales y otorgar tiempo libre para compartir con la familia y el día de su cumpleaños.
-Con base en los resultados del análisis de la variable Cargo de los empleados, se evidencia un porcentaje superior de rotación en tres cargos específicos, siendo estos Representante de ventas, Técnico de laboratorio y Recursos humanos, de esta manera se propone organizar comités que representen a los empleados de estas áreas para poder identificar los problemas que presentan para que el área administrativa y directiva pueda ofrecer soluciones y herramientas frente a las solicitudes realizadas.
-Al analizar los resultados obtenidos con la variable Estado civil, se puede observar una mayor tendencia de rotación en las personas solteras, donde se infiere que su rotación es por la aparición de nuevas oportunidades y la falta de estabilidad. Para esto se propone estandarizar el tipo de contrato a termino indefinido por sus beneficios frente a crecimiento y estabilidad laboral.
Problema 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 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.
Encontramos que todas las variables del set de datos de créditos no tienen valores faltantes además de que son variables Cuantitativas, por lo que podemos realizar un análisis de correlación para identificar el grado de relación que tienen con la variable default.
attach(creditos)
summary(creditos)## default antiguedad edad cuota
## 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. :22197021Analisis Exploratorio
Antiguedad
creditos$antiguedad=cut(creditos$antiguedad,breaks = c(0,10,20,30,40))
data.frame(table(creditos$antiguedad))## Var1 Freq
## 1 (0,10] 265
## 2 (10,20] 201
## 3 (20,30] 104
## 4 (30,40] 210require(PlotXTabs2)## Loading required package: PlotXTabs2## Warning in library(package, lib.loc = lib.loc, character.only = TRUE,
## logical.return = TRUE, : there is no package called 'PlotXTabs2'PlotXTabs2(data = creditos,x = "antiguedad",y="default")
Se puede observar que la proporción de usuarios con Default es mayor
(8%) entre las personas que tienen una antigüedad laboral de entre 0 y
10 años en comparación con aquellos que tienen más años de antigüedad.
Además, la mayor cantidad de usuarios se encuentra en este mismo grupo
de personas con menor antigüedad laboral.
Edad
creditos$edad=cut(creditos$edad,breaks = c(0,10,20,30,40,50,60,70,80,90,100))
data.frame(table(creditos$edad))## Var1 Freq
## 1 (0,10] 0
## 2 (10,20] 0
## 3 (20,30] 6
## 4 (30,40] 83
## 5 (40,50] 140
## 6 (50,60] 210
## 7 (60,70] 225
## 8 (70,80] 100
## 9 (80,90] 14
## 10 (90,100] 2PlotXTabs2(data = creditos,x = "edad",y="default")
Se observa que las personas que estan en el rango de edad de 50 - 60 tienen el mayor default, seguidos por los que tienen entre 30 - 40 años.
Cuota
require(ggplot2)
g1 <- ggplot(creditos, aes(x = default, y = cuota)) +
geom_boxplot(aes(fill = default)) +
scale_x_continuous(limits = c(-1, 2))
require(plotly)## Loading required package: plotly##
## Attaching package: 'plotly'## The following object is masked from 'package:ggplot2':
##
## last_plot## The following object is masked from 'package:stats':
##
## filter## The following object is masked from 'package:graphics':
##
## layoutggplotly(g1)## Warning: Continuous x aesthetic
## ℹ did you forget `aes(group = ...)`?## Warning: The following aesthetics were dropped during statistical transformation: fill
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
## the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
## variable into a factor?El 50% de las personas que no tienen default manejan una cuota máxima de 673.767, mientras que el 50% de las personas que tienen default tienen una cuota máxima de 1.074.994, siendo 401.227 esta puede ser una de las razones de por qué no pudieron cumplir con el crédito.
Ingresos
require(ggplot2)
g1 <- ggplot(creditos, aes(x = default, y = ingresos)) +
geom_boxplot(aes(fill = default)) +
scale_x_continuous(limits = c(-1, 2))
require(plotly)
ggplotly(g1)## Warning: Continuous x aesthetic
## ℹ did you forget `aes(group = ...)`?## Warning: The following aesthetics were dropped during statistical transformation: fill
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
## the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
## variable into a factor?La mitad de las personas que tienen un estado de DEFAULT tienen un ingreso promedio de 4.799.180, mientras que aquellos que no están en DEFAULT tienen un ingreso promedio de 5.038.000. Esto sugiere que a medida que aumenta el ingreso, disminuye el riesgo de caer en DEFAULT.
Modelo de regresion logistico multiple
modelo2=glm(default~edad+ ingresos+ antiguedad+ cuota,
data = creditos,family = "binomial")
summary(modelo2)##
## Call:
## glm(formula = default ~ edad + ingresos + antiguedad + cuota,
## family = "binomial", data = creditos)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.0235 -0.3614 -0.2667 -0.1726 3.0808
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.725e+01 1.609e+03 -0.011 0.9914
## edad(30,40] 1.488e+01 1.609e+03 0.009 0.9926
## edad(40,50] 1.478e+01 1.609e+03 0.009 0.9927
## edad(50,60] 1.560e+01 1.609e+03 0.010 0.9923
## edad(60,70] 1.501e+01 1.609e+03 0.009 0.9926
## edad(70,80] 1.545e+01 1.609e+03 0.010 0.9923
## edad(80,90] 1.024e+00 1.897e+03 0.001 0.9996
## edad(90,100] 7.169e-01 3.202e+03 0.000 0.9998
## ingresos -2.700e-07 1.080e-07 -2.500 0.0124 *
## antiguedad(10,20] -8.431e-01 4.584e-01 -1.839 0.0659 .
## antiguedad(20,30] -1.603e+00 8.139e-01 -1.969 0.0489 *
## antiguedad(30,40] -7.676e-01 7.432e-01 -1.033 0.3017
## cuota 9.775e-07 2.446e-07 3.996 6.45e-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: 279.96 on 767 degrees of freedom
## AIC: 305.96
##
## Number of Fisher Scoring iterations: 16El coeficiente para la constante (intercept) es -17.25, pero dado el elevado error estándar, no es estadísticamente significativo.
Los coeficientes para cada una de las categorías de edad (30-40, 40-50, 50-60, 60-70, 70-80, 80-90, y 90-100) se interpretan como el cambio en el logaritmo de las probabilidades de incumplimiento (default) en comparación con la categoría de referencia, que es la categoría de edad más joven, es decir, aquellos con edades menores a 30 años. Por ejemplo, el coeficiente para la categoría de edad 30-40 es 14.88, lo que significa que los individuos en este grupo de edad tienen un aumento del logaritmo de las probabilidades de incumplimiento de 14.88 en comparación con los individuos menores de 30 años.
El coeficiente para ingresos es -2.7e-07, lo que indica que un aumento de un dólar en los ingresos se asocia con una disminución del logaritmo de las probabilidades de incumplimiento en -2.7e-07 unidades, manteniendo las demás variables constantes.
Los coeficientes para cada una de las categorías de antigüedad (10-20, 20-30, y 30-40) se interpretan como el cambio en el logaritmo de las probabilidades de incumplimiento en comparación con la categoría de referencia, que es la categoría de antigüedad más baja, es decir, aquellos con menos de 10 años de antigüedad laboral. Por ejemplo, el coeficiente para la categoría de antigüedad 10-20 es -0.8431, lo que significa que los individuos en este grupo de antigüedad tienen una disminución del logaritmo de las probabilidades de incumplimiento de 0.8431 en comparación con los individuos con menos de 10 años de antigüedad laboral.
El coeficiente para la variable de cuota indica que un aumento de un dólar en la cuota mensual de un préstamo se asocia con un aumento del logaritmo de las probabilidades de incumplimiento en 9.775e-07 unidades, manteniendo las demás variables constantes.
la variable “cuota” es la que tiene el mayor impacto en la probabilidad de que un solicitante de crédito no pague a tiempo. Esto se debe a que, al aumentar la cuota, se aumenta el riesgo de que el solicitante no pueda pagar el préstamo en el futuro.
Por otro lado, la variable “ingresos” tiene un efecto negativo en la probabilidad de que un solicitante no pague a tiempo. Es decir, a medida que los ingresos del solicitante son mayores, se reduce el riesgo de que no pague el crédito.
En cuanto a las variables “antiguedad” y “edad”, aunque algunas categorías tienen coeficientes significativos, en general, no tienen tanto impacto como “cuota” e “ingresos” en la probabilidad de incumplimiento.
Evaluacion del modelo
ntrain <- nrow(creditos)*0.6
ntest <- nrow(creditos)*0.4
set.seed(123)
index_train<-sample(1:nrow(creditos),size = ntrain)
train<-creditos[index_train,] # muestra de entrenamiento
test<-creditos[-index_train,] # muestra de pruebaglm(default~edad+ ingresos+ antiguedad+ cuota , family = binomial(link = "logit"), data = train) -> modelo2_train
summary(modelo2_train)##
## Call:
## glm(formula = default ~ edad + ingresos + antiguedad + cuota,
## family = binomial(link = "logit"), data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.7756 -0.3768 -0.2761 -0.1498 3.0593
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.941e+01 6.199e+03 -0.003 0.99750
## edad(30,40] 1.667e+01 6.199e+03 0.003 0.99785
## edad(40,50] 1.709e+01 6.199e+03 0.003 0.99780
## edad(50,60] 1.742e+01 6.199e+03 0.003 0.99776
## edad(60,70] 1.736e+01 6.199e+03 0.003 0.99777
## edad(70,80] 1.200e+00 6.338e+03 0.000 0.99985
## edad(80,90] 1.236e+00 7.002e+03 0.000 0.99986
## edad(90,100] 1.002e+00 1.241e+04 0.000 0.99994
## ingresos -1.971e-07 1.332e-07 -1.480 0.13898
## antiguedad(10,20] -7.122e-01 5.563e-01 -1.280 0.20044
## antiguedad(20,30] -1.225e+00 8.690e-01 -1.409 0.15871
## antiguedad(30,40] -1.401e+00 1.028e+00 -1.363 0.17299
## cuota 9.254e-07 3.298e-07 2.806 0.00501 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 189.33 on 467 degrees of freedom
## Residual deviance: 167.42 on 455 degrees of freedom
## AIC: 193.42
##
## Number of Fisher Scoring iterations: 18valor_pronosticado <- predict(modelo2_train,test,type = "response")
niveles_pronosticados <- ifelse(valor_pronosticado >0.5,1,0) %>%
factor(.)Contruccion de la Matriz de confusion
rendimiento_data<-data.frame(observados=test$default,
predicciones= niveles_pronosticados)
Positivos <- sum(rendimiento_data$observados==1)
Negativos <- sum(rendimiento_data$observados==0)
Positivos_pronosticados <- sum(rendimiento_data$predicciones==1)
Negativos_pronosticados <- sum(rendimiento_data$predicciones==0)
Total <- nrow(rendimiento_data)
VP<-sum(rendimiento_data$observados==1 & rendimiento_data$predicciones==1)
VN<-sum(rendimiento_data$observados==0 & rendimiento_data$predicciones==0)
FP<-sum(rendimiento_data$observados==0 & rendimiento_data$predicciones==1)
FN<-sum(rendimiento_data$observados==1 & rendimiento_data$predicciones==0)
matriz_confusion=matrix(c(VP, FP, FN,VN), nrow=2)
rownames(matriz_confusion) = c(1, 0)
colnames(matriz_confusion) = c(1, 0)
matriz_confusion ## 1 0
## 1 0 15
## 0 0 297- Verdaderos positivos (VP): 0
- Falsos positivos (FP): 15
- Falsos negativos (FN): 0
- Verdaderos negativos (VN): 297
Se observa que el modelo predijo correctamente todos los casos de la clase “0” (297 verdaderos negativos), lo que indica una alta especificidad. Sin embargo, el modelo no predijo correctamente ningún caso de la clase “1” (0 verdaderos positivos) y predijo incorrectamente 15 casos de la clase “0” como “1” (15 falsos positivos), lo que indica una baja sensibilidad del modelo.
Indicadores del modelo
Exactitud <- (VP+VN)/Total
Tasa_de_Error <- (FP+FN)/Total
Sensibilidad <- VP/Positivos
Especificidad <- VN/Negativos
Precision <- VP/Positivos_pronosticados
Valor_prediccion_negativo <- VN / Negativos_pronosticados
indicadores <- t(data.frame(Exactitud,
Tasa_de_Error,
Sensibilidad,
Especificidad,
Precision,
Valor_prediccion_negativo))
colnames(indicadores)="indicadores"
rownames(indicadores) =c("Exactitud ",
"Tasa de Error ",
"Sensibilidad",
"Especificidad",
"Precisión",
"Valor predicción negativo")
indicadores ## indicadores
## Exactitud 0.95192308
## Tasa de Error 0.04807692
## Sensibilidad 0.00000000
## Especificidad 1.00000000
## Precisión NaN
## Valor predicción negativo 0.95192308Los resultados muestran que la exactitud del modelo es alta (95.19%), lo que significa que la mayoría de las predicciones son correctas. La tasa de error es baja (4.81%), lo que indica que el modelo no comete muchos errores en las predicciones.
Sin embargo, la sensibilidad es baja (0%), lo que sugiere que el modelo no puede identificar correctamente los verdaderos positivos. La especificidad es alta (100%), lo que indica que el modelo puede identificar correctamente los verdaderos negativos. La precisión no se puede calcular ya que hay un valor faltante en la tabla de contingencia.
El valor de predicción negativo es alto (95.19%), lo que sugiere que el modelo puede identificar correctamente los verdaderos negativos. En resumen, el modelo tiene una alta exactitud y especificidad, pero una baja sensibilidad.
Balanceo de datos
library(ROSE)## Warning: package 'ROSE' was built under R version 4.2.3## Loaded ROSE 0.0-4# oversampling
ntrain <- ovun.sample(default~., data=train,
p=0.5, seed=1,
method="over")$data
ntest <- ovun.sample(default~., data=test,
p=0.5, seed=1,
method="over")$dataLuego de balancear los datos volvemos a calcular los pasos anteriores
Evaluacion del modelo
ntrain <- nrow(creditos)*0.6
ntest <- nrow(creditos)*0.4
set.seed(123)
index_train<-sample(1:nrow(creditos),size = ntrain)
train<-creditos[index_train,] # muestra de entrenamiento
test<-creditos[-index_train,] # muestra de pruebaglm(default~edad+ ingresos+ antiguedad+ cuota , family = binomial(link = "logit"), data = train) -> modelo2_train
summary(modelo2_train)##
## Call:
## glm(formula = default ~ edad + ingresos + antiguedad + cuota,
## family = binomial(link = "logit"), data = train)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -0.7756 -0.3768 -0.2761 -0.1498 3.0593
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.941e+01 6.199e+03 -0.003 0.99750
## edad(30,40] 1.667e+01 6.199e+03 0.003 0.99785
## edad(40,50] 1.709e+01 6.199e+03 0.003 0.99780
## edad(50,60] 1.742e+01 6.199e+03 0.003 0.99776
## edad(60,70] 1.736e+01 6.199e+03 0.003 0.99777
## edad(70,80] 1.200e+00 6.338e+03 0.000 0.99985
## edad(80,90] 1.236e+00 7.002e+03 0.000 0.99986
## edad(90,100] 1.002e+00 1.241e+04 0.000 0.99994
## ingresos -1.971e-07 1.332e-07 -1.480 0.13898
## antiguedad(10,20] -7.122e-01 5.563e-01 -1.280 0.20044
## antiguedad(20,30] -1.225e+00 8.690e-01 -1.409 0.15871
## antiguedad(30,40] -1.401e+00 1.028e+00 -1.363 0.17299
## cuota 9.254e-07 3.298e-07 2.806 0.00501 **
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 189.33 on 467 degrees of freedom
## Residual deviance: 167.42 on 455 degrees of freedom
## AIC: 193.42
##
## Number of Fisher Scoring iterations: 18valor_pronosticado <- predict(modelo2_train,test,type = "response")
niveles_pronosticados <- ifelse(valor_pronosticado >0.5,1,0) %>%
factor(.)Contruccion de la Matriz de confusion
rendimiento_data<-data.frame(observados=test$default,
predicciones= niveles_pronosticados)
Positivos <- sum(rendimiento_data$observados==1)
Negativos <- sum(rendimiento_data$observados==0)
Positivos_pronosticados <- sum(rendimiento_data$predicciones==1)
Negativos_pronosticados <- sum(rendimiento_data$predicciones==0)
Total <- nrow(rendimiento_data)
VP<-sum(rendimiento_data$observados==1 & rendimiento_data$predicciones==1)
VN<-sum(rendimiento_data$observados==0 & rendimiento_data$predicciones==0)
FP<-sum(rendimiento_data$observados==0 & rendimiento_data$predicciones==1)
FN<-sum(rendimiento_data$observados==1 & rendimiento_data$predicciones==0)
matriz_confusion=matrix(c(VP, FP, FN,VN), nrow=2)
rownames(matriz_confusion) = c(1, 0)
colnames(matriz_confusion) = c(1, 0)
matriz_confusion ## 1 0
## 1 0 15
## 0 0 297Exactitud <- (VP+VN)/Total
Tasa_de_Error <- (FP+FN)/Total
Sensibilidad <- VP/Positivos
Especificidad <- VN/Negativos
Precision <- VP/Positivos_pronosticados
Valor_prediccion_negativo <- VN / Negativos_pronosticados
indicadores <- t(data.frame(Exactitud,
Tasa_de_Error,
Sensibilidad,
Especificidad,
Precision,
Valor_prediccion_negativo))
colnames(indicadores)="indicadores"
rownames(indicadores) =c("Exactitud ",
"Tasa de Error ",
"Sensibilidad",
"Especificidad",
"Precisión",
"Valor predicción negativo")
indicadores ## indicadores
## Exactitud 0.95192308
## Tasa de Error 0.04807692
## Sensibilidad 0.00000000
## Especificidad 1.00000000
## Precisión NaN
## Valor predicción negativo 0.95192308Luego de realizar el balanceo, encontramos que los indicadores siguen presentando los mimos resultados, por lo que puede ser otros factores los que esten afectando estos resultados.
Grafica ROC y AUC
library(ROCR)## Warning: package 'ROCR' was built under R version 4.2.3prediccion_credito= predict.glm(modelo2, newdata = creditos, type = "response")
resultado_cre=table(creditos$default, ifelse(prediccion_credito>0.2,1,0))
resultado_cre##
## 0 1
## 0 735 6
## 1 37 2sum(diag(resultado_cre)/sum(resultado_cre))## [1] 0.9448718prediccion_default= ROCR::prediction(prediccion_credito,creditos$default)
perf_credito= performance(prediction.obj = prediccion_default, "tpr", "fpr")
plot(perf_credito)
abline(a = 0, b = 1,col="red")
grid()
AUC= performance(prediccion_default,measure = "auc")@y.values[[1]]
cat("AUC: ",AUC,"n")## AUC: 0.7393681 nEl valor de AUC es de 0.7393681. Esto indica que el modelo tiene cierta capacidad de predicción, pero no es perfecto. Un valor de AUC entre 0.7 y 0.8 se considera generalmente aceptable para la mayoría de las aplicaciones.