Risk Parity
Jaehyun Ahn
2023-03-17
This document will create a portfolio using the Risk-Parity strategy (equal variance) and compare the performance with Equal Weight portfolio and Tangency Portfolio.
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
symbols <- c("NVDA", "AAPL", "MSFT", "GOOG", "SCHD")
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: 10 x 3
## # Groups: symbol [5]
## symbol date returns
## <chr> <date> <dbl>
## 1 AAPL 2015-01-02 0
## 2 AAPL 2015-01-05 -0.0286
## 3 GOOG 2015-01-02 0
## 4 GOOG 2015-01-05 -0.0211
## 5 MSFT 2015-01-02 0
## 6 MSFT 2015-01-05 -0.00924
## 7 NVDA 2015-01-02 0
## 8 NVDA 2015-01-05 -0.0170
## 9 SCHD 2015-01-02 0
## 10 SCHD 2015-01-05 -0.0142# Calculate covariance matrix
cov_mat <- cov(returns %>%
spread(symbol, returns) %>%
select(-date))
cov_mat## AAPL GOOG MSFT NVDA SCHD
## AAPL 0.0003535784 0.0002164187 0.0002368233 0.0003343175 0.0001301511
## GOOG 0.0002164187 0.0003251943 0.0002418244 0.0003123124 0.0001204959
## MSFT 0.0002368233 0.0002418244 0.0003160965 0.0003423645 0.0001334459
## NVDA 0.0003343175 0.0003123124 0.0003423645 0.0009210148 0.0001741355
## SCHD 0.0001301511 0.0001204959 0.0001334459 0.0001741355 0.0001228573# 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
# 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
head(returns2)## NVDA AAPL MSFT GOOG SCHD
## 2015-01-02 0.0000000 0.000000000 0.0000000 0.0000000 0.0000000
## 2015-01-05 -1.7034170 -2.857586856 -0.9238415 -2.1065926 -1.4166607
## 2015-01-06 -3.0788025 0.009403233 -1.4785791 -2.3449898 -0.6133327
## 2015-01-07 -0.2608865 1.392457163 1.2625065 -0.1714703 1.1722467
## 2015-01-08 3.6927330 3.770290577 2.8993596 0.3148075 1.8326230
## 2015-01-09 0.4020390 0.107193993 -0.8440510 -1.3035143 -0.7741233#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)
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
# Calculate daily returns
#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
rp_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_rp,
col_rename = 'returns',
geometric = FALSE)## Warning in check_weights(weights, assets_col, map, x): Sum of weights must be 1.rp_xts_return <- rp_return %>%
tk_xts(silent = TRUE)
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.029883037 -0.027320634 -0.0454177586
## 2015-02-27 0.082468654 0.084490528 0.1091957018
## 2015-03-31 -0.039464993 -0.040506046 -0.0484254403
## 2015-04-30 0.045112605 0.046912228 0.0627714569
## 2015-05-29 0.003518476 0.002048018 -0.0008909818
## 2015-06-30 -0.049189419 -0.049788585 -0.0697897283#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.0299 RP 0.970
## 2 2015-02-27 0.0825 RP 1.05
## 3 2015-03-31 -0.0395 RP 1.01
## 4 2015-01-30 -0.0454 TAN 0.955
## 5 2015-02-27 0.109 TAN 1.06
## 6 2015-03-31 -0.0484 TAN 1.01
## 7 2015-01-30 -0.0273 EWP 0.973
## 8 2015-02-27 0.0845 EWP 1.05
## 9 2015-03-31 -0.0405 EWP 1.01# 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") ## Warning: `position_stack()` requires non-overlapping x intervals
## `position_stack()` requires non-overlapping x intervals
## `position_stack()` requires non-overlapping x intervals
#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,15,2))## 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 = 0.88523, num df = 98, denom df = 98, p-value = 0.5474
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 0.5944035 1.3183402
## sample estimates:
## ratio of variances
## 0.8852265#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 = 0.46079, num df = 98, denom df = 98, p-value = 0.0001574
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 0.3094102 0.6862474
## sample estimates:
## ratio of variances
## 0.4607949#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 = 1.9211, num df = 98, denom df = 98, p-value = 0.001396
## alternative hypothesis: true ratio of variances is not equal to 1
## 95 percent confidence interval:
## 1.289952 2.861013
## sample estimates:
## ratio of variances
## 1.921086Apparently, Risk Parity Portoflio and EWP portfolio had no difference in risk. However, Tangency portfolio showed a statistically higher risk than other 2 portfolios.
ANOVA
#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.281420 -0.039193 0.008875 0.050900 0.159742
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.028408 0.007252 3.917 0.000111 ***
## Drp -0.009596 0.010255 -0.936 0.350197
## Dtan -0.008345 0.010255 -0.814 0.416431
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.07215 on 294 degrees of freedom
## Multiple R-squared: 0.003508, Adjusted R-squared: -0.003271
## F-statistic: 0.5175 on 2 and 294 DF, p-value: 0.5965The F-test of the ANOVA shows that all 3 portfolio has jointly same returns