Nothing
#' @title Summary of portfolio backtest
#'
#' @description Summarize the results from a portfolio backtest.
#'
#' @param bt Backtest results as produced by the function \code{\link{portfolioBacktest}}.
#' @param portfolio_indexes Numerical vector of portfolio indexes whose performance will be summarized,
#' e.g., \code{c(1, 2)} means to summarize the performance of the first and
#' second portfolios recorded in \code{bt}.
#' @param portfolio_names String vector of portfolio names whose performance will be summarized,
#' e.g., \code{c("EWP", "GMVP")} means to summarize the performance of portfolios
#' with names \code{"EWP"} and \code{"GMVP"} in \code{bt} (default is
#' \code{names(bt)} except the benchmark names). Only considered when
#' \code{portfolio_indexes} is not passed.
#' @param summary_fun Summary function to be employed (e.g., \code{median} or \code{mean}).
#' @param show_benchmark Logical value indicating whether to include benchmarks in the summary (default is \code{TRUE}).
#'
#' @return List with the following elements:
#' \item{\code{performance_summary}}{Performance criteria:
#' \code{"Sharpe ratio"}, \code{"max drawdown"}, \code{"annual return"}, \code{"annual volatility"},
#' \code{"Sterling ratio"}, \code{"Omega ratio"}, \code{"ROT bps"}, \code{"VaR (0.95)"}, \code{"CVaR (0.95)"}, \code{"cpu time"}, and \code{"failure rate"}.
#' Default is \code{"Sharpe ratio"}.}
#' \item{\code{error_message}}{Error messages generated by each portfolio function over each dataset.
#' Useful for debugging purposes.}
#'
#' @author Rui Zhou and Daniel P. Palomar
#'
#' @examples
#' \donttest{
#' library(portfolioBacktest)
#' data(dataset10) # load dataset
#'
#' # define your own portfolio function
#' EWP_portfolio <- function(dataset, ...) {
#' N <- ncol(dataset$adjusted)
#' return(rep(1/N, N))
#' }
#'
#' # do backtest
#' bt <- portfolioBacktest(list("EWP" = EWP_portfolio), dataset10)
#'
#' # show the summary
#' bt_sum <- backtestSummary(bt)
#' names(bt_sum)
#' bt_sum$performance_summary
#' }
#'
#' @export
backtestSummary <- function(bt, portfolio_indexes = NA, portfolio_names = NA,
summary_fun = median, show_benchmark = TRUE) {
if (anyNA(portfolio_names) && anyNA(portfolio_indexes))
portfolio_indexes <- setdiff(1:length(bt), attr(bt, 'benchmark_index'))
if (!anyNA(portfolio_indexes)) portfolio_names <- names(bt)[portfolio_indexes]
if (show_benchmark) portfolio_names <- c(portfolio_names, names(bt)[attr(bt, 'benchmark_index')])
res_table <- backtestTable(bt)
performance <- lapply(portfolio_names,
function(portfolio_name) backtestSummarySinglePortfolio(res_table, portfolio_name, summary_fun))
performance_summary <- do.call(cbind, performance)
colnames(performance_summary) <- portfolio_names
return(list("performance_summary" = performance_summary,
"error_message" = res_table$error_message))
}
#' @importFrom stats na.omit
backtestSummarySinglePortfolio <- function(res_table, portfolio_name, summary_fun) {
performance_names <- setdiff(names(res_table), c("error", "error_message")) # ignore two non-numerical metrics
performance <- rep(NA, length(performance_names))
names(performance) <- performance_names
fail_mask <- res_table$error[, portfolio_name]
failure_rate <- mean(fail_mask)
if (failure_rate < 1)
for (metric in performance_names)
performance[metric] <- summary_fun(na.omit(res_table[[metric]][!fail_mask, portfolio_name]))
# fix names if necessary (to be removed)
if (any(performance_names == "cpu_time"))
stop("Performance name cpu_time deprecated")
#performance_names[which(performance_names == "cpu_time")] <- "cpu time"
#names(performance) = performance_names
return(c(performance, "failure rate" = failure_rate))
}
#' @title Table with portfolio backtest results
#'
#' @description Create table with the results from a portfolio backtest.
#'
#' @inheritParams backtestSummary
#' @param measures String vector to select performane measures (default is all) from
#' \code{"Sharpe ratio"}, \code{"max drawdown"}, \code{"annual return"}, \code{"annual volatility"},
#' \code{"Sterling ratio"}, \code{"Omega ratio"}, \code{"ROT bps"},
#' \code{"error"}, \code{"cpu time"}, and \code{"error_message"}.
#'
#' @return List with the following elements:
#' \item{\code{<performance criterion>}}{One item per performance measures as selected by argument \code{measures}.}
#' \item{\code{error}}{Error status (\code{TRUE} or \code{FALSE}) for each portfolio over each dataset
#' (\code{TRUE} is when the portfolio function generates an error or the maximum CPU time is exceeded).}
#' \item{\code{cpu time}}{CPU usage by each portfolio function over each dataset.}
#' \item{\code{error_message}}{Error messages generated by each portfolio function over each dataset.
#' Useful for debugging purposes.}
#'
#' @author Rui Zhou and Daniel P. Palomar
#'
#' @examples
#' \donttest{
#' library(portfolioBacktest)
#' data(dataset10) # load dataset
#'
#' # define your own portfolio function
#' EWP_portfolio <- function(dataset, ...) {
#' N <- ncol(dataset$adjusted)
#' return(rep(1/N, N))
#' }
#'
#' # do backtest
#' bt <- portfolioBacktest(list("EWP" = EWP_portfolio), dataset10)
#'
#' # show the backtest results in table
#' bt_tab <- backtestTable(bt)
#' bt_tab[c("Sharpe ratio", "max drawdown")]
#' }
#'
#' @export
backtestTable <- function(bt, portfolio_indexes = NA, portfolio_names = NA,
show_benchmark = TRUE, measures = NULL) {
# check portfolio index and names
if (anyNA(portfolio_names) && anyNA(portfolio_indexes))
portfolio_indexes <- setdiff(1:length(bt), attr(bt, 'benchmark_index'))
if (!anyNA(portfolio_indexes)) portfolio_names <- names(bt)[portfolio_indexes]
if (show_benchmark) portfolio_names <- c(portfolio_names, names(bt)[attr(bt, 'benchmark_index')])
# check measures
performance_names <- names(bt[[portfolio_names[1]]][[1]]$performance)
all_measures <- c(performance_names, "error", "error_message", "cpu time")
if (is.null(measures)) measures <- all_measures
if (any(!(measures %in% all_measures))) stop("\"measures\" contains invalid element.")
# check if source_error happen
valid_mask <- sapply(bt[portfolio_names], function(x) is.null(x$source_error_message))
if (!any(valid_mask)) stop("all files fail to be sourced")
# extract results and combine into matrix
num_datasets <- length(bt[[portfolio_names[valid_mask][1]]])
num_portfolios <- length(portfolio_names)
mask_performance <- setdiff(measures, c('error', 'error_message', 'cpu time'))
container <- matrix(NA, num_datasets, num_portfolios)
colnames(container) <- portfolio_names
rownames(container) <- names(bt[[1]])
cpu_time <- error <- container
error_message <- list()
performance <- lapply(mask_performance, function(x) container)
names(performance) <- mask_performance
# fill in all results
for (i in 1:num_portfolios) {
tmp <- backtestSelector(bt = bt, portfolio_name = portfolio_names[i], measures = measures)
if (valid_mask[i])
for (metric in mask_performance)
performance[[metric]][, i] <- tmp$performance[, metric]
if ('error' %in% measures)
error[, i] <- if (valid_mask[i]) tmp$error
else TRUE
if ('cpu time' %in% measures)
if (valid_mask[i])
cpu_time[, i] <- tmp$`cpu time`
if ('error_message' %in% measures)
error_message[[portfolio_names[i]]] <- if (valid_mask[i]) tmp$error_message
else bt[[portfolio_names[i]]]$source_error_message
}
rt <- list()
if (length(mask_performance) >= 1) rt <- performance
if ('error' %in% measures) rt$error <- error
if ('cpu time' %in% measures) rt$`cpu time` <- cpu_time
if ('error_message' %in% measures) rt$error_message <- error_message
return(rt)
}
#' @title Selector of portfolio backtest results
#'
#' @description Select the results from a portfolio backtest.
#'
#' @inheritParams backtestSummary
#' @param portfolio_index Index number of a portfolio, e.g., \code{1} means to select the performance
#' of the first portfolio recorded in \code{bt}.
#' @param portfolio_name String name of a portfolio, e.g., \code{"GMVP"} means to select the performance
#' of portfolio with name \code{"GMVP"} in \code{bt}.
#' Only considered when \code{portfolio_index} is not passed.
#' @param measures String vector to select performane measures (default is all) from
#' \code{"Sharpe ratio"}, \code{"max drawdown"}, \code{"annual return"}, \code{"annual volatility"},
#' \code{"Sterling ratio"}, \code{"Omega ratio"}, and \code{"ROT bps"}.
#'
#' @return List with the following elements:
#' \item{\code{performance}}{Performance measures selected by argument \code{measures}.}
#' \item{\code{error}}{Error status (\code{TRUE} or \code{FALSE}) of portfolio over each dataset
#' (\code{TRUE} is when the portfolio function generates an error or the maximum CPU time is exceeded).}
#' \item{\code{error_message}}{Error messages generated by portfolio function over each dataset.
#' Useful for debugging purposes.}
#' \item{\code{cpu time}}{CPU usage by portfolio function over each dataset.}
#' \item{\code{portfolio}}{Portfolio weights generated by portfolio function over each dataset.}
#' \item{\code{return}}{Portfolio returns over each dataset.}
#' \item{\code{wealth}}{Portfolio wealth (aka cumulative returns or cumulative P&L) over each dataset.}
#'
#' @author Rui Zhou and Daniel P. Palomar
#'
#' @examples
#' \donttest{
#' library(portfolioBacktest)
#' data("dataset10") # load dataset
#'
#' # define your own portfolio function
#' EWP_portfolio <- function(dataset, ...) {
#' N <- ncol(dataset$adjusted)
#' return(rep(1/N, N))
#' }
#'
#' # do backtest
#' bt <- portfolioBacktest(list("EWP" = EWP_portfolio), dataset10)
#'
#' # extract your interested portfolio result
#' bt_sel <- backtestSelector(bt, portfolio_name = "EWP")
#' names(bt_sel)
#' }
#'
#' @export
#'
backtestSelector <- function(bt, portfolio_index = NULL, portfolio_name = NULL, measures = NULL) {
if (length(portfolio_name) > 1 || length(portfolio_index) > 1) stop("Only one portfolio can be selected.")
if (is.null(portfolio_name) && is.null(portfolio_index)) stop("must select a portfolio.")
if (!is.null(portfolio_index)) portfolio_name <- names(bt)[portfolio_index]
if (!is.null(bt[[portfolio_name]]$source_error_message)) return(bt[[portfolio_name]])
performance_names <- names(bt[[portfolio_name]][[1]]$performance)
measures_range <- c(performance_names, 'error', 'error_message', 'cpu time', 'return', 'w_optimized', "w_rebalanced")
if (is.null(measures)) measures <- measures_range
if (any(!(measures %in% measures_range))) stop("\"measures\" contains invalid element.")
if (length(measures) == 0) stop("\"measures\" must have length > 1.")
result <- list()
mask_performance <- setdiff(measures, c('error', 'error_message', 'cpu time', 'return', 'w_optimized', "w_rebalanced"))
if (length(mask_performance) > 0)
result$performance <- do.call(rbind, lapply(bt[[portfolio_name]], function(x) x$performance[mask_performance]))
if ('error' %in% measures)
result$error <- sapply(bt[[portfolio_name]], function(x) x$error)
if ('error_message' %in% measures)
result$error_message <- lapply(bt[[portfolio_name]], function(x) x$error_message)
if ('cpu time' %in% measures)
result$`cpu time` <- sapply(bt[[portfolio_name]], function(x) x$`cpu_time`)
if ('w_optimized' %in% measures)
result$portfolio <- lapply(bt[[portfolio_name]], function(x) x$w_optimized)
if ('w_rebalanced' %in% measures)
result$portfolio <- lapply(bt[[portfolio_name]], function(x) x$w_rebalanced)
if ('return' %in% measures) {
result$return <- lapply(bt[[portfolio_name]], function(x) x$return)
result$wealth <- lapply(bt[[portfolio_name]], function(x) x$wealth)
}
return(result)
}
# merge two backtest results together
mergeBacktests <- function(bt1, bt2) {
bt1_portfolios <- bt1[attr(bt1, "portfolio_index")]
bt2_portfolios <- bt2[attr(bt2, "portfolio_index")]
bt1_benchmarks <- bt1[attr(bt1, "benchmark_index")]
bt2_benchmarks <- bt2[attr(bt2, "benchmark_index")]
bt_portfolios <- c(bt1_portfolios, bt2_portfolios)
if (length(bt1_portfolios) > 0 && length(bt2_portfolios) > 0) # check and remove duplicated elements
bt_portfolios <- bt_portfolios[!duplicated(names(bt_portfolios)) | !duplicated(bt_portfolios)]
bt_benchmarks <- c(bt1_benchmarks, bt2_benchmarks)
if (length(bt1_benchmarks) > 0 && length(bt2_benchmarks) > 0)
bt_benchmarks <- bt_benchmarks[!duplicated(names(bt_benchmarks)) | !duplicated(bt_benchmarks)]
bt_merged <- c(bt_portfolios, bt_benchmarks)
attr(bt_merged, "portfolio_index") <- 1:length(bt_portfolios)
attr(bt_merged, "contain_benchmark") <- length(bt_benchmarks) > 0
if (length(bt_benchmarks) > 0)
attr(bt_merged, "benchmark_index") <- 1:length(bt_benchmarks) + length(bt_portfolios)
return(bt_merged)
}
selectBacktests <- function(bt, portfolio_names = names(bt)) {
bt_selected <- bt[c(portfolio_names)]
num_portfolios <- length(bt_selected)
if (attr(bt, "contain_benchmark"))
bt_selected <- c(bt_selected, bt[attr(bt, "benchmark_index")])
attr(bt_selected, "portfolio_index") <- c(1:num_portfolios)
attr(bt_selected, "contain_benchmark") <- attr(bt, "contain_benchmark")
attr(bt_selected, "benchmark_index") <- if (attr(bt, "contain_benchmark")) c(num_portfolios:(num_portfolios+length(attr(bt, "benchmark_index"))-1))
else integer(0)
return(bt_selected)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.