#La Regresión Logística Simple, desarrollada por
#David Cox en 1958, es un método de regresión que permite
#estimar la probabilidad de una variable cualitativa binaria
#en función de una variable cuantitativa. Una de las principales
#aplicaciones de la regresión logística es la de clasificación
#binaria, en el que las observaciones se clasifican en un grupo
#u otro dependiendo del valor que tome la variable empleada
#como predictor. Por ejemplo, clasificar a un individuo
#desconocido como hombre o mujer en función del tamaño de la
#mandíbula.
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(plotly)
##
## Adjuntando el paquete: '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':
##
## layout
library(ISLR) #Contiene datasets del libro
#"An Introduction to Statistical Learning with
#Applications in R"
#install.packages("dplyr")
library(dplyr)
library(readr)
library(ggplot2)
library(plotly)
dsBankFull <- read_csv("bank-full.csv")
## Rows: 45211 Columns: 17
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (10): job, marital, education, default, housing, loan, contact, month, p...
## dbl (7): age, balance, day, duration, campaign, pdays, previous
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
#Un conjunto de datos simulado que contiene
#información sobre diez mil clientes. El objetivo aquí es
#predecir qué clientes incumplirán con su deuda de tarjeta
#de crédito.
head(dsBankFull)
## # A tibble: 6 × 17
## age job marital education default balance housing loan contact day
## <dbl> <chr> <chr> <chr> <chr> <dbl> <chr> <chr> <chr> <dbl>
## 1 58 management married tertiary no 2143 yes no unknown 5
## 2 44 technician single secondary no 29 yes no unknown 5
## 3 33 entrepren… married secondary no 2 yes yes unknown 5
## 4 47 blue-coll… married unknown no 1506 yes no unknown 5
## 5 33 unknown single unknown no 1 no no unknown 5
## 6 35 management married tertiary no 231 yes no unknown 5
## # ℹ 7 more variables: month <chr>, duration <dbl>, campaign <dbl>, pdays <dbl>,
## # previous <dbl>, poutcome <chr>, y <chr>
#default: Un factor con niveles No y Sí que indica si el
#cliente incumplió con su deuda.
#student: Un factor con niveles No y Sí que indica si el
#cliente es estudiante.
#balance: El saldo promedio que el cliente tiene pendiente
#en su tarjeta de crédito después de realizar su pago mensual.
#income: Ingresos del cliente.
# Se recodifican los niveles No, Yes a 1 y 0
dsBankFull <- dsBankFull %>%
mutate(y = as.factor(y))
dsBankFullTr <- dsBankFull %>%
select(y, balance) %>%
mutate(y = recode(y,
"no" = 0,
"yes" = 1))
head(dsBankFullTr)
## # A tibble: 6 × 2
## y balance
## <dbl> <dbl>
## 1 0 2143
## 2 0 29
## 3 0 2
## 4 0 1506
## 5 0 1
## 6 0 231
#Para evitar estos problemas la regresión logística transforma
#el valor devuelto por la regresión lineal (β0+β1X) empleando
#una función cuyo resultado está siempre comprendido entre
#0 y 1. Utilizando la función sigmoide.
#Para valores de x muy grandes positivos, el valor de e^−x
#es aproximadamente 0 por lo que el valor de la función
#sigmoide es 1. Para valores de x muy grandes negativos,
#el valor e^−x tiende a infinito por lo que el valor de la
#función sigmoide es 0.
# Ajuste de un modelo logístico.
modelo_logistico <- glm(y ~ balance,
data = dsBankFullTr,
family = "binomial")
#Variable de respuesta=default
#Variable predictora=balance
#binomial porque tenemos una variable de respuesta con dos opciones
#names(modelo_logistico)
# Representación gráfica del modelo.
ggplot(data = dsBankFullTr, aes(x = balance, y = y)) +
geom_point(aes(color = as.factor(y)), shape = 1) +
stat_function(fun = function(x){predict(modelo_logistico,
newdata = data.frame(balance = x),
type = "response")}) +
theme_bw() +
labs(title = "Regresión logística",
y = "Probabilidad y") +
theme(legend.position = "none")
# Con geom_smooth se puede obtener el gráfico directamente.
a<-ggplot(data = dsBankFullTr, aes(x = balance, y = y)) +
geom_point(aes(color = as.factor(y)), shape = 1) +
geom_smooth(method = "glm",
method.args = list(family = "binomial"),
color = "gray20",
se = FALSE) +
theme_bw() +
theme(legend.position = "none")
ggplotly(a)
## `geom_smooth()` using formula = 'y ~ x'
#Identificar la ecuación
#ln(p/1-p)=β0+β1X
summary <- summary(modelo_logistico)
summary
##
## Call:
## glm(formula = y ~ balance, family = "binomial", data = dsBankFullTr)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.081e+00 1.595e-02 -130.50 <2e-16 ***
## balance 3.958e-05 3.840e-06 10.31 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 32631 on 45210 degrees of freedom
## Residual deviance: 32532 on 45209 degrees of freedom
## AIC: 32536
##
## Number of Fisher Scoring iterations: 4
Intercepto <- summary$coefficients[1,1];Intercepto
## [1] -2.080967
Pendiente <- summary$coefficients[2,1];Pendiente
## [1] 3.958116e-05
#ln(p/1-p)= -10.65 + 0.005499x
#Tarea para hoy Incluir la ecuación en el gráfico
#Test de Wald para coeficientes individuales
#Significancia de la variable independiente
#Ho:La variable NO es significativa.
#Ha:La variable es significativa.
#summary
#como el p-valor de los coeficientes es menor que el nivel
#de significancia 0.05 se rechaza la hipótesis nula. Es decir,
#la variable es significativa.
#ln(p/1-p)= -10.65 + 0.005499x
#Analizar los coeficientes
exp(Pendiente)
## [1] 1.00004
exp(Intercepto)
## [1] 0.1248094
#odd Ratio de la variable independiente es 1.005514
#Por cada unidad que aumenta la variable balance el odds
#de que se presente el evento aumenta 1.005514 veces.
#Calcular las probabilidades
head(modelo_logistico$fitted.values)
## 1 2 3 4 5 6
## 0.1196083 0.1110738 0.1109683 0.1169786 0.1109644 0.1118657
head(round(modelo_logistico$fitted.values,0),10)
## 1 2 3 4 5 6 7 8 9 10
## 0 0 0 0 0 0 0 0 0 0
#Probabilidad de que ocurra el evento 1 y así sucesivamente
#Clasificar según la probabilidad
#Elegir un punto de corte
dsBankFullTr$pred <- as.numeric(modelo_logistico$fitted.values>=0.5)
df <- data.frame(round(modelo_logistico$fitted.values,0),dsBankFullTr$pred)
# Crear un nuevo conjunto de datos para hacer predicciones
#(balance es la variable independiente)
nuevos_datos <- data.frame(balance = c(100, 500,
1000, 1500,
2000, 2500))
summary(dsBankFullTr$balance)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -8019 72 448 1362 1428 102127
# Realizar predicciones con el modelo logístico
predicciones <- predict(modelo_logistico,
newdata = nuevos_datos,
type = "response")
#type = "response" se especifica para obtener las
#probabilidades predichas.
# Mostrar las predicciones
print(predicciones)
## 1 2 3 4 5 6
## 0.1113516 0.1129279 0.1149257 0.1169541 0.1190136 0.1211043
#Clasificar según un umbral
umbral <- 0.5
clases_predichas <- ifelse(predicciones >= umbral, "Yes", "No")
print(clases_predichas)
## 1 2 3 4 5 6
## "No" "No" "No" "No" "No" "No"
#consultar y agregar al script la Matriz de confusión
library(caret)
## Cargando paquete requerido: lattice
##
## Adjuntando el paquete: 'caret'
## The following object is masked from 'package:purrr':
##
## lift
matriz_conf <- confusionMatrix(as.factor(dsBankFullTr$y),
as.factor(dsBankFullTr$pred))
#Acepta variables tipo factor
matriz_conf
## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 39911 11
## 1 5285 4
##
## Accuracy : 0.8829
## 95% CI : (0.8799, 0.8858)
## No Information Rate : 0.9997
## P-Value [Acc > NIR] : 1
##
## Kappa : 8e-04
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.8830649
## Specificity : 0.2666667
## Pos Pred Value : 0.9997245
## Neg Pred Value : 0.0007563
## Prevalence : 0.9996682
## Detection Rate : 0.8827719
## Detection Prevalence : 0.8830152
## Balanced Accuracy : 0.5748658
##
## 'Positive' Class : 0
##