pkgs <- c("tidyquant", "PerformanceAnalytics", "PortfolioAnalytics",
"ROI", "ROI.plugin.quadprog", "xts", "dplyr",
"tidyr", "ggplot2", "scales", "kableExtra")
for (p in pkgs) {
if (!requireNamespace(p, quietly = TRUE))
install.packages(p, repos = "https://cloud.r-project.org")
}
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
## Registered S3 method overwritten by 'PortfolioAnalytics':
## method from
## print.constraint ROI
library(tidyquant)
## Warning: package 'PerformanceAnalytics' was built under R version 4.5.2
## ── Attaching core tidyquant packages ─────────────────────── tidyquant 1.0.11 ──
## ✔ PerformanceAnalytics 2.1.0 ✔ TTR 0.24.4
## ✔ quantmod 0.4.28 ✔ xts 0.14.1
## ── Conflicts ────────────────────────────────────────── tidyquant_conflicts() ──
## ✖ zoo::as.Date() masks base::as.Date()
## ✖ zoo::as.Date.numeric() masks base::as.Date.numeric()
## ✖ PerformanceAnalytics::legend() masks graphics::legend()
## ✖ quantmod::summary() masks base::summary()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(PerformanceAnalytics)
library(PortfolioAnalytics)
## Warning: package 'PortfolioAnalytics' was built under R version 4.5.2
## Loading required package: foreach
library(ROI)
## Warning: package 'ROI' was built under R version 4.5.2
## ROI: R Optimization Infrastructure
## Registered solver plugins: nlminb, symphony, quadprog.
## Default solver: auto.
##
## Attaching package: 'ROI'
##
## The following objects are masked from 'package:PortfolioAnalytics':
##
## is.constraint, objective
library(ROI.plugin.quadprog)
library(xts)
library(dplyr)
## Warning: package 'dplyr' was built under R version 4.5.2
##
## ######################### Warning from 'xts' package ##########################
## # #
## # The dplyr lag() function breaks how base R's lag() function is supposed to #
## # work, which breaks lag(my_xts). Calls to lag(my_xts) that you type or #
## # source() into this session won't work correctly. #
## # #
## # Use stats::lag() to make sure you're not using dplyr::lag(), or you can add #
## # conflictRules('dplyr', exclude = 'lag') to your .Rprofile to stop #
## # dplyr from breaking base R's lag() function. #
## # #
## # Code in packages is not affected. It's protected by R's namespace mechanism #
## # Set `options(xts.warn_dplyr_breaks_lag = FALSE)` to suppress this warning. #
## # #
## ###############################################################################
##
## Attaching package: 'dplyr'
##
## The following objects are masked from 'package:xts':
##
## first, last
##
## The following objects are masked from 'package:stats':
##
## filter, lag
##
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(tidyr)
## Warning: package 'tidyr' was built under R version 4.5.2
library(ggplot2)
library(scales)
library(kableExtra)
##
## Attaching package: 'kableExtra'
##
## The following object is masked from 'package:dplyr':
##
## group_rows
# Portfolio tickers & weights
tickers <- c("META", "GOOGL", "EOG", "QCOM", "DELL",
"VLO", "GILD", "AMAT", "STX", "COR")
weights <- c(0.2500, 0.2115, 0.1430, 0.1205, 0.1050,
0.0700, 0.0500, 0.0300, 0.0100, 0.0100)
benchmark_ticker <- "SPY"
# Date window
end_date <- Sys.Date()
start_date <- end_date - lubridate::years(3)
cat("Backtest window:", format(start_date), "→", format(end_date), "\n")
## Backtest window: 2023-05-26 → 2026-05-26
# Download stock price data
raw_prices <- tq_get(
c(tickers, benchmark_ticker),
from = start_date,
to = end_date,
get = "stock.prices"
)
adj_prices <- raw_prices %>%
select(symbol, date, adjusted) %>%
pivot_wider(names_from = symbol, values_from = adjusted) %>%
arrange(date)
cat("Rows downloaded:", nrow(adj_prices), "\n")
## Rows downloaded: 750
# Download stock price data
raw_prices <- tq_get(
c(tickers, benchmark_ticker),
from = start_date,
to = end_date,
get = "stock.prices"
)
adj_prices <- raw_prices %>%
select(symbol, date, adjusted) %>%
pivot_wider(names_from = symbol, values_from = adjusted) %>%
arrange(date)
cat("Rows downloaded:", nrow(adj_prices), "\n")
## Rows downloaded: 750
# ── Portfolio tickers & fixed weights from the optimisation ──────────────────
tickers <- c("META", "GOOGL", "EOG", "QCOM", "DELL",
"VLO", "GILD", "AMAT", "STX", "COR")
weights <- c(0.2500, 0.2115, 0.1430, 0.1205, 0.1050,
0.0700, 0.0500, 0.0300, 0.0100, 0.0100)
benchmark_ticker <- "SPY"
# ── Date window: 3-year backtest ─────────────────────────────────────────────
end_date <- Sys.Date()
start_date <- end_date - lubridate::years(3)
cat("Backtest window:", format(start_date), "→", format(end_date), "\n")
## Backtest window: 2023-05-26 → 2026-05-26
# ── Download adjusted-close prices ───────────────────────────────────────────
raw_prices <- tq_get(
c(tickers, benchmark_ticker),
from = start_date,
to = end_date,
get = "stock.prices"
)
adj_prices <- raw_prices %>%
select(symbol, date, adjusted) %>%
pivot_wider(names_from = symbol, values_from = adjusted) %>%
arrange(date)
cat("Rows downloaded:", nrow(adj_prices), "\n")
## Rows downloaded: 750
# Download stock price data
raw_prices <- tq_get(
c(tickers, benchmark_ticker),
from = start_date,
to = end_date,
get = "stock.prices"
)
adj_prices <- raw_prices %>%
select(symbol, date, adjusted) %>%
pivot_wider(names_from = symbol, values_from = adjusted) %>%
arrange(date)
cat("Rows downloaded:", nrow(adj_prices), "\n")
## Rows downloaded: 750
cat("Date range :", format(min(adj_prices$date)), "→",
format(max(adj_prices$date)), "\n")
## Date range : 2023-05-26 → 2026-05-22
# ── Daily log-returns for each asset ─────────────────────────────────────────
port_prices <- adj_prices %>% select(date, all_of(tickers))
bench_prices <- adj_prices %>% select(date, SPY)
prices_xts <- xts::xts(
x = port_prices %>% select(-date),
order.by = port_prices$date
)
bench_xts <- xts::xts(
x = bench_prices %>% select(-date),
order.by = bench_prices$date
)
# Daily simple returns
asset_returns <- Return.calculate(prices_xts, method = "discrete")[-1, ]
bench_returns <- Return.calculate(bench_xts, method = "discrete")[-1, ]
# Portfolio return series (buy-and-hold weights, rebalanced monthly)
port_returns <- Return.portfolio(asset_returns, weights = weights,
rebalance_on = "months")
colnames(port_returns) <- "Quality_Momentum"
colnames(bench_returns) <- "SPY_Benchmark"
combined <- merge.xts(port_returns, bench_returns)
head(combined, 3)
## Quality_Momentum SPY_Benchmark
## 2023-05-30 -0.001303221 0.0003808395
## 2023-05-31 -0.011714473 -0.0055451279
## 2023-06-01 0.013642096 0.0095009115
cum_ret <- cumprod(1 + combined) - 1 # running cumulative return
cum_df <- data.frame(
date = index(cum_ret),
Portfolio = as.numeric(cum_ret[, "Quality_Momentum"]),
Benchmark = as.numeric(cum_ret[, "SPY_Benchmark"])
) %>%
pivot_longer(-date, names_to = "Series", values_to = "Cum_Return")
ggplot(cum_df, aes(x = date, y = Cum_Return, colour = Series, linetype = Series)) +
geom_line(linewidth = 1.1) +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
scale_colour_manual(values = c("Portfolio" = "#8f77b4", "Benchmark" = "#ff3F0e")) +
scale_linetype_manual(values = c("Portfolio" = "solid", "Benchmark" = "dashed")) +
labs(
title = "Cumulative Return: Quality Momentum vs. SPY",
subtitle = paste(format(start_date, "%b %Y"), "—", format(end_date, "%b %Y")),
x = NULL, y = "Cumulative Return", colour = NULL, linetype = NULL
) +
theme_minimal(base_size = 13) +
theme(legend.position = "top", plot.title = element_text(face = "bold"))
final_cum <- cum_ret[nrow(cum_ret), ]
data.frame(
Series = c("Quality Momentum Portfolio", "SPY Benchmark"),
`Cumulative Return` = percent(as.numeric(final_cum), accuracy = 0.1)
) %>%
kable(align = "lr", caption = "Total Cumulative Return over the 3-Year Period") %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Total Cumulative Return over the 3-Year Period
|
Series
|
Cumulative.Return
|
|
Quality Momentum Portfolio
|
191.7%
|
|
SPY Benchmark
|
84.5%
|
# Risk-free rate: U.S. 3-month T-bill annualised ≈ 5.25% (2024 avg), daily equiv.
rf_annual <- 0.0525
rf_daily <- (1 + rf_annual)^(1/252) - 1
sharpe_port <- SharpeRatio.annualized(port_returns, Rf = rf_daily, scale = 252)
sharpe_bench <- SharpeRatio.annualized(bench_returns, Rf = rf_daily, scale = 252)
sharpe_tbl <- data.frame(
Series = c("Quality Momentum Portfolio", "SPY Benchmark"),
`Sharpe Ratio` = round(c(as.numeric(sharpe_port), as.numeric(sharpe_bench)), 3),
`Risk-Free Rate Used` = c("5.25% p.a.", "5.25% p.a.")
)
sharpe_tbl %>%
kable(align = "lrr",
caption = "Annualised Sharpe Ratio (Rf = 5.25% p.a., 3-Year Window)") %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Annualised Sharpe Ratio (Rf = 5.25% p.a., 3-Year Window)
|
Series
|
Sharpe.Ratio
|
Risk.Free.Rate.Used
|
|
Quality Momentum Portfolio
|
1.557
|
5.25% p.a.
|
|
SPY Benchmark
|
1.098
|
5.25% p.a.
|
roll_sharpe_port <- rollapply(port_returns, width = 126,
FUN = function(x) SharpeRatio.annualized(x, Rf = rf_daily * 126, scale = 252)[1],
fill = NA, align = "right")
roll_sharpe_bench <- rollapply(bench_returns, width = 126,
FUN = function(x) SharpeRatio.annualized(x, Rf = rf_daily * 126, scale = 252)[1],
fill = NA, align = "right")
roll_df <- data.frame(
date = index(roll_sharpe_port),
Portfolio = as.numeric(roll_sharpe_port),
Benchmark = as.numeric(roll_sharpe_bench)
) %>% pivot_longer(-date, names_to = "Series", values_to = "Sharpe")
ggplot(roll_df, aes(x = date, y = Sharpe, colour = Series)) +
geom_line(linewidth = 0.9, na.rm = TRUE) +
geom_hline(yintercept = 0, linetype = "dashed", colour = "grey10") +
scale_colour_manual(values = c("Portfolio" = "#1f34b4", "Benchmark" = "#ff788e")) +
labs(title = "Rolling 6-Month Sharpe Ratio",
subtitle = "Higher = better risk-adjusted return",
x = NULL, y = "Annualised Sharpe Ratio", colour = NULL) +
theme_minimal(base_size = 13) +
theme(legend.position = "top", plot.title = element_text(face = "bold"))
chart.Drawdown(
combined,
main = "Drawdown from Peak — Quality Momentum vs. SPY",
colorset = c("#1f37b4", "#ff788e"),
lwd = 1.5,
legend.loc = "bottomleft"
)
mdd_port <- maxDrawdown(port_returns)
mdd_bench <- maxDrawdown(bench_returns)
avg_dd_port <- AverageDrawdown(port_returns)
avg_dd_bench <- AverageDrawdown(bench_returns)
dd_tbl <- data.frame(
Series = c("Quality Momentum Portfolio", "SPY Benchmark"),
`Maximum Drawdown` = percent(c(mdd_port, mdd_bench), accuracy = 0.1),
`Average Drawdown` = percent(c(avg_dd_port, avg_dd_bench), accuracy = 0.1)
)
dd_tbl %>%
kable(align = "lrr",
caption = "Drawdown Statistics over the 3-Year Backtest") %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Drawdown Statistics over the 3-Year Backtest
|
Series
|
Maximum.Drawdown
|
Average.Drawdown
|
|
Quality Momentum Portfolio
|
25.1%
|
2.4%
|
|
SPY Benchmark
|
18.8%
|
1.6%
|
# CAPM regression: portfolio excess return ~ benchmark excess return
port_excess <- port_returns - rf_daily
bench_excess <- bench_returns - rf_daily
capm_model <- lm(as.numeric(port_excess) ~ as.numeric(bench_excess))
alpha_daily <- coef(capm_model)[1]
beta_coef <- coef(capm_model)[2]
# Annualise alpha
alpha_annual <- alpha_daily * 252
cat(sprintf("Annualised Alpha : %+.4f (%+.2f%%)\n", alpha_annual, alpha_annual * 100))
## Annualised Alpha : +0.1345 (+13.45%)
cat(sprintf("Beta : %.4f\n", beta_coef))
## Beta : 1.1864
cat(sprintf("R-squared : %.4f\n", summary(capm_model)$r.squared))
## R-squared : 0.7108
cat(sprintf("R-squared : %.4f\n", summary(capm_model)$r.squared))
## R-squared : 0.7108
ab_tbl <- data.frame(
Metric = c("Annualised Alpha (Jensen's α)",
"Beta (Market Sensitivity)",
"R-Squared (Explanatory Power)"),
Value = c(
paste0(sprintf("%+.2f", alpha_annual * 100), "% p.a."),
sprintf("%.3f", beta_coef),
sprintf("%.3f", summary(capm_model)$r.squared)
),
Interpretation = c(
ifelse(alpha_annual > 0,
"Positive: strategy adds value beyond market exposure",
"Negative: market exposure explains excess performance"),
ifelse(beta_coef < 1,
"< 1: less volatile than the broad market",
"> 1: amplified market sensitivity"),
"Proportion of returns explained by SPY movements"
)
)
ab_tbl %>%
kable(align = "llll",
caption = "CAPM Alpha & Beta — Quality Momentum vs. SPY (3-Year Window)") %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) %>%
column_spec(1, bold = TRUE)
CAPM Alpha & Beta — Quality Momentum vs. SPY (3-Year Window)
|
|
Metric
|
Value
|
Interpretation
|
|
(Intercept)
|
Annualised Alpha (Jensen’s α)
|
+13.45% p.a.
|
Positive: strategy adds value beyond market exposure
|
|
as.numeric(bench_excess)
|
Beta (Market Sensitivity)
|
1.186
|
> 1: amplified market sensitivity
|
|
|
R-Squared (Explanatory Power)
|
0.711
|
Proportion of returns explained by SPY movements
|
scatter_df <- data.frame(
bench = as.numeric(bench_excess),
port = as.numeric(port_excess)
)
ggplot(scatter_df, aes(x = bench, y = port)) +
geom_point(alpha = 0.25, colour = "#7f77b4", size = 1) +
geom_smooth(method = "lm", colour = "#e92c3c", se = TRUE, linewidth = 1.2) +
scale_x_continuous(labels = percent_format(accuracy = 0.1)) +
scale_y_continuous(labels = percent_format(accuracy = 0.1)) +
labs(
title = "Security Characteristic Line",
subtitle = paste0("α = ", sprintf("%+.3f%%", alpha_annual * 100),
" p.a. | β = ", sprintf("%.3f", beta_coef)),
x = "SPY Daily Excess Return",
y = "Portfolio Daily Excess Return"
) +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"))
## `geom_smooth()` using formula = 'y ~ x'
table.AnnualizedReturns(combined, Rf = rf_daily, scale = 252) %>%
round(4) %>%
kable(caption = "Annualised Performance Summary",
col.names = c("Quality Momentum", "SPY Benchmark")) %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
Annualised Performance Summary
|
|
Quality Momentum
|
SPY Benchmark
|
|
Annualized Return
|
0.4336
|
0.2288
|
|
Annualized Std Dev
|
0.2131
|
0.1514
|
|
Annualized Sharpe (Rf=5.12%)
|
1.6995
|
1.1064
|
# Comprehensive stats table
stats_list <- lapply(list(port_returns, bench_returns), function(r) {
c(
`Ann. Return` = as.numeric(Return.annualized(r, scale = 252)),
`Ann. Volatility` = as.numeric(StdDev.annualized(r, scale = 252)),
`Sharpe Ratio` = as.numeric(SharpeRatio.annualized(r, Rf = rf_daily, scale = 252)),
`Max Drawdown` = as.numeric(maxDrawdown(r)),
`Calmar Ratio` = as.numeric(Return.annualized(r, scale = 252) / maxDrawdown(r)),
`Skewness` = as.numeric(skewness(r)),
`Kurtosis` = as.numeric(kurtosis(r))
)
})
stats_df <- do.call(cbind, stats_list)
colnames(stats_df) <- c("Quality Momentum", "SPY Benchmark")
stats_df %>%
as.data.frame() %>%
mutate(across(everything(), round, 3)) %>%
kable(caption = "Comprehensive Risk & Return Statistics (3-Year Backtest)") %>%
kable_styling(bootstrap_options = c("striped","hover","condensed"), full_width = FALSE)
## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `across(everything(), round, 3)`.
## Caused by warning:
## ! The `...` argument of `across()` is deprecated as of dplyr 1.1.0.
## Supply arguments directly to `.fns` through an anonymous function instead.
##
## # Previously
## across(a:b, mean, na.rm = TRUE)
##
## # Now
## across(a:b, \(x) mean(x, na.rm = TRUE))
Comprehensive Risk & Return Statistics (3-Year Backtest)
|
|
Quality Momentum
|
SPY Benchmark
|
|
Ann. Return
|
0.434
|
0.229
|
|
Ann. Volatility
|
0.213
|
0.151
|
|
Sharpe Ratio
|
1.557
|
1.098
|
|
Max Drawdown
|
0.251
|
0.188
|
|
Calmar Ratio
|
1.727
|
1.220
|
|
Skewness
|
0.319
|
0.948
|
|
Kurtosis
|
11.105
|
21.974
|
cat("
> **Backtest Period:** ", format(start_date, "%B %Y"), "—", format(end_date, "%B %Y"), "
> **Strategy:** Quality Momentum (FCF Yield > 5% ∩ Positive 6-Month RSI)
> **Benchmark:** S&P 500 ETF (SPY)
")
##
## > **Backtest Period:** May 2023 — May 2026
## > **Strategy:** Quality Momentum (FCF Yield > 5% ∩ Positive 6-Month RSI)
## > **Benchmark:** S&P 500 ETF (SPY)