hw 4 Emmanuel
Emmanuel Ferdinand Anggawirja
2023-05-24
library(ISLR2)
library(ggplot2)
#Numerical and Graphical summaries
data("Weekly")
names(Weekly)## [1] "Year" "Lag1" "Lag2" "Lag3" "Lag4" "Lag5"
## [7] "Volume" "Today" "Direction"dim(Weekly)## [1] 1089 9summary(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
##
##
##
## pairs(Weekly)
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.000000000attach(Weekly)
plot(Volume)
ggplot(Weekly, aes(x = Year, y = Today)) +
geom_line() +
labs(title = "Weekly Returns",
x = "Year",
y = "Today")
ggplot(Weekly, aes(x = Volume, y = Today)) +
geom_point() +
labs(title = "Volume vs. Today",
x = "Volume",
y = "Today")
#From this code, we can see that there's a pattern between each lag and today, where the value of Minimum, 1st quarter, Median, Mean, 3rd quarter, and Maximum are all the same.
#As for the correlation between each variables, most of it has no significant correlation, except between volume and year.
#Logistic Regression
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: 4###
coef(glm.fits)## (Intercept) Lag1 Lag2 Lag3 Lag4 Lag5
## 0.26686414 -0.04126894 0.05844168 -0.01606114 -0.02779021 -0.01447206
## Volume
## -0.02274153summary(glm.fits)$coef## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 0.26686414 0.08592961 3.1056134 0.001898848
## Lag1 -0.04126894 0.02641026 -1.5626099 0.118144368
## Lag2 0.05844168 0.02686499 2.1753839 0.029601361
## Lag3 -0.01606114 0.02666299 -0.6023760 0.546923890
## Lag4 -0.02779021 0.02646332 -1.0501409 0.293653342
## Lag5 -0.01447206 0.02638478 -0.5485006 0.583348244
## Volume -0.02274153 0.03689812 -0.6163330 0.537674762summary(glm.fits)$coef[, 4]## (Intercept) Lag1 Lag2 Lag3 Lag4 Lag5
## 0.001898848 0.118144368 0.029601361 0.546923890 0.293653342 0.583348244
## Volume
## 0.537674762###
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(Direction)## Up
## Down 0
## Up 1###
glm.pred <- rep("Down", 1250)
glm.pred[glm.probs > .5] = "Up"
###
train <- (Year < 2005)
Weekly.2005 <- Weekly[!train, ]
dim(Weekly.2005)## [1] 313 9Direction.2005 <- Direction[!train]
###
glm.fits <- glm(
Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 + Volume,
data = Weekly, family = binomial, subset = train
)
glm.probs <- predict(glm.fits, Weekly.2005,
type = "response")
###
glm.pred <- rep("Down", 252)
glm.pred[glm.probs > .5] <- "Up"
###
glm.fits <- glm(Direction ~ Lag1 + Lag2, data = Weekly,
family = binomial, subset = train)
glm.probs <- predict(glm.fits, Weekly.2005,
type = "response")
glm.pred <- rep("Down", 252)
glm.pred[glm.probs > .5] <- "Up"
###
predict(glm.fits,
newdata =
data.frame(Lag1 = c(1.2, 1.5), Lag2 = c(1.1, -0.8)),
type = "response"
)## 1 2
## 0.5620031 0.5365234summary(glm.pred)## Length Class Mode
## 313 character character#alternative code for Logistic Regression
logit_model <- glm(Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 + Volume, data = Weekly, family = "binomial")
summary(logit_model)##
## 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: 4#Based on the result, we can see that Lag2 predictors appears to be statistically significant with the p value of 0.0296, which rejects the null hypothesis.
#Compute confusion matrix and overall fraction of correct predicitons
predicted <- ifelse(predict(logit_model, type = "response") > 0.5, "Up", "Down")
confusion_matrix <- table(Actual = Weekly$Direction, Predicted = predicted)
correct_predictions <- sum(diag(confusion_matrix)) / sum(confusion_matrix)
print(confusion_matrix)## Predicted
## Actual Down Up
## Down 54 430
## Up 48 557cat("\nOverall fraction of correct predictions: ", correct_predictions)##
## Overall fraction of correct predictions: 0.5610652#Based on the result, we can see that it has 557 result of true positive, 54 result of true negative, 48 result of false positive, and 430 result of false negative, with 0.56 as the overall fraction. We can see that the this model produce a high false negative result, which means it falsely predict the actual "Down" of the data.
#Logistic regression using data from year 1990 to 2008 as training data and Lag2 as the only predictor. The training will be using the rest of the data (2009-2010)
train_start <- 1990
train_end <- 2008
train_data <- subset(Weekly, Year >= train_start & Year <= train_end)
logit_model2 <- glm(Direction ~ Lag2, data = train_data, family = "binomial")
test_data <- subset(Weekly, Year > train_end)
predicted2 <- ifelse(predict(logit_model2, newdata = test_data, type = "response") > 0.5, "Up", "Down")
confusion_matrix2 <- table(Actual = test_data$Direction, Predicted = predicted2)
correct_predictions2 <- sum(diag(confusion_matrix2)) / sum(confusion_matrix2)
print(confusion_matrix2)## Predicted
## Actual Down Up
## Down 9 34
## Up 5 56cat("\nOverall fraction of correct predictions: ", correct_predictions2)##
## Overall fraction of correct predictions: 0.625#We can see improvement in the result by using Lag2 as the only predictor with 0.625 overall fraction
#Using Linear Discriminant Analysis
library(MASS)##
## Attaching package: 'MASS'## The following object is masked from 'package:ISLR2':
##
## Bostonlda_model <- lda(Direction ~ Lag2, data = train_data)
predicted3 <- predict(lda_model, newdata = test_data)$class
confusion_matrix3 <- table(Actual = test_data$Direction, Predicted = predicted3)
correct_predictions3 <- sum(diag(confusion_matrix3)) / sum(confusion_matrix3)
print(confusion_matrix3)## Predicted
## Actual Down Up
## Down 9 34
## Up 5 56cat("\nOverall fraction of correct predictions: ", correct_predictions3)##
## Overall fraction of correct predictions: 0.625#Using Quadratic Discriminant Analysis
qda_model <- qda(Direction ~ Lag2, data = train_data)
predicted4 <- predict(qda_model, newdata = test_data)$class
confusion_matrix4 <- table(Actual = test_data$Direction, Predicted = predicted4)
correct_predictions4 <- sum(diag(confusion_matrix4)) / sum(confusion_matrix4)
print(confusion_matrix4)## Predicted
## Actual Down Up
## Down 0 43
## Up 0 61cat("\nOverall fraction of correct predictions: ", correct_predictions4)##
## Overall fraction of correct predictions: 0.5865385#Using KNN with k=1
library(class)
train_lag2 <- as.matrix(train_data$Lag2)
test_lag2 <- as.matrix(Weekly$Lag2[Year > train_end])
train_direction <- train_data$Direction
knn_model <- knn(train_lag2, test_lag2, train_direction, k = 1)
confusion_matrix5 <- table(Actual = Weekly$Direction[Year > train_end], Predicted = knn_model)
correct_predictions5 <- sum(diag(confusion_matrix5)) / sum(confusion_matrix5)
print(confusion_matrix5)## Predicted
## Actual Down Up
## Down 21 22
## Up 29 32cat("\nOverall fraction of correct predictions: ", correct_predictions5)##
## Overall fraction of correct predictions: 0.5096154#Using Naive Bayes
library(e1071)
nb_model <- naiveBayes(Direction ~ Lag2, data = train_data)
predicted5 <- predict(nb_model, newdata = test_data)
confusion_matrix6 <- table(Actual = test_data$Direction, Predicted = predicted5)
correct_predictions6 <- sum(diag(confusion_matrix6)) / sum(confusion_matrix6)
print(confusion_matrix6)## Predicted
## Actual Down Up
## Down 0 43
## Up 0 61cat("\nOverall fraction of correct predictions: ", correct_predictions6)##
## Overall fraction of correct predictions: 0.5865385#Based on the results of using different types of classification, the Logistic Regression and Linear Discriminant Analysis (LDA) offers the best result with 0.625 overall fraction.
#Experiment (KNN with cross validation)
train_predictors <- train_data[, "Lag2", drop = FALSE]
train_response <- train_data[, "Direction"]
library(caret)## Loading required package: latticeset.seed(123)
train_control <- trainControl(method = "cv", number = 10)
k_values <- 1:20
knn_model1 <- train(train_predictors, train_response,
method = "knn",
trControl = train_control,
tuneGrid = data.frame(k = k_values))
best_k <- knn_model1$bestTune$k
knn_model_best <- knn(train_predictors, train_predictors, train_response, k = best_k)
test_predictors <- test_data[, "Lag2", drop = FALSE]
test_response <- test_data[, "Direction"]
knn_predictions <- knn(train_predictors, test_predictors, train_response, k = best_k)
confusion_matrix7 <- table(Actual = test_response, Predicted = knn_predictions)
correct_predictions7 <- sum(diag(confusion_matrix7)) / sum(confusion_matrix7)
print(confusion_matrix7)## Predicted
## Actual Down Up
## Down 19 24
## Up 22 39cat("\nBest k value: ", best_k)##
## Best k value: 19cat("\nOverall fraction of correct predictions: ", correct_predictions7)##
## Overall fraction of correct predictions: 0.5576923#Experiment (iterate all possible combination of predictors)
predictor_vars <- c("Lag1", "Lag2", "Lag3", "Lag4", "Lag5", "Volume")
results <- list()
for (k in 1:length(predictor_vars)) {
predictors_combinations <- combn(predictor_vars, k)
for (i in 1:ncol(predictors_combinations)) {
predictors <- predictors_combinations[, i]
predictors_formula <- as.formula(paste("Direction ~", paste(predictors, collapse = " + ")))
lda_model2 <- lda(predictors_formula, data = train_data)
lda_predictions <- predict(lda_model2, newdata = test_data)
confusion_matrix8 <- table(Actual = test_data$Direction, Predicted = lda_predictions$class)
accuracy <- sum(diag(confusion_matrix8)) / sum(confusion_matrix8)
results[[paste(predictors, collapse = "-")]] <- accuracy
}
}
best_combination <- names(results)[which.max(unlist(results))]
print(results)## $Lag1
## [1] 0.5673077
##
## $Lag2
## [1] 0.625
##
## $Lag3
## [1] 0.5865385
##
## $Lag4
## [1] 0.5865385
##
## $Lag5
## [1] 0.5576923
##
## $Volume
## [1] 0.4519231
##
## $`Lag1-Lag2`
## [1] 0.5769231
##
## $`Lag1-Lag3`
## [1] 0.5961538
##
## $`Lag1-Lag4`
## [1] 0.5865385
##
## $`Lag1-Lag5`
## [1] 0.5288462
##
## $`Lag1-Volume`
## [1] 0.4615385
##
## $`Lag2-Lag3`
## [1] 0.625
##
## $`Lag2-Lag4`
## [1] 0.625
##
## $`Lag2-Lag5`
## [1] 0.5961538
##
## $`Lag2-Volume`
## [1] 0.5384615
##
## $`Lag3-Lag4`
## [1] 0.5865385
##
## $`Lag3-Lag5`
## [1] 0.5673077
##
## $`Lag3-Volume`
## [1] 0.4519231
##
## $`Lag4-Lag5`
## [1] 0.5576923
##
## $`Lag4-Volume`
## [1] 0.4615385
##
## $`Lag5-Volume`
## [1] 0.4711538
##
## $`Lag1-Lag2-Lag3`
## [1] 0.5769231
##
## $`Lag1-Lag2-Lag4`
## [1] 0.6057692
##
## $`Lag1-Lag2-Lag5`
## [1] 0.5576923
##
## $`Lag1-Lag2-Volume`
## [1] 0.5288462
##
## $`Lag1-Lag3-Lag4`
## [1] 0.5769231
##
## $`Lag1-Lag3-Lag5`
## [1] 0.5384615
##
## $`Lag1-Lag3-Volume`
## [1] 0.4423077
##
## $`Lag1-Lag4-Lag5`
## [1] 0.5384615
##
## $`Lag1-Lag4-Volume`
## [1] 0.4326923
##
## $`Lag1-Lag5-Volume`
## [1] 0.4519231
##
## $`Lag2-Lag3-Lag4`
## [1] 0.6153846
##
## $`Lag2-Lag3-Lag5`
## [1] 0.6153846
##
## $`Lag2-Lag3-Volume`
## [1] 0.5673077
##
## $`Lag2-Lag4-Lag5`
## [1] 0.6153846
##
## $`Lag2-Lag4-Volume`
## [1] 0.5288462
##
## $`Lag2-Lag5-Volume`
## [1] 0.4903846
##
## $`Lag3-Lag4-Lag5`
## [1] 0.5576923
##
## $`Lag3-Lag4-Volume`
## [1] 0.4807692
##
## $`Lag3-Lag5-Volume`
## [1] 0.4615385
##
## $`Lag4-Lag5-Volume`
## [1] 0.4807692
##
## $`Lag1-Lag2-Lag3-Lag4`
## [1] 0.5769231
##
## $`Lag1-Lag2-Lag3-Lag5`
## [1] 0.5576923
##
## $`Lag1-Lag2-Lag3-Volume`
## [1] 0.5192308
##
## $`Lag1-Lag2-Lag4-Lag5`
## [1] 0.5480769
##
## $`Lag1-Lag2-Lag4-Volume`
## [1] 0.4615385
##
## $`Lag1-Lag2-Lag5-Volume`
## [1] 0.5
##
## $`Lag1-Lag3-Lag4-Lag5`
## [1] 0.5288462
##
## $`Lag1-Lag3-Lag4-Volume`
## [1] 0.4903846
##
## $`Lag1-Lag3-Lag5-Volume`
## [1] 0.4423077
##
## $`Lag1-Lag4-Lag5-Volume`
## [1] 0.4038462
##
## $`Lag2-Lag3-Lag4-Lag5`
## [1] 0.625
##
## $`Lag2-Lag3-Lag4-Volume`
## [1] 0.5
##
## $`Lag2-Lag3-Lag5-Volume`
## [1] 0.4903846
##
## $`Lag2-Lag4-Lag5-Volume`
## [1] 0.4807692
##
## $`Lag3-Lag4-Lag5-Volume`
## [1] 0.4903846
##
## $`Lag1-Lag2-Lag3-Lag4-Lag5`
## [1] 0.5480769
##
## $`Lag1-Lag2-Lag3-Lag4-Volume`
## [1] 0.5
##
## $`Lag1-Lag2-Lag3-Lag5-Volume`
## [1] 0.4903846
##
## $`Lag1-Lag2-Lag4-Lag5-Volume`
## [1] 0.4711538
##
## $`Lag1-Lag3-Lag4-Lag5-Volume`
## [1] 0.4807692
##
## $`Lag2-Lag3-Lag4-Lag5-Volume`
## [1] 0.4903846
##
## $`Lag1-Lag2-Lag3-Lag4-Lag5-Volume`
## [1] 0.4615385cat("\nBest combination of predictors: ", best_combination)##
## Best combination of predictors: Lag2R Markdown
This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see http://rmarkdown.rstudio.com.
When you click the Knit button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this:
summary(cars)## speed dist
## Min. : 4.0 Min. : 2.00
## 1st Qu.:12.0 1st Qu.: 26.00
## Median :15.0 Median : 36.00
## Mean :15.4 Mean : 42.98
## 3rd Qu.:19.0 3rd Qu.: 56.00
## Max. :25.0 Max. :120.00Including Plots
You can also embed plots, for example:
Note that the echo = FALSE parameter was added to the
code chunk to prevent printing of the R code that generated the
plot.