R/model_update_rm_3roc.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Computes out-of-sample performance for the 3ROC 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 3ROC model OOS performance results, including
#' theoretical returns (r), cumulative return (c), compound annual
#' growth rate of returns (cagr), Calmar ratio (calmar),
#' Sortino ratio (sortino), maximum drawdown percent (mdd),
#' a time history of 3ROC rankings as a plot (rank_p), and
#' a list of plots (plots).
#' @seealso model_update_rso20_roc
#' @export
model_update_rm_3roc <- function(scorecard_row) {
  # Symbol <- Value <- Date <- NULL

  require(timeSeries,quietly = TRUE)

  setOrDefault <- function(p,dv) {
    rv <- ifelse(length(p),p,dv)
  }

  `%nin%` <- Negate(`%in%`)

  model <- scorecard_row$model
  study_title <- model$model
  # end of in-sample is start of out-of-sample
  enact_date <- model$backtest$stop
  # initial equity for out-of-sample
  initial_eq <- model$backtest$initeq
  # top number of funds to trade from basket
  top_n <- model$config$topn
  # transaction fee per trade
  transaction_fee <- model$backtest$transaction
  # ROC periods for the 3ROC formula
  periods <- model$config$periods
  # weights of each period in the lookback
  weights <- model$config$weights
  # weights mode monthly or daily
  weight_mode <- setOrDefault(model$config$weightmode,"monthly.average")
  # stretch
  stretch <- setOrDefault(model$config$stretch,1)
  # basket tickers
  basket <- model$config$basket

  #if ( nchar(weight_mode) < 3 )
  #  warning(paste("Missing 3ROC weight mode configuration for",study_title))

  # create an xts object of daily adjusted close prices
  basket_close_monthly <- monthly_prices(basket)
  # colnames(basket_close_monthly) <- basket  20180205 function covers this

  if ( grepl("daily",weight_mode) ) { # assumes daily average method
    prices <- NULL
    for (symbol in basket)
      prices <- cbind(prices,quantmod::Cl(get(symbol)))
    colnames(prices) <- basket
    returns <- diff(log(prices))[-1, ]
    # cumulatives <- cumprod(1+returns)
    returns.ts <- xts::as.timeSeries.xts(returns)
    # returns.ts <- returns
    colnames(returns.ts) <- colnames(returns)
    dar1 <- timeSeries::rollMean(returns.ts, k=periods[1], na.pad=TRUE, align="right")
    dar2 <- timeSeries::rollMean(returns.ts, k=periods[2], na.pad=TRUE, align="right")
    dar3 <- timeSeries::rollMean(returns.ts, k=periods[3], na.pad=TRUE, align="right")
    wdar <- dar1 * weights[1] + dar2 * weights[2] + dar3 * weights[3]
    if ( weight_mode == "daily.first") {
      # wdar <- ifelse(dar1>0, wdar, NA)
      wdar[which(dar1<0)] <- NA
    }
    if ( weight_mode == "daily.strict") {
      # wdar <- ifelse(dar1>0 & dar2>0 & dar3>0, wdar, NA)
      wdar[which(dar1<0 | dar2<0 | dar3<0)] <- NA
    }
    if ( weight_mode == "daily.filter") {
      # wdar <- ifelse(wdar<0, NA, wdar)
      wdar[which(wdar<0)] <- NA
    }

    colnames(wdar) <- paste0(colnames(returns),".Rank")
    daily.rank.1 <- scorecard:::row_rank(wdar)
    # daily.rank.1 <- na.locf(z)
    # daily.rank.1[which(is.na(daily.rank.1))] <- length(symbols)
    # daily.rank.1 <- replace(daily.rank.1,is.na(daily.rank.1),length(symbols))
    daily.rank.1 <- zoo::na.fill(daily.rank.1,fill=ncol(daily.rank.1))

    # change daily ranking to monthly, so signals do not trigger daily
    # d <- dim(daily.rank.1)
    mix <- zoo::index(basket_close_monthly)
    # z <- xts::xts(matrix(nrow=d[1],ncol=d[2]),order.by = zoo::index(daily.rank.1))
    #colnames(z) <- colnames(daily.rank.1)
    #z[mix,] <- daily.rank.1[mix,]

    #for ( i in seq_along(basket)) {
    #  x <- get(basket[i])
    #  if ( scorecard:::has_rank(x) )
    #    x <- x[,-grep("Rank",colnames(x),TRUE)]
    #  y <- daily.rank.1[,i]
    #  colnames(y) <- paste0(basket[i],".Rank")
    #  z <- zoo::na.locf(cbind(x,y))
    #  assign(basket[i],z)
    #}
    # monthly_rank <- daily.rank.1[ xts::endpoints(daily.rank.1, on="months", k=1), ]

    monthly_rank <- daily.rank.1[mix,]

  } else { # not daily

    weight_function <- switch (weight_mode,
      "monthly.average" = "weight_ave_3ROC",
      "monthly.filter" = "weight_ave_3ROC_filter",
      "monthly.strict" = "weight_ave_3ROC_strict",
      "weight_ave_3ROC" # default
    )
    wf <- match.fun(weight_function)

    # create an xts object of the symbol ranks
    # using end-of-month, not last-day-of-month time stamps
    monthly_rank <- apply_rank(x = basket_close_monthly,
                           rank_fun = wf,
                           n = periods,
                           weights = weights)
    monthly_rank <- zoo::na.fill(monthly_rank, fill = ncol(monthly_rank))

    colnames(monthly_rank) <- gsub(".Adjusted",
                               ".Rank",
                               colnames(monthly_rank))
    stopifnot(all.equal(gsub(".Adjusted",
                             "",
                             colnames(basket_close_monthly)),
                        basket))

    # bind the rank column to the appropriate symbol market data
    for (i in 1:length(basket)) {
      x <- get(basket[i])
      y <- zoo::na.locf(cbind(x, monthly_rank[, i]))
      y <- y[, ncol(y)]
      x <- cbind(x, y, join = "left")
      colnames(x)[ncol(x)] <- paste(basket[i],".Rank")
      assign(basket[i], x)
    }
  }

  # last six months ranking by component
  df <- utils::tail(monthly_rank, n = 6)
  colnames(df) <- gsub(".Rank", "", colnames(monthly_rank))
  recent_df <- df

  # last 24 months ranking plot
  monthly_rank_df <- as.data.frame(monthly_rank)
  colnames(monthly_rank_df) <- gsub(".Rank", "", colnames(monthly_rank))
  monthly_rank_df$Date <- as.Date(rownames(monthly_rank_df))
  monthly_rank_df <- utils::tail(monthly_rank_df, n = 24) # last 24 months
  dfg <- tidyr::gather(monthly_rank_df, Symbol, Value, -Date)
  monthly_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("3ROC Ranking by Fund") +
    ggplot2::ylab("3ROC 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, ]
  returns <- returns[paste0(enact_date, "::")]
  components <- returns

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

  # setup blotter account and portfolio
  verbose <- TRUE
  acct_name <- "3roc.acct"
  port_name <- "3roc.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 <- monthly_rank[paste0(enact_date, "::"), ]
  colnames(action_df) <- gsub(".Rank", "", 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]
    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)))
      }
      if ( length(psp) > 0 ) {
        ignore <- blotter::addTxn(Portfolio = port_name,
                        Symbol = ps,
                        TxnDate = rank_date,
                        TxnPrice = psp,
                        TxnQty = (-pos),
                        TxnFees = transaction_fee,
                        verbose = getOption("verbose"))
      } else {
        warning(paste("Price not found for",ps,"on",rank_date))
      }
      igore <- 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

    message(paste("equity to date ",port.eq)) # TEMP

    for (ts in top_symbols) {
      if (ts %in% previous_symbols) {
        if (getOption("verbose") )
          message(paste(rank_date, "already hold", ts))
      } else {
        message(paste("getting",ts,"for date",rank_date))
        gm <- get(ts)
        # tsp <- suppressWarnings(xts::to.monthly(gm,indexAt = "endof"))
        tsp <- gm
        #message(paste("contained gm",rank_date %in% index(gm)))
        #message(paste("contained tsp",rank_date %in% index(tsp)))
        tsp <- as.numeric(quantmod::Cl(tsp[rank_date, ]))
        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"))
        if ( getOption("verbose"))
          message("transaction added to blotter")
        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)

  p1 <-
    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_p = monthly_rank_p,
    recent_df = recent_df,
    plots = list(p1=p1)
  )

  return(scorecard_row)
}