Introduction

In this section, I compared the common machine learning models. I answered the Q10 at chapter 4 from the An Introduction to Statistical Learning Book. Data:

This question should be answered using the Weekly data set, which is part of the ISLR package.

Weekly data has 1089 observations on the following 9 variables.

Year: The year that the observation was recorded

Lag1: Percentage return for previous week

Lag2: Percentage return for 2 weeks previous

Lag3: Percentage return for 3 weeks previous

Lag4: Percentage return for 4 weeks previous

Lag5: Percentage return for 5 weeks previous

Volume: Volume of shares traded (average number of daily shares traded in billions)

Today: Percentage return for this week

Direction: A factor with levels Down and Up indicating whether the market had a positive or negative return on a given week

This data is similar in nature to the Smarket data from this chapter’s lab, except that it contains 1,089 weekly returns for 21 years, from the beginning of 1990 to the end of 2010.

Objective:

  1. Produce some numerical and graphical summaries of the Weekly data. Do there appear to be any patterns?

  2. Use the full data set to perform a logistic regression with Direction as the response and the five lag variables plus Volume as predictors. Use the summary() function to print the results. Do any of the predictors appear to be statistically significant? If so,which ones?

  3. Compute the confusion matrix and overall fraction of correct predictions. Explain what the confusion matrix is telling you about the types of mistakes made by logistic regression.

  4. Now fit the logistic regression model using a training data period from 1990 to 2008, with Lag2 as the only predictor. Compute the confusion matrix and the overall fraction of correct predictions for the held out data (that is, the data from 2009 and 2010).

  5. Repeat (d) using LDA.

  6. Repeat (d) using QDA.

  7. Repeat (d) using KNN with K = 1.

  8. Which of these methods appears to provide the best results on this data?

  9. Experiment with different combinations of predictors, including possible transformations and interactions, for each of the methods. Report the variables, method, and associated confusion matrix that appears to provide the best results on the held out data. Note that you should also experiment with values for K in the KNN classifier.



Data Preparation

#Loading necessary libraries
library(tidyverse) # For data manipulation
## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --
## v ggplot2 3.3.5     v purrr   0.3.4
## v tibble  3.1.4     v dplyr   1.0.7
## v tidyr   1.1.3     v stringr 1.4.0
## v readr   2.0.1     v forcats 0.5.1
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
library(dplyr) 
library(caret)  # confusion matrix
## Loading required package: lattice
## 
## Attaching package: 'caret'
## The following object is masked from 'package:purrr':
## 
##     lift
library(GGally)
## Registered S3 method overwritten by 'GGally':
##   method from   
##   +.gg   ggplot2
library(ISLR)
library(ggplot2)
library(corrplot)
## corrplot 0.90 loaded
library(MASS)
## 
## Attaching package: 'MASS'
## The following object is masked from 'package:dplyr':
## 
##     select
library(class)
library(bootStepAIC)
#PREPARING WORK SPAcE
# Clear the workspace: 
rm(list = ls())
# Load data
names(Weekly)
## [1] "Year"      "Lag1"      "Lag2"      "Lag3"      "Lag4"      "Lag5"     
## [7] "Volume"    "Today"     "Direction"
dim(Weekly)
## [1] 1089    9
summary(Weekly)
##       Year           Lag1               Lag2               Lag3         
##  Min.   :1990   Min.   :-18.1950   Min.   :-18.1950   Min.   :-18.1950  
##  1st Qu.:1995   1st Qu.: -1.1540   1st Qu.: -1.1540   1st Qu.: -1.1580  
##  Median :2000   Median :  0.2410   Median :  0.2410   Median :  0.2410  
##  Mean   :2000   Mean   :  0.1506   Mean   :  0.1511   Mean   :  0.1472  
##  3rd Qu.:2005   3rd Qu.:  1.4050   3rd Qu.:  1.4090   3rd Qu.:  1.4090  
##  Max.   :2010   Max.   : 12.0260   Max.   : 12.0260   Max.   : 12.0260  
##       Lag4               Lag5              Volume            Today         
##  Min.   :-18.1950   Min.   :-18.1950   Min.   :0.08747   Min.   :-18.1950  
##  1st Qu.: -1.1580   1st Qu.: -1.1660   1st Qu.:0.33202   1st Qu.: -1.1540  
##  Median :  0.2380   Median :  0.2340   Median :1.00268   Median :  0.2410  
##  Mean   :  0.1458   Mean   :  0.1399   Mean   :1.57462   Mean   :  0.1499  
##  3rd Qu.:  1.4090   3rd Qu.:  1.4050   3rd Qu.:2.05373   3rd Qu.:  1.4050  
##  Max.   : 12.0260   Max.   : 12.0260   Max.   :9.32821   Max.   : 12.0260  
##  Direction 
##  Down:484  
##  Up  :605  
##            
##            
##            
## 
head(Weekly)
##   Year   Lag1   Lag2   Lag3   Lag4   Lag5    Volume  Today Direction
## 1 1990  0.816  1.572 -3.936 -0.229 -3.484 0.1549760 -0.270      Down
## 2 1990 -0.270  0.816  1.572 -3.936 -0.229 0.1485740 -2.576      Down
## 3 1990 -2.576 -0.270  0.816  1.572 -3.936 0.1598375  3.514        Up
## 4 1990  3.514 -2.576 -0.270  0.816  1.572 0.1616300  0.712        Up
## 5 1990  0.712  3.514 -2.576 -0.270  0.816 0.1537280  1.178        Up
## 6 1990  1.178  0.712  3.514 -2.576 -0.270 0.1544440 -1.372      Down

