Stat_Assignment

library(ISLR2)

## Warning: package 'ISLR2' was built under R version 4.4.2

library(corrplot)

## Warning: package 'corrplot' was built under R version 4.4.2

## corrplot 0.95 loaded

library(tidyverse)

## Warning: package 'tidyverse' was built under R version 4.4.2

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.0.2

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

data("Weekly")

(13)

(a) Numerical and graphical summaries of the `Weekly` data. Do there appear to be any patterns?

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

# Plotting the weekly returns over time
# Select only numeric columns
numeric_columns <- sapply(Weekly, is.numeric)
numeric_data <- Weekly[, numeric_columns]

# Create correlation plot
corrplot(cor(numeric_data, use = "complete.obs"),method = "color", type = "lower", diag = FALSE, col = colorRampPalette(c("red", "white", "blue"))(200))

Inference : The variable Volume shows a strong positive correlation with Year. Most other correlations are weak; however, Lag1 is negatively correlated with Lag2 and Lag4, while it has a positive correlation with Lag3.

library(GGally)

## Warning: package 'GGally' was built under R version 4.4.2

## Registered S3 method overwritten by 'GGally':
##   method from   
##   +.gg   ggplot2

p_matrix <- ggpairs(Weekly[, numeric_columns],
                    upper = list(continuous = wrap("cor", size = 2, color = "blue",fontface = "bold")),
                    lower = list(continuous = wrap("smooth", color = "red", alpha = 0.5))) +
  ggtitle("Scatterplot Matrix for numeric variables") +
  theme_minimal() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),  # Rotate x-axis labels by 45 degrees
    axis.text.y = element_text(angle = 0),               # Ensure y-axis labels are horizontal
    plot.margin = margin(10, 10, 10, 10),                # Add some margin for better spacing
    plot.title = element_text(hjust = 0.5, size = 12),   # Center the title
    axis.text = element_text(size = 5),
    axis.title = element_text(size = 3)# Reduce text size to prevent overlap
  )
print(p_matrix)

(b) Logistic regression model with all lag variables and volume

# Logistic regression model with all lag variables and volume
logit_model <- glm(Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 + Volume, 
                   data = Weekly, family = binomial)

# Summary of the model
summary(logit_model)

## 
## Call:
## glm(formula = Direction ~ Lag1 + Lag2 + Lag3 + Lag4 + Lag5 + 
##     Volume, family = binomial, data = Weekly)
## 
## 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

Among the lag variables, Lag2 had a significant coefficient (p = 0.0296) in logistic regression, indicating that it might have some predictive power. Other lags (Lag1, Lag3, Lag4, Lag5) were not statistically significant.

(c) Logistic full model performance metrics

# Predicting the Direction
pred <- predict(logit_model, type = "response")
pred_direction <- ifelse(pred > 0.5, "Up", "Down")

# Fraction of correct predictions
mean(pred_direction == Weekly$Direction)

## [1] 0.5610652

conf_matrix <- table(Predicted = pred_direction, Actual = Weekly$Direction)

# Plot the confusion matrix
print(conf_matrix)

##          Actual
## Predicted Down  Up
##      Down   54  48
##      Up    430 557

Inference: The overall accuracy of the predictions is 56%. While logistic regression performs well in predicting upward movements, it tends to misclassify most downward movements as upward movements.

(d) Fitting model with significant variable ‘lag 2’

# Training data (1990 to 2008)
train_data <- subset(Weekly, Year <= 2008)

# Test data (2009 and 2010)
test_data <- subset(Weekly, Year >= 2009)

# Fit logistic regression model using Lag2
logit_model_train <- glm(Direction ~ Lag2, data = train_data, family = binomial)

# Predict using the test data
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")

# Confusion matrix for the test set
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    9  5
##      Up     34 56

# Fraction of correct predictions
mean(pred_direction_test == test_data$Direction)

## [1] 0.625

The logistic regression model, trained on data from 1990 to 2008 using Lag2 as the only predictor, achieved an overall accuracy of 62.5% on the held-out data from 2009 and 2010. The confusion matrix shows that while the model correctly predicted upward movements (56 true positives), it also misclassified downward movements as upward ones (34 false positives)

(e) LDA Model

library(MASS)

## 
## Attaching package: 'MASS'

## The following object is masked from 'package:dplyr':
## 
##     select

## The following object is masked from 'package:ISLR2':
## 
##     Boston

# Fit LDA model using Lag2
lda_model_train <- lda(Direction ~ Lag2, data = train_data)

