Load the Libraries
library(readxl)
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(zoo)
##
## Attaching package: 'zoo'
## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric
library(ggplot2)
Question 1:
# Time Series Data
week <- 1:6 # Independent variable
values1 <- c(17,13,15,11,17,14) # Dependent Variable
# Most Recent Value
forecast <- values1[-length(values1)] # Excludes the last value
actual <- values1[-1] # Exclude the first sale
mse <- mean((actual - forecast)^2)
mse # Mean Square Error is 16.2
## [1] 16.2
mae <- mean(abs(actual - forecast))
mae # Mean absolute error is 3.8
## [1] 3.8
mape <- mean(abs((actual - forecast)/actual)) * 100
mape # Mean absolute percentage error is 27.44
## [1] 27.43778
# Forecast for week 7
forecast_week7 <- tail(values1, 1)
forecast_week7
## [1] 14
# The value projected for week 7 is 14
Question 2:
# Moving Average
# Time Series Data
df <- data.frame(month=c(1,2,3,4,5,6,7,8,9,10,11,12),
values=c(240, 352, 230, 260, 280, 322, 220, 310, 240, 310, 240, 230))
summary(df) # Descriptive Statistics - Averages value over the 12 month period is 269.5
## month values
## Min. : 1.00 Min. :220.0
## 1st Qu.: 3.75 1st Qu.:237.5
## Median : 6.50 Median :250.0
## Mean : 6.50 Mean :269.5
## 3rd Qu.: 9.25 3rd Qu.:310.0
## Max. :12.00 Max. :352.0
# Time Series Plot
plot(df$month, df$values, type = "o", col = "blue", xlab = "Month", ylab = "Values",
main = "Alabama Building Contract Plot")
# Interpretation: The time series plot exhibits a horizontal pattern that is steady on the mean.
# Manually Calculate the Three-Month Moving Average
df$avg_values <- c(NA, NA, NA,
(df$values[1] + df$values[2] + df$values[3]) / 3,
(df$values[2] + df$values[3] + df$values[4]) / 3,
(df$values[3] + df$values[4] + df$values[5]) / 3,
(df$values[4] + df$values[5] + df$values[6]) / 3,
(df$values[5] + df$values[6] + df$values[7]) / 3,
(df$values[6] + df$values[7] + df$values[8]) / 3,
(df$values[7] + df$values[8] + df$values[9]) / 3,
(df$values[8] + df$values[9] + df$values[10]) / 3,
(df$values[9] + df$values[10] + df$values[11]) / 3
)
# Calculate the squared errors (only for months where moving average is available)
df <- df %>% mutate(squared_error = ifelse(is.na(avg_values), NA, (values-avg_values)^2))
# Compute MSE (excluding the initial weeks with NA)
mse1 <- mean(df$squared_error, na.rm = TRUE)
mse1 # MSE Output: 2040.44
## [1] 2040.444
# Exponential Smoothing
alpha <- 0.2
exp_smooth <- rep(NA, length(df$values))
exp_smooth[1] <- df$values[1] # Starting Point
for(i in 2:length(df$values)) {
exp_smooth[i] <- alpha * df$values[i-1] + (1 - alpha) * exp_smooth[i-1]
}
mse_exp_smooth <- mean((df$values[2:12] - exp_smooth[2:12])^2) # MSE Output: = 2593.76
# Comparison
better_method <- ifelse(mse < mse_exp_smooth, "Three-Month Moving Average", "Exponential Smoothing")
# Results
list(
MSE_Moving_Average = mse,
MSE_Exponential_Smoothing = mse_exp_smooth,
Better_Method = better_method
)
## $MSE_Moving_Average
## [1] 16.2
##
## $MSE_Exponential_Smoothing
## [1] 2593.762
##
## $Better_Method
## [1] "Three-Month Moving Average"
Question 3:
# Load the Data
data <- read_excel("C:/Users/nikol/Downloads/Mortgage.xlsx")
df1 <- data.frame(period=data$Period,
rate=data$Interest_Rate)
summary(df1) # Descriptive Statistics: The average mortgage rate over the 20 years is 5.08%.
## period rate
## Min. : 1.00 Min. :2.958
## 1st Qu.: 6.75 1st Qu.:3.966
## Median :12.50 Median :4.863
## Mean :12.50 Mean :5.084
## 3rd Qu.:18.25 3rd Qu.:6.105
## Max. :24.00 Max. :8.053
# Time Series Plot
plot(df1$period, df1$rate, type = "o", col = "blue", xlab = "Year", ylab = "Interest Rate",
main = "30 Year Mortgage Rates")
ggplot(df1, aes(x=period, y =rate)) +
geom_line() +
geom_point() +
xlab("Period") +
ylab("Interest Rate") +
ggtitle("Time Series Plot of 30 Year Mortgage Rates")
# Interpretation: We observe a decreasing trend in the time series plot with some seasonal patterns that could be explained by economic cycles.
# Linear trend equation
model <- lm(rate ~ period, data = df1)
summary(model)
##
## Call:
## lm(formula = rate ~ period, data = df1)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.3622 -0.7212 -0.2823 0.5015 3.1847
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 6.69541 0.43776 15.295 3.32e-13 ***
## period -0.12890 0.03064 -4.207 0.000364 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.039 on 22 degrees of freedom
## Multiple R-squared: 0.4459, Adjusted R-squared: 0.4207
## F-statistic: 17.7 on 1 and 22 DF, p-value: 0.0003637
# Result - estimated linear trend equation: rate = 6.69 + (-0.13)*period
# Forecast the average interest rate for period 25 i.e. 2024
forecast_period_25 <- predict(model, newdata = data.frame(period=25))
forecast_period_25 # Result 3.47
## 1
## 3.472942
# Interpretation: The forecasted 30 Year Mortgage Rate for period 25 or 2024 is 3.47%