MBD Modulo 3 Tarea 3
Joaquin Moreno
17/11/2019
1. Introduccion
Ejercicio para la tarea del modulo 3 del master de BigData. Vamos a realizar un analisis del dataset presente en la direccion https://archive.ics.uci.edu/ml/machine-learning-databases/00320/student.zip cuya variable objetivo es la nota final G3.La descripcion de las variables y el numero de observaciones la podemos encontrar en https://archive.ics.uci.edu/ml/datasets/Student+Performance
2. Carga de datos
Descargamos el archivo, lo descomprimimos y leemos el contenido del fichero de notas de portugues.
# descarga de ficheros
fileURL <- "https://archive.ics.uci.edu/ml/machine-learning-databases/00320/student.zip"
if(! "downloader" %in% installed.packages())
install.packages("downloader")
library(downloader)
download(fileURL,"./datos/student.zip", mode ="wb")
unzip("./datos/student.zip", exdir="./datos")
fechaDescarga <- date()
fechaDescarga## [1] "Sun Nov 24 11:28:49 2019"con <- file("./datos/student-por.csv","r")
studentPor <- read.csv2(con)
close(con)
head(studentPor[,1:5])## school sex age address famsize
## 1 GP F 18 U GT3
## 2 GP F 17 U GT3
## 3 GP F 15 U LE3
## 4 GP F 15 U GT3
## 5 GP F 16 U GT3
## 6 GP M 16 U LE33. Analisis descriptivo
dim(studentPor) # observaciones y variables del dataset## [1] 649 33str(studentPor)## 'data.frame': 649 obs. of 33 variables:
## $ school : Factor w/ 2 levels "GP","MS": 1 1 1 1 1 1 1 1 1 1 ...
## $ sex : Factor w/ 2 levels "F","M": 1 1 1 1 1 2 2 1 2 2 ...
## $ age : int 18 17 15 15 16 16 16 17 15 15 ...
## $ address : Factor w/ 2 levels "R","U": 2 2 2 2 2 2 2 2 2 2 ...
## $ famsize : Factor w/ 2 levels "GT3","LE3": 1 1 2 1 1 2 2 1 2 1 ...
## $ Pstatus : Factor w/ 2 levels "A","T": 1 2 2 2 2 2 2 1 1 2 ...
## $ Medu : int 4 1 1 4 3 4 2 4 3 3 ...
## $ Fedu : int 4 1 1 2 3 3 2 4 2 4 ...
## $ Mjob : Factor w/ 5 levels "at_home","health",..: 1 1 1 2 3 4 3 3 4 3 ...
## $ Fjob : Factor w/ 5 levels "at_home","health",..: 5 3 3 4 3 3 3 5 3 3 ...
## $ reason : Factor w/ 4 levels "course","home",..: 1 1 3 2 2 4 2 2 2 2 ...
## $ guardian : Factor w/ 3 levels "father","mother",..: 2 1 2 2 1 2 2 2 2 2 ...
## $ traveltime: int 2 1 1 1 1 1 1 2 1 1 ...
## $ studytime : int 2 2 2 3 2 2 2 2 2 2 ...
## $ failures : int 0 0 0 0 0 0 0 0 0 0 ...
## $ schoolsup : Factor w/ 2 levels "no","yes": 2 1 2 1 1 1 1 2 1 1 ...
## $ famsup : Factor w/ 2 levels "no","yes": 1 2 1 2 2 2 1 2 2 2 ...
## $ paid : Factor w/ 2 levels "no","yes": 1 1 1 1 1 1 1 1 1 1 ...
## $ activities: Factor w/ 2 levels "no","yes": 1 1 1 2 1 2 1 1 1 2 ...
## $ nursery : Factor w/ 2 levels "no","yes": 2 1 2 2 2 2 2 2 2 2 ...
## $ higher : Factor w/ 2 levels "no","yes": 2 2 2 2 2 2 2 2 2 2 ...
## $ internet : Factor w/ 2 levels "no","yes": 1 2 2 2 1 2 2 1 2 2 ...
## $ romantic : Factor w/ 2 levels "no","yes": 1 1 1 2 1 1 1 1 1 1 ...
## $ famrel : int 4 5 4 3 4 5 4 4 4 5 ...
## $ freetime : int 3 3 3 2 3 4 4 1 2 5 ...
## $ goout : int 4 3 2 2 2 2 4 4 2 1 ...
## $ Dalc : int 1 1 2 1 1 1 1 1 1 1 ...
## $ Walc : int 1 1 3 1 2 2 1 1 1 1 ...
## $ health : int 3 3 3 5 5 5 3 1 1 5 ...
## $ absences : int 4 2 6 0 0 6 0 2 0 0 ...
## $ G1 : int 0 9 12 14 11 12 13 10 15 12 ...
## $ G2 : int 11 11 13 14 13 12 12 13 16 12 ...
## $ G3 : int 11 11 12 14 13 13 13 13 17 13 ...any(is.na.data.frame(studentPor)) # buscamos valores nulos## [1] FALSEnames(studentPor) <- tolower(names(studentPor)) # nombres de las variables a minusculas
names(studentPor)## [1] "school" "sex" "age" "address" "famsize"
## [6] "pstatus" "medu" "fedu" "mjob" "fjob"
## [11] "reason" "guardian" "traveltime" "studytime" "failures"
## [16] "schoolsup" "famsup" "paid" "activities" "nursery"
## [21] "higher" "internet" "romantic" "famrel" "freetime"
## [26] "goout" "dalc" "walc" "health" "absences"
## [31] "g1" "g2" "g3"kable(head(studentPor[,1:10])) # estructura del dataset| school | sex | age | address | famsize | pstatus | medu | fedu | mjob | fjob |
|---|---|---|---|---|---|---|---|---|---|
| GP | F | 18 | U | GT3 | A | 4 | 4 | at_home | teacher |
| GP | F | 17 | U | GT3 | T | 1 | 1 | at_home | other |
| GP | F | 15 | U | LE3 | T | 1 | 1 | at_home | other |
| GP | F | 15 | U | GT3 | T | 4 | 2 | health | services |
| GP | F | 16 | U | GT3 | T | 3 | 3 | other | other |
| GP | M | 16 | U | LE3 | T | 4 | 3 | services | other |
3.1. Añadimos nuevas variables
De la variable objetivo G3 nos interesa solo saber alumnos aprobados y suspensos, con lo que crearemos una nueva variable que clasifique por encima de 10 en la nota y hasta 20 un aprobado(1) y por debajo de 10 suspenso(0)
studentPor$pass <- ifelse(studentPor$g3 > 9, 1, 0)
prop.table( table(studentPor$pass)) #proporcion respecto a la variable objetivo##
## 0 1
## 0.1540832 0.8459168#summary(studentPor)Vamos a transformar en un nuevo dataset las variables que no son numéricas en dummies para que puedan ser analizadas en los metodos de aprendizaje posteriores.Los factores originales texto, los asignaremos en variables .factor
stp <- studentPor
stp$sex <- ifelse(stp$sex == 'M', 1, 0)
stp$famsize <- ifelse(stp$famsize == 'GT3', 1 , 0)
stp$school <- ifelse(stp$school == 'GP', 1, 0)
stp$address <- ifelse(stp$address == '"U', 1, 0)
stp$pstatus <- ifelse(stp$pstatus == 'T',1,0)
stp$schoolsup <- ifelse(stp$schoolsup == 'yes', 1 ,0)
stp$famsup <- ifelse(stp$famsup == 'yes', 1 ,0)
stp$paid <- ifelse(stp$paid == 'yes', 1 ,0)
stp$activities <- ifelse(stp$activities == 'yes', 1 ,0)
stp$nursery <- ifelse(stp$nursery == 'yes', 1 ,0)
stp$higher <- ifelse(stp$higher == 'yes', 1 ,0)
stp$internet <- ifelse(stp$internet == 'yes', 1 ,0)
stp$romantic <- ifelse(stp$romantic == 'yes', 1 ,0)
# nominal: 'teacher', 'health' care related, civil 'services' (e.g. administrative or police), 'at_home' or 'other'
job.levels <- c('teacher', 'health' , 'services' , 'at_home', 'other')
stp$fjob <- as.integer(stp$fjob, levels = job.levels)
stp$mjob <- as.integer(stp$mjob, levels = job.levels)
# nominal: close to 'home', school 'reputation', 'course' preference or 'other'
reason.levels <- c('home', 'reputation', 'course', 'other')
stp$reason <- as.numeric(stp$reason, levels = reason.levels)
# nominal: 'mother', 'father' or 'other'
guardian.levels <- c('mother', 'father', 'other')
stp$guardian <- as.numeric(stp$guardian, levels = guardian.levels)
stp <- as.data.frame(stp)
any(is.na.data.frame(stp))## [1] FALSE str(stp)## 'data.frame': 649 obs. of 34 variables:
## $ school : num 1 1 1 1 1 1 1 1 1 1 ...
## $ sex : num 0 0 0 0 0 1 1 0 1 1 ...
## $ age : int 18 17 15 15 16 16 16 17 15 15 ...
## $ address : num 0 0 0 0 0 0 0 0 0 0 ...
## $ famsize : num 1 1 0 1 1 0 0 1 0 1 ...
## $ pstatus : num 0 1 1 1 1 1 1 0 0 1 ...
## $ medu : int 4 1 1 4 3 4 2 4 3 3 ...
## $ fedu : int 4 1 1 2 3 3 2 4 2 4 ...
## $ mjob : int 1 1 1 2 3 4 3 3 4 3 ...
## $ fjob : int 5 3 3 4 3 3 3 5 3 3 ...
## $ reason : num 1 1 3 2 2 4 2 2 2 2 ...
## $ guardian : num 2 1 2 2 1 2 2 2 2 2 ...
## $ traveltime: int 2 1 1 1 1 1 1 2 1 1 ...
## $ studytime : int 2 2 2 3 2 2 2 2 2 2 ...
## $ failures : int 0 0 0 0 0 0 0 0 0 0 ...
## $ schoolsup : num 1 0 1 0 0 0 0 1 0 0 ...
## $ famsup : num 0 1 0 1 1 1 0 1 1 1 ...
## $ paid : num 0 0 0 0 0 0 0 0 0 0 ...
## $ activities: num 0 0 0 1 0 1 0 0 0 1 ...
## $ nursery : num 1 0 1 1 1 1 1 1 1 1 ...
## $ higher : num 1 1 1 1 1 1 1 1 1 1 ...
## $ internet : num 0 1 1 1 0 1 1 0 1 1 ...
## $ romantic : num 0 0 0 1 0 0 0 0 0 0 ...
## $ famrel : int 4 5 4 3 4 5 4 4 4 5 ...
## $ freetime : int 3 3 3 2 3 4 4 1 2 5 ...
## $ goout : int 4 3 2 2 2 2 4 4 2 1 ...
## $ dalc : int 1 1 2 1 1 1 1 1 1 1 ...
## $ walc : int 1 1 3 1 2 2 1 1 1 1 ...
## $ health : int 3 3 3 5 5 5 3 1 1 5 ...
## $ absences : int 4 2 6 0 0 6 0 2 0 0 ...
## $ g1 : int 0 9 12 14 11 12 13 10 15 12 ...
## $ g2 : int 11 11 13 14 13 12 12 13 16 12 ...
## $ g3 : int 11 11 12 14 13 13 13 13 17 13 ...
## $ pass : num 1 1 1 1 1 1 1 1 1 1 ... summary(stp)## school sex age address
## Min. :0.0000 Min. :0.0000 Min. :15.00 Min. :0
## 1st Qu.:0.0000 1st Qu.:0.0000 1st Qu.:16.00 1st Qu.:0
## Median :1.0000 Median :0.0000 Median :17.00 Median :0
## Mean :0.6518 Mean :0.4099 Mean :16.74 Mean :0
## 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:18.00 3rd Qu.:0
## Max. :1.0000 Max. :1.0000 Max. :22.00 Max. :0
## famsize pstatus medu fedu
## Min. :0.0000 Min. :0.0000 Min. :0.000 Min. :0.000
## 1st Qu.:0.0000 1st Qu.:1.0000 1st Qu.:2.000 1st Qu.:1.000
## Median :1.0000 Median :1.0000 Median :2.000 Median :2.000
## Mean :0.7042 Mean :0.8767 Mean :2.515 Mean :2.307
## 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:4.000 3rd Qu.:3.000
## Max. :1.0000 Max. :1.0000 Max. :4.000 Max. :4.000
## mjob fjob reason guardian
## Min. :1.000 Min. :1.000 Min. :1.000 Min. :1.000
## 1st Qu.:2.000 1st Qu.:3.000 1st Qu.:1.000 1st Qu.:2.000
## Median :3.000 Median :3.000 Median :2.000 Median :2.000
## Mean :2.941 Mean :3.225 Mean :2.112 Mean :1.827
## 3rd Qu.:4.000 3rd Qu.:4.000 3rd Qu.:3.000 3rd Qu.:2.000
## Max. :5.000 Max. :5.000 Max. :4.000 Max. :3.000
## traveltime studytime failures schoolsup
## Min. :1.000 Min. :1.000 Min. :0.0000 Min. :0.0000
## 1st Qu.:1.000 1st Qu.:1.000 1st Qu.:0.0000 1st Qu.:0.0000
## Median :1.000 Median :2.000 Median :0.0000 Median :0.0000
## Mean :1.569 Mean :1.931 Mean :0.2219 Mean :0.1048
## 3rd Qu.:2.000 3rd Qu.:2.000 3rd Qu.:0.0000 3rd Qu.:0.0000
## Max. :4.000 Max. :4.000 Max. :3.0000 Max. :1.0000
## famsup paid activities nursery
## Min. :0.0000 Min. :0.00000 Min. :0.0000 Min. :0.0000
## 1st Qu.:0.0000 1st Qu.:0.00000 1st Qu.:0.0000 1st Qu.:1.0000
## Median :1.0000 Median :0.00000 Median :0.0000 Median :1.0000
## Mean :0.6133 Mean :0.06009 Mean :0.4854 Mean :0.8028
## 3rd Qu.:1.0000 3rd Qu.:0.00000 3rd Qu.:1.0000 3rd Qu.:1.0000
## Max. :1.0000 Max. :1.00000 Max. :1.0000 Max. :1.0000
## higher internet romantic famrel
## Min. :0.0000 Min. :0.0000 Min. :0.0000 Min. :1.000
## 1st Qu.:1.0000 1st Qu.:1.0000 1st Qu.:0.0000 1st Qu.:4.000
## Median :1.0000 Median :1.0000 Median :0.0000 Median :4.000
## Mean :0.8937 Mean :0.7673 Mean :0.3683 Mean :3.931
## 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:1.0000 3rd Qu.:5.000
## Max. :1.0000 Max. :1.0000 Max. :1.0000 Max. :5.000
## freetime goout dalc walc
## Min. :1.00 Min. :1.000 Min. :1.000 Min. :1.00
## 1st Qu.:3.00 1st Qu.:2.000 1st Qu.:1.000 1st Qu.:1.00
## Median :3.00 Median :3.000 Median :1.000 Median :2.00
## Mean :3.18 Mean :3.185 Mean :1.502 Mean :2.28
## 3rd Qu.:4.00 3rd Qu.:4.000 3rd Qu.:2.000 3rd Qu.:3.00
## Max. :5.00 Max. :5.000 Max. :5.000 Max. :5.00
## health absences g1 g2
## Min. :1.000 Min. : 0.000 Min. : 0.0 Min. : 0.00
## 1st Qu.:2.000 1st Qu.: 0.000 1st Qu.:10.0 1st Qu.:10.00
## Median :4.000 Median : 2.000 Median :11.0 Median :11.00
## Mean :3.536 Mean : 3.659 Mean :11.4 Mean :11.57
## 3rd Qu.:5.000 3rd Qu.: 6.000 3rd Qu.:13.0 3rd Qu.:13.00
## Max. :5.000 Max. :32.000 Max. :19.0 Max. :19.00
## g3 pass
## Min. : 0.00 Min. :0.0000
## 1st Qu.:10.00 1st Qu.:1.0000
## Median :12.00 Median :1.0000
## Mean :11.91 Mean :0.8459
## 3rd Qu.:14.00 3rd Qu.:1.0000
## Max. :19.00 Max. :1.0000 prop.table( table(stp$pass))##
## 0 1
## 0.1540832 0.8459168 dim(stp)## [1] 649 343.2. Matriz de correlacion
Vamos a estudiar el grado de correlacion entra las variables.Las mas correladas entre predictoras no las voy a eliminar ya que usare los metodos de caret para que lo haga automaticamente.
## pass
## pass 1.000000000
## absences -0.087482807
## goout -0.067241054
## dalc -0.123627420
## walc -0.116248544
## traveltime -0.057868623
## g1 0.563069526
## g2 0.592251189
## g3 0.663156838
## sex -0.078222103
## famsize -0.052214762
## school 0.297217102
## address 0.000000000
## pstatus -0.004240808
## fjob 0.002454165
## mjob 0.106563859
## reason 0.101215023
## guardian -0.084383714
## medu 0.144802596
## fedu 0.146249058
## studytime 0.165110815
## schoolsup 0.034526881
## famsup 0.037903372
## paid -0.053708391
## activities 0.047276197
## nursery -0.007751091
## higher 0.309707814
## internet 0.088214611
## romantic -0.081176772
Vamos a analizar las variables que aparecen mas correladas respecto a la variable objetivo: Estudios superiores y school
4. Análisis exploratorio apoyado en algún método NO supervisado
Vamos a generar reglas de asociacion entre las variables de los estudientes de portugues. En concreto trabajaremos con las variables: medu.factor,fedu.factor,famsup y pass. Tratamos de ver si existe asociación entre los niveles educativos de los padres, el soporte familiar a la educación del alumno, y si éste aprueba o no. Nos valdremos para ello del algoritmo apriori, que se usa para la búsqueda de asociaciones entre cualquier conjunto de items. Para ello, vamos a definir las reglas de asociación, que están formadas por uno o más antecedentes (lhs) y una consecuencia (rhs). Las reglas de asociación están definidas por su soporte (ratio de los casos en los que se dan los antecentes conjuntamente en el dataset completo) y su confianza (ratio de transacciones que conteniendo los antecedentes también contienen el consecuente). Estudiamos las reglas de asociación estableciendo un soporte del 5% y una confianza del 70%. En este caso en concreto vamos a buscar exclusivamente los antecedentes asociados a la variable pass.
library(arules)## Loading required package: Matrix##
## Attaching package: 'arules'## The following object is masked from 'package:dplyr':
##
## recode## The following objects are masked from 'package:base':
##
## abbreviate, write library(arulesViz)## Loading required package: grid## Registered S3 method overwritten by 'seriation':
## method from
## reorder.hclust gclus regaso.studentPor <- studentPor %>% select(higher, school, reason,studytime, pass)
regaso.studentPor <- data.frame(sapply( regaso.studentPor, as.factor))
reglas <- apriori(regaso.studentPor ,parameter = list( supp = 0.05 , conf = 0.7 , target = "rules"),
appearance = list(rhs = c("pass=1", "pass=0"), default = "lhs"))## Apriori
##
## Parameter specification:
## confidence minval smax arem aval originalSupport maxtime support minlen
## 0.7 0.1 1 none FALSE TRUE 5 0.05 1
## maxlen target ext
## 10 rules FALSE
##
## Algorithmic control:
## filter tree heap memopt load sort verbose
## 0.1 TRUE TRUE FALSE TRUE 2 TRUE
##
## Absolute minimum support count: 32
##
## set item appearances ...[2 item(s)] done [0.00s].
## set transactions ...[14 item(s), 649 transaction(s)] done [0.00s].
## sorting and recoding items ... [14 item(s)] done [0.00s].
## creating transaction tree ... done [0.00s].
## checking subsets of size 1 2 3 4 5 done [0.00s].
## writing ... [53 rule(s)] done [0.00s].
## creating S4 object ... done [0.00s].summary(reglas)## set of 53 rules
##
## rule length distribution (lhs + rhs):sizes
## 1 2 3 4 5
## 1 10 21 17 4
##
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 3.000 3.000 3.245 4.000 5.000
##
## summary of quality measures:
## support confidence lift count
## Min. :0.05085 Min. :0.7196 Min. :0.8507 Min. : 33.0
## 1st Qu.:0.09707 1st Qu.:0.8452 1st Qu.:0.9992 1st Qu.: 63.0
## Median :0.14176 Median :0.9178 Median :1.0850 Median : 92.0
## Mean :0.19731 Mean :0.8892 Mean :1.0512 Mean :128.1
## 3rd Qu.:0.21880 3rd Qu.:0.9462 3rd Qu.:1.1186 3rd Qu.:142.0
## Max. :0.84592 Max. :0.9821 Max. :1.1610 Max. :549.0
##
## mining info:
## data ntransactions support confidence
## regaso.studentPor 649 0.05 0.7inspect(sort(reglas, by = "lift")[1:10])## lhs rhs support confidence lift count
## [1] {higher=yes,
## school=GP,
## reason=reputation,
## studytime=2} => {pass=1} 0.08474576 0.9821429 1.161040 55
## [2] {higher=yes,
## school=GP,
## reason=reputation} => {pass=1} 0.16486903 0.9816514 1.160459 107
## [3] {school=GP,
## reason=home,
## studytime=2} => {pass=1} 0.09244992 0.9677419 1.144016 60
## [4] {higher=yes,
## school=GP,
## reason=home,
## studytime=2} => {pass=1} 0.09090909 0.9672131 1.143390 59
## [5] {school=GP,
## reason=reputation} => {pass=1} 0.16949153 0.9649123 1.140670 110
## [6] {higher=yes,
## school=GP,
## studytime=2} => {pass=1} 0.28813559 0.9639175 1.139494 187
## [7] {school=GP,
## studytime=3} => {pass=1} 0.10477658 0.9577465 1.132199 68
## [8] {higher=yes,
## school=GP,
## studytime=3} => {pass=1} 0.10323575 0.9571429 1.131486 67
## [9] {higher=yes,
## school=GP} => {pass=1} 0.57473035 0.9539642 1.127728 373
## [10] {school=GP,
## studytime=2} => {pass=1} 0.30200308 0.9514563 1.124763 196 plot(reglas, method = "grouped", control = list(k = 15, col = heat.colors(10)))
Se puede deducir que de cara a el aprobado las variables mas determinantes para el aprobado son School(donde GP es mas determinante), Higher y StudyTime
5. Construcción de 2 modelos de Machine Learning supervisados
Cargamos las librerías necesarias para ejecutar el ejemplo con caret
if(! "mlbench" %in% installed.packages()) install.packages("mlbench", depend = TRUE)
if(! "caret" %in% installed.packages()) install.packages("caret", depend = TRUE)
if(! "ROCR" %in% installed.packages()) install.packages("ROCR", depend = TRUE)
if(! "dplyr" %in% installed.packages()) install.packages("dplyr", depend = TRUE)
if(! "corrplot" %in% installed.packages()) install.packages("corrplot", depend = TRUE)
if(! "e1071" %in% installed.packages()) install.packages("e1071", depend = TRUE)
if(! "gbm" %in% installed.packages()) install.packages("gbm", depend = TRUE)
library(mlbench)
library(caret)## Loading required package: latticelibrary(dplyr)
library(ROCR)## Loading required package: gplots##
## Attaching package: 'gplots'## The following object is masked from 'package:stats':
##
## lowesslibrary(corrplot)
library(e1071)
library(gbm)## Loaded gbm 2.1.5Necesitamos que la varible objetivo sea un factor
stp$pass <- ifelse(stp$pass == 1, 'Aprobado', 'Suspenso')
stp$pass <- factor(stp$pass,levels = c('Aprobado', 'Suspenso') )
prop.table( table(stp$pass))##
## Aprobado Suspenso
## 0.8459168 0.1540832Se crean los dataset de entrenamiento y test con la función de caret: createDataPartition()
### Creamos las particiones de entrenamiento y test para los datos
index.stp <- createDataPartition(stp$pass, p=0.8, list=F)
train.stp <- stp[index.stp,]
test.stp <- stp[ -index.stp, ]Comprobamos que las proporciones se mantienen en los datasets de entrenamiento y test similares a las del dataset original
prop.table( table(train.stp$pass))##
## Aprobado Suspenso
## 0.8461538 0.1538462prop.table( table(test.stp$pass))##
## Aprobado Suspenso
## 0.8449612 0.1550388Vemos que se mantienen las proporciones.
Comenzamos el preprocesado de datos Buscamos variables con varianza cercana a cero (casi constantes) pues no aportan al clasificador con la función nearZeroVar().Siempre excluyendo la variable objetivo
zero.var.train.stp <- nearZeroVar( train.stp[,-dim(train.stp)[2]], saveMetrics=F )
colnames(train.stp)[zero.var.train.stp]## [1] "address"# Eliminamos las columnas con varianza casi nula en caso de que haya alguna
train.stp.nz <- train.stp[,-zero.var.train.stp]
test.stp.nz <- test.stp[,-zero.var.train.stp]Ahora buscamos variables fuertemente correladas con la función cor() y findCorrelation()
cor.train.stp.matrix <- cor( train.stp.nz[, -dim(train.stp.nz)[2]] )
# Seleccionamos los indices de las columnas con una correlación mayor de 0,8
cor.train.stp.index <- findCorrelation( cor.train.stp.matrix, 0.80 )
cor.train.stp.index## [1] 30 31cor.train.stp <- train.stp.nz[,-cor.train.stp.index]
dim(cor.train.stp)## [1] 520 31cor.test.stp <- test.stp.nz[,-cor.train.stp.index]
dim(cor.test.stp)## [1] 129 31Se han eliminado las variables G1 y G2 Centramos y escalamos las variables para reducir la desviación con la función preProcess()
#xTrans.stp <- preProcess(cor.train.stp[, -dim(cor.train.stp)[2]])
xTrans.stp <- preProcess(cor.train.stp[, -dim(cor.train.stp)[2]], method= c("center", "scale"))
train.stp.prep <- predict( xTrans.stp, cor.train.stp[,-dim(cor.train.stp)[2]])
train.stp.prep$pass <- cor.train.stp$pass
test.stp.prep <- predict( xTrans.stp, cor.test.stp[,-dim(cor.test.stp)[2]], method= c("center", "scale"))
test.stp.prep$pass <- cor.test.stp$passGeneración de modelos
5.1.Modelo KNN
# Aplicamos resampling de repeated k cross validation
fitControl <- trainControl(method="cv", repeats=5)## Warning: `repeats` has no meaning for this resampling method.# Entrenamos el modelo
knn.stp.model <- train(x=train.stp.prep[,-dim(train.stp.prep)[2]], y=train.stp.prep$pass, method="knn",
tuneLength=10, trControl=fitControl)
knn.stp.model## k-Nearest Neighbors
##
## 520 samples
## 30 predictor
## 2 classes: 'Aprobado', 'Suspenso'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 468, 468, 468, 468, 468, 468, ...
## Resampling results across tuning parameters:
##
## k Accuracy Kappa
## 5 0.8711538 0.32706067
## 7 0.8711538 0.28583124
## 9 0.8615385 0.18806711
## 11 0.8596154 0.17597563
## 13 0.8596154 0.16291890
## 15 0.8596154 0.14816480
## 17 0.8596154 0.14529233
## 19 0.8576923 0.12582330
## 21 0.8596154 0.14529233
## 23 0.8480769 0.03539823
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was k = 7.plot1 <- plot(knn.stp.model,metric="Accuracy")
print(plot1)
Visualizamos la salida del modelo KNN
knn.stp.test <- predict(knn.stp.model, newdata= test.stp.prep[,-dim(train.stp.prep)[2]])
knn.stp.test## [1] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [8] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [15] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [22] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [29] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [36] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [43] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [50] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [57] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [64] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [71] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [78] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [85] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [92] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [99] Aprobado Suspenso Aprobado Aprobado Aprobado Aprobado Aprobado
## [106] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [113] Aprobado Aprobado Suspenso Aprobado Aprobado Aprobado Aprobado
## [120] Aprobado Aprobado Suspenso Aprobado Suspenso Aprobado Aprobado
## [127] Aprobado Aprobado Aprobado
## Levels: Aprobado SuspensoComparación de predicciones, probabilidades sobre el conjunto de test
# Extracción de prediciones
knn.stp.test.preds <- extractPrediction( list(model1=knn.stp.model), testX=test.stp.prep[,-dim(train.stp.prep)[2]] , testY=test.stp.prep$pass)
conjunto.test.preds <- subset(knn.stp.test.preds, dataType== "Test")
head(conjunto.test.preds)## obs pred model dataType object
## 521 Aprobado Aprobado knn Test model1
## 522 Suspenso Aprobado knn Test model1
## 523 Aprobado Aprobado knn Test model1
## 524 Aprobado Aprobado knn Test model1
## 525 Aprobado Aprobado knn Test model1
## 526 Aprobado Aprobado knn Test model1# Extraccion de probabilidades
knn.stp.test.probs <- extractProb( list(model1=knn.stp.model),testX= test.stp.prep[,-dim(train.stp.prep)[2]], testY=test.stp.prep$pass)
conjunto.test.probs <- subset(knn.stp.test.probs, dataType== "Test")
plotClassProbs(conjunto.test.probs )
Vemos en la gráfica que las probabilidades de ser más certero prediciendo el valor Aprobado son mayores
Evaluación del modelo, matriz de confusión y curvas ROC. Funciones confusionMatrix() y prediction()
confusionMatrix(knn.stp.test, test.stp.prep$pass )## Confusion Matrix and Statistics
##
## Reference
## Prediction Aprobado Suspenso
## Aprobado 109 16
## Suspenso 0 4
##
## Accuracy : 0.876
## 95% CI : (0.8064, 0.9274)
## No Information Rate : 0.845
## P-Value [Acc > NIR] : 0.1993540
##
## Kappa : 0.297
##
## Mcnemar's Test P-Value : 0.0001768
##
## Sensitivity : 1.000
## Specificity : 0.200
## Pos Pred Value : 0.872
## Neg Pred Value : 1.000
## Prevalence : 0.845
## Detection Rate : 0.845
## Detection Prevalence : 0.969
## Balanced Accuracy : 0.600
##
## 'Positive' Class : Aprobado
## # Para poder pintar la curva ROC tenemos que pasar los valores del target a 0 y 1
pr <- prediction(ifelse(knn.stp.test == 'Aprobado',1,0), ifelse(test.stp.prep$pass == 'Aprobado',1,0))
prf <- performance(pr, measure = "tpr", x.measure = "fpr")
plot(prf)
5.2 Modelo SVM
Repetimos los mismos pasos que para Knn. Utilizamos validación cruzada como técnica de remuestreo Entrenamiento
svm.stp.model <- train(x=train.stp.prep[,-dim(train.stp.prep)[2]], y=train.stp.prep$pass, method="svmRadial", tuneLength=10, trControl=fitControl)
svm.stp.model## Support Vector Machines with Radial Basis Function Kernel
##
## 520 samples
## 30 predictor
## 2 classes: 'Aprobado', 'Suspenso'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 468, 468, 468, 468, 468, 468, ...
## Resampling results across tuning parameters:
##
## C Accuracy Kappa
## 0.25 0.8461538 0.0000000
## 0.50 0.8711538 0.2364545
## 1.00 0.8730769 0.2729013
## 2.00 0.9134615 0.6058951
## 4.00 0.9250000 0.6699516
## 8.00 0.9346154 0.7192195
## 16.00 0.9288462 0.6916134
## 32.00 0.9288462 0.6916134
## 64.00 0.9288462 0.6916134
## 128.00 0.9288462 0.6916134
##
## Tuning parameter 'sigma' was held constant at a value of 0.0204783
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were sigma = 0.0204783 and C = 8.Visualización del modelo
plot1 <- plot(svm.stp.model, metric="Accuracy")
print(plot1)
Predicción sobre nuevos valores
svm.stp.test <- predict(svm.stp.model, newdata= test.stp.prep[,-dim(train.stp.prep)[2]])
svm.stp.test## [1] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [8] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [15] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [22] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [29] Aprobado Suspenso Aprobado Aprobado Aprobado Aprobado Aprobado
## [36] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [43] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [50] Aprobado Aprobado Aprobado Suspenso Aprobado Aprobado Aprobado
## [57] Aprobado Suspenso Aprobado Aprobado Aprobado Aprobado Aprobado
## [64] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [71] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [78] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [85] Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado Aprobado
## [92] Aprobado Suspenso Aprobado Aprobado Suspenso Suspenso Aprobado
## [99] Aprobado Suspenso Aprobado Aprobado Aprobado Suspenso Aprobado
## [106] Aprobado Suspenso Aprobado Aprobado Aprobado Suspenso Aprobado
## [113] Aprobado Aprobado Suspenso Aprobado Aprobado Aprobado Suspenso
## [120] Aprobado Aprobado Suspenso Aprobado Suspenso Aprobado Aprobado
## [127] Aprobado Aprobado Aprobado
## Levels: Aprobado SuspensoEvaluación del modelo, matriz de confusión y curvas ROC
confusionMatrix(svm.stp.test, test.stp.prep$pass )## Confusion Matrix and Statistics
##
## Reference
## Prediction Aprobado Suspenso
## Aprobado 108 7
## Suspenso 1 13
##
## Accuracy : 0.938
## 95% CI : (0.8815, 0.9728)
## No Information Rate : 0.845
## P-Value [Acc > NIR] : 0.001075
##
## Kappa : 0.7303
##
## Mcnemar's Test P-Value : 0.077100
##
## Sensitivity : 0.9908
## Specificity : 0.6500
## Pos Pred Value : 0.9391
## Neg Pred Value : 0.9286
## Prevalence : 0.8450
## Detection Rate : 0.8372
## Detection Prevalence : 0.8915
## Balanced Accuracy : 0.8204
##
## 'Positive' Class : Aprobado
## pr <- prediction(ifelse(svm.stp.test == 'Aprobado',1,0), ifelse(test.stp.prep$pass == 'Aprobado',1,0))
prf <- performance(pr, measure = "tpr", x.measure = "fpr")
plot(prf)
Comparación de ambos modelos (Model1=knn, Model2=SVM) con Caret
models <- list( knn.stp.model, svm.stp.model )
compar.models <- resamples( models )
summary( compar.models )##
## Call:
## summary.resamples(object = compar.models)
##
## Models: Model1, Model2
## Number of resamples: 10
##
## Accuracy
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## Model1 0.8269231 0.8653846 0.8846154 0.8711538 0.8846154 0.8846154 0
## Model2 0.9038462 0.9086538 0.9326923 0.9346154 0.9567308 0.9807692 0
##
## Kappa
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## Model1 -0.03539823 0.2223536 0.3606557 0.2858312 0.3606557 0.4428571 0
## Model2 0.56375839 0.6335907 0.7045706 0.7192195 0.8111460 0.9221557 0Visualización del rendimiento de cada modelo. Model1=knn, Model2=SVM
dotplot( compar.models)
Se ve claramente que Model2=SVM para este caso en concreto tiene mayor precisión