Teoría

La regresión logística es un modelo estadístico de clasificación binaria, que estia la probabilidad de quje ocurra un evento (valor 1) frente a que no ocurra (valor 0), en función de variables independientes.

Cargar librerías

#install.packages("titanic")
library(titanic)
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.2     ✔ tibble    3.3.0
## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
## ✔ purrr     1.1.0     
## ── 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(caret)
## Cargando paquete requerido: lattice
## 
## Adjuntando el paquete: 'caret'
## 
## The following object is masked from 'package:purrr':
## 
##     lift

Cargar la base de datos

df <- titanic_train

Entender la base de datos

summary(df)
##   PassengerId       Survived          Pclass          Name          
##  Min.   :  1.0   Min.   :0.0000   Min.   :1.000   Length:891        
##  1st Qu.:223.5   1st Qu.:0.0000   1st Qu.:2.000   Class :character  
##  Median :446.0   Median :0.0000   Median :3.000   Mode  :character  
##  Mean   :446.0   Mean   :0.3838   Mean   :2.309                     
##  3rd Qu.:668.5   3rd Qu.:1.0000   3rd Qu.:3.000                     
##  Max.   :891.0   Max.   :1.0000   Max.   :3.000                     
##                                                                     
##      Sex                 Age            SibSp           Parch       
##  Length:891         Min.   : 0.42   Min.   :0.000   Min.   :0.0000  
##  Class :character   1st Qu.:20.12   1st Qu.:0.000   1st Qu.:0.0000  
##  Mode  :character   Median :28.00   Median :0.000   Median :0.0000  
##                     Mean   :29.70   Mean   :0.523   Mean   :0.3816  
##                     3rd Qu.:38.00   3rd Qu.:1.000   3rd Qu.:0.0000  
##                     Max.   :80.00   Max.   :8.000   Max.   :6.0000  
##                     NA's   :177                                     
##     Ticket               Fare           Cabin             Embarked        
##  Length:891         Min.   :  0.00   Length:891         Length:891        
##  Class :character   1st Qu.:  7.91   Class :character   Class :character  
##  Mode  :character   Median : 14.45   Mode  :character   Mode  :character  
##                     Mean   : 32.20                                        
##                     3rd Qu.: 31.00                                        
##                     Max.   :512.33                                        
## 
str(df)
## 'data.frame':    891 obs. of  12 variables:
##  $ PassengerId: int  1 2 3 4 5 6 7 8 9 10 ...
##  $ Survived   : int  0 1 1 1 0 0 0 0 1 1 ...
##  $ Pclass     : int  3 1 3 1 3 3 1 3 3 2 ...
##  $ Name       : chr  "Braund, Mr. Owen Harris" "Cumings, Mrs. John Bradley (Florence Briggs Thayer)" "Heikkinen, Miss. Laina" "Futrelle, Mrs. Jacques Heath (Lily May Peel)" ...
##  $ Sex        : chr  "male" "female" "female" "female" ...
##  $ Age        : num  22 38 26 35 35 NA 54 2 27 14 ...
##  $ SibSp      : int  1 1 0 1 0 0 0 3 0 1 ...
##  $ Parch      : int  0 0 0 0 0 0 0 1 2 0 ...
##  $ Ticket     : chr  "A/5 21171" "PC 17599" "STON/O2. 3101282" "113803" ...
##  $ Fare       : num  7.25 71.28 7.92 53.1 8.05 ...
##  $ Cabin      : chr  "" "C85" "" "C123" ...
##  $ Embarked   : chr  "S" "C" "S" "S" ...
df <- df[,c("Survived", "Pclass", "Sex", "Age")]
df <- na.omit(df)
df$Pclass <- as.factor(df$Pclass)
df$Sex <- as.factor(df$Sex)
df$Survived <- as.factor(df$Survived)

Crear el modelo

modelo <- glm(Survived ~ ., data = df, family = binomial)
summary(modelo)
## 
## Call:
## glm(formula = Survived ~ ., family = binomial, data = df)
## 
## Coefficients:
##              Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  3.777013   0.401123   9.416  < 2e-16 ***
## Pclass2     -1.309799   0.278066  -4.710 2.47e-06 ***
## Pclass3     -2.580625   0.281442  -9.169  < 2e-16 ***
## Sexmale     -2.522781   0.207391 -12.164  < 2e-16 ***
## Age         -0.036985   0.007656  -4.831 1.36e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 964.52  on 713  degrees of freedom
## Residual deviance: 647.28  on 709  degrees of freedom
## AIC: 657.28
## 
## Number of Fisher Scoring iterations: 5

