R/InvMetrics.R

In alejandro-sotolongo/InvMgmt:

#' @title Calculate Annualized Return
#' @param ret data.frame or tibble containing returns organized by column
#' @param freq string to specify periodicity
#' @return tibble with column names of \code{ret} and corresponding geometric means
#' @examples
#' data(ret)
#' annRet(ret, 'd')
#' @export
annRet <- function(ret, freq) {

  a <- freqToScale(freq)
  n_obs <- nrow(ret)
  ret %>%
    tidyRet() %>%
    replace_na(list(ret = 0)) %>%
    group_by(asset) %>%
    summarize_at('ret', list(~prod(. + 1)^(a / n_obs) - 1)) %>%
    rename(ann_ret = ret)
}


#' @title Calculate Annualized Standard Deviation
#' @param ret data.frame or tibble containing returns organized by column
#' @param freq string to specify periodicity
#' @return tibble with column names of \code{ret} and corresponing standard deviations
#' @examples
#' data(ret)
#' annSd(ret, 'd')
#' @export
annSd <- function(ret, freq) {

  a <- freqToScale(freq)
  ret %>%
    tidyRet() %>%
    replace_na(list(ret = 0)) %>%
    group_by(asset) %>%
    summarize_at('ret', list(~sd(.) * sqrt(a))) %>%
    rename(sd = ret)
}


#' @title Calculated Downside Volatility
#' @param ret data.frame or tibble containing returns organized by column
#' @param rf data.frame or tibble containing risk-free time-series
#' @param freq string to specifiy periodicity
#' @examples
#' data(ret)
#' annDownSd(ret, rf, 'd')
#' @export
annDownSd <- function(ret, rf, freq) {

  a <- freqToScale(freq)
  rf <- changeFreq(rf, freq)
  ret <- changeFreq(ret, freq)
  colnames(rf)[2] <- '.y'
  if (any('.y' %in% colnames(ret))) {
    ret <- ret %>% rename('..y' = '.y')
  }
  models <- tidyRet(ret) %>%
    group_by(asset) %>%
    nest()
  down_sd <- models$data %>%
    map(left_join, y = rf, by = 'date') %>%
    map(filter, ret - .y > 0) %>%
    map(summarize_at, .vars = 'ret', .funs = list(~sd(.) * sqrt(a))) %>%
    unlist()
  tibble(asset = ret %>% select(-date) %>% colnames(),
         down_sd = down_sd)
}


#' @title Utility to Calculate Annualized Return
#' @param x numeric vector of returns
#' @param a numeric periodicity scale (e.g., monthly = 12)
#' @return annualized return of the vector \code{x}
#' @export
vecAnnRet <- function(x, a) {

  prod(1 + x, na.rm = TRUE)^(a / length(x)) - 1
}



#' @export
excessMean <- function(ret, rf, freq) {

  a <- freqToScale(freq)
  colnames(rf)[2] <- '.y'
  if (any('.y' %in% colnames(ret))) {
    ret <- ret %>% rename('..y' = '.y')
  }
  comb <- combineRet(ret, rf, freq = freq)
  rf_mu <- comb %>%
    filter(asset == '.y') %>%
    summarize_at('ret', vecAnnRet, a = a) %>%
    .$ret
  comb %>%
    filter(asset != '.y') %>%
    group_by(asset) %>%
    summarize_at('ret', vecAnnRet, a = a) %>%
    mutate(excess_ret = ret - rf_mu)
}


#' @export
sharpeRatio <- function(ret, rf, freq) {

  a <- freqToScale(freq)
  colnames(rf)[2] <- '.y'
  if (any('.y' %in% colnames(ret))) {
    ret <- ret %>% rename('..y' = '.y')
  }
  vol <- combineRet(ret, rf, freq = freq) %>%
    filter(asset != '.y') %>%
    group_by(asset) %>%
    summarize_at('ret', sd, na.rm = TRUE) %>%
    mutate(vol = ret * sqrt(a)) %>%
    .$vol
  excessMean(ret, rf, freq) %>%
    select(asset, excess_ret) %>%
    mutate(vol = vol, sharpe = excess_ret / vol)
}


