Results

Library

library(readr)
library(dplyr)
library(tidymodels)
library(glmnet)

Data Loading and Wrangling

# Loading Data
performance <- read_csv("performance.csv")
info <- read_delim("info.txt", delim = " ")

# Data Arrangement
df <- left_join(info, performance, by = "ID")
df <- df %>%
  arrange(Date)

# Removing Unnecessary Columns
df$Focus <- NULL
df$Currency <- NULL

# Create Data Tables for Stock A and Index's 1-3
Stock_A <- df %>%
  filter(Name == "Stock A")
Index_1 <- df %>%
  filter(Name == "Index 1")
Index_2 <- df %>%
  filter(Name == "Index 2")
Index_3 <- df %>%
  filter(Name == "Index 3")

# Create Individual Names for  each data tables Performance value
Stock_A <- Stock_A %>%
  rename(Stock_A_Perf = Performance)
Index_1 <- Index_1 %>% 
  rename(Index_1_Perf = Performance)
Index_2 <- Index_2 %>% 
  rename(Index_2_Perf = Performance)
Index_3 <- Index_3 %>% 
  rename(Index_3_Perf = Performance)

# Eliminate Name and ID columns to allow merging all the tables into Stock_A
Stock_A$Name <- NULL
Stock_A$ID <- NULL
Index_1$Name <- NULL
Index_1$ID <- NULL
Index_2$Name <- NULL
Index_2$ID <- NULL
Index_3$Name <- NULL
Index_3$ID <- NULL

# Join the Data Tables to create one Data frame with Date, Stock A, Index 1, Index 2, and Index 3
Stock_A <- left_join(Stock_A, Index_1, by = "Date")
Stock_A <- left_join(Stock_A, Index_2, by = "Date")
Stock_A <- left_join(Stock_A, Index_3, by = "Date")

# Use the as.Date function to order the date column in time order
Stock_A <- Stock_A[order(as.Date(Stock_A$Date, format="%m/%d/%Y")),]

# Stock_A first ten entries for date order confirmation
# Part a answer
head(Stock_A, n = 10)
## # A tibble: 10 × 5
##    Date       Stock_A_Perf Index_1_Perf Index_2_Perf Index_3_Perf
##    <chr>             <dbl>        <dbl>        <dbl>        <dbl>
##  1 01/01/1990      -0.0919     -0.0688     -0.0119       -0.0191 
##  2 02/01/1990       0.0595      0.00854     0.00324      -0.0239 
##  3 03/01/1990      -0.129       0.0243      0.000737      0.0168 
##  4 04/01/1990      -0.0194     -0.0269     -0.00916      -0.0335 
##  5 05/01/1990       0.0197      0.0920      0.0296        0.0744 
##  6 06/01/1990      -0.0323     -0.00889     0.0160        0.0114 
##  7 07/01/1990      -0.0433     -0.00522     0.0138       -0.00298
##  8 08/01/1990      -0.0906     -0.0943     -0.0134       -0.113  
##  9 09/01/1990      -0.345      -0.0512      0.00827      -0.116  
## 10 10/01/1990      -0.193      -0.00670     0.0127        0.0419

Model 1

# Machine Learning Setup/part b answer
set.seed(456)
split <- initial_split(Stock_A, prop = 0.8)
train <- training(split)
test <- testing(split)

# Linear Regression Model
model1 <- linear_reg() %>%
  fit(Stock_A_Perf ~ Index_1_Perf + Index_2_Perf + Index_3_Perf, data = train)
tidy(model1)
## # A tibble: 4 × 5
##   term         estimate std.error statistic  p.value
##   <chr>           <dbl>     <dbl>     <dbl>    <dbl>
## 1 (Intercept)  -0.00287   0.00496    -0.579 5.63e- 1
## 2 Index_1_Perf  1.48      0.184       8.05  1.83e-14
## 3 Index_2_Perf -0.655     0.422      -1.55  1.22e- 1
## 4 Index_3_Perf -0.0773    0.171      -0.451 6.52e- 1
# Model1 RSME Performance
model1 %>%
  predict(test) %>%
  bind_cols(test) %>%
  rmse(truth = Stock_A_Perf, estimate = .pred)
## # A tibble: 1 × 3
##   .metric .estimator .estimate
##   <chr>   <chr>          <dbl>
## 1 rmse    standard       0.107

