R/screenStrategyParameter.R

In rengelke/quantTraiding_trato: Trading Strategies Development Tool Kit

#' Creates Matrix with Repeted Columns
#'
#' @param x numeric vector with values to fill by row
#' @param n number of columns in matrix
#'
#' @return
#'
#' @examples repeatColumn(x = c(30:100), n = 20)
repeatColumn <- function (x, n) {
  matrix(rep(x, each = n), ncol = n, byrow = TRUE)
}

#' Function to Backtest Strategy Parameters
#'
#' @param data OHLC market data
#' @param screen_perimeter list containing strat and end value parameters
#' for screening
#' @param updateStrategy predifined updateStrategy function containing strategy
#' object definition and rules to set variable parameters
#'
#' @return list with return data
#' @export
#' @import parallel
#' @import foreach
#' @import doSNOW
#' @import quantmod
#'
#' @examples screenStrategyParameter(msci_world, CCIpullback_SL-TS,
#' list(n1_min=35, n1_max=140, n2_min=6, n2_max=30))
screenStrategyParameter <- function (data, screen_perimeter, updateStrategy = updateStrategy) {

  #take min/max backtest parameters
  n1_min <- screen_perimeter$n1_min
  n1_max <- screen_perimeter$n1_max
  n2_min <- screen_perimeter$n2_min
  n2_max <- screen_perimeter$n2_max

  #estimate stop loss parameters
  stop_loss_parameter <- suggestStopLoss(data)

  #matrices with parameters for backtesting
  parameter_matrix <- list(trato:::repeatColumn(n1_min:n1_max, n2_max-n2_min+1),
                           t(trato:::repeatColumn(n2_min:n2_max, n1_max-n1_min+1)))

  #strategy backtesting for returns
  cluster = makeCluster(4, type = "SOCK")
  registerDoSNOW(cluster)
  on.exit(stopCluster(cluster))

  backtest_results_list <- foreach(s = 1:length(stop_loss_parameter),
                                   .packages = c("foreach",
                                                 "quantmod",
                                                 "magrittr",
                                                 #"PerformanceAnalytics",
                                                 "trato")
  ) %dopar% {
    #on.exit(stopCluster(cluster))
    SL <- stop_loss_parameter[[s]][1]
    TS <- stop_loss_parameter[[s]][2]
    y <- foreach(j = 1:dim(parameter_matrix[[1]])[2],
                 #.combine = "cbind",
                 .packages = c("foreach",
                               "quantmod",
                               "magrittr")
    ) %dopar% {
      x <- foreach(i = 1:dim(parameter_matrix[[1]])[1],
                   #.combine = "rbind",
                   .packages = c("foreach",
                                 "quantmod",
                                 "magrittr",
                                 "trato")
      ) %dopar% {
        n1 <- parameter_matrix[[1]][i,j]
        n2 <- parameter_matrix[[2]][i,j]
        strategy <- updateStrategy()$value
        tryCatch({
          x <- applyStrategy(data, strategy)$returns
        },
        error = function(e) {
          x <- xts(-0.3, order.by = tail(index(data), 1))
        }
        )
        return(x)
      }
      return(x)
    }
    return(y)
  }; stopCluster(cluster)

  names(backtest_results_list) <- do.call(rbind,
                                           lapply(
                                             split(stop_loss_parameter,
                                                   rep(1:length(stop_loss_parameter))),
                                             paste0)
  )

  backtest_results_list <- lapply(backtest_results_list, function(x) {
    names(x) <- parameter_matrix[[2]][1, ]
    x
  })

  backtest_results_list <- lapply(backtest_results_list, function(x) {
    lapply(x, function (x) {
      names(x) <- parameter_matrix[[1]][, 1]
      x
    })
  })

}


#
# backtest_results <- foreach(s = 1:length(stop_loss_parameter),
#                             .packages = c("foreach",
#                                           "quantmod",
#                                           "magrittr",
#                                           "PerformanceAnalytics",
#                                           "trato")
# ) %dopar% {
#   #on.exit(stopCluster(cluster))
#   SL <- stop_loss_parameter[[s]][1]
#   TS <- stop_loss_parameter[[s]][2]
#   y <- foreach(j = 1:dim(parameter_matrix[[1]])[2],
#                .combine = "cbind",
#                .packages = c("foreach",
#                              "quantmod",
#                              "magrittr",
#                              "PerformanceAnalytics")
#   ) %dopar% {
#     x <- foreach(i = 1:dim(parameter_matrix[[1]])[1],
#                  .combine = "rbind",
#                  .packages = c("foreach",
#                                "quantmod",
#                                "magrittr",
#                                "PerformanceAnalytics",
#                                "trato")
#     ) %dopar% {
#       n1 <- parameter_matrix[[1]][i,j]
#       n2 <- parameter_matrix[[2]][i,j]
#       strategy <- updateStrategy()$value
#       if (output == "returns") {
#         tryCatch({
#           x <- Return.cumulative(applyStrategy(data,
#                                                strategy)$returns,
#                                  geometric = TRUE)
#         },
#         error = function(e) {
#           x <- -0.3
#         }
#         )
#       }
#       if (output == "KellyRatio") {
#         tryCatch({
#           x <- as.numeric(
#             KellyRatio(applyStrategy(data,
#                                      strategy)$returns)
#           )
#         },
#         error = function(e) {
#           x <- -0.2
#         }
#         )
#       }
#       return(x)
#     }
#     return(x)
#   }
#   rownames(y) <- parameter_matrix[[1]][, 1]
#   colnames(y) <- parameter_matrix[[2]][1, ]
#   return(y)
# }