Probar el modelo

prueba <- data.frame(Pclass = as.factor(c(1,3,1)), Sex = as.factor(c("female", "male", "male")), Age = c(25,40,30))
probabilidad <- predict(modelo, newdata = prueba, type = "response")
cbind(prueba, Probabilidad_Sobrevive = probabilidad)
##   Pclass    Sex Age Probabilidad_Sobrevive
## 1      1 female  25             0.94544163
## 2      3   male  40             0.05701133
## 3      1   male  30             0.53610549

Conclusiones

De acuerco con nuestro modelo de regresión logística las variables más importantes para predecir si una persona sobrevivió al hundimiento del Titanic son:

  • La clase (segunda o tercera)
  • El género
  • La edad

Con la clase y el género teniendo una mayor influencia en el modelo. Al utilizar datos falsos para predecir el resultado de la supervivencia de dos viajeros, notamos que el la mujer de 25 de clase 1 tiene considerablemente una mayor probabilidad de sobrevivir al naufragio. Es importante considerar que el modelo le dio una gran importancia al género de la persona ya que la probabilidad que una mujer sobreviva es mayor que la de un hombre en la misma clase que está en el mismo rango de edad.

LS0tDQp0aXRsZTogIlJlZ3Jlc2lvbl9Mb2dpc3RpY2EiDQphdXRob3I6ICJFcmlrIEdvbnphbGV6Ig0KZGF0ZTogIjIwMjUtMDgtMjkiDQpvdXRwdXQ6IA0KICBodG1sX2RvY3VtZW50OiANCiAgICB0b2M6IFRSVUUNCiAgICB0b2NfZmxvYXQ6IFRydWUgDQogICAgY29kZV9kb3dubG9hZDogVFJVRQ0KICAgIHRoZW1lOiBib290c3RyYXANCi0tLQ0KDQojIDxzcGFuIHN0eWxlID0gImNvbG9yOmJsdWU7Ij4gVGVvcsOtYSA8L3NwYW4+DQpMYSAqcmVncmVzacOzbiBsb2fDrXN0aWNhKiBlcyB1biBtb2RlbG8gZXN0YWTDrXN0aWNvIGRlIGNsYXNpZmljYWNpw7NuIGJpbmFyaWEsIHF1ZSBlc3RpYSBsYSBwcm9iYWJpbGlkYWQgZGUgcXVqZSBvY3VycmEgdW4gZXZlbnRvICh2YWxvciAxKSBmcmVudGUgYSBxdWUgbm8gb2N1cnJhICh2YWxvciAwKSwgZW4gZnVuY2nDs24gZGUgdmFyaWFibGVzIGluZGVwZW5kaWVudGVzLiANCg0KIyA8c3BhbiBzdHlsZSA9ICJjb2xvcjpibHVlOyI+IENhcmdhciBsaWJyZXLDrWFzIDwvc3Bhbj4NCmBgYHtyfQ0KI2luc3RhbGwucGFja2FnZXMoInRpdGFuaWMiKQ0KbGlicmFyeSh0aXRhbmljKQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpsaWJyYXJ5KGNhcmV0KQ0KYGBgDQoNCg0KIyA8c3BhbiBzdHlsZSA9ICJjb2xvcjpibHVlOyI+IENhcmdhciBsYSBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4NCmBgYHtyfQ0KZGYgPC0gdGl0YW5pY190cmFpbg0KYGBgDQoNCg0KDQojIDxzcGFuIHN0eWxlID0gImNvbG9yOmJsdWU7Ij4gRW50ZW5kZXIgbGEgYmFzZSBkZSBkYXRvcyA8L3NwYW4+DQpgYGB7cn0NCnN1bW1hcnkoZGYpDQpzdHIoZGYpDQpkZiA8LSBkZlssYygiU3Vydml2ZWQiLCAiUGNsYXNzIiwgIlNleCIsICJBZ2UiKV0NCmRmIDwtIG5hLm9taXQoZGYpDQpkZiRQY2xhc3MgPC0gYXMuZmFjdG9yKGRmJFBjbGFzcykNCmRmJFNleCA8LSBhcy5mYWN0b3IoZGYkU2V4KQ0KZGYkU3Vydml2ZWQgPC0gYXMuZmFjdG9yKGRmJFN1cnZpdmVkKQ0KYGBgDQojIDxzcGFuIHN0eWxlID0gImNvbG9yOmJsdWU7Ij4gQ3JlYXIgZWwgbW9kZWxvIDwvc3Bhbj4NCmBgYHtyfQ0KbW9kZWxvIDwtIGdsbShTdXJ2aXZlZCB+IC4sIGRhdGEgPSBkZiwgZmFtaWx5ID0gYmlub21pYWwpDQpzdW1tYXJ5KG1vZGVsbykNCmBgYA0KDQojIDxzcGFuIHN0eWxlID0gImNvbG9yOmJsdWU7Ij4gUHJvYmFyIGVsIG1vZGVsbyA8L3NwYW4+DQpgYGB7cn0NCnBydWViYSA8LSBkYXRhLmZyYW1lKFBjbGFzcyA9IGFzLmZhY3RvcihjKDEsMywxKSksIFNleCA9IGFzLmZhY3RvcihjKCJmZW1hbGUiLCAibWFsZSIsICJtYWxlIikpLCBBZ2UgPSBjKDI1LDQwLDMwKSkNCnByb2JhYmlsaWRhZCA8LSBwcmVkaWN0KG1vZGVsbywgbmV3ZGF0YSA9IHBydWViYSwgdHlwZSA9ICJyZXNwb25zZSIpDQpjYmluZChwcnVlYmEsIFByb2JhYmlsaWRhZF9Tb2JyZXZpdmUgPSBwcm9iYWJpbGlkYWQpDQpgYGANCg0KDQojIDxzcGFuIHN0eWxlID0gImNvbG9yOmJsdWU7Ij4gQ29uY2x1c2lvbmVzIDwvc3Bhbj4NCkRlIGFjdWVyY28gY29uIG51ZXN0cm8gbW9kZWxvIGRlIHJlZ3Jlc2nDs24gbG9nw61zdGljYSBsYXMgdmFyaWFibGVzIG3DoXMgaW1wb3J0YW50ZXMgcGFyYSBwcmVkZWNpciBzaSB1bmEgcGVyc29uYSBzb2JyZXZpdmnDsyBhbCBodW5kaW1pZW50byBkZWwgVGl0YW5pYyBzb246IA0KDQotIExhIGNsYXNlIChzZWd1bmRhIG8gdGVyY2VyYSkNCi0gRWwgZ8OpbmVybw0KLSBMYSBlZGFkDQoNCkNvbiBsYSBjbGFzZSB5IGVsIGfDqW5lcm8gdGVuaWVuZG8gdW5hIG1heW9yIGluZmx1ZW5jaWEgZW4gZWwgbW9kZWxvLiBBbCB1dGlsaXphciBkYXRvcyBmYWxzb3MgcGFyYSBwcmVkZWNpciBlbCByZXN1bHRhZG8gZGUgbGEgc3VwZXJ2aXZlbmNpYSBkZSBkb3MgdmlhamVyb3MsIG5vdGFtb3MgcXVlIGVsIGxhIG11amVyIGRlIDI1IGRlIGNsYXNlIDEgdGllbmUgY29uc2lkZXJhYmxlbWVudGUgdW5hIG1heW9yIHByb2JhYmlsaWRhZCBkZSBzb2JyZXZpdmlyIGFsIG5hdWZyYWdpby4gRXMgaW1wb3J0YW50ZSBjb25zaWRlcmFyIHF1ZSBlbCBtb2RlbG8gbGUgZGlvIHVuYSBncmFuIGltcG9ydGFuY2lhIGFsIGfDqW5lcm8gZGUgbGEgcGVyc29uYSB5YSBxdWUgbGEgcHJvYmFiaWxpZGFkIHF1ZSB1bmEgbXVqZXIgc29icmV2aXZhIGVzIG1heW9yIHF1ZSBsYSBkZSB1biBob21icmUgZW4gbGEgbWlzbWEgY2xhc2UgcXVlIGVzdMOhIGVuIGVsIG1pc21vIHJhbmdvIGRlIGVkYWQuIA0K