This model creates an intercept at essentially 0. In order of Index, the estimated coefficients are 1.47933, -0.65479, and -0.07732 respectively. This result indicates that Index 1 has a strong positive correlation on Stock_A’s performance, while Index 2 and 3 are inversely impacting Stock_A’s performance. This model shows that Index 1 is the preferred index towards overall profitability of the stock.

One of the main issues with this model is its lack of tuning. One of the potential issues this could cause is the lack to predict outliers in data. There are a few values in the data set that are drastically different from the rest in the negative and positive direction that are not able to accurately be forecast by this model. This is seen later in the graphs where there are outliers in the data set with no reaction from the model. The model itself also lacks outliers in its prediction.

Lasso Model

# Lasso Model
lasso_model <- linear_reg(penalty = 0, mixture = 1) %>%
  set_engine("glmnet")
# Lasso Recipe
lasso_recipe <- recipe(Stock_A_Perf ~ Index_1_Perf + Index_2_Perf + Index_3_Perf, data = train) %>%
  step_normalize(all_numeric_predictors()) %>%
  step_dummy(all_nominal_predictors())

# Lasso Model Workflow
lasso_fit <- workflow() %>%
  add_recipe(lasso_recipe) %>%
  add_model(lasso_model) %>%
  fit(data = train)
# Extract Results
lasso_fit %>%
  extract_fit_parsnip() %>%
  tidy()
## # A tibble: 4 × 3
##   term         estimate penalty
##   <chr>           <dbl>   <dbl>
## 1 (Intercept)   0.00338       0
## 2 Index_1_Perf  0.0612        0
## 3 Index_2_Perf -0.00705       0
## 4 Index_3_Perf -0.00280       0
# Lasso Model RSME Performance
kfolds <- vfold_cv(train, v = 5, strata = Stock_A_Perf)

workflow() %>%
  add_recipe(lasso_recipe) %>%
  add_model(lasso_model) %>%
  fit_resamples(kfolds) %>%
  collect_metrics() %>%
  filter(.metric == 'rmse')
## # A tibble: 1 × 6
##   .metric .estimator   mean     n std_err .config             
##   <chr>   <chr>       <dbl> <int>   <dbl> <chr>               
## 1 rmse    standard   0.0815     5 0.00517 Preprocessor1_Model1

At a first glance there is a large difference in the original regression model and the lasso regression model. The intercept is still close to 0, leaning slightly positive rather than negative in the original model. Additionally, the new coefficients for the indexes are as follows, 0.06119, -0.00705. and -0.00280 respectively. These values are all much smaller than the original values, but follow a similar trend. Index_1 remains the only positive coefficient value, while Index_2 is slightly more negative than Index_3.

The reason the values for the lasso model differ from the linear model is due to the penalizing factor of the lasso model. The lasso model will relatively shrink less impact values closer and closer to 0 as the penalty increases. In the case of this data, a penalty slashes down index 3 to a value smaller than the intercept and cuts the other indexes impact severely.

Model Performance Graphing

model_predictions = predict(model1, new_data=Stock_A)
lasso_predictions <- predict(lasso_fit, new_data = Stock_A)
dates <- seq(f = as.Date("1991-01-01"), b = "month", length.out = 393)

df1 <- data.frame(Actual = Stock_A$Stock_A_Perf,
                 Predicted = as.vector(model_predictions$.pred),
                 Date = Stock_A$Date)

df1 <- data.frame(Actual = Stock_A$Stock_A_Perf, Predicted = as.vector(model_predictions$.pred), Date = Stock_A$Date)
ggplot()+
  geom_point(data = df1,
             aes(x = dates, y = Actual))+
  geom_point(data = df1,
             aes(x= dates, y = Predicted),
             color = "red")+
  scale_x_date(date_breaks = "12 months", date_labels = "%Y")+
  theme(axis.text.x = element_text(angle = 90))+
  labs(y = "Stock A Return", x = "Date by Month", title = "Comparison of Actual vs Predicted Values for Model1")

df2 <- data.frame(Actual = Stock_A$Stock_A_Perf,
                 Predicted = as.vector(lasso_predictions$.pred),
                 Date = Stock_A$Date)

ggplot()+
  geom_point(data = df2,
             aes(x = dates, y = Actual))+
  geom_point(data = df2,
             aes(x= dates, y = Predicted),
             color = "red")+
  scale_x_date(date_breaks = "12 months", date_labels = "%Y")+
  theme(axis.text.x = element_text(angle = 90))+
  labs(y = "Stock A Return", x = "Date by Month", title = "Comparison of Actual vs Predicted Values for Lasso Model")