R/model_update_rso20_roc.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Computes out-of-sample performance for the RSO models.
#' Run and report update for fixed model configuration.
#' Uses model configuration passed in by way of scorecard
#' row attributes.
#' @param scorecard_row a row of the scorecard definition
#' identifying the model configuration and other attributes
#' @return the same scorecard row object, but with a new list
#' element \code{oos} appended.  The \code{oos} element
#' contains a list of RSO model OOS performance results, including
#' theoretical returns (r), cumulative return (c),
#' model basket component returns (component_returns),
#' compound annual growth rate of returns (cagr), Calmar ratio (calmar),
#' Sortino ratio (sortino), maximum drawdown percent (mdd),
#' a time history of RSO rankings (rank) and their plot
#' (rank_p), and a list of plots (plots) containing
#' five plots related to RSO calculations (p1, p2, p3, p4 and p5).
#' @seealso model_update_rso20_roc
#' @note Does not yet do rebalancing.
#' @note Does not yet do trailing stops.
#' @export
model_update_rso20_roc <- function(scorecard_row) {

  # Symbol <- Value <- Date <- NULL
  `%nin%` <- Negate(`%in%`)

  model <- scorecard_row$model
  study_title <- model$model
  enact_date <- model$backtest$stop # end of in-sample is start of out-of-sample
  stop_date <- Sys.Date() # out-of-sample stop is today
  initial_eq <- model$backtest$initeq
  top_n <- model$config$topn
  transaction_fee <- model$backtest$transaction
  basket <- model$config$basket
  alpha_fast <- model$config$smoothing[1]
  alpha_slow <- model$config$smoothing[2]
  # TODO trail.stop.percent <- model$config$trailstop
  # TODO rebalance.freq <- model$config$rebalance
  benchmarks <- c("SPY")

  # trim basket to enact date
  for (ticker in c(basket, benchmarks) ) {
    dx <- get(ticker, envir = .GlobalEnv)
    dx <- dx[paste0(enact_date, "::", stop_date), ]
    assign(ticker, dx, envir = .GlobalEnv)
  }

  # create an xts object of daily adjusted close prices
  basket_close_monthly <- scorecard:::monthly_prices(basket)
  benchmarks_close_monthly <- scorecard:::monthly_prices(benchmarks)
  colnames(basket_close_monthly) <- basket
  colnames(benchmarks_close_monthly) <- benchmarks

  basket_ratio <- do.call(merge,
                          lapply(basket, function(s)
                            basket_close_monthly[, s] /
                              benchmarks_close_monthly[, 1]))

  basket_relative_strength <- do.call(merge,
                                      lapply(basket, function(s)
                                        basket_ratio[, s] /
                                          as.numeric(basket_ratio[1, s])))

  basket_relative_strength <- na.locf(basket_relative_strength)

  basket_slow <- do.call(merge,
                         lapply(basket, function(s)
                           TTR::EMA(basket_relative_strength[, s],
                                    n = 2,
                                    ratio = alpha_slow)))
  basket_fast <- do.call(merge,
                         lapply(basket, function(s)
                           TTR::EMA(basket_relative_strength[, s],
                                    n = 2,
                                    ratio = alpha_fast)))
  basket_slow[1, ] <- 1
  basket_fast[1, ] <- 1
  colnames(basket_slow) <- paste(basket, "Slow", sep = ".")
  colnames(basket_fast) <- paste(basket, "Fast", sep = ".")
  basket_oscillator <- 100 * (basket_fast / basket_slow - 1)
  colnames(basket_oscillator) <- paste(basket, "RSO", sep = ".")

  # basket_rank <- ifelse(basket_oscillator > 0, basket_oscillator, NA)
  basket_rank <- replace(basket_oscillator,basket_oscillator <= 0, NA)
  basket_rank <- zoo::na.fill(scorecard:::row_rank(basket_rank), length(basket))
  colnames(basket_rank) <- gsub(".RSO", "", colnames(basket_rank))

  # last six months ranking by component
  df <- utils::tail(basket_rank, n = 6)
  recent_df <- df

  # last 24 months ranking plot
  basket_rank_df <- as.data.frame(basket_rank)
  basket_rank_df$Date <- as.Date(rownames(basket_rank_df))
  basket_rank_df <- utils::tail(basket_rank_df, n = 24) # last 24 months
  dfg <- tidyr::gather(basket_rank_df,
                       Symbol,
                       Value,
                       # 1:(ncol(df) - 1))
                       -Date)
  basket_rank_p <-
    ggplot2::ggplot(dfg, ggplot2::aes(x = Date, y = Value)) +
    ggplot2::facet_grid(Symbol~.) +
    ggplot2::geom_step(color = "blue") +
    ggplot2::scale_y_reverse(breaks = c(1, 3, 5, 7, 9),
                             labels = c("1", "3", "5", "7", "9")) +
    ggplot2::ggtitle("RSO Ranking by Fund") +
    ggplot2::ylab("RSO Value (1 is Highest)") +
    ggplot2::xlab(NULL) +
    ggplot2::geom_hline(yintercept = top_n,
                        linetype = "dashed",
                        color = "darkgreen")

  # returns and performance starting enact date
  prices <- NULL
  for (symbol in basket)
    prices <- cbind(prices, quantmod::Cl(get(symbol)))
  colnames(prices) <- basket
  returns <- diff(log(prices))[-1, ]
  components <- returns[paste0(enact_date, "::"), ]

  # bind the columns to the appropriate symbol market data
  yr <- ceiling(max(abs(basket_relative_strength)))
  df <- data.frame(zoo::coredata(basket_relative_strength),
                   Date = zoo::index(basket_relative_strength))
  dfg <- tidyr::gather(df, Symbol, Value, 1:(ncol(df) - 1))

  # RS in separate panels
  p1 <- ggplot2::ggplot(dfg, ggplot2::aes(x = Date, y = Value)) +
    ggplot2::facet_grid(Symbol~.,
                        scales = "free_y") +
    ggplot2::geom_line() +
    ggplot2::ggtitle(paste("Relative Strength",
                           "Market",
                           benchmarks[1],
                           sep = " - ")) +
    ggplot2::xlab(NULL) +
    ggplot2::ylab("Relative Strength") +
    ggplot2::geom_hline(yintercept = 1,
                        linetype = "dashed",
                        color = "darkgreen")

  # RS overlaid
  p2 <- ggplot2::ggplot(dfg,
                        ggplot2::aes(x = Date,
                                     y = Value,
                                     color = Symbol)) +
    ggplot2::geom_line() +
    ggplot2::ggtitle(paste("Relative Strength",
                           "Market",
                           benchmarks[1],
                           sep = " - ")) +
    ggplot2::xlab(NULL) +
    ggplot2::ylab("Relative Strength") +
    ggplot2::geom_hline(yintercept = 1,
                        linetype = "dashed",
                        color = "darkgreen")
  p2 <- directlabels::direct.label(p2)

  # RSO
  colnames(basket_oscillator) <- gsub(".RSO",
                                      "",
                                      colnames(basket_oscillator))

  yr <- ceiling(max(abs(basket_oscillator)))
  df <- data.frame(zoo::coredata(basket_oscillator),
                   Date = zoo::index(basket_oscillator))
  dfg <- tidyr::gather(df, Symbol, Value, 1:(ncol(df) - 1))

  # RSO in separate panels
  p3 <- ggplot2::ggplot(dfg,
                        ggplot2::aes(x = Date,
                                     y = Value)) +
    ggplot2::facet_grid(Symbol~., scales = "free_y") +
    ggplot2::geom_line() +
    ggplot2::ggtitle(paste("Relative Strength Oscillator",
                           "Market",
                           benchmarks[1],
                           sep = " - ")) +
    ggplot2::xlab(NULL) +
    ggplot2::ylab("Relative Strength Oscillator") +
    ggplot2::geom_hline(yintercept = 0,
                        linetype = "dashed",
                        color = "darkgreen")

  # RSO overlaid
  p4 <- ggplot2::ggplot(dfg,
                        ggplot2::aes(x = Date,
                                     y = Value,
                                     color = Symbol)) +
    ggplot2::geom_line() +
    ggplot2::ggtitle(paste("Relative Strength Oscillator",
                           "Market",
                           benchmarks[1],
                           sep = " - ")) +
    ggplot2::xlab(NULL) +
    ggplot2::ylab("Relative Strength Oscillator") +
    ggplot2::geom_hline(yintercept = 0,
                        linetype = "dashed",
                        color = "darkgreen")

  p4 <- directlabels::direct.label(p4)


  # recreate transactions
  # clear the blotter account and portfolios
  scorecard:::reset_quantstrat()

  # setup blotter account and portfolio
  acct_name <- "rso.acct"
  port_name <- "rso.port"
  acct_date <- as.Date(enact_date) - 1
  ignore <- blotter::initPortf(name = port_name,
                     basket,
                     initDate = acct_date,
                     currency = "USD")
  ignore <- blotter::initAcct(name = acct_name,
                    portfolios = c(port_name),
                    initDate = acct_date,
                    initEq = initial_eq)

  # setup blotter instruments
  for (mt in basket) {
    ignore <- FinancialInstrument::stock(mt,
                               currency = "USD",
                               multiplier = 1)
  }

  action.df <- basket_rank[paste0(enact_date, "::"), ]
  colnames(action.df) <- gsub(".RSO", "", colnames(action.df))
  previous.symbols <- c()

  for (i in 1:nrow(action.df)) {
    ignore <- blotter::updatePortf(port_name)
    ignore <- blotter::updateAcct(acct_name)
    ignore <- blotter::updateEndEq(acct_name)

    ranks.df <- action.df[i]
    if ( any(which(ranks.df <= top_n))) {
      top.df <- ranks.df[, which(ranks.df <= top_n)]

      rank.date <- as.Date(zoo::index(ranks.df))
      top.symbols <- colnames(top.df)

      # sell old positions
      for (ps in previous.symbols[which(previous.symbols %nin% top.symbols)]) {
        psp <- suppressWarnings(xts::to.monthly(get(ps), indexAt = "endof"))
        psp <- as.numeric(quantmod::Cl(psp[rank.date, ]))
        pos <- as.numeric(blotter::getPos(Portfolio = port_name,
                                          Symbol = ps,
                                          Date = rank.date,
                                          Columns = "Pos.Qty",
                                          n = 1))

        if ( getOption("verbose") ) {
        message(paste(rank.date,
                      "sell position",
                      ps,
                      pos,
                      "shares",
                      "at",
                      scales::dollar(psp)))
        }

        blotter::addTxn(Portfolio = port_name,
                        Symbol = ps,
                        TxnDate = rank.date,
                        TxnPrice = psp,
                        TxnQty = (-pos),
                        TxnFees = transaction_fee,
                        verbose = getOption("verbose"))
        ignore <- blotter::updatePortf(port_name)
        ignore <- blotter::updateAcct(acct_name)
        ignore <- blotter::updateEndEq(acct_name)
      }

      # portfolio equity to date
      port.eq <- blotter::getEndEq(acct_name,
                                   as.character(rank.date)) +
        initial_eq

      for (ts in top.symbols) {
        if (ts %in% previous.symbols) {
          if ( getOption("verbose") ) {
            message(paste(rank.date, "already hold", ts))
          }
        } else {
          tsp <- suppressWarnings(xts::to.monthly(get(ts), indexAt = "endof"))
          tsp <- as.numeric(quantmod::Cl(tsp[rank.date, ])) # price
          tsi <- port.eq / top_n # investment
          tss <- round(tsi / tsp, 0) # shares

          if ( getOption("verbose") ) {
            message(paste(rank.date,
                        "buy position",
                        ts,
                        tss,
                        "shares",
                        "at",
                        scales::dollar(tsp)))
          }

          ignore <- blotter::addTxn(Portfolio = port_name,
                          Symbol = ts,
                          TxnDate = rank.date,
                          TxnPrice = tsp,
                          TxnQty = tss,
                          TxnFees = transaction_fee,
                          verbose = getOption("verbose"))
          ignore <- blotter::updatePortf(port_name)
          ignore <- blotter::updateAcct(acct_name)
          ignore <- blotter::updateEndEq(acct_name)
        }
      }
      previous.symbols <- top.symbols
    }
  }

  # mark the book and get final equity
  ignore <- blotter::updatePortf(port_name)
  ignore <- blotter::updateAcct(acct_name)
  ignore <- blotter::updateEndEq(acct_name)

  pr <- blotter::PortfReturns(acct_name)
  colnames(pr) <- gsub(".DailyEndEq", "", colnames(pr))
  pr <- pr[paste0(enact_date, "::"), ]
  pr$Theoretical <- rowSums(pr)
  pc <- cumprod( 1 + pr)

  p5 <-
    scorecard:::gg_charts_summary_2(pr$Theoretical,
                        ptitle = paste(study_title, "(Theoretical)"),
                        drawdown_minima = "gray")

  annual_percent <-
    as.numeric(PerformanceAnalytics::Return.annualized(pr$Theoretical)) * 100
  calmar_ratio <-
    as.numeric(PerformanceAnalytics::CalmarRatio(pr$Theoretical))
  sortino_ratio <-
    as.numeric(PerformanceAnalytics::SortinoRatio(pr$Theoretical,
                                                  MAR = 0))
  max_drawdown_percent <-
    PerformanceAnalytics::maxDrawdown(pr$Theoretical) * 100


  scorecard_row$oos <- list(
    r = pr$Theoretical,
    c = pc,
    component_returns = components,
    cagr = annual_percent,
    calmar = calmar_ratio,
    sortino = sortino_ratio,
    mdd = max_drawdown_percent,
    rank = basket_rank,
    rank_p = basket_rank_p,
    recent_df = recent_df,
    plots = list(p1=p1, p2=p2, p3=p3, p4=p4, p5=p5)
  )

  return(scorecard_row)
}