#' @export
sortinoRatio <- function(ret, rf, freq) {

  down_vol <- annDownSd(ret, rf, freq) %>%
    .$down_sd
  excessMean(ret, rf, freq) %>%
    select(asset, excess_ret) %>%
    mutate(down_vol = down_vol, sortino = excess_ret / down_vol)
}

#' @export
trackingError <- function(ret, bench, freq) {
  a <- freqToScale(freq)
  colnames(bench)[2] <- '.y'
  bench <- changeFreq(bench, freq)
  if (any('.y' %in% colnames(ret))) {
    ret <- ret %>% rename('..y' = '.y')
  }
  combineRet(ret, bench, freq = freq) %>%
    filter(asset != '.y') %>%
    group_by(asset) %>%
    nest() %>%
    .$data %>%
    map(left_join, y = bench, by = 'date') %>%
    lapply(calcTE) %>%
    unlist() %>%
    tibble() %>%
    add_column(asset = ret %>% select(-date) %>% colnames, .before = 1) %>%
    rename('TE' = '.') %>%
    mutate(TE = TE * sqrt(a))
}

#' @export
calcTE <- function(x) {
  sd(x[[2]] - x[[3]])
}

#' @export
infoRatio <- function(ret, bench, rf, freq) {
  te <- trackingError(ret, bench, freq)
  excessMean(ret, bench, freq) %>%
    left_join(te, by = 'asset') %>%
    mutate(IR = excess_ret / TE)
}

#' @export
maxDrawdown <- function(ret, rf) {
  max_dd <- drawdown(ret) %>%
    select(-date) %>%
    apply(2, min) %>%
    tibble() %>%
    add_column(asset = ret %>% select(-date) %>% colnames()) %>%
    rename('max_dd' = '.')
  excessMean(ret, rf, freq) %>%
    left_join(max_dd, by = 'asset') %>%
    mutate(ratio = excess_ret / abs(max_dd))
}

#' @export
upDownStat <- function(ret, bench, freq) {

  colnames(bench)[2] <- '.y'
  colnames(rf)[2] <- '.rf'
  if (any('.y' %in% colnames(ret))) {
    ret <- ret %>% rename('..y' = '.y')
  }
  ret <- changeFreq(ret, freq)
  bench <- changeFreq(bench, freq)
  all_ret <- combineRet(ret, bench, freq = freq)
  ret_trunc <- ret %>%
    filter(date %in% all_ret$date)
  up_date <- all_ret %>%
    filter(asset == '.y' & ret >= 0) %>%
    .$date
  ret_up_down <- ret_trunc %>%
    tidyRet() %>%
    mutate(direction = ifelse(date %in% up_date, 'up', 'down'),
           direction = as.factor(direction)) %>%
    group_by(direction, asset) %>%
    nest()
  models <- map(ret_up_down$data, left_join, y = bench, by = 'date')
  reg <- models %>%
    map(select, -date) %>%
    map(~lm(ret ~ .y, data = .))
  coeff <- sapply(reg, '[[', 'coefficients')
  odd <- seq(from = 1, to = ncol(coeff), by = 2)
  even <- seq(from = 2, to = ncol(coeff), by = 2)
  up_beta <- coeff[2, odd]
  down_beta <- coeff[2, even]
  calcCapt <- function(model, freq) {
    geo_ret <- annRet(model, freq)
    geo_ret$ann_ret[1] / geo_ret$ann_ret[2]
  }
  capt <- sapply(models, calcCapt, freq = freq)
  up_capt <- capt[odd]
  down_capt <- capt[even]
  nUp <- function(x) {
    sum(x >= 0)
  }
  n_up <- apply(ret_trunc[, 2:ncol(ret_trunc), drop = FALSE], 2, nUp)
  n_down <- nrow(ret_trunc) - n_up
  tibble(Asset = ret %>% select(-date) %>% colnames(),
         UpCapture = up_capt,
         DownCapture = down_capt,
         UpBeta = up_beta,
         DownBeta = down_beta,
         UpPeriods = n_up,
         DownPeriods = n_down)
}

