R/resolveStopLoss.R

In rengelke/quantTraiding_trato: Trading Strategies Development Tool Kit

#' Function to Calculate Stop Losses and Weights
#'
#' @param data xts object with open, high, low, close market data
#' @param data_buy xts object with open, high, low, close market data,
#' trading strategy condition data and buys signals
#' @param strategy strategy object
#' @param ... not in use
#' @return xts object with open, high, low, close market data including trading
#' strategy condition and buying information
#' @import xts
#' @import quantmod
#' @examples resolveStopLoss(data, data_cond, strategy)
#'
resolveStopLoss <- function (data, data_buy, strategy, ...) {

  data_tmp <- data_buy
  stop_loss <- strategy$stop_loss[[1]]

  #looping through the buy signal dates to estimate stop loss exits
  buy_index <- as.Date(as.POSIXct(
    index(data_tmp$buy_signal[data_tmp$buy_signal != 0]))
  )
  weights_list <- list()
  sell_signal_list<-list()

  n=1
  while (n < length(buy_index)) {

    date1 <- paste0(buy_index[n], "::")      #day of buying and all following
    nxt <- as.Date(ifelse(n == length(buy_index), tail(buy_index(data_tmp), 1), buy_index[n+1])) #start of next period
    period1 <- paste(buy_index[n], nxt, sep = "::")  #period between two buys


    # limit stop loss ---------------------------------------------------------
    if (!is.null(stop_loss$stop_limit$type)) {
      if (stop_loss$stop_limit$type == "percent") {
        #running close price / buying price
        perc_change_limit <- merge.xts( (Cl(data_tmp)[date1] / as.numeric(data_tmp$buy_price[date1][1]) - 1) )
        #first time limit stop was triggered
        limit_stop <- head(perc_change_limit[perc_change_limit <= (-1)*stop_loss$stop_limit$level], 1)
        # #percent below fixed limit stop on day the limit stop was triggered
        # limit_stop_diff <- limit_stop - (-1)*stop_loss$stop_limit$level
        #exact price at which trail stop was triggered
        #case when not triggered
        if (length(limit_stop) == 0) { #close price of last day
          limit_stop_price <- tail(Cl(data), 1)
        } else {  #when triggered sell price is next open price
          limit_stop_price <- Op(data[paste0(index(limit_stop), "::")][2, ])
        }
      }
    } else {
      limit_stop_price <- tail(Cl(data), 1)
    }


    # trailing stop loss ------------------------------------------------------
    if (!is.null(stop_loss$stop_trailing$type)) {
      if (stop_loss$stop_trailing$type == "percent") {
        #current daily low price / trailing max price
        perc_change_trail <- merge.xts( Lo(data_tmp)[date1] / cummax(Hi(data_tmp)[date1]) - 1 )
        #first time trailing stop was triggered
        trail_stop <- head(perc_change_trail[perc_change_trail <= (-1)*stop_loss$stop_trailing$level], 1)
        #percent below fixed trailing stop on day the trailing stop was triggered
        trail_stop_diff <- trail_stop - (-1)*stop_loss$stop_trailing$level
        #exact price at which trail stop was triggered
        #>>currently not relevant since only weights are used and buy on next open
        #case when not triggered
        if (length(trail_stop) == 0) {
          trail_stop_price <- tail(Cl(data),1)
        } else {  #when triggered
          #case when Lo=Open then this is sell price
          if (Lo(data)[index(trail_stop)] >= Op(data)[index(trail_stop)]) {
            trail_stop_price <- Op(data)[index(trail_stop)]
          } else {  #otherwise crossing of stop limit during the day
            trail_stop_price <- Lo(data_tmp)[index(trail_stop)] - Lo(data_tmp)[index(trail_stop)]*trail_stop_diff
          }
        }
      }
    } else {
      trail_stop_price <- tail(Cl(data), 1)
    }


    # support stop loss -------------------------------------------------------
    if (!is.null(stop_loss$stop_support$type)) {
      if (stop_loss$stop_support$type == "support") {
        #find valleys
        #thresh estimated based on length(support_level) which should be around 150
        #as manually counted valleys in msci world from 2006-2018
        support_level <- Lo(data)[quantmod::findValleys(Lo(data), thresh=stop_loss$stop_support$thresh)-1, ]*0.97
        colnames(support_level) <- "support_level"
        #start from previous support or at -5% buying price
        #find previous support level
        if (all(index(support_level)>as.Date(date1))) {  #case when no previous support level
          date_n <- 1
        } else {  #otherwise determine last support before buying day
          date_n <- index(support_level)-as.Date(date1) #highest negative number is position
          date_n <- Position(function(x) x < 0, date_n, right = TRUE)
        }
        support_level <- support_level[paste0(index(support_level[date_n]), "::")]
        support_level <- TTR::runMax(support_level, n=1, cumulative = TRUE)
        data_sup <- merge.xts(OHLC(data), support_level)[date1]
        data_sup$support_level[1] <- Lo(data_sup)[1]*0.95
        data_sup$support_level2 <- na.locf(data_sup$support_level, na.rm = TRUE)
        data_sup$support_level2 <- na.locf(data_sup$support_level2, fromLast = TRUE)
        perc_change_support <- merge.xts( (Cl(data_sup)[date1] / data_sup$support_level2[date1]) - 1)
        #
        # merge.xts(Lo(data), data_sup$support_level2, join = "left") %>% na.locf() %>%
        #   chart_Series(.)
        #
        #first time limit stop was triggered
        support_stop <- head(perc_change_support[perc_change_support <= 0], 1)
        #case when not triggered
        if (length(support_stop) == 0) {
          support_stop_price <- tail(Cl(data), 1)
        } else {  #when triggered then next day open price
            support_stop_price <- Op(data[paste0(index(support_stop), "::")][2, ])
        }
      }
    } else {
      support_stop_price <- tail(Cl(data), 1)
    }


    # time limit stop loss ----------------------------------------------------
    if (!is.null(stop_loss$stop_time)) {
      #perc_change_time <- merge.xts( (Lo(data_tmp)[date1] / as.numeric(data_tmp$buy_spread[date1][1]) - 1) )
      #perc_change_time <- perc_change_time[1:stop_loss$stop_time, ]
      #time stop is closing price on last day of time stop
      time_stop <- tail(Cl(data)[paste0(date1, as.Date(date1)+stop_loss$stop_time)], 1)
      if (length(time_stop_price) == 0) {
        time_stop_price <- tail(Cl(data), 1)
        } else {
          time_stop_price <- Op(data[paste0(index(time_stop), "::")][2, ])
        }
    } else {
      time_stop_price <- tail(Cl(data), 1)
    }


    # indicator stop loss -----------------------------------------------------
    ###this is still in dev : use resolveCondition function
    if (!is.null(stop_loss$stop_indicator)) {

      data_correct <- convertOHLC(data, stop_loss$stop_indicator$indicator)

      change_indicator <- do.call(stop_loss$stop_indicator$indicator,
                                  c(list(data_correct), stop_loss$stop_indicator$arguments))
      change_indicator <- change_indicator[date1]
      #first time indicator stop was triggered
      indicator_stop <- head(change_indicator[change_indicator <= stop_loss$stop_indicator$on], 1)
      #sell price is Cl price indicator stop was triggered
      indicator_stop_price <- Cl(data)[index(indicator_stop)]
      if (length(indicator_stop_price) == 0) { indicator_stop_price <- tail(Cl(data_tmp),1) }

    } else {
      indicator_stop_price <- tail( Cl(data), 1 )  #basically last day: no time limit
    }


    # take profit -------------------------------------------------------------
    if (!is.null(stop_loss$take_profit)) {
      #current daily high price / buying price
      perc_take_profit <- merge.xts( (Hi(data)[date1] / as.numeric(data_tmp$buy_spread[date1][1]) - 1) )
      #first time take limit was triggered
      take_limit <- head(perc_take_profit[perc_take_profit >= stop_loss$take_profit$level], 1)
      #percent below fixed limit stop on day the limit stop was triggered
      take_limit_diff <- take_limit - stop_loss$take_profit$level
      #exact price at which trail stop was triggered
      take_limit_price <- Hi(data)[index(take_limit)] - Hi(data)[index(take_limit)]*take_limit_diff
      if (length(take_limit_price) == 0) {
        take_limit_price <- tail(Cl(data),1)
        }
      } else {
        take_limit_price <- tail(Cl(data), 1)
      }




    # stop loss evaluation ----------------------------------------------------
    #which stop signal was triggered first since beginning of n-period and when
    first_trigg <- head(rbind(trail_stop_price, limit_stop_price, support_stop_price,
                              time_stop_price, indicator_stop_price, take_limit_price), 1)
    #renaming using stop trigger name should help to code but not really necessary
    if (first_trigg %in% trail_stop_price) {
      names(first_trigg) <- "trail_stop_price"
    } else if (first_trigg %in% limit_stop_price) {
      names(first_trigg) <- "limit_stop_price"
    } else if (first_trigg %in% support_stop_price) {
      names(first_trigg) <- "support_stop_price"
    } else if (first_trigg %in% time_stop_price) {
      names(first_trigg) <- "time_stop_price"
    } else if (first_trigg %in% indicator_stop_price) {
      names(first_trigg) <- "indicator_stop_price"
    } else {
      names(first_trigg) <- "take_limit_price"
    }

    #price for this trade
    begin <- index(data_tmp$buy_signal[date1][1])
    finish <- index(first_trigg)
    sell_signal_list[[n]] <- as.xts(1, order.by = index(first_trigg))
    days <- length(Cl(data_tmp)[paste0(begin, "::", finish)])
    #dates from buying day to stop trigger
    beg_fin <- paste0(index(data_tmp$buy_signal[date1][1]), "::", index(first_trigg))
    #weights =1 between buying and day of stop trigger
    weights_list[[n]] <- as.xts(rep(1, length(index(data_tmp[beg_fin]))), order.by = index(data_tmp[beg_fin]))

    #which periods were covered by the recent loop
    period_completed <- buy_index <= as.Date(index(first_trigg))

    #increase n by the number of periods covered, except when all finished
    if (all(period_completed) == TRUE) {
      n = length(buy_index)
    } else {
      while (period_completed[n] == TRUE) {
        n=n+1
      }
    }

  } #end while loop through trading periods

  #sell signal
  sell_signal_list <- sell_signal_list[!unlist(lapply(sell_signal_list, is.null))]
  data_tmp$sell_signal <- do.call(rbind, sell_signal_list)
  data_tmp$sell_signal <- na.fill(data_tmp$sell_signal, fill = 0)

  #position weights
  weights_list <- weights_list[!unlist(lapply(weights_list, is.null))]
  data_tmp$weights <- do.call(rbind, weights_list)
  data_tmp$weights <- lag(data_tmp$weights, k = 1)
  data_tmp$weights <- na.fill(data_tmp$weights, fill = 0)

  #strategy price
  data_tmp$price <- Cl(data_tmp) * data_tmp$weights
  data_tmp$price <- ifelse(data_tmp$price == 0, NA, data_tmp$price)
  data_tmp$price <- na.locf(data_tmp$price)
  data_tmp$price[tail(index(data_tmp), 1)] <- NA

  #strategy returns
  data_tmp$returns <- data_tmp$daily_returns_opop * data_tmp$weights
  data_tmp$returns <- na.locf(data_tmp$returns, fromLast = TRUE)

  #price adjusted
  data_tmp$returns_clcl <- data_tmp$daily_returns_clcl * data_tmp$weights
  data_tmp$returns_clcl <- na.locf(data_tmp$returns_clcl, fromLast = TRUE)
  data_tmp$price_adj <- exp(cumsum(data_tmp$returns_clcl)) * 100

  data_tmp

}