Assignment 3
#10 > Equation 4.32 derived an expression for log 1 Pr(Y =k|X=x) Pr(Y =K|X=x) in the setting where p > 1, so that the mean for the kth class, µk, is a pdimensional vector, and the shared covariance Σ is a p × p matrix. However, in the setting with p = 1, (4.32) takes a simpler form, since the means µ1,…,µK and the variance σ2 are scalars. In this simpler setting, repeat the calculation in (4.32), and provide expressions for ak and bkj in terms of πk, πK, µk, µK, and σ2
Given that: \[ log(\frac{Pr(Y =k | X =x )}{Pr(Y = K | X = x)}) \]
we can assume the following: \[ log(\frac{\pi _kf_k(x)}{\pi _Kf_K(x)})\] and \[ \log\left(\frac{\pi_k \exp\left(-\frac{1}{2}(x-\mu_k)^T(\Sigma_k)^{-1}(x-\mu_k)\right)}{\pi_K \exp\left(-\frac{1}{2}(x-\mu_K)^T(\Sigma_K)^{-1}(x-\mu_K)\right)}\right) \]
Under the assumption that all the classes have the same variance, the posterior probabilities will become \[ pk(x) = \frac{\pi_k\frac{1}{\sqrt(2\pi\sigma)}exp(\frac{1}{2\sigma^2}(x-\mu_k)^2)}{\sum^k_{i=1}\pi_i(\frac{1}{\sqrt{2\pi\sigma}}exp(\frac{1}{{2\sigma^2}})x-\mu_i)^2)} \]
By simplification, the formula becomes: \[ p_k(x) = x\frac{\mu_k}{\sigma^2}-\frac{\mu^2_k}{2\sigma^2} + log(\pi_k) \]
With the terms \[a_k\] is equivalent to \[ x\frac{\mu_k}{\sigma ^2} - \frac{\mu^2_k}{2\sigma^2}\] and \[b_kj\] is equivalent to \[log(\pi_k)\]
11
Work out the detailed forms of ak, bkj , and bkjl in (4.33). Your answer should involve πk, πK, µk, µK, Σk, and ΣK.
Section 4.33 assumes the following:
\[ log(\frac{Pr(Y =k | X =x )}{Pr(Y = K | X = x)}) = a_k + \sum_{j=1}^{p}b_{kj}x_j + \sum_{j=1}^{p}\sum_{i=1}^{p}c_{kji}x_{j}x_i \] Where \[a_k=\] \[log(\frac{\pi_k}{\pi_k})\]
and \[b_{bj}=\] \[log(\frac{b_{kj}x_j}{\pi_{Kj}x_j})\]
and lastly \[c_{kji}=\] \[log(\frac{c_{kji}x_jx_i}{c_{Kji}x_jx_i})\]
13
This question should be answered using the Weekly data set, which is part of the ISLR2 package. 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.
- Produce some numerical and graphical summaries of te weekly data. Do there appear to be any patterns?
library(ISLR2)## Warning: package 'ISLR2' was built under R version 4.1.3head(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 Downpairs(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
##
##
##
## The data has information from year 1990 - year 2010. As far as relationships go, there appears to me a logrithmic relationship between year and volume.
cor(Weekly[,-9])## Year Lag1 Lag2 Lag3 Lag4
## Year 1.00000000 -0.032289274 -0.03339001 -0.03000649 -0.031127923
## Lag1 -0.03228927 1.000000000 -0.07485305 0.05863568 -0.071273876
## Lag2 -0.03339001 -0.074853051 1.00000000 -0.07572091 0.058381535
## Lag3 -0.03000649 0.058635682 -0.07572091 1.00000000 -0.075395865
## Lag4 -0.03112792 -0.071273876 0.05838153 -0.07539587 1.000000000
## Lag5 -0.03051910 -0.008183096 -0.07249948 0.06065717 -0.075675027
## Volume 0.84194162 -0.064951313 -0.08551314 -0.06928771 -0.061074617
## Today -0.03245989 -0.075031842 0.05916672 -0.07124364 -0.007825873
## Lag5 Volume Today
## Year -0.030519101 0.84194162 -0.032459894
## Lag1 -0.008183096 -0.06495131 -0.075031842
## Lag2 -0.072499482 -0.08551314 0.059166717
## Lag3 0.060657175 -0.06928771 -0.071243639
## Lag4 -0.075675027 -0.06107462 -0.007825873
## Lag5 1.000000000 -0.05851741 0.011012698
## Volume -0.058517414 1.00000000 -0.033077783
## Today 0.011012698 -0.03307778 1.000000000There is a strong correlation between Year and Volume
- 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?
glm.fits = glm(Direction~Lag1+Lag2+Lag3+Lag4+Lag5+ Volume, data = Weekly, family = binomial)
summary(glm.fits)##
## Call:
## glm(formula = Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 +
## Volume, family = binomial, data = Weekly)
##
## 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: 4The most significan variable appears to be Lag2 with an estiamte of .058. This means that if the stock market went up 2 years ago, it is more likely to go up in the week you are present in
- 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(glm.fits, type = "response")
glm.probs[1:10]## 1 2 3 4 5 6 7 8
## 0.6086249 0.6010314 0.5875699 0.4816416 0.6169013 0.5684190 0.5786097 0.5151972
## 9 10
## 0.5715200 0.5554287contrasts(Weekly$Direction)## Up
## Down 0
## Up 1summary(Weekly$Direction)## Down Up
## 484 605dim(Weekly)## [1] 1089 9glm.pred = rep("Down", nrow(Weekly)) # uses the #of rows on weekly
glm.pred[glm.probs > .5] = "Up"table(glm.pred, Weekly$Direction)##
## glm.pred Down Up
## Down 54 48
## Up 430 557The confusion matrix is presented above (54 + 557)/1089 = .5610652
This demonstrates that the model predicted the weekly market trend 56.11% of the time. However, it appears to predict for up 92% of the time, while for odwn only 11.15% of the time
- 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).
train = (Weekly$Year<2009)
Weekly.2009 = Weekly[!train,]
Direction.2009 = Weekly$Direction[!train]
dim(Weekly.2009)## [1] 104 9glm.fits = glm(Direction ~ Lag2, data = Weekly, family =binomial, subset = train)
glm.probs = predict(glm.fits, Weekly.2009, type = "response")glm.pred = rep("Down", nrow(Weekly.2009))
glm.pred[glm.probs > .5] = "Up"table(glm.pred, Direction.2009)## Direction.2009
## glm.pred Down Up
## Down 9 5
## Up 34 56\[ \frac{56+9}{104} = .625\] The model correctly ID the weekly movement of the stock market 62.5% of the time for the years 2009 and 2010
- Repeat (d) using LDA
library(MASS)## Warning: package 'MASS' was built under R version 4.1.3##
## Attaching package: 'MASS'## The following object is masked from 'package:ISLR2':
##
## Bostonlda.fit = lda(Direction~Lag2, data = Weekly, subset = train)
lda.fit## Call:
## lda(Direction ~ Lag2, data = Weekly, subset = train)
##
## Prior probabilities of groups:
## Down Up
## 0.4477157 0.5522843
##
## Group means:
## Lag2
## Down -0.03568254
## Up 0.26036581
##
## Coefficients of linear discriminants:
## LD1
## Lag2 0.4414162The prior probabilities of the groups for Down is .44 and for Up it is .56
lda.pred = predict(lda.fit, Weekly.2009)
names(lda.pred)## [1] "class" "posterior" "x"lda.class = lda.pred$class
table(lda.class, Direction.2009)## Direction.2009
## lda.class Down Up
## Down 9 5
## Up 34 56The lda model makes a correct prediction \[ (56+9)/104 \] 62.5% of the time
- Repeat (d) using QDA.
qda.fit = qda(Direction~Lag2, data = Weekly, subset = train)
qda.fit## Call:
## qda(Direction ~ Lag2, data = Weekly, subset = train)
##
## Prior probabilities of groups:
## Down Up
## 0.4477157 0.5522843
##
## Group means:
## Lag2
## Down -0.03568254
## Up 0.26036581The prior probabilities of the groups for Down is .45 and for Up it is .55
qda.class = predict(qda.fit, Weekly.2009)$class
table(qda.class, Direction.2009)## Direction.2009
## qda.class Down Up
## Down 0 0
## Up 43 61The QDA model predicted correctly \[ \frac{0+61}{104} = .5865385 \] of the time.
- Repeat (d) using KNN with K = 1.
attach(Weekly)
library(class)## Warning: package 'class' was built under R version 4.1.3train.X = cbind(Lag1, Lag2)[train,]
test.X = cbind(Lag1, Lag2)[!train,]
train.Direction = Weekly$Direction[train]set.seed(1)
knn.pred = knn(train.X, test.X, train.Direction, k =1)
table(knn.pred, Direction.2009)## Direction.2009
## knn.pred Down Up
## Down 18 29
## Up 25 32(32+18)/ 104## [1] 0.4807692Knn predicted correctly .48% of the time
detach(Weekly)
- Repeat (d) using naive Bayes.
library(e1071)## Warning: package 'e1071' was built under R version 4.1.3library(ISLR)## Warning: package 'ISLR' was built under R version 4.1.3##
## Attaching package: 'ISLR'## The following objects are masked from 'package:ISLR2':
##
## Auto, Creditnb.fit = naiveBayes(Direction~Lag2, data = Weekly, subset = train)
nb.fit##
## Naive Bayes Classifier for Discrete Predictors
##
## Call:
## naiveBayes.default(x = X, y = Y, laplace = laplace)
##
## A-priori probabilities:
## Y
## Down Up
## 0.4477157 0.5522843
##
## Conditional probabilities:
## Lag2
## Y [,1] [,2]
## Down -0.03568254 2.199504
## Up 0.26036581 2.317485nb.class = predict(nb.fit, Weekly.2009)
table(nb.class, Direction.2009)## Direction.2009
## nb.class Down Up
## Down 0 0
## Up 43 61The model only correctly predicts 58.65% of the time. However, it never predicts for down
- Which of these methods appear to provide the best results on the data?
By just looking at the predictions, it looks like Logistic Regression and Linear discriminant analysis had the highest (and same)accuracy out of all the 5 models.
- Experiment with different combinations of predictors including possible transformations and interactiosn for each method:
Logistic Regression:
train = (Weekly$Year<2009)
Weekly.2009 = Weekly[!train,]
Direction.2009 = Weekly$Direction[!train]
dim(Weekly.2009)## [1] 104 9glm.fits = glm(Direction ~ Lag2:Lag4+Lag2, data = Weekly, family =binomial, subset = train)
glm.probs = predict(glm.fits, Weekly.2009, type = "response")
glm.pred = rep("Down", nrow(Weekly.2009))
glm.pred[glm.probs > .5] = "Up"
table(glm.pred, Direction.2009)## Direction.2009
## glm.pred Down Up
## Down 3 4
## Up 40 57\[ \frac{57+3}{104} = .5769 \]
The model correctly ID the weekly movement of the stock market 57.8% of the time for the years 2009 and 2010. Note, this is THE SAME as if it is
LDA
lda.fit = lda(Direction~ Lag2:Lag4+Lag2, data = Weekly, subset = train)
lda.fit## Call:
## lda(Direction ~ Lag2:Lag4 + Lag2, data = Weekly, subset = train)
##
## Prior probabilities of groups:
## Down Up
## 0.4477157 0.5522843
##
## Group means:
## Lag2 Lag2:Lag4
## Down -0.03568254 0.78824608
## Up 0.26036581 0.04407141
##
## Coefficients of linear discriminants:
## LD1
## Lag2 0.3442725
## Lag2:Lag4 -0.0608715lda.pred = predict(lda.fit, Weekly.2009)
names(lda.pred)## [1] "class" "posterior" "x"lda.class = lda.pred$class
table(lda.class, Direction.2009)## Direction.2009
## lda.class Down Up
## Down 3 3
## Up 40 58\[ \frac{58+3}{104} = .5865 \] The lda model makes a correct prediction 58.65% of the time
QDA
qda.fit = qda(Direction~Lag2:Lag4+Lag2, data = Weekly, subset = train)
qda.fit## Call:
## qda(Direction ~ Lag2:Lag4 + Lag2, data = Weekly, subset = train)
##
## Prior probabilities of groups:
## Down Up
## 0.4477157 0.5522843
##
## Group means:
## Lag2 Lag2:Lag4
## Down -0.03568254 0.78824608
## Up 0.26036581 0.04407141qda.class = predict(qda.fit, Weekly.2009)$class
table(qda.class, Direction.2009)## Direction.2009
## qda.class Down Up
## Down 7 6
## Up 36 55\[ \frac{55+7}{104} = .5480769231\] The QDA model predicted correctly 54.8% of the time
KNN
attach(Weekly)
Week.train=as.matrix(Lag2[train])
Week.test=as.matrix(Lag2[!train])
train.Direction =Direction[train]
set.seed(1)
Weekknn.pred=knn(Week.train,Week.test,train.Direction,k=10)
table(Weekknn.pred,Direction.2009)## Direction.2009
## Weekknn.pred Down Up
## Down 17 21
## Up 26 40When k = 10, we have a 54.8% accuracy
Week.train=as.matrix(Lag2[train])
Week.test=as.matrix(Lag2[!train])
train.Direction =Direction[train]
set.seed(1)
Weekknn.pred=knn(Week.train,Week.test,train.Direction,k=100)
table(Weekknn.pred,Direction.2009)## Direction.2009
## Weekknn.pred Down Up
## Down 10 11
## Up 33 50When k = 100, we have a 57.7% accuracy
Bayes
nb.fit = naiveBayes(Direction~Lag2*Lag2, data = Weekly, subset = train)
nb.fit##
## Naive Bayes Classifier for Discrete Predictors
##
## Call:
## naiveBayes.default(x = X, y = Y, laplace = laplace)
##
## A-priori probabilities:
## Y
## Down Up
## 0.4477157 0.5522843
##
## Conditional probabilities:
## Lag2
## Y [,1] [,2]
## Down -0.03568254 2.199504
## Up 0.26036581 2.317485nb.class = predict(nb.fit, Weekly.2009)
table(nb.class, Direction.2009)## Direction.2009
## nb.class Down Up
## Down 0 0
## Up 43 61\[ \frac{63}{104} = .5865\]
The model only correctly predicts 58.65% of the time. However, it never predicts for down