Assignment 3

Applied Questions

Question 10

10a

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

names(Weekly)

## [1] "Year"      "Lag1"      "Lag2"      "Lag3"      "Lag4"      "Lag5"     
## [7] "Volume"    "Today"     "Direction"

dim(Weekly)

## [1] 1089    9

data("Weekly")

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  
##            
##            
##            
##

plot(Weekly)

CorrWeekly<-cor(Weekly[, names(Weekly) !="Direction"])
corrplot(CorrWeekly, method = "number")

RESPONSE: By analyzing the scatter plot matrix, there seems to be a positive correlation between the variables years and volume which would be the year the observation was recorded, and the average daily volume of shares traded. Perhaps this just tells us as the years have gone by more and more trading has occured. The average volume of daily shares traded from 1990 to 2010 has been about 1.57 billion! From the other variables, which can be translated as the percentage returns for the previous week, the percentage return for the previous two week period, and so on, have around the same means. The correlation heat matrix as I call it gives us a good visualisation of the relationships of the variables. As noted volume and year are positvely correlated. We can also say that there appears to be no correlation between the weekly returns.

10b

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?

logitDirect <- glm(Direction~., data=Weekly[,c(2:7,9)], family=binomial) # note to self that the function glm is similiar to lm, however we must pass the argument family = binomial to tell R to run a logistic regression rather than some other glm. 

summary(logitDirect)

## 
## Call:
## glm(formula = Direction ~ ., family = binomial, data = Weekly[, 
##     c(2:7, 9)])
## 
## 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

RESPONSE: The only statistically significant predictor variable of interest is Lag2.

10c

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.

LogiProb<- predict(logitDirect, Weekly, type="response")
LogiPred <- ifelse(LogiProb > 0.5, "Up", "Down")
table( LogiPred, Weekly$Direction)

##         
## LogiPred Down  Up
##     Down   54  48
##     Up    430 557

(54+557)/nrow(Weekly) # Accuracy Rate

## [1] 0.5610652

54/(54+48) # Down weeks Accuracy

## [1] 0.5294118

557/(430+557) # Up weeks Accuracy

## [1] 0.5643364

RESPONSE: The confusion matrix allows us to see how accurately our predictions are with a .50 predicted probability that the weekly return would be up or down. We see the overall accuracy rate is around 56.11%. We also can say that the accuracy rate for Up weeks is higher than the accuracy rates of down weeks at 56.43% and 52.94% respectively.

10d

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).

TrainYrs <- Weekly$Year %in% (1990:2008)
Train <- Weekly[TrainYrs,]
Test <- Weekly[!TrainYrs,]
fit2 <- glm(Direction~Lag2, data=Train, family=binomial) # note to self this is log regression for Direction ~ Lag2
fit2Prob <- predict(fit2, Test, type="response")
fit2Pred <- ifelse(fit2Prob > 0.5, "Up", "Down")
table(fit2Pred, Test$Direction)

##         
## fit2Pred Down Up
##     Down    9  5
##     Up     34 56

mean(fit2Pred == Test$Direction)  # Accuracy Rate Logistic Regression

## [1] 0.625

10e

Repeat (d) using LDA

LDAWeekly<- lda(Direction~Lag2, data=Train)
FitPredLDA <- predict(LDAWeekly, Test)$class
table(FitPredLDA, Test$Direction)

##           
## FitPredLDA Down Up
##       Down    9  5
##       Up     34 56

mean(FitPredLDA == Test$Direction)  # Accuracy Rate LDA

## [1] 0.625

10f

Repeat (d) using QDA

QDAFit<- qda(Direction~Lag2, data=Train)
QDAFitPred <- predict(QDAFit, Test)$class
table(QDAFitPred, Test$Direction)

##           
## QDAFitPred Down Up
##       Down    0  0
##       Up     43 61

mean(QDAFitPred == Test$Direction)  # Accuracy Rate QDA

## [1] 0.5865385

10g

Repeat (d) using KNN with K = 1

set.seed(1)
TrainX<- as.matrix(Train$Lag2)
TestX<- as.matrix(Test$Lag2)
KNNPred<- knn(TrainX, TestX, Train$Direction, k=1)
table(KNNPred, Test$Direction)

##        
## KNNPred Down Up
##    Down   21 30
##    Up     22 31

mean(KNNPred == Test$Direction)  # Accuracy Rate KNN = 1

## [1] 0.5

10h

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

RESPONSE: The best methods were the logistic regression and the Linear Discriminant Analysis, resulting in accuracy rates at 62.5%.

10i

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.

KNNPred.i <- knn(TrainX, TestX, Train$Direction, k =15)
table(KNNPred.i, Test$Direction)

##          
## KNNPred.i Down Up
##      Down   20 20
##      Up     23 41

mean(KNNPred.i == Test$Direction)

## [1] 0.5865385

RESPONSE: Experimenting with the K nearest neighbor classifying method, k values between 12-15 gave the best accuracy rate around 58%.

