Homework4
Charris Rosmery, Coronell Karen, Diaz Astrid
7/3/2021
#load functions
source('https://www.dropbox.com/s/gnwm7vuvhojg9q4/logistic-functions.R?dl=1')## Esta es una colección de funciones creadas
## por el profesor Jorge Vélez <https://jivelez.github.io/>
## para el ajuste y validación de modelos de Regresión LogÃstica
##
## En caso de presentar algún inconveniente, por favor
## repórtelo a jvelezv@uninorte.edu.co
## Contexto
Cuando miramos los datos de divorcios de 33 países miembros de la Organización para la Cooperación y el Desarrollo Económicos (OCDE), se ve que Turquía se encuentra entre los 12 países con una tasa de divorcios en aumento. Esto plantea la necesidad de desarrollar políticas y prácticas científicas sobre las causas y la prevención del divorcio.
Los datos de la investigación se recopilaron mediante la técnica de entrevista cara a cara y a través de Google Drive, incluyen preguntas sobre género, estado civil, edad, ingresos mensuales, estructura familiar, tipo de matrimonio, felicidad en el matrimonio y pensamiento de divorcio.
Los participantes divorciados respondieron los ítems de la escala considerando sus matrimonios. Y, de los participantes casados, solo aquellos con matrimonios felices, sin ningún pensamiento de divorcio, fueron incluidos en el estudio.
De estudios anteriores, se ha descrito que de los participantes, 84 (49%) estaban divorciados y 86 (51%) eran parejas casadas. Había 84 hombres (49%) y 86 mujeres (51%) en el grupo de estudio. Las edades de los participantes variaron de 20 a 63 (X̄ = 36.04, SD = 9.34). Aunque los datos del estudio se recopilaron de siete regiones diferentes de Turquía, los datos fueron predominantemente de la región del Mar Negro (n = 79). De los participantes, 74 (43,5%) estaban casados por amor y 96 (56,5%) estaban casados en un matrimonio concertado. Mientras que 127 (74,7%) de los participantes tenían hijos, 43 (25,3%) no tenían hijos. Además, 18 (10.58%) de los participantes eran graduados de la escuela primaria, 15 (8.8%) eran graduados de la escuela secundaria, 33 (19.41%) eran graduados de la escuela secundaria, 88 (51.76%) eran graduados universitarios y 15 (8.8%) ) tenía una maestría.
En el siguiente estudio se construyó un RF para predecir la clase divorced o married a partir de las 54 preguntas x1, x2,…, x54 utilizando los datos de divorcio, Además se calculó un intervalo de confianza del 95 % para el lift y se establecieron resultados del clasificador (AUC, intervalo de confianza para el lift, curva ROC y TCC).
Lectura de la base de datos
divorce <- read_delim("C:/Users/hp/Downloads/divorce.csv",";", escape_double = FALSE, trim_ws = TRUE)
k<-head(divorce,10)
kable( k, caption = "Presentación de las primeras 10 observaciones, de la base de datos divorce", row.names = TRUE
, digits = 1
, format.args = list( decimal.mark = ","))%>%
kable_paper() %>%
scroll_box(width = "650px", height = "400px")%>%
footnote(general = "https://archive.ics.uci.edu/ml/datasets/Divorce+Predictors+data+set#")| Atr1 | Atr2 | Atr3 | Atr4 | Atr5 | Atr6 | Atr7 | Atr8 | Atr9 | Atr10 | Atr11 | Atr12 | Atr13 | Atr14 | Atr15 | Atr16 | Atr17 | Atr18 | Atr19 | Atr20 | Atr21 | Atr22 | Atr23 | Atr24 | Atr25 | Atr26 | Atr27 | Atr28 | Atr29 | Atr30 | Atr31 | Atr32 | Atr33 | Atr34 | Atr35 | Atr36 | Atr37 | Atr38 | Atr39 | Atr40 | Atr41 | Atr42 | Atr43 | Atr44 | Atr45 | Atr46 | Atr47 | Atr48 | Atr49 | Atr50 | Atr51 | Atr52 | Atr53 | Atr54 | y | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 1 | 2 | 2 | 4 | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 1 | 0 | 1 | 1 | 0 | 1 | 0 | 0 | 0 | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 1 | 1 | 2 | 1 | 2 | 0 | 1 | 2 | 1 | 3 | 3 | 2 | 1 | 1 | 2 | 3 | 2 | 1 | 3 | 3 | 3 | 2 | 3 | 2 | 1 | 1 |
| 2 | 4 | 4 | 4 | 4 | 4 | 0 | 0 | 4 | 4 | 4 | 4 | 3 | 4 | 0 | 4 | 4 | 4 | 4 | 3 | 2 | 1 | 1 | 0 | 2 | 2 | 1 | 2 | 0 | 1 | 1 | 0 | 4 | 2 | 3 | 0 | 2 | 3 | 4 | 2 | 4 | 2 | 2 | 3 | 4 | 2 | 2 | 2 | 3 | 4 | 4 | 4 | 4 | 2 | 2 | 1 |
| 3 | 2 | 2 | 2 | 2 | 1 | 3 | 2 | 1 | 1 | 2 | 3 | 4 | 2 | 3 | 3 | 3 | 3 | 3 | 3 | 2 | 1 | 0 | 1 | 2 | 2 | 2 | 2 | 2 | 3 | 2 | 3 | 3 | 1 | 1 | 1 | 1 | 2 | 1 | 3 | 3 | 3 | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 1 | 1 | 1 | 2 | 2 | 2 | 1 |
| 4 | 3 | 2 | 3 | 2 | 3 | 3 | 3 | 3 | 3 | 3 | 4 | 3 | 3 | 4 | 3 | 3 | 3 | 3 | 3 | 4 | 1 | 1 | 1 | 1 | 2 | 1 | 1 | 1 | 1 | 3 | 2 | 3 | 2 | 2 | 1 | 1 | 3 | 3 | 4 | 4 | 2 | 2 | 3 | 2 | 3 | 2 | 2 | 3 | 3 | 3 | 3 | 2 | 2 | 2 | 1 |
| 5 | 2 | 2 | 1 | 1 | 1 | 1 | 0 | 0 | 0 | 0 | 0 | 1 | 0 | 1 | 1 | 1 | 1 | 1 | 2 | 1 | 1 | 0 | 0 | 0 | 0 | 2 | 1 | 2 | 1 | 1 | 1 | 1 | 1 | 1 | 0 | 0 | 0 | 0 | 2 | 1 | 0 | 2 | 3 | 0 | 2 | 2 | 1 | 2 | 3 | 2 | 2 | 2 | 1 | 0 | 1 |
| 6 | 0 | 0 | 1 | 0 | 0 | 2 | 0 | 0 | 0 | 1 | 0 | 2 | 1 | 0 | 2 | 0 | 2 | 1 | 0 | 1 | 0 | 0 | 0 | 0 | 2 | 2 | 0 | 0 | 0 | 0 | 4 | 1 | 1 | 1 | 1 | 1 | 1 | 2 | 0 | 2 | 2 | 1 | 2 | 3 | 0 | 2 | 2 | 1 | 2 | 1 | 1 | 1 | 2 | 0 | 1 |
| 7 | 3 | 3 | 3 | 2 | 1 | 3 | 4 | 3 | 2 | 2 | 2 | 2 | 2 | 3 | 2 | 3 | 3 | 3 | 3 | 2 | 3 | 3 | 3 | 3 | 2 | 3 | 3 | 2 | 2 | 2 | 1 | 2 | 2 | 1 | 1 | 2 | 3 | 2 | 2 | 3 | 3 | 3 | 3 | 4 | 3 | 3 | 2 | 3 | 2 | 3 | 3 | 2 | 2 | 2 | 1 |
| 8 | 2 | 1 | 2 | 2 | 2 | 1 | 0 | 3 | 3 | 2 | 4 | 3 | 2 | 3 | 4 | 3 | 2 | 3 | 2 | 1 | 2 | 1 | 1 | 2 | 3 | 3 | 2 | 2 | 2 | 3 | 1 | 1 | 0 | 2 | 2 | 1 | 4 | 4 | 4 | 4 | 4 | 4 | 3 | 2 | 0 | 0 | 1 | 2 | 2 | 2 | 1 | 1 | 1 | 0 | 1 |
| 9 | 2 | 2 | 1 | 0 | 0 | 4 | 1 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 3 | 2 | 2 | 2 | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 2 | 2 | 2 | 2 | 2 | 2 | 2 | 2 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 |
| 10 | 1 | 1 | 1 | 1 | 1 | 2 | 0 | 2 | 2 | 2 | 3 | 0 | 0 | 2 | 1 | 0 | 1 | 2 | 1 | 0 | 0 | 0 | 0 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 0 | 1 | 0 | 0 | 1 | 1 | 2 | 2 | 1 | 2 | 3 | 2 | 2 | 2 | 0 | 2 | 2 | 2 | 2 | 4 | 3 | 3 | 1 |
dim(divorce)## [1] 170 55La base de datos divorce, cuenta con 170 individuos, a quienes se les realizó 54 preguntas, las cuales son nuestras variables predictoras, y una variable llamada y de tipo dicotómico, que representa el estado civil del individuo(casado o divorciado).
A la variable y las volvemos factor.
require(stringr)
divorce$y<-factor(divorce$y)
reemplazos<-c("0"="casado","1"="divorciado")
divorce$y<-factor(str_replace_all( divorce$y, reemplazos ))
levels(divorce$y)## [1] "casado" "divorciado"x<-divorce[,1:54]Revisamos el modelo teniendo en cuenta la metrica de Accuracy
## Subconjuntos Training y Testing
intrain <- createDataPartition(y = divorce$y, p= 0.7, list = FALSE)
training <- divorce[intrain,]
testing <- divorce[-intrain,]## Control de parámetros en caret
control <- trainControl(method = "repeatedcv",
number = 10,
repeats = 3)
## Método de comparación elegido es el AUC
metric <- "Accuracy"
set.seed(123)
mtry <- sqrt(ncol(x))
tunegrid <- expand.grid(.mtry=mtry)
rf_default <- train(y~.,
data=training,
method='rf',
metric='Accuracy',
tuneGrid=tunegrid,
trControl=control)
print(rf_default)## Random Forest
##
## 120 samples
## 54 predictor
## 2 classes: 'casado', 'divorciado'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold, repeated 3 times)
## Summary of sample sizes: 107, 108, 108, 108, 108, 108, ...
## Resampling results:
##
## Accuracy Kappa
## 0.9752137 0.9500079
##
## Tuning parameter 'mtry' was held constant at a value of 7.348469Determinamos medidas de clasificación del modelo sobre el traininig y el testing
## training
test_pred_RF <- predict(rf_default, newdata = training)
m <- confusionMatrix(test_pred_RF, factor(training$y, levels = c('casado','divorciado')))$table
(mtraining <- m[2:1, 2:1])## Reference
## Prediction divorciado casado
## divorciado 59 0
## casado 0 61measures(mtraining)## sensitivity specificity ppv npv fdr fpr
## 1.000000 1.000000 1.000000 1.000000 0.000000 0.000000
## class_rate lift delta
## 1.000000 2.033898 0.000000rft(mtraining, graph = FALSE)$auc## [1] 1## testing
test_pred_RFT <- predict(rf_default,
newdata = testing)
m <- confusionMatrix(test_pred_RFT, factor(testing$y, levels = c('casado','divorciado')))$table
(mtesting <- m[2:1, 2:1])## Reference
## Prediction divorciado casado
## divorciado 24 0
## casado 1 25measures(mtesting)## sensitivity specificity ppv npv fdr fpr
## 0.9600000 1.0000000 1.0000000 0.9615385 0.0000000 0.0000000
## class_rate lift delta
## 0.9800000 2.0000000 0.0400000Modelo Final
rf_default$finalModel##
## Call:
## randomForest(x = x, y = y, mtry = param$mtry)
## Type of random forest: classification
## Number of trees: 500
## No. of variables tried at each split: 7
##
## OOB estimate of error rate: 2.5%
## Confusion matrix:
## casado divorciado class.error
## casado 61 0 0.00000000
## divorciado 3 56 0.05084746Realizamos la grafica ROC
## nice colors
cols <- c("#0080ff", "#ff00ff", "darkgreen", "#ff0000",
"orange", "#00ff00", "brown")
par(mfrow = c(1, 1), mar = c(4, 4, 2, 1))
rft(mtraining, las = 1)$auc## [1] 1rft(mtesting, las = 1, add = TRUE, line.col =cols[2])$auc
## [1] 0.98lift modelo final
library(funModeling)
require(purrr)
require(caret)
lift1=lift(y ~ Atr1 + Atr18 + Atr37 + Atr42 + Atr49, data=divorce);lift1##
## Call:
## lift.formula(x = y ~ Atr1 + Atr18 + Atr37 + Atr42 + Atr49, data = divorce)
##
## Models: Atr1, Atr18, Atr37, Atr42, Atr49
## Event: casado (50.6%)