#' @export
multiReg <- function(ret, xfact, rf, freq, net_rf = TRUE) {

  ret <- checkRet(ret)
  xfact <- checkRet(xfact)
  rf <- checkRet(rf)
  date_start <- max(ret$date[1], xfact$date[1])
  date_end <- min(ret$date[nrow(ret)], xfact$date[nrow(xfact)])
  if (net_rf) {
    ret <- excessRet(ret, rf, freq = freq)
  }
  fact_nm <- colnames(xfact)[2:ncol(xfact)]
  ret_nm <- colnames(ret)[2:ncol(ret)]
  ydat <- ret %>%
    filter(date >= date_start, date <= date_end) %>%
    reshape2::melt(id = 'date') %>%
    group_by(variable) %>%
    nest()
  xdat <- filter(xfact, date >= date_start, date <= date_end)
  if (any(colnames(xdat) == 'value')) {
    xdat <- rename(xdat, value.x = value)
  }
  fit <- map(ydat$data, left_join, y = xdat, by = 'date') %>%
    map(select, -date) %>%
    map(~ lm(value ~., data = .))
  sfit <- map(fit, summary)
  r2 <- map_dbl(sfit, 'adj.r.squared')
  coeff <- map(sfit, 'coefficients') %>%
    lapply(as.tibble)
  est <- sapply(coeff, '[[', 'Estimate') %>% t()
  colnames(est) <- c('resid', fact_nm)
  tval <- sapply(coeff, '[[', 't value') %>% t()
  colnames(tval) <- colnames(est)
  est <- as_tibble(est) %>%
    select(-resid, everything()) %>%
    add_column('Adj R^2' = r2) %>%
    add_column('Asset' = ret_nm, .before = 1) %>%
    mutate(resid = resid * freqToScale(freq))
  tval <- as_tibble(tval) %>% select(-resid, everything())
  est_fmt <- est %>%
    mutate_at(fact_nm, fNum) %>%
    mutate_at(c('resid', 'Adj R^2'), fPercent)
  res <- list()
  res$fit <- fit
  res$est <- est
  res$est_fmt <- est_fmt
  res$tval <- tval
  return(res)
}

#' @export
factRiskWgt <- function(xbeta, cov_fact, variance_y) {
  xbeta <- matrix(xbeta, nrow = length(xbeta), ncol = 1)
  risk_wgt <- (xbeta * (cov_fact %*% xbeta)) / variance_y[1]
  return(risk_wgt)
}


