R/utility_functions.R

In rengelke/tradr:

## ColClasses -------------------------------------------------------

setClass("my_num")
setAs("character", "my_num", function(from) {
  as.numeric(gsub(",","\\.", gsub("\\.","", from)))
  })


setClass("my_date")
setAs("character", "my_date", function(from) as.Date(as.POSIXct(
  lubridate::dmy(from, tz = "UTC")
), tz = "UTC") )


setClass("my_date_hr")
setAs("character", "my_date_hr", function(from) as.Date(as.POSIXct(
  lubridate::dmy_hms(from, tz = "UTC")
), tz = "UTC") )



#' Clean Global Environment with Exceptions
#'
#' @param keep
#'
#' @return NULL
#'
#' @examples clean_GlobalEnv(keep = c("warn"))
clean_GlobalEnv <- function (keep = c("warn", "output")) {

  keep <- match.arg(keep, c("warn", "output"))
  list_remove <- ls()[-grepl(keep, ls())]
  if (length(list_remove) == 0) {
    rm(list = ls())
  } else {
    rm(list = list_remove)
  }
}


# # -----------------------------------------------------------------------
#' Samples a Subset of N Rows From a Matrix Object
#'
#' @param x matrix, data.frame or xts object
#' @param n_sub numerical value indicating how many rows should be sampled
#'
#' @return subset of n-rows of x
#' @export
#'
#' @examples sub_sample(prices)
sub_sample <- function(x, n_sub = 40) {
  # Assuming sampling by row, preserving all returns and cross symbol
  #   dependence structure at a given timestamp
  ii <- sample(1:NROW(x), size = n_sub, replace = FALSE)
  # sort in order to preserve time ordering?
  ii <- sort(ii)
  xs <- x[ii, ]
  xs
}


# # -----------------------------------------------------------------------
#' Function to Add Messages to "Messages" List
#'
#' @param message character string containing the message
#'
#' @return adds message to "messages" list in GlobalEnv
#' @export
#'
#' @examples add_message("Hello World!")
add_message <- function(message) {

  if (!isTRUE(is.character(message))) {
    stop("Message must be a character string")
  }

  if (isTRUE("messages" %in% ls(envir = .GlobalEnv))) {
    messages <- get("messages", envir = .GlobalEnv)
  } else {
    messages <- list()
  }

  m <- length(messages)+1
  messages[[m]] <- message

  messages <<- messages
  #alternatively:
  #assign(messages, messages, envir = .GlobalEnv)

}


# # -----------------------------------------------------------------------
#' Create Date sequence without weekends and holidays
#'
#' @param date1 date object 1
#' @param date2 date object 2
#'
#' @return date vector w/o weekends and German holidays
#' @export
#' @importFrom magrittr %>%
#'
#' @examples seq_date(as.Date("2014-01-01"), as.Date("2025-03-22"))
seq_date <- function (date1, date2) {

  date1 <- as.Date(date1)
  date2 <- as.Date(date2)
  seq(date1, date2, by="days") %>%
    .[!(weekdays(.) %in% c("Saturday", "Sunday"))] %>%
    .[!(. %in% (c(timeDate:::NewYearsDay(2010:2025),
                  timeDate:::GoodFriday(2010:2025),
                  timeDate:::EasterMonday(2010:2025),
                  timeDate:::LaborDay(2010:2025),
                  timeDate:::DEAscension(2010:2025),
                  timeDate:::PentecostMonday(2010:2025),
                  timeDate:::DECorpusChristi(2010:2025),
                  timeDate:::DEGermanUnity(2010:2025),
                  timeDate:::ChristmasEve(2010:2025),
                  timeDate:::ChristmasDay(2010:2025),
                  timeDate:::BoxingDay(2010:2025),
                  timeDate:::DENewYearsEve(2010:2025)) %>%
                  as.Date()))]
}