As you can notice,Today is fully correlated with Direction, because Direction is the outcome of the Today’s variable, therefore, I am going to remove it from Data set.

# Remove the highly correlated variables
df = subset(Weekly, select = -c(Today) )

(a) Produce some numerical and graphical summaries of the Weekly data. Do there appear to be any patterns?

corrplot(cor(df[,-8]), method="square")

ggpairs(Weekly,                  # Data frame
        columns = 1:7,           # Columns
        aes(color = Direction,   # Color by group (cat. variable)
            alpha = 0.5),        # Transparency
        upper = list(continuous = wrap("cor", size = 2.4))) # Font size

We can notice that Year and Volume have high correlation, we will check later multi collinearity with Variance Inflation Factor method. The other variables do not have a correlation.

(b) Use the full data set to perform a logistic regression with Direction as the response and the five lag variables plus Volume as predictors. Use the summary() function to print the results. Do any of the predictors appear to be statistically significant? If so,which ones?

fit <- glm(Direction ~ Lag1+Lag2+Lag3+Lag4+Lag5+Volume, data=df,
           family = binomial(link = logit))
summary(fit)
## 
## Call:
## glm(formula = Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 + 
##     Volume, family = binomial(link = logit), data = df)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -1.6949  -1.2565   0.9913   1.0849   1.4579  
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)   
## (Intercept)  0.26686    0.08593   3.106   0.0019 **
## Lag1        -0.04127    0.02641  -1.563   0.1181   
## Lag2         0.05844    0.02686   2.175   0.0296 * 
## Lag3        -0.01606    0.02666  -0.602   0.5469   
## Lag4        -0.02779    0.02646  -1.050   0.2937   
## Lag5        -0.01447    0.02638  -0.549   0.5833   
## Volume      -0.02274    0.03690  -0.616   0.5377   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 1496.2  on 1088  degrees of freedom
## Residual deviance: 1486.4  on 1082  degrees of freedom
## AIC: 1500.4
## 
## Number of Fisher Scoring iterations: 4

The only variable which is statistically significant at the level of significance α =0.05 is Lag2. The other variables are not statistically significant.

(c) Compute the confusion matrix and overall fraction of correct predictions. Explain what the confusion matrix is telling you about the types of mistakes made by logistic regression.

glm.probs <- predict(fit, type = "response")
# Print first 8 probabilities
glm.probs[1:8]
##         1         2         3         4         5         6         7         8 
## 0.6086249 0.6010314 0.5875699 0.4816416 0.6169013 0.5684190 0.5786097 0.5151972

The probabilities are spread out around 0.5, so it is very easy to misclassify the response variable.

#Assign all variables to "Down"
glm.pred <- rep("Down", 1089)
#Assign variables to "Up" whose prob. higher than 0.5
glm.pred[glm.probs>0.5]="Up"

#Create a Confusion Matrix
tab1 <- table(glm.pred,Weekly$Direction)
#Print table
tab1
##         
## glm.pred Down  Up
##     Down   54  48
##     Up    430 557
# Print Overall Probability
mean(glm.pred==Weekly$Direction)
## [1] 0.5610652