#' @export
rollReg <- function(fund, xfact, rf, freq, net_rf = TRUE, roll_win = 90) {
  ret <- changeFreq(fund, freq)
  xfact <- changeFreq(xfact, freq)
  rf <- changeFreq(rf, freq)
  date_start <- max(ret$date[1], xfact$date[1])
  date_end <- min(ret$date[nrow(ret)], xfact$date[nrow(xfact)])
  if (net_rf) {
    ret <- excessRet(ret, rf, freq = freq)
  }
  fact_nm <- colnames(xfact)[2:ncol(xfact)]
  ret_nm <- colnames(ret)[2:ncol(ret)]
  ydat <- ret %>%
    filter(date >= date_start, date <= date_end) %>%
    reshape2::melt(id = 'date') %>%
    tsibble::as_tsibble(key = variable, index = date) %>%
    group_by(variable) %>%
    nest()
  xdat <- filter(xfact, date >= date_start, date <= date_end) %>%
    tsibble::as_tsibble(index = date)
  models <- map(ydat$data, left_join, y = xdat, by = 'date')
  reg <- function(...) {
      dat <- tibble(...) %>%
        select(-date)
      fit <- lm(value ~., data = dat)
      list(coeff = fit$coefficients, adj_r_2 = summary(fit)$adj.r.square)
  }
  nest_models <- tibble(ret_nm, models)
  res <- nest_models %>%
    mutate(reg = map(models, ~slide::pslide_dfr(., reg, .before = roll_win,
                                                .complete = TRUE)))
  res_list <- lapply(res$reg, '[[', 'coeff') %>%
    lapply(do.call, what = 'rbind') %>%
    lapply(as.data.frame) %>%
    lapply(add_column,
           date = res$models[[1]]$date[(roll_win+1):nrow(res$models[[1]])],
           .before = 1)
  adj_r_2 <- lapply(res$reg, '[[', 'adj_r_2') %>%
    lapply(do.call, what = 'rbind')
  res_list <- mapply(add_column, .data = res_list, Adj.R.Sqr = adj_r_2,
                     SIMPLIFY = FALSE)
  return(res_list)
}


#' @export
turbulence <- function(ret) {
  turb <- data.frame(date = ret$date)
  mu <- ret %>%
    select(-date) %>%
    colMeans()
  xcov <- ret %>%
    select(-date) %>%
    cov()
  turb %>%
    mutate(val = mahalanobis(select(ret, -date), center = mu, cov = xcov),
           pct = rank(turb) / (nrow(ret) + 1))
}

#' @export
rollAbsorption <- function(ret, n_pc = 2, roll_win = 252,
                           cov_win = c(252, 63, 21),
                           cov_wgt = c(0.25, 0.25, 0.5),
                           short_win = 15, long_win = 252) {

  roll_ar <- slide::slide(ret,
                          ~absorptionCalc(.x, n_pc, cov_win[1], cov_win[2],
                                          cov_win[3], cov_wgt),
                          .before = roll_win, .complete = TRUE) %>%
    unlist()
  delta_ar <- slide::slide(roll_ar, ~stdChange(.x, short_win, long_win),
                           .before = long_win, .complete = TRUE) %>%
    unlist()
  tibble(date = ret$date,
         ar = c(rep(NA, roll_win), roll_ar),
         delta = c(rep(NA, roll_win + long_win), delta_ar))
}

#' @export
absorptionCalc <- function(ret, n_pc = 2, long_win = 252, med_win = 63,
                           short_win = 21, wgt = c(0.25, 0.25, 0.5)) {
  xcov <- covWgtAvg(ret, long_win, med_win, short_win, wgt)
  eig <- cov2cor(xcov) %>%
    svd %>%
    .$d
  sum(eig[1:n_pc]) / sum(eig)
}

#' @export
rollTurbulance <- function(ret, roll_win = 252, short_win = 15, long_win = 252) {

  roll_turb <- slide::slide(ret, ~calcTurbulence(.x), .before = roll_win,
                            .complete = TRUE) %>%
    unlist()
  delta_turb <- slide::slide(roll_turb, ~stdChange(.x, short_win, long_win),
                             .before = long_win, .complete = TRUE) %>%
    unlist()
  tibble(date = ret$date,
         turb = c(rep(NA, roll_win), roll_turb),
         delta = c(rep(NA, roll_win + long_win), delta_turb),
         percentile = c(rep(NA, roll_win), rank(roll_turb, na.last = 'keep') /
           (1 + length(roll_turb))))
}

#' @export
calcTurbulence <- function(ret) {

  xret <- ret %>%
    select(-date)
  mahalanobis(xret, colMeans(xret), cov(xret))[nrow(xret)]
}

