R/calcOpenGapCoefParallel.R

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

#' Calculate Open Gap Coeficient
#'
#' @param window Window length of linear regression
#' @param roc.pc2to Rate of Change by prior close to today open.
#' @param roc.to2tc Rate of Change by today open to today close.
#' @param parallel Run parallel or not.
#'
#' @importFrom parallel makeCluster
#' @importFrom parallel detectCores
#' @importFrom parallel stopCluster
#' @importFrom doParallel registerDoParallel
#' @importFrom utils sessionInfo
#' @importFrom foreach foreach
#' @importFrom foreach %dopar%
#' @importFrom foreach %do%
#' @importFrom zoo coredata
#' @importFrom xts merge.xts
#' @importFrom stats lm
#' @importFrom stats coef
#'
#' @return xts of Open Gap Coeficient
#' @export
calcOpenGapCoefParallel <- function(window, roc.pc2to, roc.to2tc,
                                    parallel = TRUE) {

  # calcLm <- function(xts.data) {
  #   if (all(is.na(xts.data$ret)) | all(is.na(xts.data$gap))) {
  #     return(NA)
  #   } else {
  #     return(coef(lm(ret ~ gap + 0, data = xts.data)))
  #   }
  # }

  # Check two xts have the same dim
  stopifnot(all(names(roc.pc2to) == names(roc.to2tc)))
  stopifnot(all(index(roc.pc2to) == index(roc.to2tc)))

  ogc <- roc.pc2to
  coredata(ogc) <- rep(NA, length(ogc))

  # result <- pforeach(col = 1:ncol(roc.to2tc), .c = merge.xts) ({

  #   xts.data <- merge(roc.to2tc[, col], roc.pc2to[, col])
  #   colnames(xts.data) <- c("ret", "gap")

  #   # rst <- rollapply(xts.d, 10, calcLm, by.column = FALSE)
  #   ogc <- rollapply(xts.data, window, function(d) {
  #     if (all(is.na(d$ret)) | all(is.na(d$gap))) {
  #       return(NA)
  #     } else {
  #       return(coef(lm(ret ~ gap + 0, data = d)))
  #     }
  #   }, by.column = FALSE)

  #   colnames(ogc) <- colnames(roc.to2tc[, col])
  #   ogc
  # })

  # Prepare parallel foreach
  # pkgs <- sessionInfo()$otherPkgs %>% names
  # cl   <- makeCluster(detectCores())

  # registerDoParallel(cl)
  # on.exit(stopCluster(cl))

  # result <- foreach(col = 1:ncol(ogc), .c = "merge.xts", .packages = pkgs) %dopar% {
  #   xts.d <- merge(roc.to2tc[, col], roc.pc2to[, col])
  #   colnames(xts.d) <- c("ret", "gap")

  #   rst <- rollapply(xts.d, window, calcLm, by.column = FALSE)
  #   colnames(rst) <- colnames(ogc[, col])
  #   rst
  #   # for (row in window:nrow(ogc)) {
  #   #   data <- data.frame(ret = as.numeric(roc.to2tc[(row - window + 1):row, col]),
  #   #                      gap = as.numeric(roc.pc2to[(row - window + 1):row, col]))
  #   #   if (all(is.na(data$ret)) | all(is.na(data$gap))) {
  #   #     ogc[row, col] <- NA
  #   #   } else {
  #   #     lm.fit <- lm(ret ~ gap + 0, data = data)
  #   #     ogc[row, col] <- coef(lm.fit)
  #   #   }
  #   # }
  # }

  for (col in 1:ncol(ogc)) {
    for (row in window:nrow(ogc)) {
      # sub <- ogc[row, col]
      # print(paste0(colnames(sub), ":", index(sub)))

      data <- data.frame(ret = as.numeric(roc.to2tc[(row - window + 1):row, col]),
                         gap = as.numeric(roc.pc2to[(row - window + 1):row, col]))

      if (all(is.na(data$ret)) | all(is.na(data$gap))) {
        ogc[row, col] <- NA
      } else {
        lm.fit <- lm(ret ~ gap + 0, data = data)
        ogc[row, col] <- coef(lm.fit)
      }
    }
  }

  return (ogc)
}

# calcOpenGapCoefParallelOld <- function(window, roc.pc2to, roc.to2tc,
#                                     parallel = TRUE) {

#   calcLm <- function(xts.data) {
#     if (all(is.na(xts.data$ret)) | all(is.na(xts.data$gap))) {
#       return(NA)
#     } else {
#       return(coef(lm(ret ~ gap + 0, data = xts.data)))
#     }
#   }

#   calcRollLm <- function(symbol, window, roc.pc2to, roc.to2tc) {

#     xts.data <- merge(roc.pc2to[, symbol], roc.to2tc[, symbol])
#     colnames(xts.data) <- c("gap", "ret")

#     result <- rollapply(xts.data, window, calcLm, by.column = FALSE)
#     colnames(result) <- symbol

#     return(result)
#   }

#   if (parallel) {
#     result <- pforeach(name = names(roc.pc2to), .combine = "merge") ({
#       calcRollLm(name, window, roc.pc2to, roc.to2tc)
#     })

#   } else {

#     result <- npforeach(name = names(roc.pc2to), .combine = "merge") ({
#       calcRollLm(name, window, roc.pc2to, roc.to2tc)
#     })
#   }

#   # Replace "." with "-". ("." is created by xts cbind.)
#   colnames(result) <- str_replace(colnames(result), "TRUE.", "TRUE")
#   colnames(result) <- str_replace(colnames(result), "\\.", "-")

#   return(result)
# }