R/apply_position_sl.R

In rengelke/tradr:

#' Apply Position Stop-Loss on xts Object Containing Weights
#'
#' @param weights xts object with portfolio weights
#' @param prices price list of instruments in portfolio weights object
#' @param sl1 number indicating drawdown at which to initiate gradual stop loss
#' @param sl2 number indicating drawdown to which to extend gradual stop loss
#' @param ma moving average type (SMA, EMA, ALMA or DEMA) to use for drawdown calculation
#' @param n number of periods to use for moving average calculation
#'
#' @return
#' @export
#' @import xts
#' @importFrom magrittr %<>% %>% %$%
#'
#' @examples apply_position_sl(stock_weights, stock_prices, sl1 = -0.2, sl2 = -0.3, ma = "EMA", n = 3)
apply_position_sl <- function (weights, prices, sl1, sl2, ma = c("ALMA"), n = 5) {

    weights_bckp <- weights
    weights[weights != 0] <- 1
    weights[1, ] <- 0

    if (is.list(prices)) {
        prices %<>%
            lapply(quantmod::Cl) %>%
            do.call(cbind, .) %>%
            .[index(weights)] %>%
            `colnames<-`(names(prices))
    }

    object_aligned <- tradr::align_xts(weights, prices)
    weights <- object_aligned[[1]] %>%
        na.fill(fill=0)
    prices <- object_aligned[[2]] %>%
        na.approx() %>%
        na.locf() %>%
        na.locf(fromLast = TRUE)

    weights %>% assertive.types::assert_is_any_of(classes = c("xts"))
    prices %>% assertive.types::assert_is_any_of(classes = c("xts"))

    if (!(colnames(prices)==colnames(weights)) %>% all()) {
        stop("Prices and weights column names do not match")
    }

    weights_index <- index(weights)

    weights %>% dim() %>% .[2] %>% seq_len() %>%
        lapply(function (i) {

            buys <- weights[, i] %>% diff() %>% .[. != 0, ] %>% .[. > 0, ]
            sells <- weights[, i] %>% diff() %>% .[. != 0, ] %>% .[. < 0, ]

            if (length(buys) == 0) {
                weights_trade_sl <- weights[, i]
            } else {
                seq_along(buys) %>% lapply(function (j) {

                    #print(paste0(i, " ", j))
                    buy_day <- index(buys)[j]
                    sell_day <- index(sells)[j]

                    # position was not sold yet
                    if (length(buys) > length(sells) & j == length(buys)) {
                        sell_day <- index(weights[, i]) %>% last()
                        period_trade <- paste0(buy_day, "::", sell_day)
                    } else {
                        period_trade <- paste0(buy_day, "::", sell_day-1)
                    }

                    # sl calculation
                    weights_period_sl <- prices[, i] %>%
                        .[period_trade] %>%
                        tradr::calculate_sl(sl1 = sl1, sl2 = sl2, ma = ma, n = n)

                    # safety index alignment
                    weights_period_sl %<>%
                        cbind(., weights[, i] %>% .[period_trade]) %>%
                        na.locf(fromLast = TRUE) %>%
                        na.locf() %>%
                        .[period_trade] %$%
                        StopLoss

                    return(weights_period_sl)

                }) %>%
                    do.call(rbind, .) %>%
                    `<<-`(weights_trade_sl, .)

                weights_trade_sl %<>% .[!duplicated(index(.)), ] %>%
                    `colnames<-`(colnames(weights[, i]))
            }

            return(weights_trade_sl)

        }) %>%
        do.call(cbind.xts, .) %>%
        `<<-`(weights_sl, .)

    weights_sl %<>% na.fill(fill = 0)

    if (!all((weights_sl %>% rowSums()) <= (weights %>% rowSums()))) {
        warning("Stop Loss weights are higher then original weights")
    }

    tradr::combine_xts(weights_bckp, weights_sl, fill = 0, task = "multiply")

}