#' @export
sysRiskPerf <- function(ret, sys_risk, freq = 'w') {
  ret <- changeFreq(ret, freq)
  sys_risk <- changeFreq(sys_risk, freq, 'level')
  high_turb_date <- sys_risk %>%
    filter(percentile >= 0.90) %>%
    .$date
  high_ar_date <- sys_risk %>%
    filter(delta.ar >= 1.75) %>%
    .$date
  high_turb_ar_date <- sys_risk %>%
    filter(delta.ar >= 1.75,
           percentile >= 0.90) %>%
    .$date
  ret_high_turb <- ret %>%
    filter(date %in% high_turb_date) %>%
    select(-date) %>%
    mutate_all(mean) %>%
    slice(1) %>%
    as.numeric()
  ret_high_ar <- ret %>%
    filter(date %in% high_ar_date) %>%
    select(-date) %>%
    mutate_all(mean) %>%
    slice(1) %>%
    as.numeric()
  ret_high_turb_ar <- ret %>%
    filter(date %in% high_turb_ar_date) %>%
    select(-date) %>%
    mutate_all(mean) %>%
    slice(1) %>%
    as.numeric()
  tibble(Asset = ret %>% select(-date) %>% colnames(),
         `High Turbulence` = ret_high_turb,
         `High Fragility` = ret_high_ar,
         `High Turb. and Frag.` = ret_high_turb_ar)
}

#' @export
stdChange <- function(x, short_win, long_win) {
  (mean(x[1:short_win]) - mean(x[1:long_win])) / sd(x[1:long_win])
}


#' @export
covWgtAvg <- function(ret, long_win = 252, med_win = 63, short_win = 21,
                      wgt = c(0.25, 0.25, 0.5)) {

  ret_desc <- arrange(ret, desc(date))
  xret <- ret %>%
    select(-date)
  long_cov <- xret %>%
    slice(1:long_win) %>%
    cov()
  med_cov <- xret %>%
    slice(1:med_win) %>%
    cov()
  short_cov <- xret %>%
    slice(1:short_win) %>%
    cov()
  long_cov * wgt[1] + med_cov * wgt[2] + short_cov * wgt[3]
}

#' @export
covEWMA <- function(ret, freq) {

  ret <- checkRet(ret)
  retn <- ret[, 2:ncol(ret)] %>%
    replace(is.na(.), 0)
  freq <- checkFreq(freq)
  mult <- freqToScale(freq)
  n_obs <- nrow(retn)
  n_assets <- ncol(retn)
  mu <- colMeans(retn)
  mu_mat <- matrix(mu, nrow = n_obs, ncol = n_assets, byrow = TRUE)
  retc <- retn - mu_mat
  lambda <- 1 - 2 / (n_obs + 1)
  exp_cov <- matrix(0, nrow = n_assets, ncol = n_assets)
  for (t in 1:n_obs) {
    roll_ret <- retc[t, ]
    eps <- t(roll_ret) %*% as.numeric(roll_ret) * mult
    exp_cov <- lambda * exp_cov + (1 - lambda) * eps
  }
  return(exp_cov)
}

#' @export
wealthIndex <- function(ret, init_val = 1) {
  ret <- checkRet(ret)
  addOne <- function(x) x + 1
  row_zero <- data.frame(ret$date[1] - 1,
                         matrix(init_val, ncol = ncol(ret) - 1))
  colnames(row_zero) <- colnames(ret)
  wi <- ret %>%
    replace(is.na(.), 0) %>%
    mutate_at(vars(-date), addOne) %>%
    bind_rows(row_zero) %>%
    arrange(date) %>%
    mutate_at(vars(-date), cumprod)
  return(wi)
}

#' @export
drawdown <- function(ret) {
  ret <- checkRet(ret)
  drawdownCalc <- function(x) {
    wi <- cumprod(x + 1)
    wi_peaks <- cummax(wi)
    dd <- wi / wi_peaks - 1
    return(dd)
  }
  dd <- ret %>%
    replace(is.na(.), 0) %>%
    mutate_at(vars(-date), drawdownCalc)
  return(dd)
}