# # -----------------------------------------------------------------------
#' Extends xts Object by N Days
#'
#' @param data xts object
#' @param n days to extend
#' @param weekday TRUE/FALSE if weekdays only
#'
#' @return xts object extended by n days
#' @import xts
#' @export
#'
#' @examples extend.xts(prices)
extend_xts <- function (data, n = 1, weekday = TRUE) {

  n_col <- dim(data)[2]
  last_day <- last(index(data), 1)
  next_day <- last_day + 1
  ext_day <- last_day + 9*n

  ext_period <- tradr::seq_date(next_day, ext_day)
  ext_period_alldays <- seq(next_day, ext_day, by="days")

  if (isTRUE(weekday) & n == 1) {
    ext_period <- ext_period[1]
  }
  if (isTRUE(weekday) & n >= 1) {
    ext_period <- ext_period[1:n]
  }
  if (!isTRUE(weekday) & n == 1) {
    ext_period <- ext_period_alldays[1]
  }
  if (!isTRUE(weekday) & n >= 1) {
    ext_period <- ext_period_alldays[1:n]
  }

  rbind.xts(data,
            as.xts(
              matrix(
                as.numeric(rep(NA, n_col)), nrow=n),
              order.by = as.Date(ext_period)
            )
  )
}


#' Combine Two xts objects
#'
#' @param xts1 first xts object
#' @param xts2 second xts object
#' @param task arithmetical task for combination: add, multiply
#' @param add_corr add correction column to make rows sum up to 1
#' @param fill fill value for NAs, numeric or "min"
#'
#' @return
#' @export
#' @import xts
#' @importFrom magrittr %>% %<>%
#'
#' @examples combine_xts(weights1, weights2)
combine_xts <- function (xts1, xts2, task = "multiply", fill = 0) {


  task %<>% match.arg(c("multiply", "add"), several.ok = FALSE)



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

  xts_list <- tradr::align_xts(xts1, xts2)
  xts_list %<>% lapply(function (x) na.locf(x, maxgap = 3, na.rm = FALSE))

  if (task == "multiply") {
    xts_combined <- (xts_list[[1]] * xts_list[[2]])
  }
  if (task == "add") {
    xts_combined <- (xts_list[[1]] + xts_list[[2]])
  }

  xts_combined %<>%
    na.locf(na.rm = FALSE)

  if (fill == "min") {
    fill <- min(as.matrix(xts_combined), na.rm = TRUE)
  }
  xts_combined %<>% na.fill(fill = fill)

  return(xts_combined)
}


# # -----------------------------------------------------------------------
#' Function to Fix the Index in OHLC Market Data
#'
#' @param data xts object
#'
#' @return OHLC object
#' @export
#' @import xts
#' @import quantmod
#' @importFrom magrittr %<>% %>%
#'
#' @examples fix_OHLC(getSymbols("^GDAXI"))
fix_OHLC <- function (data) {

  if (!all(quantmod::has.OHLC(data))) {
    warning("Market data is missing open, high, low or close column")
  }

  #last working day
  last_day <- tradr:::date_seq[tradr:::date_seq < Sys.Date()] %>%
    last()
  if (!(last_day %in% index(data))) {
    warning(paste0("Last working day [", last_day, "] data is missing"))
  }

  if (!is.index.unique(data)) {
    warning("Removing duplicate index values")
    data <- data[unique(index(data)), ]
  }

  data_compare <- merge.xts(data,
                            xts(, order.by = tradr:::date_seq,
                                dateFormat = "Date"),
                            join = "left")

  if (!is.index.unique(data_compare)) {
    warning("Warning: Removed duplicate index entries in xts.")
    data_compare <- data_compare[unique(index(data_compare)), ]
  }

  #remove zeros
  data_compare[, has.OHLC(data, which = TRUE)] %<>% replace(. == 0, NA)

  #trim OHLC NAs
  idx_trim <- data_compare[, has.OHLC(data, which = TRUE)] %>%
    na.trim(sides = "both") %>%
    index()
  data_compare %<>% .[idx_trim, ]

  #missing days
  is_missing <- is.na(data_compare[, 1])
  #days missing per year
  n_days <- sum(is_missing, na.rm = TRUE) / (length(index(data))/365.25)
  #max sequential missing values
  n_days_seq <- max(TTR::runSum(is_missing), na.rm = TRUE)

  if (n_days >= 12) {
    warning("Market data contains more than 12 missing days per year")
  } else if (n_days >= 18) {
    stop("Market data contains more than 18 missing days per year")
  }
  if (n_days_seq > 4) {
    warning("Market data contains more than 4 sequential missing days")
  } else if (n_days_seq > 7) {
    warning("Market data contains more than 7 sequential missing days")
  } else if (n_days_seq > 10) {
    stop("Market data contains more than 10 sequential missing days")
  }

  data_compare %>%
    na.locf(maxgap = 2) %>%
    na.approx(na.rm = TRUE)

}