LDAWeekly.i<- lda(Direction~Lag2^2, data=Train)
FitPredLDA.i <- predict(LDAWeekly.i, Test)$class
table(FitPredLDA.i, Test$Direction)

##             
## FitPredLDA.i Down Up
##         Down    9  5
##         Up     34 56

mean(FitPredLDA == Test$Direction)  # Accuracy Rate LDA

## [1] 0.625

RESPONSE:I wanted to see if perfroming a transformation would result in a higher accuracy rate but as we see the accuracy rate for the Linear Discriminant Analysis was unchanged.

Question 11

11a

Create a binary variable, mpg01, that contains a 1 if mpg contains a value above its median, and a 0 if mpg contains a value below its median. You can compute the median using the median() function. Note you may find it helpful to use the data.frame() function to create a single data set containing both mpg01 and the other Auto variables.

data(Auto)
mpg01 <- ifelse(Auto$mpg > median(Auto$mpg), 1, 0)
Auto2 <- data.frame(Auto, mpg01)
table(mpg01)

## mpg01
##   0   1 
## 196 196

11b

Explore the data graphically in order to investigate the association between mpg01 and the other features. Which of the other features seem most likely to be useful in predicting mpg01? Scatterplots and boxplots may be useful tools to answer this question. Describe your findings.

pairs(Auto2)

ggplot(Auto2 , aes(x = weight, y = mpg01)) + geom_point()

par(mfrow = c(2,2))
boxplot(weight~mpg01,Auto2,main = "Weight by mpg01")
boxplot(displacement~mpg01,Auto2,main = "Displacement by mpg01")
boxplot(acceleration~mpg01,Auto2,main = "Acceleration by mpg01")
boxplot(horsepower~mpg01,Auto2,main = "Horsepower by mpg01")

RESPONSE: Box plots are a good way to vizualize how our dummy variable mpg01 is associated through out the data set. It isn’t as clear in the scatter plot matrix what associations there are with mpg01 and the predictor variables. Recall, the mpg01 variable contains a 1 if mpg contains a value above its median, and a 0 if mpg contains a value below its median. So the boxplots essentially show us for example in weight there is a clear difference in the mean values betweeon 0 and 1 and perhaps this could be useful in predicting mpg01, as is the case with the other three predictors I made boxplots for.

11c

Split the data into a training set and a test set.

set.seed(1)
trainSetup <- sample(1:nrow(Auto2), nrow(Auto2)*0.7 , replace=F)  #70% train, 30% test
train <- Auto2[trainSetup,]
test <- Auto2[-trainSetup,]

11d

Perform LDA on the training data in order to predict mpg01 using the variables that seemed most associated with mpg01 in (b). What is the test error of the model obtained?

LDAFit<- lda(mpg01~displacement+horsepower+weight+acceleration, data=train)
LDAFitPred<- predict(LDAFit, test)$class
table(LDAFitPred, test$mpg01)

##           
## LDAFitPred  0  1
##          0 47  1
##          1 14 56

mean(LDAFitPred != test$mpg01) #error Rate

## [1] 0.1271186

Response: LDA Error Rate = 12.71%

11e

Perform QDA on the training data in order to predict mpg01 using the variables that seemed most associated with mpg01 in (b). What is the test error of the model obtained?

QDAFit <- qda(mpg01~displacement+horsepower+weight+acceleration, data=train)
QDAFitPred <- predict(QDAFit, test)$class
table(QDAFitPred, test$mpg01)

##           
## QDAFitPred  0  1
##          0 49  5
##          1 12 52

mean(QDAFitPred != test$mpg01)  # error rate

## [1] 0.1440678

RESPONSE: QDA Error Rate: 14.41%

11f

Perform logistic regression on the training data in order to predict mpg01 using the variables that seemed most associated with mpg01 in (b). What is the test error of the model obtained?

LogisticRegFit <- glm(mpg01~displacement+horsepower+weight+acceleration, data=train, family=binomial)
LogisticProb <- predict(LogisticRegFit, test, type="response")
LogisticPred <- ifelse(LogisticProb > 0.5, 1, 0)
table(LogisticPred, test$mpg01)

##             
## LogisticPred  0  1
##            0 53  4
##            1  8 53

mean(LogisticPred != test$mpg01)  # error rate

## [1] 0.1016949

RESPONSE: Logistic Regression Error Rate: 10.17%

11g

Perform KNN on the training data, with several values of K, in order to predict mpg01. Use only the variables that seemed most associated with mpg01 in (b). What test errors do you obtain? Which value of K seems to perform the best on this data set?

TrainX <- cbind(train$displacement, train$horsepower, train$weight, train$acceleration)
TestX <- cbind(test$displacement, test$horsepower, test$weight, test$acceleration)
KNNPred <- knn(TrainX, TestX, train$mpg01, k=4)
table(KNNPred, test$mpg01)

##        
## KNNPred  0  1
##       0 51  4
##       1 10 53