#' @export
rollSd <- function(ret, freq, roll_win = 63) {
  a <- freqToScale(freq)
  ret <- checkRet(ret)
  roll_sd <- apply(ret[, 2:ncol(ret)], 2, RcppRoll::roll_sdr, n = roll_win) %>%
    as.data.frame() %>%
    add_column(date = ret$date, .before = 1)
  roll_sd %>%
    mutate_at(vars(-date), ~(. * sqrt(a)))
}

#' @export
portRet <- function(mu_vec, wgt_vec, rf) {
  mu <- matrix(mu_vec, ncol = 1)
  wgt <- matrix(wgt_vec, ncol = 1)
  if (nrow(mu) != nrow(wgt)) {
    stop('mu_vec must be the same length as wgt_vec')
  }
  rf_ctr <- (1 - sum(wgt)) * rf
  res <- t(wgt) %*% mu + rf_ctr
  return(as.numeric(res))
}

#' @export
portSd <- function(wgt_vec, cov_mat) {
  wgt <- matrix(wgt_vec, ncol = 1)
  if (nrow(wgt) != nrow(cov_mat)) {
    stop('wgt_vec and cov_mat must be the same length')
  }
  return(sqrt(t(wgt) %*% cov_mat %*% wgt))
}

#' @export
portCorr <- function(wgt_vec_1, wgt_vec_2, cov_mat) {
  w1 <- as.matrix(wgt_vec_1, ncol = 1)
  w2 <- as.matrix(wgt_vec_2, ncol = 1)
  (t(w1) %*% cov_mat %*% w2) /
    (sqrt(t(w1) %*% cov_mat %*% w1) * sqrt(t(w2) %*% cov_mat %*% w2))
}

#' @export
portBeta <- function(wgt_vec_1, wgt_vec_2, cov_mat) {
  w1 <- as.matrix(wgt_vec_1, ncol = 1)
  w2 <- as.matrix(wgt_vec_2, ncol = 1)
  (t(w2) %*% cov_mat %*% w1) / (t(w2) %*% cov_mat %*% w2)
}

#' @export
sdWgt <- function(wgt_vec, cov_mat) {
  wgt <- matrix(wgt_vec, ncol = 1)
  risk_wgt <- (wgt * (cov_mat %*% wgt)) / (t(wgt) %*% cov_mat %*% wgt)[1]
  return(risk_wgt)
}

#' @export
contrToRet <-function(p, date_start = NA, date_end = NA) {
  if (is.na(date_start)) {
    date_start <- as.Date('0000-01-01')
  }
  if (is.na(date_end)) {
    date_end <- Sys.Date()
  }
  asset_index <- p$reb$asset_index
  if (is.null(asset_index)) {
    stop('p must be the result of the rebal function, see rebal for details')
  }
  before_start <- asset_index$date >= date_start
  if (sum(before_start) == 0) {
    warning('last date in asset time-series is before date_start')
    return(rep(NA, nrow(p$reb$curr_df) + 1))
  }
  if (min(asset_index$date) > date_start) {
    warning('date_start is before asset time-series')
    return(rep(NA, nrow(p$reb$curr_df) + 1))
  }
  num_seq <- 1:length(before_start)
  before_index <- min(num_seq[before_start]) - 1
  before_index <- max(before_index, 1)
  asset_index <- asset_index[before_index:nrow(asset_index), ] %>%
    filter(date <= date_end)
  asset_ret <- p$reb$asset_ret %>%
    filter(date >= date_start) %>%
    filter(date <= date_end)
  port_index <- p$reb$port_index
  port_index <- port_index[before_index:nrow(port_index), ] %>%
    filter(date_end <= date_end)
  contr_mat <- asset_index[1:(nrow(asset_index) - 1), 2:ncol(asset_ret)] *
    asset_ret[, 2:ncol(asset_ret)]
  contr_tbl <- tibble(date = asset_ret$date, contr_mat) %>%
    filter(date >= date_start) %>%
    filter(date <= date_end)
  contr <- apply(contr_tbl[, -1], 2, sum, na.rm = TRUE) / port_index$value[1]
  resid <- port_index$value[nrow(port_index)] /
    port_index$value[1] - 1 - sum(contr)
  res <- c(contr, resid)
  names(res) <- c(colnames(p$reb$asset_ret[, 2:ncol(p$reb$asset_index)]), 'resid.')
  return(res)
}

