In greatgray/scorecard: GGCM Model Performance Scorecard

require(scales)
require(gplots)
require(magrittr)
require(ggplot2)

knitr::opts_chunk$set(echo = FALSE,
                      warning = FALSE,
                      message = FALSE)

## Set options
options(scipen = 999, # prevent scientific notation on large numbers
        stringsAsFactors = F) # prevent R from turning everything to factors

## read parameters
scorecard_dir <- params$scorecard_dir
scorecard_ws <- params$scorecard_ws

# find the workspace to use
# the workspace should have been written by scorecard_update
if ( stringr::str_length(scorecard_ws) > 0) {
  message("Using argument-specified workspace")
} else {
  message("Using latest scorecard workspace")
  # workspace not overridden in environment, so find in directory
  # find the scorecard workspace directory and load files
  if (is.na(scorecard_dir) || stringr::str_length(scorecard_dir) < 1) {
    stop("Scorecard output directory missing: use scorecard_dir")
  }

  # identify all workspaces in the directory, choose latest one by name
  scorecard_wss <- dir(scorecard_dir,
                       pattern = "scorecard_workspace",
                       full.names = TRUE)
  scorecard_wss <- base::sort(scorecard_wss,
                              decreasing = TRUE)
  scorecard_ws <- scorecard_wss[1]
}

# read the workspace and recover variable values
message(paste("Using workspace", scorecard_ws))

# check that workspace file can be read
if ( as.numeric(file.access(scorecard_ws, mode = 4)) < 0 ) {
  stop(paste("Cannot read workspace file:", scorecard_ws))
}

workspace <- new.env()
load(scorecard_ws, envir = workspace)
scorecard_table <- get("scorecard_table", envir = workspace) # a list

candidate_list <- list()
for ( i in 1:length(scorecard_table) ) {
  x <- scorecard_table[[i]]
  if ( x$status == 'candidate' )
    candidate_list <<- append(candidate_list, list(x))
}

Introduction

The following models are candidates and represent specific model configurations under consideration for investment. They compete with the activated models for a position in the portfolio. Candidate model performance measures are based on out-of-sample simulation of the model using actual price histories.

for ( n in 1:length(candidate_list)) {
  row <- candidate_list[[n]]
  cat("# Model", ' ', row$id, '\n' )
  cat('\n')
  cat("* Partner: ", row$partner, '\n' )
  cat("* Live date: ", row$live, '\n' )
  cat('\n')  

  cat("## Configuration",'\n')
  cat("* Version: ", row$model$version, '\n' )
  cat("* Basket: ", row$model$config$basket, '\n')
  if ( row$model$model == "RSO" ) {
    rmc <- row$model$config
    cat("* Smoothing: ", rmc$smoothing[1], " fast, ", rmc$smoothing[2], "slow", '\n')
    cat("* Rebalance: ", rmc$rebalance, '\n')
    cat("* Trailing stop: ", percent(rmc$trailstop), '\n')
    cat("* Top N: ", rmc$topn, '\n')
  }
  if ( row$model$model == "3ROC" ) {
    rmc <- row$model$config
    cat("* Periods: ", rmc$periods, '\n')
    cat("* Weghts: ", rmc$weights, '\n')
    cat("* Rebalance: ", rmc$rebalance, '\n')
    cat("* Trailing stop: ", percent(rmc$trailstop), '\n')
    cat("* Top N: ", rmc$topn, '\n')
  }

  cat("\n")
  cat("## Performance Summary",'\n')
  rmb <- row$model$backtest
  cat("* Period: ", rmb$start, " to ", rmb$stop, "\n")
  cat("* Initial equity: ", dollar(rmb$initeq), "\n" )
  cat("* Transaction fee: ", dollar(rmb$transaction), "\n" )
  cat("* Benchmark: ", rmb$benchmark, "\n")
  cat("\n")

  cat("Mode | CAGR | MDD | Sortino | Calmar","\n")
  cat("-----|------|-----|---------|-------","\n")

  cat("Expected","|")
  cat(paste0(rmb$cagr,"%"), "|")
  cat(paste0(rmb$mdd,"%"), "|")
  cat(rmb$sortino, "|")
  cat(rmb$calmar, "\n")

  #rba <- row$actual
  #cat("Actual", "|")
  #cat(sprintf("%.1f%%", rba$cagr), "|")
  #cat(sprintf("%.1f%%", rba$mdd), "|")
  #cat(sprintf("%.1f", rba$sortino), "|")
  #cat(sprintf("%.1f", rba$calmar), "\n")

  rbo <- row$oos
  cat("Out-of-Sample", "|")
  cat(sprintf("%.1f%%", rbo$cagr), "|")
  cat(sprintf("%.1f%%", rbo$mdd), "|")
  cat(sprintf("%.1f", rbo$sortino), "|")
  cat(sprintf("%.1f", rbo$calmar), "\n")

  rbh <- row$buyhold
  cat("Buy-Hold", "|")
  cat(sprintf("%.1f%%",rbh$cagr), "|")
  cat(sprintf("%.1f%%", rbh$mdd), "|")
  cat(sprintf("%.1f", rbh$sortino), "|")
  cat(sprintf("%.1f", rbh$calmar), "\n")

  cat("Benchmark", "|")
  cat(sprintf("%.1f%%", row$benchmark.cagr), "|")
  cat(sprintf("%.1f%%", row$benchmark.mdd), "|")
  cat(sprintf("%.1f", row$benchmark.sortino), "|")
  cat(sprintf("%.1f", row$benchmark.calmar), "\n")

  cat("\n")
  cat("## Out of Sample Performance","\n")
  cat("\n")
  rbo <- row$oos

  p <- scorecard:::gg_charts_summary_2(rbo$r)
  p <- p + ggtitle("Theoretical Returns and Drawdown")
  plot(p)
  cat("\n","\n")

  cat("## Component Contribution","\n")
  cat("\n")

  p <- scorecard:::gg_charts_summary_2(rbo$component_returns)
  p <- p + ggtitle("Component Returns and Drawdown")
  plot(p)
  cat("\n","\n")
  if ( row$model$model == "RSO" ) {
    plot(rbo$plots$p1)
    cat("\n","\n")
    plot(rbo$plots$p2)
    cat("\n","\n")
    plot(rbo$plots$p3)
    cat("\n","\n")
    plot(rbo$plots$p4)
    cat("\n","\n")
    plot(rbo$plots$p5)
    cat("\n","\n")
  } 
  if ( row$model$model == "3ROC") {
    plot(rbo$plots$p1)
    cat("\n","\n")
  }

  cat("## Recent Signals", "\n")
  textplot(rbo$recent_df,
           cmar=1,
           halign="center")
           # cex=0.9)
  cat("\n","\n")

  cat("## Rank History","\n")
  plot(rbo$rank_p)
  cat("\n","\n")

}