hw
2025-04-01
# Load ALL required packages
library(tidyquant) ## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo## ── Attaching core tidyquant packages ─────────────────────── tidyquant 1.0.11 ──
## ✔ PerformanceAnalytics 2.0.8 ✔ TTR 0.24.4
## ✔ quantmod 0.4.26 ✔ 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 errorslibrary(dplyr) ##
## ######################### 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, unionlibrary(tidyr) # For spread()
library(xts) # For time series handling (contains to.monthly)
library(quantmod) # For financial calculations
library(PerformanceAnalytics) # For portfolio analysis
library(riskParityPortfolio) # For risk parity optimization
library(quadprog) # For quadratic programming
library(portfolioBacktest) # For backtesting
library(zoo) # For na.locf()
library(Matrix) # For nearPD()##
## Attaching package: 'Matrix'
##
## The following objects are masked from 'package:tidyr':
##
## expand, pack, unpack# 1. Download Stock Data Properly
stks <- c("AAPL", "MSFT", "AMZN", "NVDA", "GOOGL", "META", "BRK-B",
"TSLA", "UNH", "XOM", "JNJ", "JPM", "V", "PG", "LLY", "AVGO",
"MA", "HD", "MRK")
# Download adjusted closing prices
stk_data <- tq_get(stks,
from = "2019-01-01",
to = "2023-05-31",
get = "stock.prices") %>%
dplyr::select(symbol, date, adjusted) %>%
tidyr::spread(key = symbol, value = adjusted)
# Convert to monthly prices and handle NAs using xts::to.monthly
prices <- stk_data %>%
dplyr::select(-date) %>%
xts::xts(order.by = stk_data$date) %>%
xts::to.monthly(OHLC = FALSE) %>% # Correctly using xts version
zoo::na.locf()
# Create dataset in required format
stk_data <- list(adjusted = prices)
save.image("STKS_riskParity.RData")
load("STKS_riskParity.RData")
# Clean and prepare data
prices <- stk_data$adjusted
prices <- do.call(merge, lapply(seq_len(ncol(prices)), function(ii) {
tmp <- zoo::na.locf(Cl(xts::to.monthly(prices[,ii])))
names(tmp) <- gsub(".Close", "", names(tmp))
tmp
}))
stk_data <- list(adjusted = prices)
# Portfolio functions
risk_parity <- function(dataset, ...) {
prices <- dataset$adjusted
log_returns <- diff(log(prices))[-1]
log_returns[is.na(log_returns)] <- 0
riskParityPortfolio::riskParityPortfolio(cov(log_returns))$w
}
max_sharpe_ratio <- function(dataset, ...) {
prices <- dataset$adjusted
log_returns <- diff(log(prices))[-1]
log_returns[is.na(log_returns)] <- 0
N <- ncol(prices)
Sigma <- cov(log_returns)
mu <- colMeans(log_returns)
if (all(mu <= 1e-8)) return(rep(0, N))
Dmat <- 2 * Sigma
Amat <- cbind(mu, diag(N))
bvec <- c(1, rep(0, N))
dvec <- rep(0, N)
res <- try(quadprog::solve.QP(Dmat, dvec, Amat, bvec, meq = 1), silent = TRUE)
if(inherits(res, 'try-error')) {
D_mat <- Matrix::nearPD(Dmat)
res <- quadprog::solve.QP(as.matrix(D_mat$mat), dvec, Amat, bvec, meq = 1)
}
w <- res$solution
w/sum(w)
}
# Run backtest
bt <- portfolioBacktest(
list("Risk_Parity" = risk_parity,
"Tangency" = max_sharpe_ratio),
list(stk_data),
lookback = 6,
optimize_every = 3,
rebalance_every = 1,
shortselling = TRUE,
benchmarks = '1/N', # Ensure benchmark is included
execution = "next period"
)## Backtesting 2 portfolios over 1 datasets (periodicity = monthly data)...
## Backtesting benchmarks...# Safe naming approach
num_portfolios <- length(bt)
if(num_portfolios == 3) {
names(bt) <- c("Risk_Parity", "Tangency", "Equal_Weight")
} else if(num_portfolios == 2) {
names(bt) <- c("Risk_Parity", "Tangency")
} else {
stop("Unexpected number of portfolios: ", num_portfolios)
}
cat("\nRebalanced Dates:\n")##
## Rebalanced Dates:index(bt$Risk_Parity$data1$w_rebalanced)## [1] "Jun 2019" "Jul 2019" "Aug 2019" "Sep 2019" "Oct 2019" "Nov 2019"
## [7] "Dec 2019" "Jan 2020" "Feb 2020" "Mar 2020" "Apr 2020" "May 2020"
## [13] "Jun 2020" "Jul 2020" "Aug 2020" "Sep 2020" "Oct 2020" "Nov 2020"
## [19] "Dec 2020" "Jan 2021" "Feb 2021" "Mar 2021" "Apr 2021" "May 2021"
## [25] "Jun 2021" "Jul 2021" "Aug 2021" "Sep 2021" "Oct 2021" "Nov 2021"
## [31] "Dec 2021" "Jan 2022" "Feb 2022" "Mar 2022" "Apr 2022" "May 2022"
## [37] "Jun 2022" "Jul 2022" "Aug 2022" "Sep 2022" "Oct 2022" "Nov 2022"
## [43] "Dec 2022" "Jan 2023" "Feb 2023" "Mar 2023"cat("\nPerformance Summary:\n")##
## Performance Summary:round(backtestSummary(bt)$performance, 4)## Risk_Parity Tangency Equal_Weight
## Sharpe ratio 5.1608 4.9848 5.9123
## max drawdown 0.2100 0.2226 0.1986
## annual return 5.0928 5.1216 5.5318
## annual volatility 0.9868 1.0274 0.9356
## Sortino ratio 8.9237 9.2315 11.1977
## downside deviation 0.5707 0.5548 0.4940
## Sterling ratio 24.2507 23.0098 27.8476
## Omega ratio 2.1970 2.1883 2.4230
## VaR (0.95) 0.0841 0.0918 0.0753
## CVaR (0.95) 0.1088 0.0984 0.0819
## rebalancing period 1.0217 1.0217 1.0217
## turnover 0.2946 0.5195 0.0539
## ROT (bps) 676.9923 376.8843 4025.8130
## cpu time 0.0049 0.0343 0.0046
## failure rate 0.0000 0.0000 0.0000# Set up layout for charts
par(mfrow = c(2, 1))
# Cumulative Returns
tryCatch({
portfolioBacktest::backtestChartCumReturn(bt)
}, error = function(e) {
returns <- do.call(merge, lapply(bt, function(x) x$portfolio_returns))
PerformanceAnalytics::charts.PerformanceSummary(
returns,
main = "Cumulative Returns",
colorset = 1:3,
lwd = 2
)
})
# Drawdown Chart
portfolioBacktest::backtestChartDrawdown(bt)
# Risk Parity Weights
backtestChartStackedBar(bt, portfolio = "Risk_Parity", legend = TRUE)
# Tangency Portfolio Weights
backtestChartStackedBar(bt, portfolio = "Tangency", legend = TRUE)
R Markdown
This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see http://rmarkdown.rstudio.com.
When you click the Knit button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this:
summary(cars)## speed dist
## Min. : 4.0 Min. : 2.00
## 1st Qu.:12.0 1st Qu.: 26.00
## Median :15.0 Median : 36.00
## Mean :15.4 Mean : 42.98
## 3rd Qu.:19.0 3rd Qu.: 56.00
## Max. :25.0 Max. :120.00Including Plots
You can also embed plots, for example:
Note that the echo = FALSE parameter was added to the
code chunk to prevent printing of the R code that generated the
plot.