EXAMEN_INTERMEDIO
Maria Alejandra Molina Berbeo
9/5/2021
EXámen intermedio de R data science
Pregunta 1
Codificar las variable wine_type (white= 1 y red=2) y particionar los datos en entrenamiento (75%) y prueba (25%)
knitr::opts_chunk$set(echo = TRUE)
library(knitr)
require("knitr")
opts_knit$set(root.dir = "D:/Curso_R_Social_data/EXAMEN_R_INTERMEDIO_files")library(e1071)
library(caTools)
library(MASS)
library(ROSE)## Loaded ROSE 0.0-3library(caret)## Loading required package: lattice## Loading required package: ggplot2library(ROCR)
library(ggplot2)
library(pROC)## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, var#Lectura de archivo
vino<-read.csv("D:/Curso_R_Social_data/EXAMEN_R_INTERMEDIO_files/wines_types - wines_types.csv")
#Se evidencia que hay datos mal escritos,se encuentran 40 registros con números extraños y se eliminan
#Rectifico que todas sean tipo numérico
vino[,1:11]= apply(vino[,1:11], MARGIN=2, FUN=function(x){as.numeric(as.character(x))})## Warning in FUN(newX[, i], ...): NAs introducidos por coerción#Identifico los valores raros
raros=which(is.na(vino),arr.ind = T)
#Los elimino de mi base de datos
vino=vino[-raros[,1],]
#1. Codificar las variable wine_type (white= 1 y red=2) y particionar
#los datos en entrenamiento (75%) y prueba (25%)
#Codificación de la variable wine_type (white =0, red =1)
vino$wine_cat=ifelse(vino$wine_type=="white",0,1)
vino$wine_cat=as.factor(vino$wine_cat)
str(vino)## 'data.frame': 6457 obs. of 13 variables:
## $ fixed.acidity : num 7 7.7 6.8 6.3 7.4 7.2 7.5 6.8 9 7.1 ...
## $ volatile.acidity : num 0.17 0.64 0.39 0.28 0.35 0.53 0.27 0.11 0.44 0.23 ...
## $ citric.acid : num 0.74 0.21 0.34 0.47 0.2 0.14 0.31 0.27 0.49 0.3 ...
## $ residual.sugar : num 12.8 2.2 7.4 11.2 13.9 2.1 17.7 8.6 2.4 2.6 ...
## $ chlorides : num 45 77 0.02 0.04 54 64 51 44 78 34 ...
## $ free.sulfur.dioxide : num 24 32 38 61 63 15 33 45 26 62 ...
## $ total.sulfur.dioxide: num 126 133 133 183 229 29 173 104 121 148 ...
## $ density : num 9.94 9.96 99.21 99.59 99.89 ...
## $ pH : num 3.26 3.27 3.18 3.12 3.11 3.35 3.09 3.2 3.23 3.03 ...
## $ sulphates : num 0.38 0.45 0.44 0.51 0.5 0.61 0.64 0.37 0.58 0.56 ...
## $ alcohol : num 12.2 9.9 12 9.5 8.9 12.1 10.2 9.9 9.2 11.3 ...
## $ wine_type : Factor w/ 2 levels "red","white": 2 1 2 2 2 1 2 2 1 2 ...
## $ wine_cat : Factor w/ 2 levels "0","1": 1 2 1 1 1 2 1 1 2 1 ...#Particionar los datos en entrenamiento (75%) y prueba (25%)
set.seed(2019)
generar = sample.split(vino$wine_cat, SplitRatio = 0.75)
d_entrenamiento = subset(vino, generar == TRUE)
d_prueba = subset(vino, generar == FALSE)
#Proporción de observaciones de entrenamiento
(prop.table(table(d_entrenamiento$wine_cat)))*100##
## 0 1
## 75.32521 24.67479table(d_entrenamiento$wine_cat)##
## 0 1
## 3648 1195#(prop.table(table(d_prueba$wine_cat)))*100
#set.seed(10)
#balanceo de datos
data_balanced_entrenamiento1 <- ovun.sample(wine_cat~., data=d_entrenamiento,
p=0.50, seed=2050, method="over",na.action=na.pass)
data_balanced_entrenamiento2 <- ovun.sample(wine_cat~., data=d_entrenamiento,
p=0.50, seed=2050, method="under",na.action=na.pass)
data_balanced_entrenamiento3 <- ovun.sample(wine_cat~., data=d_entrenamiento,
p=0.50, seed=2050, method="both",na.action=na.pass)
#Generar modelo gml
#Modelo con data balanceada por método over
vino_modelo_over <- glm(wine_cat~.,
family = binomial(link = "logit"),
data=data_balanced_entrenamiento1$data[,-12])
#Modelo con data balanceada por método under
#Modelo escogido
vino_modelo_under <- glm(wine_cat~.,
family = binomial(link = "logit"),
data=data_balanced_entrenamiento2$data[,-12])
#Modelo con data balanceada por método both
vino_modelo_both <- glm(wine_cat~.,
family = binomial(link = "logit"),
data=data_balanced_entrenamiento3$data[,-12])
#Sin balanceo
vino_modelo_sin <- glm(wine_cat~.,
family = binomial(link = "logit"),
data=d_entrenamiento[,-12])
#Buscar el menor valor de AIC para encontrar la mejor manera de balancear lso datos
summary(vino_modelo_over)##
## Call:
## glm(formula = wine_cat ~ ., family = binomial(link = "logit"),
## data = data_balanced_entrenamiento1$data[, -12])
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -3.2745 -0.1169 -0.0061 0.0791 5.6065
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.389e+01 2.265e+00 -14.960 < 2e-16 ***
## fixed.acidity 1.706e+00 9.176e-02 18.595 < 2e-16 ***
## volatile.acidity 5.154e-04 5.293e-04 0.974 0.3302
## citric.acid -6.761e+00 6.355e-01 -10.639 < 2e-16 ***
## residual.sugar -1.193e-01 2.533e-02 -4.708 2.50e-06 ***
## chlorides 2.281e-02 2.163e-03 10.549 < 2e-16 ***
## free.sulfur.dioxide 7.621e-03 6.627e-03 1.150 0.2502
## total.sulfur.dioxide -4.470e-02 2.259e-03 -19.784 < 2e-16 ***
## density -7.475e-04 2.918e-04 -2.561 0.0104 *
## pH 8.524e+00 5.382e-01 15.839 < 2e-16 ***
## sulphates 8.020e+00 5.860e-01 13.685 < 2e-16 ***
## alcohol -5.499e-01 7.025e-02 -7.827 4.98e-15 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 10029.3 on 7234 degrees of freedom
## Residual deviance: 1587.2 on 7223 degrees of freedom
## AIC: 1611.2
##
## Number of Fisher Scoring iterations: 8summary(vino_modelo_under)##
## Call:
## glm(formula = wine_cat ~ ., family = binomial(link = "logit"),
## data = data_balanced_entrenamiento2$data[, -12])
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -3.0041 -0.1307 0.0005 0.0857 5.5471
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.203e+01 3.896e+00 -8.223 < 2e-16 ***
## fixed.acidity 1.586e+00 1.598e-01 9.922 < 2e-16 ***
## volatile.acidity 1.043e-03 8.720e-04 1.196 0.2316
## citric.acid -4.824e+00 1.049e+00 -4.596 4.30e-06 ***
## residual.sugar -9.349e-02 4.180e-02 -2.237 0.0253 *
## chlorides 2.740e-02 3.737e-03 7.331 2.28e-13 ***
## free.sulfur.dioxide 8.124e-03 1.188e-02 0.684 0.4940
## total.sulfur.dioxide -4.713e-02 4.152e-03 -11.351 < 2e-16 ***
## density -9.836e-04 5.268e-04 -1.867 0.0619 .
## pH 8.062e+00 9.037e-01 8.922 < 2e-16 ***
## sulphates 6.912e+00 9.254e-01 7.470 8.04e-14 ***
## alcohol -5.041e-01 1.173e-01 -4.296 1.74e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3290.95 on 2373 degrees of freedom
## Residual deviance: 524.33 on 2362 degrees of freedom
## AIC: 548.33
##
## Number of Fisher Scoring iterations: 8summary(vino_modelo_both)##
## Call:
## glm(formula = wine_cat ~ ., family = binomial(link = "logit"),
## data = data_balanced_entrenamiento3$data[, -12])
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.9292 -0.1123 -0.0064 0.0687 5.7060
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.537e+01 2.851e+00 -12.407 < 2e-16 ***
## fixed.acidity 1.829e+00 1.191e-01 15.352 < 2e-16 ***
## volatile.acidity 6.738e-04 7.782e-04 0.866 0.387
## citric.acid -7.367e+00 8.485e-01 -8.682 < 2e-16 ***
## residual.sugar -1.357e-01 3.232e-02 -4.198 2.69e-05 ***
## chlorides 2.414e-02 2.769e-03 8.720 < 2e-16 ***
## free.sulfur.dioxide 5.590e-03 8.407e-03 0.665 0.506
## total.sulfur.dioxide -4.608e-02 2.840e-03 -16.225 < 2e-16 ***
## density -5.116e-04 3.735e-04 -1.370 0.171
## pH 8.794e+00 6.729e-01 13.069 < 2e-16 ***
## sulphates 7.587e+00 7.021e-01 10.807 < 2e-16 ***
## alcohol -5.206e-01 8.818e-02 -5.904 3.55e-09 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 6713.1 on 4842 degrees of freedom
## Residual deviance: 1013.9 on 4831 degrees of freedom
## AIC: 1037.9
##
## Number of Fisher Scoring iterations: 8summary(vino_modelo_sin)##
## Call:
## glm(formula = wine_cat ~ ., family = binomial(link = "logit"),
## data = d_entrenamiento[, -12])
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.8737 -0.1097 -0.0353 -0.0019 6.0584
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -3.730e+01 3.256e+00 -11.456 < 2e-16 ***
## fixed.acidity 1.763e+00 1.303e-01 13.530 < 2e-16 ***
## volatile.acidity 9.853e-04 6.869e-04 1.434 0.1515
## citric.acid -6.470e+00 8.820e-01 -7.336 2.20e-13 ***
## residual.sugar -7.607e-02 3.660e-02 -2.078 0.0377 *
## chlorides 3.121e-02 3.045e-03 10.252 < 2e-16 ***
## free.sulfur.dioxide 1.721e-02 1.017e-02 1.693 0.0905 .
## total.sulfur.dioxide -5.330e-02 3.612e-03 -14.759 < 2e-16 ***
## density -7.078e-04 4.381e-04 -1.616 0.1062
## pH 8.901e+00 7.525e-01 11.829 < 2e-16 ***
## sulphates 7.684e+00 7.596e-01 10.116 < 2e-16 ***
## alcohol -4.745e-01 1.011e-01 -4.691 2.72e-06 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 5411.90 on 4842 degrees of freedom
## Residual deviance: 772.49 on 4831 degrees of freedom
## AIC: 796.49
##
## Number of Fisher Scoring iterations: 8Valores de AIC para cada método de balanceo over = 1661 under = 566 both = 1131 sin balancear = 815 Se elige el balanceo por undersimpling que posee menor AIC. Determinar el valor óptimo de p en el balanceo de acuerdo al menor AIC que arroje, en este caso es el p = 0.50 0.30 = 742 0.35 = 691 0.40 = 636 0.45 = 605 0.50 = 566
Pregunta 2
Modelar el tipo de vino (wine_type) en función a las variables predictoras haciendo uso del modelo de regresión logístico. Considerar para las predicciones un punto de corte de 0.6
vino_modelo_under <- glm(wine_cat~.,
family = binomial(link = "logit"),
data=data_balanced_entrenamiento2$data[,-12])Pregunta 3
Aplicar los parámetros del modelo de entrenamiento a los datos de testeo, considerar para las predicciones un punto de corte de 0.6
d_prueba$vino_predict_log <- as.numeric((predict(vino_modelo_under, #modelo
newdata=d_prueba[,-12], #data sin la variable a predecir
type="response") >= 0.60))
d_prueba$vino_predict_log_factor = as.factor(d_prueba$vino_predict_log)Pregunta 4
Evaluar el modelo de regresión logístico haciendo uso de las métricas de accuracy, sensibilidad. especificidad, auc y curva ROC
evaluacion_log=confusionMatrix(d_prueba$vino_predict_log_factor,d_prueba$wine_cat,positive = "1")
#Curva ROC modelo glm
plotROC <- function(prediccion, real, adicionar=FALSE, color = "red")
## Se definen dos variables "prediccion", "real"
{
pred <- prediction(prediccion, real) ## crear un objeto llamado "pred", donde se evaluara la función "prediction", con las variables prediccion y real
perf <- performance(pred, "tpr", "fpr") ## crear un objeto llamado "perf", donde se evaluara la función "perfomance", con el objeto "pred", anteriormente creado
plot(perf,col = color, add = adicionar, main = "curva ROC")
segments(0, 0, 1, 1, col = "black") ## se hace un plot con el objeto perf
grid()
}
plotROC(as.numeric(d_prueba$vino_predict_log_factor), as.numeric(d_prueba$wine_cat))
areaROC <- function(prediccion, real)
## Se definen dos variables "prediccion", "real"
{
pred <- prediction(prediccion, real) ## crear un objeto llamado "pred", donde se evaluara la función "prediction", con las variables prediccion y real
auc <- performance(pred,"auc")@y.values ## crear un objeto llamado "auc", donde se evaluara la función perfomance, con el objeto pred
return(auc) ## e retorna el valor del "auc"
}
areaROC(as.numeric(d_prueba$vino_predict_log_factor), as.numeric(d_prueba$wine_cat))## [[1]]
## [1] 0.9684318Pregunta 5
Modelar el tipo de vino (wine_type) en función a las variables predictoras haciend uso del modelo de análisis discriminante lineal. Considerar para las predicciones un punto de corte de 0.6.
vino_modelo_lda<-lda(wine_cat~.,data=data_balanced_entrenamiento2$data[,-12])Pregunta 6
Aplicar los parámetros del modelo de entrenamiento a los datos de testeo, considerar para las predicciones un punto de corte de 0.6
vino_predict_lda=predict(vino_modelo_lda, newdata=d_prueba[,-c(12)])
d_prueba$vino_predict_lda=as.factor(ifelse(vino_predict_lda$posterior[,2]>=0.6,1,0))
#Evaluación
evaluacion_lda = confusionMatrix(d_prueba$vino_predict_lda,d_prueba$wine_cat, positive = "1")
plotROC(as.numeric(d_prueba$vino_predict_lda), as.numeric(d_prueba$wine_cat))
areaROC(as.numeric(d_prueba$vino_predict_lda), as.numeric(d_prueba$wine_cat))## [[1]]
## [1] 0.9692087Pregunta 7
Modelar el tipo de vino (wine_type) en función a las variables predictoras haciendo uso del modelo de análisis discriminante cuadrático. Considerar para las predicciones un punto de corte de 0.6.
vino_modelo_qda<-qda(wine_cat~.,data=data_balanced_entrenamiento2$data[,-12])Pregunta 8
Aplicar los parámetros del modelo de entrenamiento a los datos de testeo, considerar para las predicciones un punto de corte de 0.6.
vino_predict_qda=predict(vino_modelo_qda, newdata=d_prueba[,-12])
d_prueba$vino_predict_qda=as.factor(ifelse(vino_predict_qda$posterior[,2]>=0.6,1,0))
#Evluación
evaluacion_qda = confusionMatrix(d_prueba$vino_predict_qda,d_prueba$wine_cat, positive = "1")
plotROC(as.numeric(d_prueba$vino_predict_qda), as.numeric(d_prueba$wine_cat))
areaROC(as.numeric(d_prueba$vino_predict_qda), as.numeric(d_prueba$wine_cat))## [[1]]
## [1] 0.9617847Pregunta 9
Evaluar los modelos de análisis discriminante lineal y cuadrático haciendo uso de las métricas de accuracy, sensibilidad, especificidad, auc y curva ROC 
Modelo glm: El accuracy del modelo es del 96% lo cual indica que el poder de predicción es alto, de cada 100 observaciones logra predecir correctamente 96. Respecto a la sensitividad, el modelo de glm logra predecir correctamente 95 casos de cada 100 para la clase positiva de vino rojo de allí que su AUC sea también algo con un 96%. Mientras que para la clase de vino blanco logra predecir 98 de cada 100 casos.
Modelo lda: El modelo de análisis discriminante líneal predice correctamente 97 de cada 100 observaciones, para el caso de la clase positiva vino rojo logra predecir 94 de cada 100 casos, mientras que predice 97 de cada 100 casos para la clase negativa que es vino blanco. El AUC de este modelo es de 96% igualemnte.
Modelo qda: Para el análisis discriminante cuadrático, se tiene que predice para la clase positiva de vino rojo 94 de cada 100 observaciones. Mientras que predice 96 de cada 100 casos para la clase negativa de vino blanco. El accuracy de este modelo es de 95%, el menor de los tres modelos y un AUC de 95% un punto por debajo de los dos modelos anteriores.
Teniendo en cuenta lo anterior, se selecciona el modelo lineal logarítmico como el modelos con mejor performance.
Pregunta 10
Realice una evaluación comentada de los tres modelos y seleccione uno de ellos (el de mejor performance) y estime la probabilidad de que el tipo de vino sea rojo teniendo en cuenta los siguientes valores para las variables:
#Leo el archvivo donde están los nuevos predictores
vino2=read.csv("D:/Curso_R_Social_data/EXAMEN_R_INTERMEDIO_files/vino.csv")
View(vino2)
vino2$vino_predict_log_final <- as.numeric((predict(vino_modelo_under,
newdata=vino2,
type="response") >= 0.60))
vino2$tipo_vino=ifelse(vino2$vino_predict_log_final==0,"Blanco","Rojo")
#Predicción
print(vino2$tipo_vino)## [1] "Blanco"