2023-2P
La regresión logística es un tipo de análisis estadístico, también conocido como modelo logit, que se utiliza a menudo para el modelado y la analítica predictiva.
Se utiliza para predecir el resultado de una variable categórica (una variable que puede adoptar un número limitado de categorías) en función de las variables independientes o predictoras.
En este enfoque analítico, la variable dependiente es finita o categórica, ya sea A o B (regresión binaria) o una variedad de opciones finitas A, B, C o D (regresión multinomial).
Se analiza la relación entre la variable dependiente y una o más variables independientes mediante la estimación de probabilidades con una ecuación de regresión logística.
Este tipo de análisis puede ayudarle a predecir la probabilidad de que ocurra un evento o de que se tome una decisión1. Por ejemplo, es posible que desee conocer la probabilidad de que un visitante elija una oferta realizada en su sitio web, o no (variable dependiente).
Su análisis puede observar las características conocidas de los visitantes, como los sitios de los que provienen, las visitas repetidas a su sitio, el comportamiento en su sitio (variables independientes).
## `geom_smooth()` using formula = 'y ~ x'
.
.
Cargamos la libreria de “mtcars”
data(mtcars) str(mtcars)
## 'data.frame': 32 obs. of 11 variables: ## $ mpg : num 21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ... ## $ cyl : num 6 6 4 6 8 6 8 4 4 6 ... ## $ disp: num 160 160 108 258 360 ... ## $ hp : num 110 110 93 110 175 105 245 62 95 123 ... ## $ drat: num 3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ... ## $ wt : num 2.62 2.88 2.32 3.21 3.44 ... ## $ qsec: num 16.5 17 18.6 19.4 17 ... ## $ vs : num 0 0 1 1 0 1 0 1 1 1 ... ## $ am : num 1 1 1 0 0 0 0 0 0 0 ... ## $ gear: num 4 4 4 3 3 3 3 4 4 4 ... ## $ carb: num 4 4 1 1 2 1 4 2 2 4 ...
Analizamos una variable que es categorica.
mtcars$transmision <- ifelse(mtcars$gear==4, "Automatic", "Manual") table(mtcars$transmision)
## ## Automatic Manual ## 12 20
mtcars$transmisionBin <- ifelse(mtcars$transmision== "Automatic" , 0, 1) table(mtcars$transmisionBin)
## ## 0 1 ## 12 20
Planteamos el modelo.
modelo <- glm(transmisionBin ~ mpg + hp + qsec, data = mtcars, family= binomial) summary(modelo)
## ## Call: ## glm(formula = transmisionBin ~ mpg + hp + qsec, family = binomial, ## data = mtcars) ## ## Deviance Residuals: ## Min 1Q Median 3Q Max ## -1.37625 -0.54754 0.01794 0.15044 1.71689 ## ## Coefficients: ## Estimate Std. Error z value Pr(>|z|) ## (Intercept) -14.94560 13.41940 -1.114 0.2654 ## mpg 0.16762 0.19615 0.855 0.3928 ## hp 0.08211 0.04326 1.898 0.0577 . ## qsec 0.11388 0.38560 0.295 0.7677 ## --- ## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ## ## (Dispersion parameter for binomial family taken to be 1) ## ## Null deviance: 42.340 on 31 degrees of freedom ## Residual deviance: 19.737 on 28 degrees of freedom ## AIC: 27.737 ## ## Number of Fisher Scoring iterations: 7
coef(modelo)
## (Intercept) mpg hp qsec ## -14.94560077 0.16761804 0.08210926 0.11388390
Evaluamos el modelo
new_data <- data.frame(mpg = 20, hp = 150, qsec = 17) prediction <- predict(modelo, new_data, type = "response")
Identifiquemos un dataset muy conocido DONORS
library(tidyverse)
donors <- read_csv("https://assets.datacamp.com/production/repositories/718/datasets/9055dac929e4515286728a2a5dae9f25f0e4eff6/donors.csv") %>%
mutate(donated = as.factor(donated))
str(donors)
Identifiquemos un dataset muy conocido DONORS
str(donors)
## tibble [93,462 × 13] (S3: tbl_df/tbl/data.frame) ## $ donated : num [1:93462] 0 0 0 0 0 0 0 0 0 0 ... ## $ veteran : num [1:93462] 0 0 0 0 0 0 0 0 0 0 ... ## $ bad_address : num [1:93462] 0 0 0 0 0 0 0 0 0 0 ... ## $ age : num [1:93462] 60 46 NA 70 78 NA 38 NA NA 65 ... ## $ has_children : num [1:93462] 0 1 0 0 1 0 1 0 0 0 ... ## $ wealth_rating : num [1:93462] 0 3 1 2 1 0 2 3 1 0 ... ## $ interest_veterans: num [1:93462] 0 0 0 0 0 0 0 0 0 0 ... ## $ interest_religion: num [1:93462] 0 0 0 0 1 0 0 0 0 0 ... ## $ pet_owner : num [1:93462] 0 0 0 0 0 0 1 0 0 0 ... ## $ catalog_shopper : num [1:93462] 0 0 0 0 1 0 0 0 0 0 ... ## $ recency : chr [1:93462] "CURRENT" "CURRENT" "CURRENT" "CURRENT" ... ## $ frequency : chr [1:93462] "FREQUENT" "FREQUENT" "FREQUENT" "FREQUENT" ... ## $ money : chr [1:93462] "MEDIUM" "HIGH" "MEDIUM" "MEDIUM" ...
Construir un Modelos de Donación
donation_model <- glm(donated ~ bad_address + interest_religion + interest_veterans, data = donors, family = "binomial") # Summarize the model results donation_model$coefficients
## (Intercept) bad_address interest_religion interest_veterans ## -2.95138685 -0.30779707 0.06723943 0.11008669
Resumen del modelo
# Summarize the model results summary(donation_model)
## ## Call: ## glm(formula = donated ~ bad_address + interest_religion + interest_veterans, ## family = "binomial", data = donors) ## ## Deviance Residuals: ## Min 1Q Median 3Q Max ## -0.3480 -0.3192 -0.3192 -0.3192 2.5678 ## ## Coefficients: ## Estimate Std. Error z value Pr(>|z|) ## (Intercept) -2.95139 0.01652 -178.664 <2e-16 *** ## bad_address -0.30780 0.14348 -2.145 0.0319 * ## interest_religion 0.06724 0.05069 1.327 0.1847 ## interest_veterans 0.11009 0.04676 2.354 0.0186 * ## --- ## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ## ## (Dispersion parameter for binomial family taken to be 1) ## ## Null deviance: 37330 on 93461 degrees of freedom ## Residual deviance: 37316 on 93458 degrees of freedom ## AIC: 37324 ## ## Number of Fisher Scoring iterations: 5
Comportamiento en las predicciones:
table(donors$donated)
## ## 0 1 ## 88751 4711
Probabilidad de Obtener una donación:
donors$donation_prob <- predict(donation_model, type = "response")
Encuentre la probabilidad de donación del prospecto promedio.
mean(donors$donated)
## [1] 0.05040551
Predecir una donación si la probabilidad de donación es mayor que promedio (0.0504)
donors$donation_pred <- ifelse(donors$donation_prob > 0.0504, 1,0) # Calculate the model's accuracy mean(donors$donated == donors$donation_pred)
## [1] 0.794815
En el ejercicio anterior, descubrió que el modelo de regresión logística realizó una predicción correcta casi el 80 % de las veces. A pesar de esta precisión relativamente alta, el resultado es engañoso debido a la rareza del resultado que se predice.
El conjunto de datos de donantes está disponible en su espacio de trabajo. ¿Cuál habría sido la precisión si un modelo simplemente hubiera predicho “no donación” para cada persona?
Por favor calculemos el problema:
## [1] 0.9495945
como calcular Indicadores de precisión y exactitud:
# Load the pROC package library(pROC)
## Type 'citation("pROC")' for a citation.
## ## Attaching package: 'pROC'
## The following objects are masked from 'package:stats': ## ## cov, smooth, var
# Create a ROC curve ROC <- roc(donors$donated, donors$donation_prob)
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
como calcular Indicadores de precisión y exactitud:
plot(ROC, col = "blue")
Calculamos el area debajo de la curva:
auc(ROC)
## Area under the curve: 0.5102
Uno de los mejores predictores de donaciones futuras es un historial de donaciones recientes, frecuentes y cuantiosas. En términos de marketing, esto se conoce como R/F/M: -Reciente -Frecuencia -Dinero
Es especialmente probable que los donantes que han donado recientemente y con frecuencia vuelvan a donar; en otras palabras, el impacto combinado de lo reciente y la frecuencia puede ser mayor que la suma de los efectos separados.
Debido a que estos predictores juntos tienen un mayor impacto sobre la variable dependiente, su efecto conjunto debe modelarse como una interacción.
RFM MODEL
# Build a recency, frequency, and money (RFM) model
rfm_model <- glm(donated ~ money + recency*frequency,
donors,family = "binomial")
# Compute predicted probabilities for the RFM model
rfm_prob <- predict(rfm_model, type = "response")
Plot the ROC curve and find AUC for the new model
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
Valor del Area debajo de la Curva
auc(ROC)
## Area under the curve: 0.5785
En ausencia de experiencia en la materia, la regresión gradual puede ayudar con la búsqueda de los predictores más importantes del resultado de interés.
En este ejercicio, utilizará un enfoque paso a paso para agregar predictores al modelo uno por uno hasta que no se observe ningún beneficio adicional.
library(MASS)
## ## Attaching package: 'MASS'
## The following object is masked from 'package:dplyr': ## ## select
# Specify a null model with no predictors
null_model <- glm(donated ~ 1, data = donors, family = "binomial")
# Specify the full model using all of the potential predictors
full_model <- glm(donated ~ . , data = donors, family = "binomial")
# Stepwise regression model
step_model <- step(null_model,
direction = "both",
scope = list(upper = full_model,
lower = null_model),
trace = 0)
## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit ## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit ## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit ## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit ## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit ## Warning in add1.glm(fit, scope$add, scale = scale, trace = trace, k = k, : ## using the 70916/93462 rows from a combined fit
summary(step_model)
## ## Call: ## glm(formula = donated ~ frequency + money + wealth_rating + has_children + ## pet_owner, family = "binomial", data = donors) ## ## Deviance Residuals: ## Min 1Q Median 3Q Max ## -0.4023 -0.3625 -0.2988 -0.2847 2.7328 ## ## Coefficients: ## Estimate Std. Error z value Pr(>|z|) ## (Intercept) -3.05529 0.04556 -67.058 < 2e-16 *** ## frequencyINFREQUENT -0.49649 0.03100 -16.017 < 2e-16 *** ## moneyMEDIUM 0.36594 0.04301 8.508 < 2e-16 *** ## wealth_rating 0.03294 0.01238 2.660 0.007805 ** ## has_children -0.15820 0.04707 -3.361 0.000777 *** ## pet_owner 0.11712 0.04096 2.860 0.004243 ** ## --- ## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ## ## (Dispersion parameter for binomial family taken to be 1) ## ## Null deviance: 37330 on 93461 degrees of freedom ## Residual deviance: 36920 on 93456 degrees of freedom ## AIC: 36932 ## ## Number of Fisher Scoring iterations: 6
step_prob <- predict(step_model, type = "response") library(pROC) ROC1 <- roc(donors$donated, step_prob)
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
plot(ROC1, col = "red")
auc(ROC1)
## Area under the curve: 0.5855
library(openxlsx)
hurricanes <- read.xlsx("https://userpage.fu-berlin.de/soga/data/raw-data/hurricanes.xlsx")
str(hurricanes)
## 'data.frame': 337 obs. of 12 variables: ## $ RowNames: chr "1" "2" "3" "4" ... ## $ Number : num 430 432 433 436 437 438 440 441 445 449 ... ## $ Name : chr "NOTNAMED" "NOTNAMED" "NOTNAMED" "NOTNAMED" ... ## $ Year : num 1944 1944 1944 1944 1944 ... ## $ Type : num 1 0 0 0 0 1 0 1 0 0 ... ## $ FirstLat: num 30.2 25.6 14.2 20.8 20 29.2 16.1 27.6 21.6 19 ... ## $ FirstLon: num -76.1 -74.9 -65.2 -58 -84.2 -55.8 -80.8 -85.6 -95.2 -56.6 ... ## $ MaxLat : num 32.1 31 16.6 26.3 20.6 38 21.9 27.6 28.6 24.9 ... ## $ MaxLon : num -74.8 -78.1 -72.2 -72.3 -84.9 -53.2 -82.9 -85.6 -96.1 -79.6 ... ## $ LastLat : num 35.1 32.6 20.6 42.1 19.1 50 28.4 31.7 29.5 28.9 ... ## $ LastLon : num -69.2 -78.2 -88.5 -71.5 -93.9 -46.5 -82.1 -79.1 -96 -81.8 ... ## $ MaxInt : num 80 80 105 120 70 85 105 100 120 120 ...
library(ggplot2) ggplot(hurricanes, aes(x = Year)) + geom_bar(stat = "count")
Graficamos los tipos de huracanes
Contamos como estan las categorias:
hurricanes_table <- table(hurricanes$Type) hurricanes_table
## ## 0 1 3 ## 187 77 73
Categorizamos en dos conjuntos:
hurricanes$Type_new <- ifelse(test = hurricanes$Type == 0, yes = 0, no = 1)
Visualizamos como quedan los conjuntos:
table(hurricanes$Type_new)
## ## 0 1 ## 187 150
Graficarlo
options(viewer = NULL)
library(leaflet)
m <- leaflet()
m <- addTiles(m)
m <- addProviderTiles(m, "Esri.OceanBasemap")
cols <- c("red", "navy")
m <- addCircleMarkers(m,
lng = hurricanes$FirstLon,
lat = hurricanes$FirstLat,
radius = 2.5,
color = cols[hurricanes$Type_new + 1],
popup = paste("Year:", as.character(hurricanes$Year))
)
m <- addLegend(m,
"topright",
colors = cols,
labels = c("tropical", "non-tropical"),
title = "Type of Hurricane",
opacity = 1
)
m
Graficarlo
Ajustado el modelo:
log_model <- glm(Type_new ~ FirstLat, data = hurricanes, family = "binomial") summary(log_model)
## ## Call: ## glm(formula = Type_new ~ FirstLat, family = "binomial", data = hurricanes) ## ## Deviance Residuals: ## Min 1Q Median 3Q Max ## -2.1841 -0.4954 -0.1664 0.4718 3.2397 ## ## Coefficients: ## Estimate Std. Error z value Pr(>|z|) ## (Intercept) -9.08263 0.96148 -9.446 <2e-16 *** ## FirstLat 0.37283 0.03947 9.447 <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: 463.11 on 336 degrees of freedom ## Residual deviance: 232.03 on 335 degrees of freedom ## AIC: 236.03 ## ## Number of Fisher Scoring iterations: 6
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
auc(ROC3)
## Area under the curve: 0.9249
Tarea, evaluar si este es el mejor modelo?
Quieren ver la solución?
solución
## ## Call: ## glm(formula = Type_new ~ FirstLat + LastLat + LastLon + Year + ## FirstLon, family = "binomial", data = hurricanes) ## ## Deviance Residuals: ## Min 1Q Median 3Q Max ## -2.59587 -0.37533 -0.04522 0.36649 2.71521 ## ## Coefficients: ## Estimate Std. Error z value Pr(>|z|) ## (Intercept) -70.40240 21.51235 -3.273 0.00107 ** ## FirstLat 0.48766 0.06026 8.093 5.83e-16 *** ## LastLat -0.15749 0.03536 -4.453 8.45e-06 *** ## LastLon 0.06222 0.01952 3.187 0.00144 ** ## Year 0.03327 0.01080 3.081 0.00206 ** ## FirstLon -0.03484 0.02115 -1.647 0.09952 . ## --- ## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 ## ## (Dispersion parameter for binomial family taken to be 1) ## ## Null deviance: 463.11 on 336 degrees of freedom ## Residual deviance: 195.35 on 331 degrees of freedom ## AIC: 207.35 ## ## Number of Fisher Scoring iterations: 6
## Setting levels: control = 0, case = 1
## Setting direction: controls < cases
## Area under the curve: 0.9473