#' Convert prices from currency a to b
#'
#' @param prices input vector with prices
#' @param from input vector with currencies to convert from. Character with 3-letter ISO currency codes.
#' @param to input vector with currencies to convert to. Character with 3-letter ISO currency codes.
#'
#' @return A numeric vector
#' @export
#' @import xts
#' @importFrom magrittr %>% %<>%
#'
#' @examples convert_currency(equity_prices, c("USD", "HKD"), "EUR")
convert_currency <- function(prices, from = "USD", to = "EUR", n = 15) {

  from_fx <- from %>% as.character()
  to_fx <- to %>% as.character()

  if (to_fx %>% is.na() %>% any()|from_fx %>% is.na() %>% any()) {
    warning("Conversion currency vector contains NAs. Filling NAs with `EUR`.")
    from_fx %<>% replace(., is.na(.), "EUR")
    from_fx %<>% replace(., is.na(.), "EUR")
  }
  assertive.types::assert_is_character(from_fx)
  assertive.types::assert_is_character(to_fx)

  if (length(from_fx) > 1 & length(to_fx) > 1) {
    if (length(from_fx) != length(to_fx))
      stop("`from` and `to` must have equal length")
  }
  if (length(from_fx) > 1 & length(to_fx) == 1) {
    to_fx %<>% rep(., length(from_fx))
  }

  fx_accept <- c("USD", "EUR", "AUD", "HKD", "CAD", "NOK", "GBP", "BRL",
                 "CHF", "CNY", "CZK", "DKK", "ZAR", "HUF", "IDR", "ILS",
                 "JPY", "MXN", "NZD", "SEK", "SGD", "THB", "TWD", "RUB",
                 "KRW", "INR")
  from_fx %<>% match.arg(from_fx, several.ok = TRUE)
  to_fx %<>% match.arg(to_fx, several.ok = TRUE)

  fx_pairs_all <- paste0(from_fx, "/", to_fx)
  fx_pairs <- fx_pairs_all %>% unique()

  fx_list <- fx_pairs %>% lapply(function (x) {
    quantmod::getFX(x,
                    from = Sys.Date()-(2*n),
                    auto.assign = FALSE) %>%
      xts::last(n) %>%
      mean(na.rm = TRUE)
  })
  names(fx_list) <- fx_pairs

  prices %<>% as.numeric()
  prices %<>% replace(., is.infinite(.), 0)

  price_conv <-
    seq_along(prices) %>% sapply(function (i) {
    prices[i] * fx_list[[fx_pairs_all[i]]]
      }) %>%
    round(2)

  price_conv
}


#' Last Observation Carried Forward for N Periods
#'
#' @param object xts object
#' @param n periods to carry forward
#'
#' @return
#' @export
#' @import xts
#' @importFrom magrittr %>%
#'
#' @examples na_locf_until(weights, n = 50)
na_locf_until <- function (object, n) {

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

  object_ext <-
    object %>% dim() %>% .[2] %>% seq_len() %>%
    lapply(function (i) {
      order_idx <- index(object[, i])
      x <- object[, i]
      l <- cumsum(!is.na(x))
      c(NA, x[!is.na(x)])[replace(l, ave(l, l, FUN = seq_along) > (n + 1), 0) + 1] %>%
        xts(., order.by = order_idx, dateFormat = "Date")
    }) %>%
    do.call(cbind.xts, .) %>%
    `colnames<-`(colnames(object))

  return(object_ext)
}



#' Convert object to weights
#'
#' @param object object to be converted to weights
#' @param rank how many ranks to include
#' @param method which method to use
#'
#' @return
#' @export
#' @import xts
#' @importFrom magrittr %>% %<>%
#'
#' @examples make_weights(stock_rank, rank = 20, method = "rank")
make_weights <- function (object, rank, method = "rank") {

  if (method == "rank") {
    weights <-
      apply(object, 2,
            function(x) {
              ifelse(x > dim(object)[2] - rank,
                     (100/rank/100), 0)
            }) %>%
      sweep(., 1, apply(., 1, sum), "/")
    weights[weights > 1/rank] <- 1/rank

    weights %<>% as.xts(., dateFormat="Date") %>%
      na.fill(fill = 0)

    weights %<>% .[rowSums(.) == 1, ]
  }
  return(weights)
}