The confusion matrix gives me the correct and incorrect predictions, the diagonal elements of the matrix indicate the correct predictions and the off-diagonals represent incorrect predictions.

In this case, there are total 54+557=611 correct predictions and 1089-611=478 incorrect predictions.

So, The logistic model predicted the weekly market trend correctly 56.11% of the time, by using first 5 lags and Volume.

However, if we look at closely, we can see that Logistic model predicted the Up weekly trends \(\frac{557}{557+48}\)=92.07 ; 92.07% correct. On the other hand, Down weekly trends were predicted at a lower rate, \(\frac{54}{54+430}\)=0.1115; or only 11.15% correctly predicted.

This result is misleading us, because we trained and tested the model on the same data set. We should have separated the data and fit the model over train data set and examine how well it predicts over test data set.

(d) Now fit the logistic regression model using a training data period from 1990 to 2008, with Lag2 as the only predictor. Compute the confusion matrix and the overall fraction of correct predictions for the held out data (that is, the data from 2009 and 2010)

#Data Partition
train <- (df$Year<2009)
df.09_10 <- df[!train,]
Test <- df$Direction[!train]

glm.fits <- glm(Direction~Lag2, data = df, family = binomial, subset=train)
glm.probs2 = predict(glm.fits, df.09_10, type = "response")

glm.pred2 <- rep("Down",104)
glm.pred2[glm.probs2>.5]="Up"
#Create a Confusion Matrix
tab2 <- table(glm.pred2,Test)
#Print table
tab2
##          Test
## glm.pred2 Down Up
##      Down    9  5
##      Up     34 56
# Print Overall Probability
mean(glm.pred2==Test)
## [1] 0.625

When we splitted data, and used only one predictor, we obtain sightly better result which is 62.5%.

(e) Repeat (d) using LDA.

#Fit Model
lda.fit = lda(Direction~Lag2, data=df,subset=train)
#Predict 
lda.pred <-predict(lda.fit, df.09_10)
#Assign predicted classes 
lda.class <-lda.pred$class
#Create a Confusion Matrix
tab3 <- table(lda.class, Test)
#Print Confusion Matrix
tab3
##          Test
## lda.class Down Up
##      Down    9  5
##      Up     34 56
# Print Overall Probability
mean(lda.class==Test)
## [1] 0.625

Linear Discriminant Analysis returns a similar results as the logistic regression model returned in part D.

(f) Repeat (d) using QDA.

#Fit Model
qda.fit <- qda(Direction~Lag2, data = df, subset = train)
#Predict
qda <- predict(qda.fit, df.09_10)
#Assign predicted classes 
qda.class <- qda$class
#Create a Confusion Matrix
tab4 <- table(qda.class, Test)
#Print Confusion Matrix
tab4
##          Test
## qda.class Down Up
##      Down    0  0
##      Up     43 61
# Print Overall Probability
mean(qda.class==Test)
## [1] 0.5865385

This is not better than the LDA or GLM prediction. This model only considered predicting the correctness of weekly upward trends, completely disregard the downward weekly trends.

(g) Repeat (d) using KNN with K = 1.

#Data Partition 
train.X <- as.matrix(df$Lag2[train])
test.X <- as.matrix(df$Lag2[!train])
train.Direction =df$Direction[train]


set.seed(1)
#Fit Model
knn.pred <- knn(train.X,test.X, train.Direction, k=1)
#Create confusion Matrix
tab5 <- table(knn.pred, Test)
#Print Confusion Matrix
tab5
##         Test
## knn.pred Down Up
##     Down   21 30
##     Up     22 31
# Print Overall Probability
sum(diag(tab5))/sum(tab5)
## [1] 0.5
#Check Probability Using Mean
mean(knn.pred==Test)
## [1] 0.5

The result is not very good, only 50% of the observations are correctly predicted which is a random chance.

(h) Which of these methods appears to provide the best results on this data? Logistic regression and Linear Discriminant analysis’ results appear to be same with 62.5% correct prediction and highe than Quadratic Discriminant analysis, So I would choose one of those method.

(i) Experiment with different combinations of predictors, including possible transformations and interactions, for each of the methods. Report the variables, method, and associated confusion matrix that appears to provide the best results on the held out data. Note that you should also experiment with values for K in the KNN classifier.

