R/calcGapStrategy.R

In tmk-c/myrlib: My R library for daily work

#' Calculate "Open Gap Strategy" performance
#'
#' @param params Strategy parameters.
#' @param data Sliced data by getSlicedData function.
#' @param output output type (Valid options = full, simple and trans).
#'
#' @importFrom magrittr %>%
#'
#' @return Strategy result by output type.
#' @export
calcGapStrategy <- function(params, data, output = "full") {

  # Functions ------------------------------------------------------------------
  selectNSignals <- function(zscores, signal, params) {

    # Zscore that generage "singal buy"
    zscores_sig <- zscores * signal

    # NA/Zero => Long:Inf, Short:-Inf to sort
    if (params$side == "Long") {
      zscores_sig[is.na(zscores_sig)] <- Inf
      zscores_sig[zscores_sig == 0] <- Inf # Zero produced by zscore * FALSE
    } else {
      zscores_sig[is.na(zscores_sig)] <- -Inf
      zscores_sig[zscores_sig == 0] <- -Inf
    }

    # Extract worst/best nth RoC value
    nth_val <- apply(zscores_sig, 1, function(x) {
      if (params$side == "Long") {
        sort(x) %>% .[params$num_trades + 1]
      } else {
        sort(x, decreasing = TRUE) %>% .[params$num_trades + 1]
      }
    })

    # Build matrix of nth value
    nrow    <- length(nth_val)
    ncol    <- ncol(zscores_sig)
    nth_mat <- matrix(rep(nth_val, ncol), ncol = ncol, nrow = nrow)

    # Generate signal if RoC is lower than nth value
    if (params$side == "Long") {
      signal_n <- (zscores_sig < nth_mat)
    } else {
      signal_n <- (zscores_sig > nth_mat)
    }

    return(signal_n)
  }

  createGapStrategyTrans <- function(data, signal, sma, sd, ato, ogc, zscores,
                                    params, debug = TRUE) {
    # Functions
    getDateAndSymbol <- function(idx, signal) {

      # Calc column and row indexes
      col <- floor(idx / nrow(signal))
      row <- idx - col * nrow(signal)

      # in case row is the last row of the signal data
      if (row == 0) {
        col <- col - 1
        row <- nrow(signal)
      }

      # Subset date and symbol from signal xts
      date   <- signal[row, col + 1] %>% zoo::index()
      date   <- as.Date(strftime(date, "%Y-%m-%d"))
      symbol <- signal[row, col + 1] %>% colnames()
      result <- data.table::data.table(date = date, symbol = symbol)
      return(result)
    }

    # Create transaction from signals
    index <- which(signal)
    trans <- do.call("rbind", lapply(index, getDateAndSymbol, signal))

    # Build columns
    if (debug) {
      trans[, sma    := sma %>% as.vector %>% .[index]]
      trans[, sd     := sd %>% as.vector %>% .[index]]
      trans[, ato    := ato %>% as.vector %>% .[index]]
      trans[, ogc    := ogc %>% as.vector %>% .[index]]
      trans[, zscore := zscores %>% as.vector %>% .[index]]
    }

    trans[, open  := data$open %>% as.vector %>% .[index]]
    trans[, high  := data$high %>% as.vector %>% .[index]]
    trans[, low   := data$low %>% as.vector %>% .[index]]
    trans[, close := data$close %>% as.vector %>% .[index]]

    # Trades -------------------------------------------------------------------
    p <- params

    # Entry
    if (p$side == "Long") {
      trans[, entry:= round(open + (open * p$slippage), digits = 2)]
    } else {
      trans[, entry:= round(open - (open * p$slippage), digits = 2)]
    }

    # Stop
    if (p$side == "Long") {
      trans[, stop:= round(entry - (entry * sd * p$stop_thres), digit = 2)]
    } else {
      trans[, stop:= round(entry + (entry * sd * p$stop_thres), digit = 2)]
    }

    # Exit
    if (p$side == "Long") {
      trans[, exit:= ifelse(low <= stop,
                      round(stop - (stop * p$slippage), digits = 2),
                      round(close - (close * p$slippage), digits = 2))]
    } else {
      trans[, exit:= ifelse(high >= stop,
                      round(stop + (stop * p$slippage), digits = 2),
                      round(close + (close * p$slippage), digits = 2))]
    }

    trans[, qty        := floor(p$lot / entry)]
    trans[, comm_entry := calcIBCommission(qty, entry)]
    trans[, comm_exit  := calcIBCommission(qty, exit)]
    trans[, cost       := entry * qty + abs(comm_entry) + abs(comm_exit)]

    # PnL
    if (p$side == "Long") {
      trans[, pnl:= (exit * qty) - (entry * qty) + comm_entry + comm_exit]
    } else {
      trans[, pnl:= (entry * qty) - (exit * qty) + comm_entry + comm_exit]
    }

    # Sort
    trans <- trans[order(date, zscore)]
    return(trans)
  }

  # Check inputs (params and data)----------------------------------------------

  # Params inputs
  if (is.null(params$range)) {
    stop("Params must at least have range.")
  }
  if (is.null(params$side)) {
    stop("Params must at least have side.")
  }

  # Data inputs
  columns <- c("open", "high", "low", "close", "adj.open", "roc.pc2to",
               "sd", "avg.tover")

  if (params$sma_len != 0) columns <- c(columns, "sma")
  if (params$ogc_len != 0) columns <- c(columns, "open.gap.coef")

  if (length(setdiff(columns, names(data))) != 0) {
    stop("Data columns is mismatch to test GapStrategy.")
  }

  # Set default params ---------------------------------------------------------

  # Data params
  p <- params
  if (is.null(p$sma_len)) p$sma_len <- 0
  if (is.null(p$sd_len))  p$sd_len  <- 50
  if (is.null(p$ato_len)) p$ato_len <- 200
  if (is.null(p$ogc_len)) p$ogc_len <- 0

  # Strat params
  if (is.null(p$sd_thres))    p$sd_thres    <- 0.01
  if (is.null(p$ato_l_thres)) p$ato_l_thres <- 10000000
  if (is.null(p$ato_h_thres)) p$ato_h_thres <- Inf
  if (is.null(p$ogc_thres))   p$ogc_thres   <- 0
  if (is.null(p$stop_thres))  p$stop_thres  <- 0.3
  if (is.null(p$min_thres))   p$min_thres   <- 10
  if (is.null(p$slippage))    p$slippage    <- 0.001
  if (is.null(p$num_trades))  p$num_trades  <- 10
  if (is.null(p$lot))         p$lot         <- 10000

  # Subset data ----------------------------------------------------------------

  # SMA
  if (p$sma_len == 0) {
    if (p$side == "Long") {
      sma <- -Inf
    } else {
      sma <- Inf
    }
  } else {
    sma <- data$sma[[as.character(p$sma.len)]] %>% xts::lag.xts()
  }

  # SD
  sd <- data$sd[[as.character(p$sd_len)]] %>% xts::lag.xts()
  # 0 must be converted to NA to avoid dividing by zero in zscore calc
  sd[sd == 0] <- NA

  # Turnover
  ato <- data$avg.tover[[as.character(p$ato_len)]] %>% xts::lag.xts()

  # Open Gap Coeficient
  if (p$ogc_len == 0) {
    ogc <- -Inf
  } else {
    ogc <- data$open.gap.coef[[as.character(p$ogc_len)]] %>% xts::lag.xts()
  }

  # Generate signals -----------------------------------------------------------

  # Filters
  if (p$side == "Long") {
    filter_sma <- data$open >= sma
  } else {
    filter_sma <- data$open <= sma
  }

  filter_sd  <- (sd >= p$sd_thres)
  filter_ato <- (p$ato_l_thres <= ato) & (ato <= p$ato_h_thres)
  filter_ogc <- (ogc <= p$ogc_thres)
  filter_min <- (p$min_thres <= data$open & data$open < p$lot)

  # Zscore
  roc <- data$roc.pc2to
  # RoC = Inf or -Inf must be converted to NA to avoid infinite zscore
  roc[is.infinite(roc)] <- NA
  zscores <- (roc / sd)

  signal   <- (filter_sma & filter_sd & filter_ato & filter_ogc & filter_min)
  signal_n <- selectNSignals(zscores, signal, p)

  trans <- createGapStrategyTrans(data, signal_n, sma, sd, ato, ogc, zscores,
                                     p, TRUE)

  equity_curve <- calcEquityCurveFromTrans(trans, base_xts = data$adj.open)

  perf <- calcPerformance(equity_curve)

  # Arrange results ------------------------------------------------------------

  # "simple" for parallel parameter sweep
  if (output == "simple") {
    result <- cbind(p, perf)

  # "trans" for WFA to combine transactions
  } else if (output == "trans") {
    result <- trans

  } else if (output == "full") {
    plot <- buildEquityCurvePlot(equity_curve, perf)

    result <- list(
      simple       = cbind(p, perf),
      signal       = signal_n,
      trans        = trans,
      equity_curve = equity_curve,
      perf         = perf,
      plot         = plot
    )
  }

  return(result)
}