**Class Exercise 16: Chapter 17
Question 1
Method 1: Naive Approach
# Time Series Data
week <- 1:6 # This is the independent variable - time
values <- c(17, 13, 15, 11, 17, 14) # dependent variableMost Recent Value as Forecast
forecast_a <- values[-length(values)] #Excludes the last sale
actual_a <- values[-1] #Exclude the first value
mse_a <- mean((actual_a - forecast_a)^2)Interpretation: Mean square error is 16.2.# Mean Absolute Error (MAE)
mae_a <- mean(abs(actual_a - forecast_a))Interpretation: Mean Absolute Error is 3.8.# Mean Absolute Percentage Error (MAPE)
mape_a <- mean(abs((actual_a - forecast_a) / actual_a)) * 100Interpretation: Mean Absolute Percentage Error is 27.44.# Forecast the value for week 7
forecast_week7_a <- tail(values, 1)Interpretation: The value in week 7 is 14.Question 2
Method 2: Smoothing Approach
# Load the libraries
library(dplyr)## Warning: package 'dplyr' was built under R version 4.2.3##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(zoo)## Warning: package 'zoo' was built under R version 4.2.3##
## Attaching package: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric# Import the 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))
# Descriptive statistics
summary(df)## 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.0Interpretation: The average values of the building over the 12-month period is 269.5.#Time series plot
plot(df$month, df$values, type = "o", col = "blue", xlab = "Month", ylab = "Values",
main = "Alabama Building Plot Data")
Interpretation: The time series plot exhibits a horizontal pattern, as the values fluctuate around a consistent mean without showing a clear trend or seasonality.# Manually calculate the Three-Week Moving Average
df$avg_values3 <- c(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,
(df$values[10] + df$values[11] + df$values[12]) / 3
)
# Calculate the squared errors (only for months are moving average is available)
df <- df %>%
mutate(
squared_error = ifelse(is.na(avg_values3), NA, (values - avg_values3)^2)
)# Calculate MSE (excluding the initial weeks with NA)
mse <- mean(df$squared_error, na.rm = TRUE)Interpretation: Output the MSE - 996.8.# Part B. Exponential Smoothing
# Note: We're using the same data set from line 13
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_exp_smooth## [1] 2593.762Interpretation: Output the MSE - 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] 996.8
##
## $MSE_Exponential_Smoothing
## [1] 2593.762
##
## $Better_Method
## [1] "Three-Month Moving Average"Interpretation: The Three-Month Moving Average provides more accurate forecasts because it has a significantly lower Mean Squared Error (MSE) compared to the Exponential Smoothing method.Question 3, 4, 5
Method 3: Linear Trend Approach
# Load the libraries
library(readxl)## Warning: package 'readxl' was built under R version 4.2.3library(ggplot2)## Warning: package 'ggplot2' was built under R version 4.2.3# Load the data
df <- read_excel(file.choose())
# Create the data frame
df <- data.frame(
Year = as.Date(c("2000-01-01", "2001-01-01", "2002-01-01", "2003-01-01", "2004-01-01",
"2005-01-01", "2006-01-01", "2007-01-01", "2008-01-01", "2009-01-01",
"2010-01-01", "2011-01-01", "2012-01-01", "2013-01-01", "2014-01-01",
"2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01", "2019-01-01",
"2020-01-01", "2021-01-01", "2022-01-01", "2023-01-01")),
Period = 1:24,
Interest_Rate = c(8.05, 6.97, 6.54, 5.83, 5.84, 5.87, 6.41, 6.34, 6.03, 5.04,
4.69, 4.45, 3.66, 3.98, 4.17, 3.85, 3.65, 3.99, 4.54, 4.66,
3.11, 2.89, 2.75, 3.21)
)
# Descriptive statistics
summary(df)## Year Period Interest_Rate
## Min. :2000-01-01 Min. : 1.00 Min. :2.750
## 1st Qu.:2005-10-01 1st Qu.: 6.75 1st Qu.:3.803
## Median :2011-07-02 Median :12.50 Median :4.600
## Mean :2011-07-02 Mean :12.50 Mean :4.855
## 3rd Qu.:2017-04-02 3rd Qu.:18.25 3rd Qu.:5.910
## Max. :2023-01-01 Max. :24.00 Max. :8.050Interpretation: On average the number of Interest rate over 24 years is ~4.86# Construct a time series plot
ggplot(df, aes(x = Period, y = Interest_Rate)) +
geom_line() +
geom_point() +
xlab("Period") +
ylab("Interest Rate") +
ggtitle("Time Series Plot of Interest Rates Over Periods")
Interpretation: We observe an decreasing pattern or trend in the time series plot.# Develop a linear trend equation
model <- lm(Interest_Rate ~ Period, data = df)
summary(model)##
## Call:
## lm(formula = Interest_Rate ~ Period, data = df)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.1029 -0.3811 -0.1807 0.4883 1.1872
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7.15870 0.24919 28.73 < 2e-16 ***
## Period -0.18430 0.01744 -10.57 4.38e-10 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.5914 on 22 degrees of freedom
## Multiple R-squared: 0.8354, Adjusted R-squared: 0.8279
## F-statistic: 111.7 on 1 and 22 DF, p-value: 4.381e-10Interpretation:
# Interest_Rate = -7.16 - 0.18 * Period
# The R-square is 0.84
# The overall model is significant as p-value < 0.05## To find the MSE and MAPE values
# Calculate the fitted values from the model
df$predicted_interest_rate <- predict(model)
# Calculate residuals
df$residuals <- df$Interest_Rate - df$predicted_interest_rate
# Calculate the Mean Squared Error (MSE)
mse <- mean(df$residuals^2)
cat("Mean Squared Error (MSE):", mse, "\n")## Mean Squared Error (MSE): 0.3206241# Calculate Mean Absolute Percentage Error (MAPE)
mape <- mean(abs(df$residuals / df$Interest_Rate)) * 100
cat("Mean Absolute Percentage Error (MAPE):", mape, "%\n")## Mean Absolute Percentage Error (MAPE): 10.1497 %# Forecast the average interest rate for period 25 (i.e., 2024)
forecast_period_25 <- predict(model, newdata = data.frame(Period = 25))
cat("Forecasted Interest Rate for Period 25 (2024):", forecast_period_25, "\n")## Forecasted Interest Rate for Period 25 (2024): 2.551304Interpretation: The forecasted number of the average interest rate in 2024 is ~2.55.