Feature Selection

1.Feature Importance Method

# Prepare training scheme
control <- trainControl(method="repeatedcv", number=10, repeats=3)
# Train the model
model <- train(Direction~., data=df, method="lvq", preProcess="scale", trControl=control)
# Estimate variable importance
importance <- varImp(model, scale=FALSE)
# Summarize importance
plot(importance)

First, I am going to choose the top 4 features that are: Lag1, Lag2, Lag5 and Volume.

2.Backward Stepwise Method

#Logistic Model with All variables
glm.fit <- glm(Direction~Lag1+Lag2+Lag3+Lag4+Lag5+Volume, data = df, family = binomial, subset=train)

back_step<-stepAIC(glm.fit, direction="backward", trace=FALSE)

back_step
## 
## Call:  glm(formula = Direction ~ Lag1 + Lag2, family = binomial, data = df, 
##     subset = train)
## 
## Coefficients:
## (Intercept)         Lag1         Lag2  
##     0.21109     -0.05421      0.05384  
## 
## Degrees of Freedom: 984 Total (i.e. Null);  982 Residual
## Null Deviance:       1355 
## Residual Deviance: 1347  AIC: 1353

Backward Stepwise method suggest me to use only Lag 1 and Lag2 for features.

1.Model: Logistic Regression with Lag1, Lag2, Lag5 and Volume

glm.fit1 <- glm(Direction~Lag1+Lag2+Lag5+Volume, data = df, family = binomial, subset=train)
glm.probs1 = predict(glm.fit1, df.09_10, type = "response")

glm.pred1 <- rep("Down",104)
glm.pred1[glm.probs1>.5]="Up"
table(glm.pred1,Test)
##          Test
## glm.pred1 Down Up
##      Down   30 40
##      Up     13 21
#Prediction Rate
mean(glm.pred1==Test)
## [1] 0.4903846

2.Model: Logistic Regression with Lag1 & Lag2 

glm.fits2 <- glm(Direction~Lag1+Lag2, data = df, family = binomial, subset=train)
glm.probs2 = predict(glm.fits2, df.09_10, type = "response")

glm.pred2 <- rep("Down",104)
glm.pred2[glm.probs2>.5]="Up"

#Prediction Rate
mean(glm.pred2==Test)
## [1] 0.5769231

Lag1 and Lag2 predicts predicts higher rate than the other complex model. Thus, I will be using only these two variables for the further models.

3.Model: LDA with Lag1 & Lag2

lda.fit1 = lda(Direction~Lag1+Lag2, data=df,subset=train)

lda.class1 <-predict(lda.fit1, df.09_10)$class

#Prediction Rate
mean(lda.class1==Test)
## [1] 0.5769231

4.Model:QDA with Lag1 & Lag2

qda.fit1 <- qda(Direction~Lag1+Lag2, data = df, subset = train)

qda.class1 <- predict(qda.fit1, df.09_10)$class

#Prediction Rate
mean(qda.class1==Test)
## [1] 0.5576923

5.Model:KNN with Lag1, Lag2

train.X2 <- cbind(df$Lag1, df$Lag2)[train,]
test.X2 <-  cbind(df$Lag1, df$Lag2)[!train,]
train.Direction =df$Direction[train]

set.seed(1)

#K=2
knn.pred <- knn(train.X2,test.X2, train.Direction, k=2)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.5288462
#K=10
knn.pred <- knn(train.X2,test.X2, train.Direction, k=10)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.4903846
#K=20
knn.pred <- knn(train.X2,test.X2, train.Direction, k=20)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.5480769
#K=30
knn.pred <- knn(train.X2,test.X2, train.Direction, k=30)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.5673077
#K=50
knn.pred <- knn(train.X2,test.X2, train.Direction, k=50)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.5288462
#K=100
knn.pred <- knn(train.X2,test.X2, train.Direction, k=100)
#Prediction Rate
mean(knn.pred==Test)
## [1] 0.5192308
# It gets better when K increases and reach its highest point when K=300

Result: Clearly, QDA method is not better than the other models, Logistic Regression and LDA predicted the highest accuracy rate (57.69%). KNN model with k=30 returns the highest accuracy rate among all of KNN models, however it is still lower than Logistic regression and LDA models.




******************