#' @export
pcaCov <- function(cov_mat) {
  s <- svd(cov_mat)
  latent <- s$d
  raw_coeff <- s$v
  p <- dim(raw_coeff)[1]
  d <- dim(raw_coeff)[2]
  max_index <- max.col(t(abs(raw_coeff)))
  col_sign <- sign(raw_coeff[max_index + seq(from = 0, to = (d - 1) * p, by = p)])
  coeff <- matrix(col_sign, nrow = p, ncol = d, byrow = TRUE) * raw_coeff
  res <- list()
  res$latent <- latent
  res$coeff <- coeff
  return(res)
}

#' @export
tblCalRet <- function(ret, as_of = Sys.Date()) {

  xwin <- c('dtd', 'wtd', 'mtd', 'qtd', 'ytd', 'ttm', '3 yr', '5 yr', '10 yr',
            '20 yr', '30 yr')
  date_start <- lapply(xwin, calTime, asof = as_of) %>%
    unlist() %>%
    as.Date(origin = '1970-01-01')
  date_start_vec <- rep(date_start, ncol(ret) - 1) %>%
    sort(decreasing = TRUE)
  models <- ret %>%
    tidyRet() %>%
    group_by(asset) %>%
    nest()
  retmat <- mapply(calRet, models$data, date_start = date_start_vec,
                   date_end = as_of, SIMPLIFY = TRUE) %>%
    matrix(ncol = 11)
  colnames(retmat) <- xwin
  num <- as_tibble(retmat) %>%
    mutate(`3 yr` = (1 + `3 yr`)^(1/3) - 1,
           `5 yr` = (1 + `5 yr`)^(1/5) - 1,
           `10 yr` = (1 + `10 yr`)^(1/10) - 1,
           `20 yr` = (1 + `20 yr`)^(1/20) - 1,
           `30 yr` = (1 + `30 yr`)^(1/30) - 1) %>%
    add_column(asset = ret %>% select(-date) %>% colnames, .before = 1)
  fmt <- num %>%
    mutate_at(vars(-asset), fPercent)
  res <- list()
  res$num <- num
  res$fmt <- fmt
  return(res)
}

#' @export
tblContrCalRet <- function(p, as_of = Sys.Date()) {

  xwin <- c('dtd', 'wtd', 'mtd', 'qtd', 'ytd', 'ttm', '3 yr', '5 yr', '10 yr',
            '20 yr', '30 yr')
  date_start <- lapply(xwin, calTime, asof = as_of) %>%
    unlist() %>%
    as.Date(origin = '1970-01-01')
  ctr <- lapply(date_start, contrToRet, p = p) %>%
    as.data.frame()
  colnames(ctr) <- xwin
  num <- add_column(ctr, asset = rownames(num), .before = 1) %>%
    as_tibble()
  fmt <- num %>%
    mutate_at(vars(-asset), fPercent)
  res <- list()
  res$num <- num
  res$fmt <- fmt
  return(res)
}

#' @export
calRet <- function(ret, date_start, date_end) {

  if (date_start < min(ret$date)) {
    return(NA)
  }
  if (date_end > max(ret$date)) {
    return(NA)
  }
  truncReturns(ret, date_start, date_end) %>%
    select(-date) %>%
    mutate_all(~(1 + .x)) %>%
    apply(2, prod, na.rm = TRUE) - 1
}