Trabajo Práctico 3
library("data.table")
library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:data.table':
##
## between, first, last## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(tidyverse)## ── Attaching packages ─────────────────────────────────────────────────────────────────────────────────── tidyverse 1.2.1 ──## ✔ ggplot2 3.2.0 ✔ readr 1.3.1
## ✔ tibble 2.1.3 ✔ purrr 0.3.2
## ✔ tidyr 0.8.3 ✔ stringr 1.4.0
## ✔ ggplot2 3.2.0 ✔ forcats 0.4.0## ── Conflicts ────────────────────────────────────────────────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::between() masks data.table::between()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::first() masks data.table::first()
## ✖ dplyr::lag() masks stats::lag()
## ✖ dplyr::last() masks data.table::last()
## ✖ purrr::transpose() masks data.table::transpose()library(broom)
library(ISLR)
library(GGally)## Registered S3 method overwritten by 'GGally':
## method from
## +.gg ggplot2##
## Attaching package: 'GGally'## The following object is masked from 'package:dplyr':
##
## nasalibrary(modelr)##
## Attaching package: 'modelr'## The following object is masked from 'package:broom':
##
## bootstraplibrary(pROC)## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varlibrary(cowplot)##
## ********************************************************## Note: As of version 1.0.0, cowplot does not change the## default ggplot2 theme anymore. To recover the previous## behavior, execute:
## theme_set(theme_cowplot())## ********************************************************library(OneR)
library(rlang)##
## Attaching package: 'rlang'## The following objects are masked from 'package:purrr':
##
## %@%, as_function, flatten, flatten_chr, flatten_dbl,
## flatten_int, flatten_lgl, flatten_raw, invoke, list_along,
## modify, prepend, splice## The following object is masked from 'package:data.table':
##
## :=library(caret)## Loading required package: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## liftset.seed(1992)Lectura de mis datasets
df_train <- fread('titanic_complete_train.csv')
dim(df_train)## [1] 891 12df_test <- fread('titanic_complete_test.csv')
dim(df_test)## [1] 418 12df_all <- rbind(df_train, df_test)
glimpse(df_all)## Observations: 1,309
## Variables: 12
## $ PassengerId <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 1…
## $ Survived <int> 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1…
## $ Pclass <int> 3, 1, 3, 1, 3, 3, 1, 3, 3, 2, 3, 1, 3, 3, 3, 2, 3, 2…
## $ Name <chr> "Braund, Mr. Owen Harris", "Cumings, Mrs. John Bradl…
## $ Sex <chr> "male", "female", "female", "female", "male", "male"…
## $ Age <dbl> 22.00000, 38.00000, 26.00000, 35.00000, 35.00000, 26…
## $ SibSp <int> 1, 1, 0, 1, 0, 0, 0, 3, 0, 1, 1, 0, 0, 1, 0, 0, 4, 0…
## $ Parch <int> 0, 0, 0, 0, 0, 0, 0, 1, 2, 0, 1, 0, 0, 5, 0, 0, 1, 0…
## $ Ticket <chr> "A/5 21171", "PC 17599", "STON/O2. 3101282", "113803…
## $ Fare <dbl> 7.2500, 71.2833, 7.9250, 53.1000, 8.0500, 8.4583, 51…
## $ Cabin <chr> NA, "C85", NA, "C123", NA, NA, "E46", NA, NA, NA, "G…
## $ Embarked <chr> "S", "C", "S", "S", "S", "Q", "S", "S", "S", "C", "S…Conservo solo las variables indicadas y transformo Survived, Pclass y Embarked a factor.
df_train <- df_train %>% select(c('PassengerId', 'Survived', 'Pclass', 'Sex', 'Age', 'SibSp','Parch', 'Fare', 'Embarked'))
df_train$Survived <- as.factor(df_train$Survived)
df_train$Pclass <- as.factor(df_train$Pclass)
df_train$Embarked <- as.factor(df_train$Embarked)
df_train$Sex <- as.factor(df_train$Sex)
summary(df_train)## PassengerId Survived Pclass Sex Age
## Min. : 1.0 0:549 1:216 female:314 Min. : 0.42
## 1st Qu.:223.5 1:342 2:184 male :577 1st Qu.:21.75
## Median :446.0 3:491 Median :26.51
## Mean :446.0 Mean :29.32
## 3rd Qu.:668.5 3rd Qu.:36.00
## Max. :891.0 Max. :80.00
## SibSp Parch Fare Embarked
## Min. :0.000 Min. :0.0000 Min. : 0.00 C:168
## 1st Qu.:0.000 1st Qu.:0.0000 1st Qu.: 7.91 Q: 77
## Median :0.000 Median :0.0000 Median : 14.45 S:646
## Mean :0.523 Mean :0.3816 Mean : 32.20
## 3rd Qu.:1.000 3rd Qu.:0.0000 3rd Qu.: 31.00
## Max. :8.000 Max. :6.0000 Max. :512.33Realizamos un gráfico exploratorio completo para ver el comportamiento y las relaciones entre las variables.
df_train_gg <- df_train %>% select(Survived,Sex,Pclass,Age,Fare)
ggpairs(df_train_gg,mapping = aes(colour= Survived)) + theme(axis.text.x = element_text(angle = 90, hjust = 1)) + theme_bw()## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Correspondiendo el color azul a la personas que sobrevivieron y el rojo a las que no, vemos a siemple vista que son más las personas que no sobrevivieron que las que sobrevivieron.
A su vez observamos que la variable de supervivencia depende en gran medida de las variables Sex y Pclass. Si bien son la clase minoritaria (se observa hubo más hombres que mujeres a bordo, y mayor proporción de 3ra clase que segunda y primera), Las mujeres y aquellos de clase alta presentan una alta tasa de supervivencia en contrasete con su complemento.
Se ven bastantes outliers en la variable Fare, unas pocas personas pagaron un valor muy alto en comparación con la mediana poblacional.
Mostramos la distribución de clase (Sobrevivientes vs No Sobrevivientes)
classes <- df_train %>% group_by(Survived) %>% summarise(numero_de_casos=n())
ggplot(classes, aes(x=Survived, y=numero_de_casos, fill = Survived)) + geom_col() + labs(subtitle = "Distribución de sobrevivientes", x = "Supervivencia", y = "Número de casos") + guides(fill = "none") + theme_bw()
Dividir al dataset en conjunto de entrenamiento (70% de los datos) y validación (30% de los datos). Volver a analizar la distribución de clase para chequear que sea aproximadamente igual entre ambos conjuntos y respecto a la distribución de clase que obtuvieron para todo el dataset en el punto 1.E
train_val <- df_train %>% resample_partition(c(train=0.7,val=0.3))
df_train_set <- train_val$train %>% as_tibble()
dim(df_train_set)## [1] 623 9df_val_set <- train_val$val %>% as_tibble()
dim(df_val_set)## [1] 268 9classes_train <- df_train_set %>% group_by(Survived) %>% summarise(numero_de_casos=n())
classes_val<- df_val_set %>% group_by(Survived) %>% summarise(numero_de_casos=n())
ggplot(classes_train, aes(x=Survived, y=numero_de_casos, fill = Survived)) + geom_col() + labs(subtitle = "Distribución de sobrevivientes", x = "Supervivencia", y = "Número de casos") + guides(fill = "none") + theme_bw()
ggplot(classes_val, aes(x=Survived, y=numero_de_casos, fill = Survived)) + geom_col() + labs(subtitle = "Distribución de sobrevivientes", x = "Supervivencia", y = "Número de casos") + guides(fill = "none") + theme_bw()
Vemos que en ambos datasets, train y validación con 623 y 268 filas respectivamente, poseen una distribución similar de número de sobrevivientes.
Predicciones
Realizar un modelo de regresión logística para predecir la supervivencia en función de Pclass, Sex y Age. Usar solo el dataset de entrenamiento
model_p2 <- glm(Survived ~ Pclass + Sex + Age, data = df_train_set, family = "binomial")
summary(model_p2)##
## Call:
## glm(formula = Survived ~ Pclass + Sex + Age, family = "binomial",
## data = df_train_set)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.6908 -0.6562 -0.4564 0.6199 2.4514
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 3.673518 0.453574 8.099 5.54e-16 ***
## Pclass2 -0.914067 0.321464 -2.843 0.00446 **
## Pclass3 -2.359267 0.303473 -7.774 7.59e-15 ***
## Sexmale -2.456667 0.219553 -11.189 < 2e-16 ***
## Age -0.040252 0.009038 -4.454 8.44e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 831.47 on 622 degrees of freedom
## Residual deviance: 571.37 on 618 degrees of freedom
## AIC: 581.37
##
## Number of Fisher Scoring iterations: 4Para ello usamos la funcíón glm() nos permite crear un modelo lineal generalizado eligiendo la función link que vamos a utilizar en el modelo. En nuestro caso, Binomial: link=logit
Obtenemos un modelo, cuyos coeficientes son en todos los casos significativos. Podemos interpretarlos como, De ser hombre, a mayor edad, a menor clase, menor será la probabilidad de ser un sobreviviente (todos estos coeficientes tienen signo negativo).
¿Quién tiene una mayor probabilidad de supervivencia? Rose que es una mujer de 17 años que viaja en primera clase o Jack que es un hombre de 20 años viajando en tercera clase
De acuerdo a la interpretación de los coeficientes, Rose, una mujer joven de clase alta tiene mayores probabilidades de supervivencia que Jack, un hombre que si bien es joven, por el hecho de ser hombre y viajar en tercera clase la tendrá más dificil.
Calculando:
rose_type <- data.frame(Pclass = factor(1, levels = levels(df_train_set$Pclass)),
Sex = factor("female", levels = levels(df_train_set$Sex)),
Age = 17)
proba_rose <- predict(object = model_p2, newdata = rose_type, type = "response")
jacki_type <- data.frame(Pclass = factor(3, levels = levels(df_train_set$Pclass)),
Sex = factor("male", levels = levels(df_train_set$Sex)),
Age = 20)
proba_jack <- predict(object = model_p2, newdata = jacki_type, type = "response")
proba_rose## 1
## 0.9520853proba_jack## 1
## 0.1248308Vemos que una persona con las características de Rose tiene altas probabilidades de sobrevivir, un 96%. Mientras que una persona del estilo de Jack, solo tiene 12%.
Generación de modelos
Generar 3 modelos de regresión logística sobre el dataset de entrenamiento utilizando diferentes combinaciones de variables. Al menos dos modelos deben ser multivariados
Para ello utilizamos el paquete modelr para crear un objeto que contiene todas las fórmulas que vamos a utilizar. Sumamos el modelo del punto 2, para realizar comparaciones posteriores.
logit_formulas <- formulas(.response = ~Survived, # único lado derecho de las formulas.
modelop2= ~Sex+Pclass+Age,
modelo1= ~Sex+Pclass, ## El que mejor esperaría que clasifique acorde a lo que vimos en el ggplot
modelo2= ~Parch+Embarked+Age,
modelo3= ~Sex+Pclass+Embarked+Age
)
models <- data_frame(logit_formulas) %>% # dataframe a partir del objeto formulas
mutate(models = names(logit_formulas), # columna con los nombres de las formulas
expression = paste(logit_formulas), # columna con las expresiones de las formulas
mod = map(logit_formulas, ~glm(.,family = 'binomial', data = df_train_set))) ## Warning: `data_frame()` is deprecated, use `tibble()`.
## This warning is displayed once per session.models %>%
filter(models %in% c('modelo1','modelo2','modelo3')) %>%
mutate(tidy = map(mod,tidy)) %>%
unnest(tidy, .drop = TRUE) %>%
mutate(estimate=round(estimate,5),
p.value=round(p.value,4))## # A tibble: 16 x 7
## models expression term estimate std.error statistic p.value
## <chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
## 1 modelo1 Survived ~ Sex + Pc… (Inte… 2.12 0.259 8.19 0
## 2 modelo1 Survived ~ Sex + Pc… Sexma… -2.55 0.215 -11.8 0
## 3 modelo1 Survived ~ Sex + Pc… Pclas… -0.492 0.297 -1.66 0.0974
## 4 modelo1 Survived ~ Sex + Pc… Pclas… -1.71 0.252 -6.80 0
## 5 modelo2 Survived ~ Parch + … (Inte… 0.732 0.285 2.57 0.0102
## 6 modelo2 Survived ~ Parch + … Parch 0.163 0.100 1.63 0.104
## 7 modelo2 Survived ~ Parch + … Embar… -0.794 0.333 -2.38 0.0171
## 8 modelo2 Survived ~ Parch + … Embar… -0.995 0.218 -4.57 0
## 9 modelo2 Survived ~ Parch + … Age -0.0164 0.00660 -2.49 0.0129
## 10 modelo3 Survived ~ Sex + Pc… (Inte… 3.95 0.482 8.21 0
## 11 modelo3 Survived ~ Sex + Pc… Sexma… -2.41 0.221 -10.9 0
## 12 modelo3 Survived ~ Sex + Pc… Pclas… -0.732 0.332 -2.20 0.0275
## 13 modelo3 Survived ~ Sex + Pc… Pclas… -2.28 0.316 -7.21 0
## 14 modelo3 Survived ~ Sex + Pc… Embar… -0.111 0.429 -0.259 0.795
## 15 modelo3 Survived ~ Sex + Pc… Embar… -0.575 0.283 -2.04 0.0418
## 16 modelo3 Survived ~ Sex + Pc… Age -0.0391 0.00907 -4.31 0Interpretación de modelos
A simple vista, vemos que el modelo 1 (que utiliza las variables Sexo y Clase), es el único para el cual todos sus coeficientes resultaron significativos. Los coeficientes de Sexmale, Pclass2 y Pclass3 tienen el mismo signo obtenido para el modelo que tmb utiliza Age.
Para el modelo 2, notamos que la variable Parch no llega a ser significativa.
Para el modelo 3 obtuvimos algunas varaibles con coeficientes significativos, que resultaron ser las mismas que el modelo 1, sumado a age. Para esta ultima a mayor edad, menor la probabilidad de sobrevivir.
Ordenar por la deviance los 3 modelos creados en el punto 3)a) y el creado en el punto 2)a) y seleccionar el mejor modelo en términos de la deviance explicada
# Calcular las medidas de evaluación para cada modelo
models <- models %>%
mutate(glance = map(mod,glance))
# Obtener las medidas de evaluacion de interes
models %>%
unnest(glance, .drop = TRUE) %>%
# Calculo de la deviance explicada
mutate(perc_explained_dev = 1-deviance/null.deviance) %>%
select(-c(models, df.null, AIC, BIC)) %>%
arrange(deviance)## # A tibble: 4 x 6
## expression null.deviance logLik deviance df.residual perc_explained_…
## <chr> <dbl> <dbl> <dbl> <int> <dbl>
## 1 Survived ~ Se… 831. -283. 566. 616 0.319
## 2 Survived ~ Se… 831. -286. 571. 618 0.313
## 3 Survived ~ Se… 831. -296. 593. 619 0.287
## 4 Survived ~ Pa… 831. -401. 801. 618 0.0364Vemos que el modelo 3, el cual posee la mayor cantidad de variables, es el que menor deviance arroja (566). Observando su null.deviance, podemos concluir que la deviance explicada es de 32%.
El peor modelo, que no posee mis varaibles más relevantes posee una deviance explicada del 3%.
Evaluación del modelo (Trabajar con dataset de ENTRENAMIENTO)
Realizar el gráfico de curva ROC y obtener el AUC para el modelo elegido. Interpretar el gráfico
models <- models %>%
mutate(pred= map(mod,augment, type.predict = "response"))
prediction <- models %>%
filter(models=="modelo3") %>%
unnest(pred, .drop=TRUE)
roc_full <- roc(response=prediction$Survived, predictor=prediction$.fitted)## Setting levels: control = 0, case = 1## Setting direction: controls < casesggroc(list(full=roc_full), size=1) + geom_abline(slope = 1, intercept = 1, linetype='dashed') + theme_bw() + labs(title='Curvas ROC')
print(paste('AUC: Modelo_3', roc_full$auc))## [1] "AUC: Modelo_3 0.844229975451326"Las curvas ROC (Receiver Operating Characteristic) nos ayudan a determinar el punto de corte óptimo para el caso de uso que queremos darle a nuestro modelo. Básicamente, qué nos interesa? tener más recall, acompañado de FP, o apuntar a un modelo más conservador, con mayor precisión pero con mayor contidad de FN? En este sentido, si queremos focalizarnos en clasificar la mayor cantidad de positivos correctamente (tener mayor sensitivity), deberemos conformarnos con clasificar mal varios negativos (perder en specificity).
En la curva ROC, el eje X se refiere al FP rate (specifity), mientras que el eje Y se refiere al TP rate (Sensitivity). A medida que nos movemos a la derecha en la curva, perdemos specificity, pero ganamos en sensitivity.
Un punto de corte optimo parecería ser aquel que arroja 0.8 de sensitivity y specifity, donde la curva deja de crecer. Esto sería, clasificamos correctamente al 80% de los TP, pero a su vez incluímos un 20% de la otra clase en mi predicción (FP)
El area bajo la curva (AUC) resulta ser de 0.854. Un AUC por encima de 0.5 puede entenderse tiene capacidad de discriminación de clases.
Realizar un violin plot e interpretar
violin = ggplot(prediction, aes(x=Survived, y=.fitted, group=Survived, fill=Survived)) +
geom_violin() +
theme_bw() +
guides(fill=FALSE) +
labs(title='Violin plot Model_3', x='Supervivencia', y='Predicted probability')
violin
A partir de este diagrama podemos visualizar la distribución de los datos según su clase y la densidad de probabilidades que fueron predichas por el modelo. Las probabilidades asocaidas a la clase ‘no sobrevive’ están concentradas cerca de 0, mientras que las probabilidades asociadas a la clase ‘sobrevive’ se concentran más cerca al uno. Sin embargo, no existe un punto de corte óptimo, al menos con este modelo.
Elección del punto corte (Trabajar con dataset de VALIDACION)
Sobre el dataset de validación realizar un gráfico de Accuracy, Specificity, Recall y Precision en función del punto de corte
Para elegir nuestro punto de corte, usaremos el dataset de validación.
dim(df_val_set)## [1] 268 9models_v <- models %>%
filter(models=="modelo3") %>%
mutate(val= map(mod,augment, newdata=df_val_set, type.predict = "response"))
prediction_v <- models_v %>%
unnest(val, .drop=TRUE)
prediction_metrics <- function(cutoff, predictions=prediction_v){
table <- predictions %>%
mutate(predicted_class=if_else(.fitted>cutoff, 1, 0) %>% as.factor(),
Survived= factor(Survived))
confusionMatrix(table$predicted_class, table$Survived, positive = "1") %>%
tidy() %>%
select(term, estimate) %>%
filter(term %in% c('accuracy', 'sensitivity', 'specificity', 'precision','recall')) %>%
mutate(cutoff=cutoff)
}
# Creación del gráfico de Accuracy, Sensitivity, Specificity, Recall y Precision en función de distintos puntos de corte.
cutoffs = seq(0.01,0.95,0.01)
logit_pred= map_dfr(cutoffs, prediction_metrics)%>% mutate(term=as.factor(term))## Warning in confusionMatrix.default(table$predicted_class, table$Survived, :
## Levels are not in the same order for reference and data. Refactoring data
## to match.
## Warning in confusionMatrix.default(table$predicted_class, table$Survived, :
## Levels are not in the same order for reference and data. Refactoring data
## to match.ggplot(logit_pred, aes(cutoff,estimate, group=term, color=term)) + geom_line(size=1) + theme_bw() +
labs(title= 'Accuracy, Sensitivity, Specificity, Recall y Precision', subtitle= 'Modelo 3', color="") + geom_vline(xintercept=0.4, linetype="dashed", color = "black")
Elegir un punto de corte y explicar su decisión
Siendo specifity igual a TN/(TN+FP), sensitivity o recall igual a TP/(TP+FN), precision igual a TP/(TP+FP) y accuracy a la métrica que engloba todo lo correctamente clasificado, (TP+TN)/(TP+FN+TN+FP) vemos que:
Siempre deberemos ser flexibles con una métrica para mejorar otra, si queremos ser conservadores a nivel general, el punto de corte que podríamos tomar sería 0.40. Allí vemos que la accuracy se estanca, y de seguir a cortes más altos comenzaremos a perder cada vez más en sensitivity empieza (pierdo gran parte de mi clase positiva capturada).
Por otro lado, para valores mayores a 0.4, mi precision y mi specificity aumentan. Esto es, pierdo en TP sí, pero tmb pierdo en FP. Soy más precisa, pero abarco menos. En specificity puedo verlo como, cada vez meto menos ‘basura’ dentro de mi predicción, a costas de cada vez entregar menos.
Obtener la matriz de confusión con el modelo y punto de corte elegidos. Interpretarla
sel_cutoff = 0.40
tabla <- prediction_v %>%
mutate(predicted_class=if_else(.fitted>sel_cutoff,"1", "0") %>% as.factor(),
Survived= factor(Survived)) %>% select(predicted_class,Survived)
confusionMatrix(table(tabla$predicted_class, tabla$Survived), positive = "1") ## Confusion Matrix and Statistics
##
##
## 0 1
## 0 133 20
## 1 34 81
##
## Accuracy : 0.7985
## 95% CI : (0.7454, 0.8449)
## No Information Rate : 0.6231
## P-Value [Acc > NIR] : 4.447e-10
##
## Kappa : 0.5824
##
## Mcnemar's Test P-Value : 0.07688
##
## Sensitivity : 0.8020
## Specificity : 0.7964
## Pos Pred Value : 0.7043
## Neg Pred Value : 0.8693
## Prevalence : 0.3769
## Detection Rate : 0.3022
## Detection Prevalence : 0.4291
## Balanced Accuracy : 0.7992
##
## 'Positive' Class : 1
## Esto implica tendremos 78 personas que sobreviven clasificadas correctamente por el modelo, mientras que otros 26 fueron clasificados erroneamente como no supervivientes (FN). El otro error que puede observarse, FP, es de 37.
Dataset de testeo (Trabajar con dataset de TESTEO)
Ya fijado el corte podemos utilizar nuestro dataset de testeo para evaluar la performance del modelo. De no performar correctamente, sería un error metódico modificar los hiperparametros en este punto (en este caso, el corte), mis resultados ya no serían validos para describir correctamente a mi modelo.
df_test <- df_test %>% select(c('PassengerId', 'Survived', 'Pclass', 'Sex', 'Age', 'SibSp','Parch', 'Fare', 'Embarked'))
df_test$Survived <- as.factor(df_test$Survived)
df_test$Pclass <- as.factor(df_test$Pclass)
df_test$Embarked <- as.factor(df_test$Embarked)
df_test$Sex <- as.factor(df_test$Sex)
summary(df_test)## PassengerId Survived Pclass Sex Age
## Min. : 892.0 0:261 1:107 female:152 Min. : 0.17
## 1st Qu.: 996.2 1:157 2: 93 male :266 1st Qu.:23.00
## Median :1100.5 3:218 Median :25.00
## Mean :1100.5 Mean :29.42
## 3rd Qu.:1204.8 3rd Qu.:36.38
## Max. :1309.0 Max. :76.00
## SibSp Parch Fare Embarked
## Min. :0.0000 Min. :0.0000 Min. : 0.000 C:102
## 1st Qu.:0.0000 1st Qu.:0.0000 1st Qu.: 7.896 Q: 46
## Median :0.0000 Median :0.0000 Median : 14.454 S:270
## Mean :0.4474 Mean :0.3923 Mean : 35.577
## 3rd Qu.:1.0000 3rd Qu.:0.0000 3rd Qu.: 31.472
## Max. :8.0000 Max. :9.0000 Max. :512.329Con el modelo y punto de corte elegidos clasificar a las personas del dataset de testing.
models_test <- models %>%
filter(models=="modelo3") %>%
mutate(val= map(mod,augment, newdata=df_test, type.predict = "response"))
prediction_test <- models_test %>%
unnest(val, .drop=TRUE)
tabla <- prediction_test %>%
mutate(predicted_class=if_else(.fitted>sel_cutoff,"1", "0") %>% as.factor(),
Survived= factor(Survived)) %>% select(predicted_class,Survived)
tabla## # A tibble: 418 x 2
## predicted_class Survived
## <fct> <fct>
## 1 0 0
## 2 0 1
## 3 0 0
## 4 0 0
## 5 1 1
## 6 0 1
## 7 1 0
## 8 0 1
## 9 1 1
## 10 0 0
## # … with 408 more rowsconfusionMatrix(table(tabla$predicted_class, tabla$Survived), positive = "1") ## Confusion Matrix and Statistics
##
##
## 0 1
## 0 192 38
## 1 69 119
##
## Accuracy : 0.744
## 95% CI : (0.6993, 0.7852)
## No Information Rate : 0.6244
## P-Value [Acc > NIR] : 1.419e-07
##
## Kappa : 0.4749
##
## Mcnemar's Test P-Value : 0.003729
##
## Sensitivity : 0.7580
## Specificity : 0.7356
## Pos Pred Value : 0.6330
## Neg Pred Value : 0.8348
## Prevalence : 0.3756
## Detection Rate : 0.2847
## Detection Prevalence : 0.4498
## Balanced Accuracy : 0.7468
##
## 'Positive' Class : 1
## Vemos mi acuracy es similar a la obtenida en mi dataset de validación, algo menor. Esto es entendible, ya que mi corte lo elegí para mejorar las métricas obtenidas en el dataset anterior. De haber obtenido un resultado mucho más chico, debería empezar a pensar en resolver problemas overfitting de mi modelo.
Vemos mi Sensitivity es muy similar al obtenido anteriormente, es decir, mis estoy clasificando las misma proporcion de postivos en forma correcta, mientras que mi Specificity baja 4 puntos porcentuales, a lo cual esta asociada la baja en mi accuracy.