# Predict using the test data
pred_lda_test <- predict(lda_model_train, newdata = test_data)$class

# Confusion matrix for LDA
table(Predicted = pred_lda_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    9  5
##      Up     34 56

# Fraction of correct predictions
mean(pred_lda_test == test_data$Direction)

## [1] 0.625

(f) QDA Model

# Fit QDA model using Lag2
qda_model_train <- qda(Direction ~ Lag2, data = train_data)

# Predict using the test data
pred_qda_test <- predict(qda_model_train, newdata = test_data)$class

# Confusion matrix for QDA
table(Predicted = pred_qda_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    0  0
##      Up     43 61

# Fraction of correct predictions
mean(pred_qda_test == test_data$Direction)

## [1] 0.5865385

(g) K- Nearest neighbours

library(class)

# Standardizing the predictors (important for KNN)
train_x <- scale(train_data$Lag2)
test_x <- scale(test_data$Lag2)

# Fit KNN model with K = 1
knn_pred_test <- knn(train = train_x, test = test_x, cl = train_data$Direction, k = 1)

# Confusion matrix for KNN
table(Predicted = knn_pred_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down   13 26
##      Up     30 35

# Fraction of correct predictions
mean(knn_pred_test == test_data$Direction)

## [1] 0.4615385

(h) Naive Bayes Model

library(e1071)

## Warning: package 'e1071' was built under R version 4.4.2

# Fit Naive Bayes model using Lag2
nb_model_train <- naiveBayes(Direction ~ Lag2, data = train_data)

# Predict using the test data
pred_nb_test <- predict(nb_model_train, newdata = test_data)

# Confusion matrix for Naive Bayes
table(Predicted = pred_nb_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    0  0
##      Up     43 61

# Fraction of correct predictions
mean(pred_nb_test == test_data$Direction)

## [1] 0.5865385

(i) Model Comparison

The logistic regression model with all lag variables had an accuracy of 56.1%, which is only slightly better than random guessing. Using only Lag2 as a predictor improved the test accuracy to 62.5% for logistic regression and LDA. QDA and Naïve Bayes models showed lower performance (58.6% accuracy). The KNN model (K=1) performed the worst, with only 48% accuracy, suggesting high sensitivity to noise.

(j) Model tuning considering different combinations, interactions and transformed variables

# Fit logistic regression model using Lag1
print("logit lag 1")

## [1] "logit lag 1"

logit_model_train <- glm(Direction ~ Lag1, data = train_data, family = binomial)
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    4  6
##      Up     39 55

mean(pred_direction_test == test_data$Direction)

## [1] 0.5673077

print("logit lag 3")

## [1] "logit lag 3"

# Fit logistic regression model using Lag3
logit_model_train <- glm(Direction ~ Lag3, data = train_data, family = binomial)
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##        Up   43 61

mean(pred_direction_test == test_data$Direction)

## [1] 0.5865385

print("logit lag 4")

## [1] "logit lag 4"

# Fit logistic regression model using Lag4
logit_model_train <- glm(Direction ~ Lag4, data = train_data, family = binomial)
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##        Up   43 61

mean(pred_direction_test == test_data$Direction)

## [1] 0.5865385

print("logit lag 5")

## [1] "logit lag 5"

# Fit logistic regression model using Lag5
logit_model_train <- glm(Direction ~ Lag5, data = train_data, family = binomial)
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    0  3
##      Up     43 58

mean(pred_direction_test == test_data$Direction)

## [1] 0.5576923

print("logit Volume")

## [1] "logit Volume"

# Fit logistic regression model using Volume
logit_model_train <- glm(Direction ~ log(Volume), data = train_data, family = binomial)
pred_test <- predict(logit_model_train, newdata = test_data, type = "response")
pred_direction_test <- ifelse(pred_test > 0.5, "Up", "Down")
table(Predicted = pred_direction_test, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    1  1
##      Up     42 60

mean(pred_direction_test == test_data$Direction)

## [1] 0.5865385

# Load necessary libraries
library(caret)

## Warning: package 'caret' was built under R version 4.4.2

## Loading required package: lattice

## 
## Attaching package: 'caret'

## The following object is masked from 'package:purrr':
## 
##     lift

library(ggplot2)

# Assuming you have train_data and test_data already split
# If not, you can split the dataset as:
# set.seed(123)
# train_index <- createDataPartition(Weekly$Direction, p = 0.7, list = FALSE)
# train_data <- Weekly[train_index, ]
# test_data <- Weekly[-train_index, ]

# Logistic Regression with interaction between Lag1 and Lag2
logit_model_inter1 <- glm(Direction ~ Lag1 * Lag2, data = train_data, family = binomial)
pred_test_inter1 <- predict(logit_model_inter1, newdata = test_data, type = "response")
pred_direction_inter1 <- ifelse(pred_test_inter1 > 0.5, "Up", "Down")
cm_inter1 <- table(Predicted = pred_direction_inter1, Actual = test_data$Direction)
accuracy_inter1 <- mean(pred_direction_inter1 == test_data$Direction)
cat("Model with Lag1 * Lag2 Interaction\n")

## Model with Lag1 * Lag2 Interaction

print(cm_inter1)

##          Actual
## Predicted Down Up
##      Down    7  8
##      Up     36 53

cat("Accuracy:", accuracy_inter1, "\n\n")

## Accuracy: 0.5769231

# Logistic Regression with higher-order polynomial terms (Lag1^2, Lag2^2, Lag1^3, Lag2^3)
logit_model_inter2 <- glm(Direction ~ Lag1 + Lag2 + I(Lag1^2) + I(Lag2^2), 
                          data = train_data, family = binomial)
pred_test_inter2 <- predict(logit_model_inter2, newdata = test_data, type = "response")
pred_direction_inter2 <- ifelse(pred_test_inter2 > 0.5, "Up", "Down")
cm_inter2 <- table(Predicted = pred_direction_inter2, Actual = test_data$Direction)
accuracy_inter2 <- mean(pred_direction_inter2 == test_data$Direction)
cat("Model with Higher-order Polynomial Terms (Lag1^2, Lag2^2)\n")

## Model with Higher-order Polynomial Terms (Lag1^2, Lag2^2)

print(cm_inter2)

##          Actual
## Predicted Down Up
##      Down    7  9
##      Up     36 52

cat("Accuracy:", accuracy_inter2, "\n\n")

## Accuracy: 0.5673077

# Logistic Regression with interaction between Lag1, Lag2, and Lag3
logit_model_inter3 <- glm(Direction ~ Lag1 * Lag2 * Lag3, data = train_data, family = binomial)
pred_test_inter3 <- predict(logit_model_inter3, newdata = test_data, type = "response")
pred_direction_inter3 <- ifelse(pred_test_inter3 > 0.5, "Up", "Down")
cm_inter3 <- table(Predicted = pred_direction_inter3, Actual = test_data$Direction)
accuracy_inter3 <- mean(pred_direction_inter3 == test_data$Direction)
cat("Model with Lag1 * Lag2 * Lag3 Interaction\n")

## Model with Lag1 * Lag2 * Lag3 Interaction

print(cm_inter3)

##          Actual
## Predicted Down Up
##      Down   10  8
##      Up     33 53

cat("Accuracy:", accuracy_inter3, "\n\n")

## Accuracy: 0.6057692

# Logistic Regression with log transformation of Lag1 and Lag2
logit_model_inter4 <- glm(Direction ~ log(1 + abs(Lag1)) + log(1 + abs(Lag2)), 
                          data = train_data, family = binomial)
pred_test_inter4 <- predict(logit_model_inter4, newdata = test_data, type = "response")
pred_direction_inter4 <- ifelse(pred_test_inter4 > 0.5, "Up", "Down")
cm_inter4 <- table(Predicted = pred_direction_inter4, Actual = test_data$Direction)
accuracy_inter4 <- mean(pred_direction_inter4 == test_data$Direction)
cat("Model with Log-transformed Lag1 and Lag2\n")

## Model with Log-transformed Lag1 and Lag2

print(cm_inter4)

##          Actual
## Predicted Down Up
##        Up   43 61

cat("Accuracy:", accuracy_inter4, "\n\n")

## Accuracy: 0.5865385

# Logistic Regression with interaction between Lag1, Lag2 and Volume
logit_model_inter5 <- glm(Direction ~ Lag1 + Lag2 + Volume + Lag1:Volume + Lag2:Volume, 
                          data = train_data, family = binomial)
pred_test_inter5 <- predict(logit_model_inter5, newdata = test_data, type = "response")
pred_direction_inter5 <- ifelse(pred_test_inter5 > 0.5, "Up", "Down")
cm_inter5 <- table(Predicted = pred_direction_inter5, Actual = test_data$Direction)
accuracy_inter5 <- mean(pred_direction_inter5 == test_data$Direction)
cat("Model with Lag1, Lag2, and Volume Interaction\n")

## Model with Lag1, Lag2, and Volume Interaction

print(cm_inter5)

##          Actual
## Predicted Down Up
##      Down   28 35
##      Up     15 26

cat("Accuracy:", accuracy_inter5, "\n\n")

## Accuracy: 0.5192308

# Compare all models' accuracies
cat("Comparison of Model Accuracies:\n")

## Comparison of Model Accuracies:

cat("Lag1 * Lag2 Interaction Accuracy:", accuracy_inter1, "\n")

## Lag1 * Lag2 Interaction Accuracy: 0.5769231

cat("Higher-order Polynomial Terms Accuracy:", accuracy_inter2, "\n")

## Higher-order Polynomial Terms Accuracy: 0.5673077

cat("Lag1 * Lag2 * Lag3 Interaction Accuracy:", accuracy_inter3, "\n")

## Lag1 * Lag2 * Lag3 Interaction Accuracy: 0.6057692

cat("Log-transformed Lag1 and Lag2 Accuracy:", accuracy_inter4, "\n")

## Log-transformed Lag1 and Lag2 Accuracy: 0.5865385

cat("Lag1, Lag2, and Volume Interaction Accuracy:", accuracy_inter5, "\n")

## Lag1, Lag2, and Volume Interaction Accuracy: 0.5192308

lda_model_optimized <- lda(Direction ~ Lag1 + Lag2 + I(Lag1^2) + I(Lag2^2), data = train_data)
pred_lda_optimized <- predict(lda_model_optimized, newdata = test_data)$class

# Confusion Matrix
table(Predicted = pred_lda_optimized, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    8  9
##      Up     35 52

# Accuracy
mean(pred_lda_optimized == test_data$Direction)

## [1] 0.5769231

qda_model_optimized <- qda(Direction ~ Lag1 + Lag2 + I(Lag1^2) + I(Lag2^2), data = train_data)
pred_qda_optimized <- predict(qda_model_optimized, newdata = test_data)$class

# Confusion Matrix
table(Predicted = pred_qda_optimized, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down   20 14
##      Up     23 47

# Accuracy
mean(pred_qda_optimized == test_data$Direction)

## [1] 0.6442308

qda_model_optimized2 <- qda(Direction ~ Lag1*Lag2, data = train_data)
pred_qda_optimized <- predict(qda_model_optimized2, newdata = test_data)$class

# Confusion Matrix
table(Predicted = pred_qda_optimized, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down   23 36
##      Up     20 25

# Accuracy
mean(pred_qda_optimized == test_data$Direction)

## [1] 0.4615385

library(class)

# Standardize predictors
train_x <- scale(train_data[, c("Lag1", "Lag2")])
test_x <- scale(test_data[, c("Lag1", "Lag2")])

# Optimize K using a loop
accuracy_results <- sapply(1:20, function(k) {
  knn_pred <- knn(train = train_x, test = test_x, cl = train_data$Direction, k = k)
  mean(knn_pred == test_data$Direction)
})

best_k <- which.max(accuracy_results)
print(paste("Best K:", best_k))

## [1] "Best K: 18"

# Fit KNN with best K
knn_pred_optimized <- knn(train = train_x, test = test_x, cl = train_data$Direction, k = best_k)

# Confusion Matrix
table(Predicted = knn_pred_optimized, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down   23 20
##      Up     20 41

# Accuracy
mean(knn_pred_optimized == test_data$Direction)

## [1] 0.6153846

library(e1071)
nb_model_optimized <- naiveBayes(Direction ~ Lag1 + Lag2 , data = train_data)
pred_nb_optimized <- predict(nb_model_optimized, newdata = test_data)

# Confusion Matrix
table(Predicted = pred_nb_optimized, Actual = test_data$Direction)

##          Actual
## Predicted Down Up
##      Down    3  8
##      Up     40 53

# Accuracy
mean(pred_nb_optimized == test_data$Direction)

## [1] 0.5384615

accuracy_results <- data.frame(
  Model = c("Logistic Regression", "LDA", "QDA", "KNN (Best K)", "Naive Bayes", "Logit Log transform"),
  Accuracy = c(
    mean(pred_direction_inter1 == test_data$Direction),
    mean(pred_lda_optimized == test_data$Direction),
    mean(pred_qda_optimized == test_data$Direction),
    mean(knn_pred_optimized == test_data$Direction),
    mean(pred_nb_optimized == test_data$Direction),
    mean(pred_direction_inter4 == test_data$Direction)
  )
)

print(accuracy_results)

##                 Model  Accuracy
## 1 Logistic Regression 0.5769231
## 2                 LDA 0.5769231
## 3                 QDA 0.4615385
## 4        KNN (Best K) 0.6153846
## 5         Naive Bayes 0.5384615
## 6 Logit Log transform 0.5865385

Based on the accuracy results, Quadratic Discriminant Analysis (QDA) provides the highest accuracy at 0.6442 on the held-out data. Therefore, QDA appears to be the best-performing method.

(14)

(a)

library(ISLR2)
data(Auto)

# Create the binary variable mpg01:
mpg_median <- median(Auto$mpg)
Auto$mpg01 <- ifelse(Auto$mpg > mpg_median, 1, 0)

(b) Scatterplot and Boxplots

# Scatterplots for continuous predictors vs. mpg
pairs(Auto[, c("mpg", "cylinders", "displacement", "horsepower", "weight", "acceleration")],
      main = "Scatterplots of Auto Variables")

# Convert mpg01 to a factor
Auto$mpg01 <- as.factor(Auto$mpg01)

# Reshaping data to long format
library(tidyr)
Auto_long <- Auto %>%
  gather(key = "variable", value = "value", cylinders, displacement, horsepower, 
         weight, acceleration, year, origin)

# Create a ggplot for the combined data
ggplot(Auto_long, aes(x = mpg01, y = value, fill = mpg01)) + 
  geom_boxplot() + 
  facet_wrap(~variable, scales = "free", ncol = 2) + 
  scale_fill_brewer(palette = "Set1") + 
  theme_minimal() + 
  theme(legend.position = "none", aspect.ratio = 1) + 
  ggtitle("Various Predictors vs mpg01")

When evaluating the predictive strength of different variables for mpg01, it appears that cylinders, displacement, and weight are the strongest predictors. These variables exhibit clear separation in their distributions when compared against mpg01, suggesting a strong relationship.

Horsepower also shows some predictive power but appears to be somewhat weaker than the three strongest predictors.

Year and acceleration seem to be even weaker predictors, as their distributions overlap significantly, making it harder to distinguish between mpg01 categories.

Origin, being a categorical variable, is more challenging to visually compare against the numerical predictors. However, based on the observed distribution, it seems to have a weaker relationship with mpg01 compared to displacement, weight, and cylinders.

(c)

set.seed(42)  # for reproducibility
n <- nrow(Auto)
train_indices <- sample(1:n, size = round(0.666 * n))
test_indices <- setdiff(1:n, train_indices)

# Create training and test sets:
train_data <- Auto[train_indices, ]
test_data  <- Auto[test_indices, ]

(d) LDA on the Training Data

library(MASS)
lda_fit <- lda(mpg01 ~ cylinders + weight + displacement + horsepower , data = train_data)
lda_pred <- predict(lda_fit, test_data)$class

# Confusion Matrix for LDA:
lda_cm <- table(Predicted = lda_pred, Actual = test_data$mpg01)
print("LDA Confusion Matrix:")

## [1] "LDA Confusion Matrix:"

print(lda_cm)

##          Actual
## Predicted  0  1
##         0 48  4
##         1  9 70

# Test Error:
lda_error <- mean(lda_pred != test_data$mpg01)
print(paste("LDA Test Error:", round(lda_error, 4)))

## [1] "LDA Test Error: 0.0992"

(e) QDA on the Training Data

qda_fit <- qda(mpg01 ~ cylinders + weight + displacement + horsepower, data = train_data)
qda_pred <- predict(qda_fit, test_data)$class

# Confusion Matrix for QDA:
qda_cm <- table(Predicted = qda_pred, Actual = test_data$mpg01)
print("QDA Confusion Matrix:")

## [1] "QDA Confusion Matrix:"

print(qda_cm)

##          Actual
## Predicted  0  1
##         0 49  6
##         1  8 68

# Test Error:
qda_error <- mean(qda_pred != test_data$mpg01)
print(paste("QDA Test Error:", round(qda_error, 4)))

## [1] "QDA Test Error: 0.1069"

(f) Logistic Regression on the Training Data

glm_fit <- glm(mpg01 ~ cylinders + weight + displacement + horsepower, data = train_data, family = binomial)
glm_probs <- predict(glm_fit, test_data, type = "response")
glm_pred <- ifelse(glm_probs >= 0.5, 1, 0)

# Confusion Matrix for Logistic Regression:
glm_cm <- table(Predicted = glm_pred, Actual = test_data$mpg01)
print("Logistic Regression Confusion Matrix:")

## [1] "Logistic Regression Confusion Matrix:"

print(glm_cm)

##          Actual
## Predicted  0  1
##         0 49  4
##         1  8 70

# Test Error:
glm_error <- mean(glm_pred != test_data$mpg01)
print(paste("Logistic Regression Test Error:", round(glm_error, 4)))

## [1] "Logistic Regression Test Error: 0.0916"

(g) Naive Bayes on the Training Data

library(e1071)
# Ensure mpg01 is treated as a factor:
train_data$mpg01 <- as.factor(train_data$mpg01)
test_data$mpg01 <- as.factor(test_data$mpg01)

nb_fit <- naiveBayes(mpg01 ~ cylinders + weight + displacement + horsepower, data = train_data)
nb_pred <- predict(nb_fit, test_data)

# Confusion Matrix for Naive Bayes:
nb_cm <- table(Predicted = nb_pred, Actual = test_data$mpg01)
print("Naive Bayes Confusion Matrix:")

## [1] "Naive Bayes Confusion Matrix:"

print(nb_cm)

##          Actual
## Predicted  0  1
##         0 48  5
##         1  9 69

# Test Error:
nb_error <- mean(nb_pred != test_data$mpg01)
print(paste("Naive Bayes Test Error:", round(nb_error, 4)))

## [1] "Naive Bayes Test Error: 0.1069"

(h) KNN on the Training Data

library(class)

# Prepare the predictor matrices:
train_X <- scale(train_data[, c("weight", "cylinders", "displacement","horsepower")])
test_X  <- scale(test_data[, c("weight", "cylinders", "displacement","horsepower")])

# The response for KNN (as a factor):
train_Y <- train_data$mpg01

# Try several values of K:
set.seed(1)
k_values <- c(1:50)
knn_errors <- sapply(k_values, function(k) {
  knn_pred <- knn(train_X, test_X, cl = train_Y, k = k)
  mean(knn_pred != test_data$mpg01)
})

knn_results <- data.frame(K = k_values, Test_Error = round(knn_errors, 4))
print("KNN Test Errors for different K:")

## [1] "KNN Test Errors for different K:"

print(knn_results)

##     K Test_Error
## 1   1     0.1603
## 2   2     0.0992
## 3   3     0.0992
## 4   4     0.0992
## 5   5     0.0840
## 6   6     0.0992
## 7   7     0.1069
## 8   8     0.0763
## 9   9     0.0916
## 10 10     0.0916
## 11 11     0.0916
## 12 12     0.0916
## 13 13     0.0916
## 14 14     0.0916
## 15 15     0.0916
## 16 16     0.0916
## 17 17     0.0916
## 18 18     0.0916
## 19 19     0.0916
## 20 20     0.0916
## 21 21     0.0916
## 22 22     0.0916
## 23 23     0.0916
## 24 24     0.0916
## 25 25     0.0916
## 26 26     0.0916
## 27 27     0.0916
## 28 28     0.0916
## 29 29     0.0916
## 30 30     0.0916
## 31 31     0.0916
## 32 32     0.0916
## 33 33     0.0916
## 34 34     0.0916
## 35 35     0.0916
## 36 36     0.0916
## 37 37     0.0916
## 38 38     0.0916
## 39 39     0.0916
## 40 40     0.0916
## 41 41     0.0916
## 42 42     0.0992
## 43 43     0.0916
## 44 44     0.0916
## 45 45     0.0916
## 46 46     0.0916
## 47 47     0.0916
## 48 48     0.0916
## 49 49     0.0916
## 50 50     0.0916

# Choose the best K and compute confusion matrix
best_k <- k_values[which.min(knn_errors)]
knn_best_pred <- knn(train_X, test_X, cl = train_Y, k = best_k)

# Confusion Matrix
knn_cm <- table(Predicted = knn_best_pred, Actual = test_data$mpg01)
print(paste("Best K:", best_k))

## [1] "Best K: 8"

print("KNN Confusion Matrix:")

## [1] "KNN Confusion Matrix:"

print(knn_cm)

##          Actual
## Predicted  0  1
##         0 50  4
##         1  7 70

# Compute Test Error
knn_error <- mean(knn_best_pred != test_data$mpg01)
print(paste("KNN Test Error:", round(knn_error, 4)))

## [1] "KNN Test Error: 0.084"

error_summary <- data.frame(
  Model = c("LDA", "QDA", "Logistic Regression", "Naive Bayes", paste("KNN (K =", best_k, ")")),
  Test_Error = c(lda_error, qda_error, glm_error, nb_error, knn_error)
)

print(error_summary)

##                 Model Test_Error
## 1                 LDA 0.09923664
## 2                 QDA 0.10687023
## 3 Logistic Regression 0.09160305
## 4         Naive Bayes 0.10687023
## 5        KNN (K = 8 ) 0.08396947

K-NN (K = 8) seems to be the best-performing model with the lowest test error, which suggests that a k-value of 8 offers the best trade-off between bias and variance for this dataset.

Logistic Regression and LDA show relatively competitive performance, with logistic regression slightly outperforming LDA.

QDA and Naive Bayes have the highest test errors, which may indicate that these models are overfitting or that their assumptions are not well-suited for this particular data.

(16)

# Load necessary libraries
library(MASS)
library(class)   # For KNN
library(e1071)   # For Naive Bayes

# Load the Boston dataset
data(Boston)

# Create binary response variable (high crime = 1, low crime = 0)
crime_median <- median(Boston$crim)
Boston$crim01 <- ifelse(Boston$crim > crime_median, 1, 0)

# Check distribution
table(Boston$crim01)

## 
##   0   1 
## 253 253

# Scatterplots
pairs(Boston[, c("crim", "zn", "indus", "nox", "rm", "age", "dis", "tax", "ptratio")], 
      main = "Scatterplot Matrix")

# Boxplots for selected variables against crim01
par(mfrow = c(2, 3))
boxplot(zn ~ crim01, data = Boston, main = "ZN vs Crime")
boxplot(indus ~ crim01, data = Boston, main = "INDUS vs Crime")
boxplot(nox ~ crim01, data = Boston, main = "NOX vs Crime")
boxplot(rm ~ crim01, data = Boston, main = "Rooms vs Crime")
boxplot(tax ~ crim01, data = Boston, main = "Tax vs Crime")
boxplot(ptratio ~ crim01, data = Boston, main = "PTRATIO vs Crime")

set.seed(1)
n <- nrow(Boston)
train_indices <- sample(1:n, size = round(0.7 * n))
test_indices <- setdiff(1:n, train_indices)

train_data <- Boston[train_indices, ]
test_data  <- Boston[test_indices, ]

# Fit logistic regression model
glm_fit <- glm(crim01 ~ nox + indus + tax + ptratio + rm + dis, data = train_data, family = binomial)

# Make predictions on the test set
glm_probs <- predict(glm_fit, test_data, type = "response")
glm_pred <- ifelse(glm_probs > 0.5, 1, 0)

# Confusion Matrix
glm_cm <- table(Predicted = glm_pred, Actual = test_data$crim01)
print("Logistic Regression Confusion Matrix:")

## [1] "Logistic Regression Confusion Matrix:"

print(glm_cm)

##          Actual
## Predicted  0  1
##         0 65 11
##         1  8 68

# Compute Test Error
glm_error <- mean(glm_pred != test_data$crim01)
print(paste("Logistic Regression Test Error:", round(glm_error, 4)))

## [1] "Logistic Regression Test Error: 0.125"

lda_fit <- lda(crim01 ~ nox + indus + tax + ptratio + rm + dis, data = train_data)
lda_pred <- predict(lda_fit, test_data)$class

# Confusion Matrix
lda_cm <- table(Predicted = lda_pred, Actual = test_data$crim01)
print("LDA Confusion Matrix:")

## [1] "LDA Confusion Matrix:"

print(lda_cm)

##          Actual
## Predicted  0  1
##         0 68 20
##         1  5 59

# Compute Test Error
lda_error <- mean(lda_pred != test_data$crim01)
print(paste("LDA Test Error:", round(lda_error, 4)))

## [1] "LDA Test Error: 0.1645"

nb_fit <- naiveBayes(crim01 ~ nox + indus + tax + ptratio + rm + dis, data = train_data)
nb_pred <- predict(nb_fit, test_data)

# Confusion Matrix
nb_cm <- table(Predicted = nb_pred, Actual = test_data$crim01)
print("Naive Bayes Confusion Matrix:")

## [1] "Naive Bayes Confusion Matrix:"

print(nb_cm)

##          Actual
## Predicted  0  1
##         0 63 18
##         1 10 61

# Compute Test Error
nb_error <- mean(nb_pred != test_data$crim01)
print(paste("Naive Bayes Test Error:", round(nb_error, 4)))

## [1] "Naive Bayes Test Error: 0.1842"

# Standardize predictors
train_X <- scale(train_data[, c("nox", "indus", "tax", "ptratio", "rm", "dis")])
test_X  <- scale(test_data[, c("nox", "indus", "tax", "ptratio", "rm", "dis")])

train_Y <- train_data$crim01

# Try several values of K
set.seed(1)
k_values <- c(1, 3, 5, 7, 9)
knn_errors <- sapply(k_values, function(k) {
  knn_pred <- knn(train_X, test_X, cl = train_Y, k = k)
  mean(knn_pred != test_data$crim01)
})

knn_results <- data.frame(K = k_values, Test_Error = round(knn_errors, 4))
print("KNN Test Errors for different K:")

## [1] "KNN Test Errors for different K:"

print(knn_results)

##   K Test_Error
## 1 1     0.0461
## 2 3     0.0592
## 3 5     0.0461
## 4 7     0.0526
## 5 9     0.0724

# Choose the best K and compute confusion matrix
best_k <- k_values[which.min(knn_errors)]
knn_best_pred <- knn(train_X, test_X, cl = train_Y, k = best_k)

# Confusion Matrix
knn_cm <- table(Predicted = knn_best_pred, Actual = test_data$crim01)
print(paste("Best K:", best_k))

## [1] "Best K: 1"

print("KNN Confusion Matrix:")

## [1] "KNN Confusion Matrix:"

print(knn_cm)

##          Actual
## Predicted  0  1
##         0 68  2
##         1  5 77

# Compute Test Error
knn_error <- mean(knn_best_pred != test_data$crim01)
print(paste("KNN Test Error:", round(knn_error, 4)))

## [1] "KNN Test Error: 0.0461"

# Create a summary of test errors
error_results <- data.frame(
  Model = c("Logistic Regression", "LDA", "Naive Bayes", "KNN (Best K)"),
  Test_Error = c(glm_error, lda_error, nb_error, knn_error))

print("Comparison of Model Test Errors:")

## [1] "Comparison of Model Test Errors:"

print(error_results)

##                 Model Test_Error
## 1 Logistic Regression 0.12500000
## 2                 LDA 0.16447368
## 3         Naive Bayes 0.18421053
## 4        KNN (Best K) 0.04605263

Key Takeaways:

KNN (K=1) is the best-performing model, achieving the lowest test error (4.61%).
Logistic Regression provides a good balance between accuracy and interpretability, making it a practical choice.
LDA and Naive Bayes perform worse, with LDA struggling with high-crime predictions and Naive Bayes suffering from its independence assumption.
KNN might be computationally expensive for large datasets, so logistic regression may still be preferable in real-world scenarios.

Stat_Assignment_3

Sreeja Yalamaddi

2025-03-07

(13)

(a) Numerical and graphical summaries of the `Weekly` data. Do there appear to be any patterns?

(b) Logistic regression model with all lag variables and volume

(c) Logistic full model performance metrics

(d) Fitting model with significant variable ‘lag 2’

(e) LDA Model

(f) QDA Model

(g) K- Nearest neighbours

(h) Naive Bayes Model

(i) Model Comparison

(j) Model tuning considering different combinations, interactions and transformed variables

(14)

(a)

(b) Scatterplot and Boxplots

(c)

(d) LDA on the Training Data

(e) QDA on the Training Data

(f) Logistic Regression on the Training Data

(g) Naive Bayes on the Training Data

(h) KNN on the Training Data

(16)

Stat_Assignment_3

Sreeja Yalamaddi

2025-03-07

(13)

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

(b) Logistic regression model with all lag variables and volume

(c) Logistic full model performance metrics

(d) Fitting model with significant variable ‘lag 2’

(e) LDA Model

(f) QDA Model

(g) K- Nearest neighbours

(h) Naive Bayes Model

(i) Model Comparison

(j) Model tuning considering different combinations, interactions and transformed variables

(14)

(a)

(b) Scatterplot and Boxplots

(c)

(d) LDA on the Training Data

(e) QDA on the Training Data

(f) Logistic Regression on the Training Data

(g) Naive Bayes on the Training Data

(h) KNN on the Training Data

(16)

(a) Numerical and graphical summaries of the `Weekly` data. Do there appear to be any patterns?