Bonus: Let’s create a safe optimizer that attempts to find a particular specified optimization (given as input parameter), and defaults to 1/N if it fails…
It then repeats this on a rolling basis…
The following is how we loaded our data previously:
pacman::p_load(tidyverse)
pacman::p_load(RiskPortfolios);pacman::p_load(fitHeavyTail)
StartDate <- lubridate::ymd(20100101)
Dax <- fmxdat::DAX %>% filter(date > StartDate)
# Let's now pick and only use the top 50 stocks from the last date:
Top_70 <-
Dax %>% filter(date == last(date)) %>%
arrange(desc(weight)) %>% top_n(70, weight) %>% pull(Tickers)
# Right, with this let's subset our entire dataframe:
Dax <-
Dax %>% filter(Tickers %in% Top_70)
return_mat <- Dax %>% select(date, Tickers, return) %>% spread(Tickers, return)
impute_missing_returns <- function(return_mat, impute_returns_method = "NONE"){
# Make sure we have a date column called date:
if( !"date" %in% colnames(return_mat) ) stop("No 'date' column provided in return_mat. Try again please.")
# Note my use of 'any' below...
# Also note that I 'return' return_mat - which stops the function and returns return_mat.
if( impute_returns_method %in% c("NONE", "None", "none") ) {
if( any(is.na(return_mat)) ) warning("There are missing values in the return matrix.. Consider maybe using impute_returns_method = 'Drawn_Distribution_Own' / 'Drawn_Distribution_Collective'")
return(return_mat)
}
if( impute_returns_method == "Average") {
return_mat <-
return_mat %>% gather(Stocks, Returns, -date) %>%
group_by(date) %>%
mutate(Avg = mean(Returns, na.rm=T)) %>%
mutate(Avg = coalesce(Avg, 0)) %>% # date with no returns - set avg to zero
ungroup() %>%
mutate(Returns = coalesce(Returns, Avg)) %>% select(-Avg) %>% spread(Stocks, Returns)
# That is just so much easier when tidy right? See how I gathered and spread again to give back a wide df?
return(return_mat)
} else
if( impute_returns_method == "Drawn_Distribution_Own") {
N <- nrow(return_mat)
return_mat <-
# DIY: see what density function does
left_join(return_mat %>% gather(Stocks, Returns, -date),
return_mat %>% gather(Stocks, Returns, -date) %>% group_by(Stocks) %>%
mutate(Dens = list(density(Returns, na.rm=T))) %>%
summarise(set.seed(as.numeric(format( Sys.time(), format = "%s"))/1e3*sample(1:100)[1]), Random_Draws = list(sample(Dens[[1]]$x, N, replace = TRUE, prob=.$Dens[[1]]$y))),
by = "Stocks"
) %>% group_by(Stocks) %>%
# Random draw from sample:
mutate(Returns = coalesce(Returns, Random_Draws[[1]][row_number()])) %>%
select(-Random_Draws) %>% ungroup() %>% spread(Stocks, Returns)
return(return_mat)
} else
if( impute_returns_method == "Drawn_Distribution_Collective") {
NAll <- nrow(return_mat %>% gather(Stocks, Returns, -date))
# DIY: see what density function does
return_mat <-
bind_cols(
return_mat %>% gather(Stocks, Returns, -date),
return_mat %>% gather(Stocks, Returns, -date) %>%
mutate(Dens = list(density(Returns, na.rm=T))) %>%
summarise(set.seed(as.numeric(format( Sys.time(), format = "%s"))/1e3*sample(1:100)[1]), Random_Draws = list(sample(Dens[[1]]$x, NAll, replace = TRUE, prob=.$Dens[[1]]$y))) %>%
unnest(Random_Draws)
) %>%
mutate(Returns = coalesce(Returns, Random_Draws)) %>% select(-Random_Draws) %>% spread(Stocks, Returns)
return(return_mat)
} else
if( impute_returns_method == "Zero") {
warning("This is probably not the best idea but who am I to judge....")
return_mat[is.na(return_mat)] <- 0
return(return_mat)
} else
stop("Please provide a valid impute_returns_method method. Options include:\n'Average', 'Drawn_Distribution_Own', 'Drawn_Distribution_Collective' and 'Zero'.")
return_mat
}
# Now we will use this function as follows (after saving and sourcing it of course....):
# Note my seed is the year, day hour and minute - so unless you do this multiple times a minute, it will always differ.
options(scipen = 999) # Stop the scientific notation of
return_mat <-
impute_missing_returns(return_mat, impute_returns_method = "Drawn_Distribution_Collective")
# And it is pretty quick too....
# Right! So now we have a square matrix:
any(is.na(return_mat))## [1] FALSEreturn_mat_Nodate <- data.matrix(return_mat[, -1])
# Simple Sample covariance and mean:
Sigma <- RiskPortfolios::covEstimation(return_mat_Nodate)
Mu <- return_mat %>% summarise(across(-date, ~prod(1+.)^(1/n())-1)) %>% purrr::as_vector()Now let’s now calculate the EV, MinVol, ERC and Risk-eff optimizations from RiskPortfolios, while appending it together.
Let you function alert you when weights do not converge.
LB = 0.001
UB = 0.25
optim_foo <- function(Type = "mv", mu, Sigma, LB, UB, printmsg = TRUE){
Safe_Optim <- purrr::safely(RiskPortfolios::optimalPortfolio)
Opt_W <-
Safe_Optim(mu = mu, Sigma = Sigma,
control = list(type = Type, constraint = 'user',
LB = rep(LB, ncol(Sigma)),
UB = rep(UB, ncol(Sigma))))
if( is.null(Opt_W$error)){
optimw <-
tibble(Tickers = colnames(Sigma), weights = Opt_W$result) %>%
# Take note:
rename(!!Type := weights)
if(printmsg) optimw <- optimw %>% mutate(Result = glue::glue("Converged: {Type}"))
} else {
optimw <- tibble(Tickers = colnames(Sigma), weights = 1/ncol(Sigma)) %>%
# Take note:
rename(!!Type := weights)
if(printmsg) optimw <- optimw %>% mutate(Result = glue::glue("Failed to Converge: {Type}"))
}
optimw
}
My_Weights <-
optim_foo(Type = "mv", mu, Sigma, LB, UB, printmsg = T)
My_Weights## # A tibble: 70 × 3
## Tickers mv Result
## <chr> <dbl> <glue>
## 1 1COV GR Equity 0.0143 Failed to Converge: mv
## 2 ADS GR Equity 0.0143 Failed to Converge: mv
## 3 AFX GR Equity 0.0143 Failed to Converge: mv
## 4 AIR GR Equity 0.0143 Failed to Converge: mv
## 5 ALV GR Equity 0.0143 Failed to Converge: mv
## 6 AT1 GR Equity 0.0143 Failed to Converge: mv
## 7 B4B GR Equity 0.0143 Failed to Converge: mv
## 8 BAS GR Equity 0.0143 Failed to Converge: mv
## 9 BAYN GR Equity 0.0143 Failed to Converge: mv
## 10 BC8 GR Equity 0.0143 Failed to Converge: mv
## # … with 60 more rows
## # ℹ Use `print(n = ...)` to see more rowsTo have multiple solutions side by side (set off printmsg)
My_Weights <-
left_join(
optim_foo(Type = "mv", mu, Sigma, LB, UB, printmsg = F),
optim_foo(Type = "minvol", mu, Sigma, LB, UB, printmsg = F),
by = c("Tickers")) %>%
left_join(.,optim_foo(Type = "erc", mu, Sigma, LB, UB, printmsg = F),by = c("Tickers")) %>%
left_join(.,optim_foo(Type = "riskeff", mu, Sigma, LB, UB, printmsg = F),by = c("Tickers"))
My_Weights## # A tibble: 70 × 5
## Tickers mv minvol erc riskeff
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 1COV GR Equity 0.0143 0.0143 0.0163 0.0143
## 2 ADS GR Equity 0.0143 0.00100 0.00912 0.0143
## 3 AFX GR Equity 0.0143 0.001 0.0118 0.0143
## 4 AIR GR Equity 0.0143 0.00100 0.00889 0.0143
## 5 ALV GR Equity 0.0143 0.001 0.00796 0.0143
## 6 AT1 GR Equity 0.0143 0.0674 0.0364 0.0143
## 7 B4B GR Equity 0.0143 0.0533 0.0309 0.0143
## 8 BAS GR Equity 0.0143 0.00100 0.00773 0.0143
## 9 BAYN GR Equity 0.0143 0.00100 0.00836 0.0143
## 10 BC8 GR Equity 0.0143 0.001 0.00781 0.0143
## # … with 60 more rows
## # ℹ Use `print(n = ...)` to see more rowsLet’s now apply the latter function in a way to make it rolling (by appending a date entry to distinguish it).
E.g.:
Calculate for every rebalance on a January and June, the optimized portfolio weights using MV, ERC, Risk-eff and MinVol.
Build a flexible look-back model, looking back by default 36 months when calculating the returns.
Replace NA’s by sampling from collective distribution.
Use a map_df call to achieve this, by specifying the selected date as an input, looking back N periods - skipping the optimization if nrow < N and then ultimately binding rows with amended dates.
library(lubridate)##
## Attaching package: 'lubridate'## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, unionEOM_datevec <- return_mat %>% select(date) %>% unique %>% mutate(YM = format(date, "%Y%B")) %>% group_by(YM) %>% filter(date == last(date)) %>% ungroup() %>% pull(date) %>% unique
Roll_optimizer <- function(return_mat, EOM_datevec, LookBackSel = 36){
return_df_used <- return_mat %>% filter(date >= EOM_datevec %m-% months(LookBackSel))
if(return_df_used %>% nrow() < LookBackSel) return(NULL) # PRO TIP - return NULL effectively skips the iteration when binding....
return_mat_Nodate <- data.matrix(return_df_used[, -1])
# Simple Sample covariance and mean for the lookback period:
Sigma <- RiskPortfolios::covEstimation(return_mat_Nodate)
Mu <- return_mat %>% summarise(across(-date, ~prod(1+.)^(1/n())-1)) %>% purrr::as_vector()
My_Weights <-
left_join(
optim_foo(Type = "mv", mu, Sigma, LB, UB, printmsg = F),
optim_foo(Type = "minvol", mu, Sigma, LB, UB, printmsg = F),
by = c("Tickers")) %>%
left_join(.,optim_foo(Type = "erc", mu, Sigma, LB, UB, printmsg = F),by = c("Tickers")) %>%
left_join(.,optim_foo(Type = "riskeff", mu, Sigma, LB, UB, printmsg = F),by = c("Tickers")) %>%
mutate(date = EOM_datevec , Look_Back_Period = LookBackSel)
}
Result <-
EOM_datevec %>% map_df(~Roll_optimizer(return_mat, EOM_datevec = ., LookBackSel = 36))
Result## # A tibble: 8,540 × 7
## Tickers mv minvol erc riskeff date Look_Back_Period
## <chr> <dbl> <dbl> <dbl> <dbl> <date> <dbl>
## 1 1COV GR Equity 0.0143 0.0143 0.0163 0.0143 2010-01-29 36
## 2 ADS GR Equity 0.0143 0.00100 0.00912 0.0143 2010-01-29 36
## 3 AFX GR Equity 0.0143 0.001 0.0118 0.0143 2010-01-29 36
## 4 AIR GR Equity 0.0143 0.00100 0.00889 0.0143 2010-01-29 36
## 5 ALV GR Equity 0.0143 0.001 0.00796 0.0143 2010-01-29 36
## 6 AT1 GR Equity 0.0143 0.0674 0.0364 0.0143 2010-01-29 36
## 7 B4B GR Equity 0.0143 0.0533 0.0309 0.0143 2010-01-29 36
## 8 BAS GR Equity 0.0143 0.00100 0.00773 0.0143 2010-01-29 36
## 9 BAYN GR Equity 0.0143 0.00100 0.00836 0.0143 2010-01-29 36
## 10 BC8 GR Equity 0.0143 0.001 0.00781 0.0143 2010-01-29 36
## # … with 8,530 more rows
## # ℹ Use `print(n = ...)` to see more rowsAnd that’s a wrap.