mean(KNNPred != test$mpg01)

## [1] 0.1186441

RESPONSE: K values around 3-5, or lower values seem to result in a better KNN classification method resulting in an error rate of as low as 9%

Question 13

Using the Boston data set, fit classification models in order to predict whether a given suburb has a crime rate above or below the median. Explore logistic regression, LDA, and KNN models using various subsets of the predictors. Describe your findings.

rm(list=ls())
data(Boston)
crim01 <- ifelse(Boston$crim > median(Boston$crim), 1, 0)


attach(Boston)
par(mfrow=c(2,6))
for(i in names(Boston)){
  if( grepl(i, pattern="^crim|^chas")){ next}# excluding the own crime variables and the chas variable
  boxplot(eval(parse(text=i)) ~ crim01, ylab=i, col=c("orange", "blue"), varwidth=T)
}

RESPONSE: Most of the predictor variables show some difference in means within our crim01. It is noteworthy to look at the outliers that are present in age, rm, and black predictor variables.

Boston2 <- data.frame(Boston, crim01)
pairs(Boston2)

sort(cor(Boston2)[1,])

##        medv       black         dis          rm          zn        chas 
## -0.38830461 -0.38506394 -0.37967009 -0.21924670 -0.20046922 -0.05589158 
##     ptratio         age       indus      crim01         nox       lstat 
##  0.28994558  0.35273425  0.40658341  0.40939545  0.42097171  0.45562148 
##         tax         rad        crim 
##  0.58276431  0.62550515  1.00000000

RESPONSE: The above scatter plot matrix and correlations show us that crim is mostly correlated to tax and rad.

set.seed(1)
BostonTrain <- sample(1:nrow(Boston2), nrow(Boston2)*0.7 , replace=F)  # 70% train, 30% test
train <- Boston2[BostonTrain,]
test <- Boston2[-BostonTrain,]
train.X1 <- cbind(train$age, train$dis, train$lstat, train$medv)
test.X1 <- cbind(test$age, test$dis, test$lstat, test$medv)
train.X2 <- cbind(train$tax, train$rad)
test.X2 <- cbind(test$tax, test$rad)

Linear Regressions Method

BostonLogistic <- glm(crim01~age+dis+medv+tax+rad+nox, data=train, family=binomial)
BostonProb <- predict(BostonLogistic, test, type="response")
BostonPred <- ifelse(BostonProb > 0.5, 1, 0)
mean(BostonPred != test$crim01)  # error rate

## [1] 0.1578947

BostonLogistic2 <- glm(crim01~nox, data=train, family=binomial)
BostonProb2 <- predict(BostonLogistic2, test, type="response")
BostonPred2 <- ifelse(BostonProb2 > 0.5, 1, 0)
mean(BostonPred2 != test$crim01)  # error rate

## [1] 0.1184211

RESPONSE:It is a bit surprising that by using only nox, a variable that is defined as nitrogen oxides concentrations (parts per 10 million), results in a lower error rate compared to the Logistic Regression using more predictors.

Least Discriminant Analysis Method

BostonLDA <- lda(crim01~age+dis+nox+medv+tax+rad, data=train)
BostonLDAPred <- predict(BostonLDA, test)$class
mean(BostonLDAPred != test$crim01)  # error rate

## [1] 0.125

BostonLDA2 <- lda(crim01~nox ,data=train)
BostonLDAPred2 <- predict(BostonLDA2, test)$class
mean(BostonLDAPred2 != test$crim01)  # error rate

## [1] 0.1710526

RESPONSE: the LDA method resulted in the opposite conclusion, the error rate is lower for the LDA that had more predictor variables, however it is still higher than the Linear Regression using only nox. The lowest error rate for the LDA was 12.50% compared to the lowest Logistic Regression error rate at 11.84%

Quadratic Discriminant Analysis Method

BostonQDA <- qda(crim01~age+dis+nox+medv+tax+rad, data=train)
BostonQDAPred <- predict(BostonQDA, test)$class
mean(BostonQDAPred != test$crim01)  # error rate

## [1] 0.1381579

BostonQDA2 <- qda(crim01~nox+black+age+tax+medv, data=train)
BostonQDAPred2<- predict(BostonQDA2, test)$class
mean(BostonQDAPred2 != test$crim01)  # error rate

## [1] 0.1315789

RESPONSE: The second QDA resulted in a lower error rate, yet still not better then the logistic regression using only nox

K Nearest Neighbor Method

set.seed(1)
BostonKNNPred <- knn(train.X1, test.X1, train$crim01, k=10)
mean(BostonKNNPred != test$crim01)

## [1] 0.1644737

knn2.pred <- knn(train.X2, test.X2, train$crim01, k=1)
mean(knn2.pred != test$crim01)

## [1] 0.03947368

RESPONSE: Out of all the methods the KNN method with two predictors yielded the lowest error rate.Indeed a considerably lower error rate compared to all the other methods, at around 3.95%.