R/backtestSummary.R

In dppalomar/portfolioBacktest: Automated Backtesting of Portfolios over Multiple Datasets

#' @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)
}