Revised Risk Parity
Jaehyun Ahn
2023-03-21
This document will create a portfolio using the Risk-Parity strategy (equal variance) and compare the performance with Equal Weight portfolio and Tangency Portfolio. Risk-Parity portfolio aims to provide diversification effect among different asset classes by constructing protfolio that contributes same risk for each different asset class.
Reference:https://cran.r-project.org/web/packages/riskParityPortfolio/vignettes/RiskParityPortfolio.html
Portfolio Construction
#Import Library
library(tidyquant)## 필요한 패키지를 로딩중입니다: lubridate##
## 다음의 패키지를 부착합니다: 'lubridate'## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, union## 필요한 패키지를 로딩중입니다: PerformanceAnalytics## 필요한 패키지를 로딩중입니다: xts## 필요한 패키지를 로딩중입니다: zoo##
## 다음의 패키지를 부착합니다: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric##
## 다음의 패키지를 부착합니다: 'PerformanceAnalytics'## The following object is masked from 'package:graphics':
##
## legend## 필요한 패키지를 로딩중입니다: quantmod## 필요한 패키지를 로딩중입니다: TTR## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoolibrary(riskParityPortfolio)
library(ggplot2)
library(portfolioBacktest)
library(PerformanceAnalytics)
library(PortfolioAnalytics)## 필요한 패키지를 로딩중입니다: foreachlibrary(timetk)
library(tidyverse)## -- Attaching core tidyverse packages ------------------------ tidyverse 2.0.0 --
## v dplyr 1.0.8 v stringr 1.5.0
## v forcats 1.0.0 v tibble 3.1.6
## v purrr 0.3.4 v tidyr 1.2.0
## v readr 2.1.4## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x purrr::accumulate() masks foreach::accumulate()
## x dplyr::filter() masks stats::filter()
## x dplyr::first() masks xts::first()
## x dplyr::lag() masks stats::lag()
## x dplyr::last() masks xts::last()
## x purrr::when() masks foreach::when()
## i Use the [conflicted package](http://conflicted.r-lib.org/) to force all conflicts to become errors#Import stock prices using tidyquant
#IGV is a Software ETF
#BND is a Bond ETF
symbols <- c("IGV", "BND")
start_date <- "2015-01-01"
end_date <- Sys.Date()
prices <- tq_get(symbols, get = "stock.prices", from = start_date, to = end_date)
# Calculate daily returns
returns <- prices %>%
group_by(symbol) %>%
tq_transmute(select = adjusted,
mutate_fun = periodReturn,
period = "daily",
type = "log",
col_rename = 'returns')
returns %>%
slice(1:2)## # A tibble: 4 x 3
## # Groups: symbol [2]
## symbol date returns
## <chr> <date> <dbl>
## 1 BND 2015-01-02 0
## 2 BND 2015-01-05 0.00290
## 3 IGV 2015-01-02 0
## 4 IGV 2015-01-05 -0.0124# Calculate covariance matrix
cov_mat <- cov(returns %>%
spread(symbol, returns) %>%
select(-date))
cov_mat## BND IGV
## BND 1.105897e-05 7.846179e-06
## IGV 7.846179e-06 2.646161e-04Risk-Parity
# Calculate risk-parity portfolio weights
weights_rp <- riskParityPortfolio(cov_mat)$w
#Risk Parity Allocation
V_rp <- barplotPortfolioRisk(weights_rp,cov_mat,color='cornflowerblue')+
ggtitle('Risk Parity Portfolio')+
scale_y_continuous(labels = scales::percent)
V_rp
Tangency Portfolio
# Calculate maximum Sharpe ratio portfolio weights
# Convert the data into xts to use PerformanceAnlytics package
returns2 <- returns %>%
select(symbol,date,returns) %>%
pivot_wider(names_from = symbol, values_from = returns) %>%
tk_xts(silent = TRUE) * 100 #time_tk helps change data into different format
head(returns2)## IGV BND
## 2015-01-02 0.0000000 0.00000000
## 2015-01-05 -1.2426464 0.28989209
## 2015-01-06 -1.7482136 0.28916863
## 2015-01-07 0.6120379 0.06005942
## 2015-01-08 2.1076226 -0.15630399
## 2015-01-09 -0.9714470 0.16838881#Add constraints and objective for tangency portfolio
portf <- portfolio.spec(colnames(returns2))
portf <- add.constraint(portf, type="weight_sum", min_sum=1, max_sum=1)
portf <- add.constraint(portf, type="long_only")
portf <- add.constraint(portf, type="box", min=.10,max=0.9) # Included 10% minimum weight
portf <- add.objective(portf, type="return", name="mean")
portf <- add.objective(portf, type="risk", name="StdDev")
portf_max_sharpe <- optimize.portfolio(returns2, portf,
optimize_method = 'ROI',
trace=TRUE,maxSR=TRUE
)## Registered S3 method overwritten by 'ROI':
## method from
## print.constraint PortfolioAnalytics#Tangency Allocation
V_sp <- barplotPortfolioRisk(portf_max_sharpe$weights,cov_mat,col = "#A29BFE")+
ggtitle('Tangency Portfolio')+
scale_y_continuous(labels = scales::percent)
V_sp
#Equally weighted portfolio
EWP = rep(1/nrow(cov_mat),nrow(cov_mat))
V_ewp <- barplotPortfolioRisk(EWP,cov_mat,col = "lightgreen")+
ggtitle('Equally Weighted Portfolio')+
scale_y_continuous(labels = scales::percent)+
scale_x_discrete(labels = symbols)
V_ewp
#Aggregate and Visualize tghe weights and risk contribution
w_all <- cbind("RPP" = weights_rp,
"Tangency" = portf_max_sharpe$weights,
"EWP" = EWP)
barplotPortfolioRisk(w_all, cov_mat,colors = c('cornflowerblue',"#A29BFE","lightgreen")) +
scale_y_continuous(labels = scales::percent)
Performance
#Create variables to use PerformanceAnalytics Package
#Weights of each portfolio
w_rp <- c(weights_rp)
w_ewp <- c(EWP)
w_tan <- c(portf_max_sharpe$weights)
#Create Return columns and convert to XTS to utilize PerformanceAnalytics Visualizaiton Package
rp_return <- prices %>%
group_by(symbol) %>%
tq_transmute(select = adjusted,
mutate_fun = periodReturn,
period = "monthly", #Converting it to log monthly return
type = "log",
col_rename = 'returns') %>%
tq_portfolio(assets_col = symbol,
returns_col = returns,
weights = w_rp,
col_rename = 'returns', #Creates return based on the weights
geometric = FALSE)
rp_xts_return <- rp_return %>%
tk_xts(silent = TRUE) # Use timetk library to conver the data to xts format
ewp_return <- prices %>%
group_by(symbol) %>%
tq_transmute(select = adjusted,
mutate_fun = periodReturn,
period = "monthly",
type = "log",
col_rename = 'returns') %>%
tq_portfolio(assets_col = symbol,
returns_col = returns,
weights = w_ewp,
col_rename = 'returns',
geometric = FALSE)
ewp_xts_return <- ewp_return %>%
tk_xts(silent = TRUE)
tan_return <- prices %>%
group_by(symbol) %>%
tq_transmute(select = adjusted,
mutate_fun = periodReturn,
period = "monthly",
type = "log",
col_rename = 'returns') %>%
tq_portfolio(assets_col = symbol,
returns_col = returns,
weights = w_tan,
col_rename = 'returns',
geometric = FALSE)
tan_xts_return <- tan_return %>%
tk_xts(silent = TRUE)
#Aggregate and change column names
p.returns <- merge(rp_xts_return,ewp_xts_return,tan_xts_return)
names(p.returns) <- c('Risk Parity Portfolio','Equal Weight Portfolio','Tangency Portfolio')
head(p.returns)## Risk Parity Portfolio Equal Weight Portfolio Tangency Portfolio
## 2015-01-30 -0.022025634 -0.005165743 -0.001818908
## 2015-02-27 0.075533496 0.040255656 0.033252698
## 2015-03-31 -0.017553241 -0.008408545 -0.006593244
## 2015-04-30 0.030317323 0.016969219 0.014319504
## 2015-05-29 0.008837744 0.003341592 0.002250558
## 2015-06-30 -0.013205656 -0.012402094 -0.012242580#Visualize the performance
charts.PerformanceSummary(p.returns, colorset=rich6equal,
lwd=3, cex.legend = 1, event.labels = TRUE,main='Portfolio Performance')
#Create Variables to visualize using ggplot2
rp_return$symbol <- 'RP'
ewp_return$symbol <- 'EWP'
tan_return$symbol <- 'TAN'
#Calculate Cumulative Return
rp_return<- rp_return %>%
mutate(cr=cumprod(1+returns))
ewp_return<- ewp_return %>%
mutate(cr=cumprod(1+returns))
tan_return<- tan_return %>%
mutate(cr=cumprod(1+returns))
#Merge data
p_return_df <- rbind(rp_return,ewp_return,tan_return) %>%
group_by(symbol)
p_return_df$symbol <- factor(p_return_df$symbol, levels = c("RP", "TAN", "EWP")) #To order it
p_return_df %>%
slice(1:3)## # A tibble: 9 x 4
## # Groups: symbol [3]
## date returns symbol cr
## <date> <dbl> <fct> <dbl>
## 1 2015-01-30 -0.0220 RP 0.978
## 2 2015-02-27 0.0755 RP 1.05
## 3 2015-03-31 -0.0176 RP 1.03
## 4 2015-01-30 -0.00182 TAN 0.998
## 5 2015-02-27 0.0333 TAN 1.03
## 6 2015-03-31 -0.00659 TAN 1.02
## 7 2015-01-30 -0.00517 EWP 0.995
## 8 2015-02-27 0.0403 EWP 1.03
## 9 2015-03-31 -0.00841 EWP 1.03# Create the bar plot
ggplot(p_return_df, aes(x = date, y = returns,fill=symbol)) +
geom_bar(stat = "identity",width=20,color='black') +
scale_fill_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
labs(x = "Date", y = "Returns",fill='Portfolio')+
scale_y_continuous(labels = scales::percent,
breaks = seq(-0.5,0.75,0.1)) +
facet_wrap(~symbol,ncol=1) +
ggtitle('Portfolio Monthly Returns') +
theme(legend.position = "top") 
#Box Plot
p_return_df %>%
ggplot(aes(symbol, returns,fill=symbol)) +
geom_boxplot(width=0.2) +
scale_fill_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
labs(x="Portfolio", y="Monthly Returns",fill='Portfolio') +
scale_y_continuous(labels = scales::percent) +
theme(legend.position = "top") +
ggtitle('Portoflio Monthly Return Boxplot')
#Mean Return
p_return_df%>%
mutate(year=year(date)) %>%
group_by(symbol,year) %>%
summarise(mean = mean(returns),
sd = sd(returns)) %>%
ggplot(aes(x = year, y = mean, fill = symbol)) +
geom_bar(stat = "identity", position = "dodge", width = 0.7,color="black") +
scale_y_continuous(breaks = seq(-0.2,0.2,0.02),
labels = scales::percent) +
scale_x_continuous(breaks = seq(2015,2023,1)) +
scale_fill_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
labs(x = "Year", y = "Monthly Mean Return",fill='Portfolio') +
theme(legend.position = "top") +
ggtitle("Portfolio Monthly Mean Return")## `summarise()` has grouped output by 'symbol'. You can override using the
## `.groups` argument.
#Standard Deviation
p_return_df%>%
mutate(year=year(date)) %>%
group_by(symbol,year) %>%
summarise(mean = mean(returns),
sd = sd(returns)) %>%
ggplot(aes(x = year, y = sd, fill = symbol)) +
geom_bar(stat = "identity", position = "dodge", width = 0.7,color="black") +
scale_y_continuous(breaks = seq(-0.1,0.4,0.02),
labels = scales::percent) +
scale_x_continuous(breaks = seq(2015,2023,1)) +
scale_fill_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
labs(x = "Year", y = "Monthly Risk",fill='Portfolio') +
theme(legend.position = "top") +
ggtitle("Portfolio Monthly Standard Deviation")## `summarise()` has grouped output by 'symbol'. You can override using the
## `.groups` argument.
#Sharpe Ratio
#Annualize Return
mean_rp <- (mean(rp_return$returns)+1)^12 - 1
mean_tan <- (mean(tan_return$returns)+1)^12 - 1
mean_ewp <- (mean(ewp_return$returns)+1)^12 - 1
#Annualize Risk
sd_rp <- sd(rp_return$returns)*sqrt(12)
sd_tan <- sd(tan_return$returns)*sqrt(12)
sd_ewp <- sd(ewp_return$returns)*sqrt(12)
#Risk free rate
rf <- 0.04
sharpe_rp <- (mean_rp-rf)/sd_rp
sharpe_tan <- (mean_tan-rf)/sd_tan
sharpe_ewp <- (mean_ewp-rf)/sd_ewp
sharpe <- tibble(Portfolio=c('RP','TAN',"EWP"),SharpeRatio=c(sharpe_rp,sharpe_tan,sharpe_ewp))
sharpe$Portfolio <- factor(sharpe$Portfolio, levels = c("RP", "TAN", "EWP"))
sharpe %>%
ggplot(aes(x=Portfolio,y=SharpeRatio,fill=Portfolio))+
geom_bar(stat='identity',color="black",width=0.4)+
scale_fill_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
ggtitle('Portfolio Sharpe Ratio')+
geom_text(aes(label=sprintf('%.2f', SharpeRatio)), vjust=-0.2, size=4)+
theme(legend.position = "top") 
#Cumulative Return
ggplot(p_return_df, aes(x = date, y = cr, color=symbol)) +
geom_line(size=1)+
geom_point(size=1.5)+
scale_color_manual(values = c("RP" = "cornflowerblue",
"TAN" = "#A29BFE",
"EWP" = "lightgreen")) +
labs(x = "Date", y = "Cumulative Return",color='Portfolio')+
ggtitle('Portfolio Cumulative Return') +
theme(legend.position = "top") +
scale_y_continuous(breaks = seq(0,4,1))## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## i Please use `linewidth` instead.
Statistical Analysis
Variance Test
#Risk Parity - EWP
var.test(x=rp_return$returns,y=ewp_return$returns)##
## F test to compare two variances
##
## data: rp_return$returns and ewp_return$returns
## F = 2.3064, num df = 98, denom df = 98, p-value = 4.736e-05
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 1.548681 3.434854
## sample estimates:
## ratio of variances
## 2.306403#Risk Parity - Tangency
var.test(x=rp_return$returns,y=tan_return$returns)##
## F test to compare two variances
##
## data: rp_return$returns and tan_return$returns
## F = 2.835, num df = 98, denom df = 98, p-value = 4.774e-07
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 1.903610 4.222056
## sample estimates:
## ratio of variances
## 2.834986#Tangency - EWP
var.test(x=tan_return$returns,y=ewp_return$returns)##
## F test to compare two variances
##
## data: tan_return$returns and ewp_return$returns
## F = 0.81355, num df = 98, denom df = 98, p-value = 0.3087
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 0.5462748 1.2115945
## sample estimates:
## ratio of variances
## 0.81355#Create Dummy Variables
Drp <- rep(1,99)
Drp[100:297] <- 0
Dtan <- rep(0,99)
Dtan[100:198] <- 1
Dtan[199:297] <- 0
Dewp <- rep(0,198)
Dewp[199:297] <- 1
anova <- cbind(p_return_df,Drp,Dtan,Dewp)## New names:
## * `` -> `...5`
## * `` -> `...6`
## * `` -> `...7`colnames(anova)[5:7] <- c('Drp','Dtan','Dewp')
library(DT)
datatable(anova)reg <- lm(data=anova, returns~Drp+Dtan) #Don't include Dewp due to dummy trap
summary(reg)##
## Call:
## lm(formula = returns ~ Drp + Dtan, data = anova)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.132734 -0.021575 0.001049 0.024225 0.107560
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.0055873 0.0037597 1.486 0.138
## Drp 0.0042328 0.0053170 0.796 0.427
## Dtan 0.0007011 0.0053170 0.132 0.895
##
## Residual standard error: 0.03741 on 294 degrees of freedom
## Multiple R-squared: 0.002471, Adjusted R-squared: -0.004315
## F-statistic: 0.3641 on 2 and 294 DF, p-value: 0.6951