R/Report.R

In alejandro-sotolongo/InvestmentSuite: Investment Asset and Portfolio Time-Series Analysis

#' @title Dataframe to kable
#' @param df data.frame
#' @param remove_row_names option to remove the rownames from the data.frame
#' @details Utility function for R Markdown pdf reports, will output
#' a data.frame as a kable using the latex striped option from kableExtra
#' @importFrom kableExtra kable kable_styling
#' @export
df_to_kable <- function(df, remove_row_names = FALSE) {
  if (remove_row_names) {
    rownames(df) <- NULL
  }
  kbl <- kableExtra::kable(df, 'latex')
  kableExtra::kable_styling(kbl, latex_options = 'striped')
}


#' @title Calculate periodic return betweem two dates
#' @param ret data.frame containing return time-series
#' @param date_start return starting date
#' @param date_end return ending date
#' @param freq to annualize returns for dates longer than 1 year apart
#' @return numeric vector of return(s)
#' @export
cal_ret <- function(ret, date_start, date_end, freq) {

  ret <- check_time_series(ret)
  ret <- return_fill_na(ret)
  if (date_start < min(ret$date)) {
    return(NA)
  }
  if (date_end > max(ret$date)) {
    return(NA)
  }
  trunc_ret <- trunc_time_series(ret, date_start, date_end)
  cumret <- apply(trunc_ret[, 2:ncol(ret), drop = FALSE] + 1, 2, prod)
  if (date_end - date_start >= 364) {
    a <- freq_to_scale(freq)
    return(apply(as.data.frame(cumret), 2, function(x, a, n_obs) {x^(a / n_obs) - 1},
                 a = a, n_obs = nrow(trunc_ret)))
  } else {
    return(cumret - 1)
  }
}


#' @title Create table of returns over different calendar periods
#' @param ret data.frame containing returns
#' @param freq to annualize returns for periods longer than 1 year
#' @param asof ending date for calendar periods
#' @return data.frame with periodic returns, day-to-date, week-to-date, etc
#' @export
tbl_cal_perf <- function(ret, freq, asof = Sys.Date()) {

  xwin <- c('dtd', 'wtd', 'mtd', 'qtd', 'ytd', 'ttm', '3 yr', '5 yr', '10 yr',
            '20 yr', '30 yr')
  date_start <- sapply(xwin, cal_time, asof = asof)
  date_start_vec <- rep(as.Date(date_start, origin = '1970-01-01'),
                        ncol(ret) - 1)
  date_start_sort <- sort(date_start_vec, decreasing = TRUE)
  t_ret <- tidy_ret(ret)
  t_ret$series <- factor(t_ret$series, unique(t_ret$series))
  t_split_ret <- split(t_ret, t_ret$series)
  split_ret <- lapply(t_split_ret, untidy_ret)
  cal_vec <- mapply(cal_ret, split_ret, date_start = date_start_sort,
                    date_end = asof, freq = freq, SIMPLIFY = TRUE)
  cal_mat <- matrix(cal_vec, ncol = length(xwin))
  cal_num <- data.frame(Asset = colnames(ret)[2:ncol(ret)], cal_mat)
  colnames(cal_num)[2:ncol(cal_num)] <- toupper(xwin)
  cal_fmt <- apply(cal_mat, 2, fPercent)
  cal_fmt_mat <- matrix(cal_fmt, ncol = length(xwin))
  cal_df <- data.frame(Asset = colnames(ret)[2:ncol(ret)], cal_fmt_mat)
  colnames(cal_df)[2:ncol(cal_df)] <- toupper(xwin)
  res <- list()
  res$fmt <- cal_df
  res$num <- cal_num
  return(res)
}


#' @title Create table of performance statistics
#' @param fund data.frame containing return time-series for one or more funds
#' @param bench data.frame containing return time-series for one benchmark
#' @param rf data.frame containing return time-series for risk-free asset
#' @param freq character to represent common frequency
#' @return table with performance statistics
#' @export
tbl_perf_summary <- function(fund, bench, rf, freq) {

  combo <- combine_time_series(fund, bench, freq = freq)
  ann_ret <- geo_ret(combo, freq)
  er <- excess_mean(fund, bench, freq)
  ann_vol <- ann_vol(combo, freq)
  xbeta <- fund_beta(fund, bench, rf, freq)
  te <- tracking_error(fund, bench, freq)
  worst_dd <- worst_drawdowm(combo)
  var_5 <- val_at_risk(combo)
  sharpe <- sharpe_ratio(combo, rf, freq)
  sortino <- sortino_ratio(combo, rf, freq)
  ir <- info_ratio(fund, bench, freq)
  ret_dd <- ann_ret / -worst_dd
  omega <- omega_ratio(combo)
  num <- data.frame(Asset = colnames(combo)[2:ncol(combo)], # 1
                    Annual.Return = ann_ret,                # 2
                    Excess.Return = c(er, NA),              # 3
                    Volatility = ann_vol,                   # 4
                    Beta = xbeta,                           # 5
                    Tracking.Error = c(te, NA),             # 6
                    Worst.Drawdown = worst_dd,              # 7
                    Period.Value.at.Risk = var_5,           # 8
                    Sharpe.Ratio = sharpe,                  # 9
                    Sortino.Ratio = sortino,                # 10
                    Info.Ratio = c(ir, NA),                 # 11
                    Geo.Mean.to.Drawdown = ret_dd,          # 12
                    Omega = omega,                          # 13
                    row.names = NULL)
  fmt <- num
  p_col <- c(2:4, 6:8)
  n_col <- c(5, 9:13)
  fmt[, p_col] <- apply(fmt[, p_col], 2, fPercent)
  fmt[, n_col] <- apply(fmt[, n_col], 2, fNum)
  fmt_out <- t(fmt[, 2:ncol(fmt)])
  colnames(fmt_out) <- fmt$Asset
  num_out <- t(num[, 2:ncol(num)])
  colnames(num_out) <- num$Asset
  res <- list()
  res$fmt <- fmt_out
  res$num <- num_out
  return(res)
}


#' @title Create table with beta, correlation, and r^2 stats
#' @param ret data.frame containing return time-series, see details
#' @details The beta, correlation, and r^2 will be relative to the last column
#' in the \code{ret} time-series
#' @export
tbl_cov <- function(ret) {

  xcov <- cov(ret[, 2:ncol(ret)])
  xcor <- cov2cor(xcov)
  xbeta <- xcov[1, ] / diag(xcov)
  df <- data.frame(Beta = fNum(xbeta),
                   Corr. = fPercent(xcor[1, ]),
                   R2 = fPercent(xcor[1, ]^2))
  return(df)
}


#' @title Rank the last observation of a time-series from largest to smallest
.rank_last_observation <- function(x) {
  rank_last_x <- rank(x[nrow(x), 2:ncol(x)])
  series_order <- names(sort(rank_last_x, decreasing = TRUE))
  return(series_order)
}


#' @title Plot line chart
#' @param dat data.frame of time-series to plot
#' @details Uses ggplot2's geom_line and aranges legend based on the last
#' observation in order of largest to smallest value
#' @import ggplot2
#' @export
chart_line <- function(dat) {

  series_order <- .rank_last_observation(dat)
  tidy_dat <- tidy_ret(dat)
  if (ncol(dat) > 2) {
    tidy_dat$series <- factor(tidy_dat$series, series_order)
  }
  ggplot(tidy_dat, aes(x = date, y = values, color = series)) +
    geom_line() +
    labs(color = NULL)
}


#' @title Plot PCA charts
#' @param ret data.frame containing returns
#' @param n_pc number of PCs to cut off plots
#' @return a list containing two ggplots, see details
#' @details The loadings plot displays a bar chart for each PC up to the
#' \code{n_pc} paramter. It is assumed the first column of the returns is the
#' fund or asset of interest and is highlighted. The cumulative variance
#' explained chart displays the cumulative portion of total variance explained
#' by each PC.
#' @import ggplot2
#' @importFrom tidyr pivot_longer
#' @export
chart_pca <- function(ret, n_pc = 8) {

  p <- princomp(cor(ret[, 2:ncol(ret)]), cor = TRUE)
  p_loadings <- data.frame(p$loadings[, 1:n_pc])
  p_loadings$Asset <- factor(rownames(p_loadings), rev(rownames(p_loadings)))
  tidy_dat <- tidyr::pivot_longer(p_loadings, -Asset, values_to = 'values',
                                  names_to = 'series')
  chart_loadings <- ggplot(tidy_dat, aes(x = Asset, y = values, fill = Asset)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    coord_flip() +
    facet_wrap(. ~ series) +
    scale_fill_manual(values = c(rep('darkgrey', ncol(ret) - 2), 'indianred3')) +
    ylab('') + xlab('') +
    theme(legend.position = 'none')
  cum_var_expl <- data.frame(x = 1,
                             PC = paste0('PC ', 1:n_pc),
                             var = p$sdev[1:n_pc]^2)
  chart_var_expl <- ggplot(cum_var_expl, aes(x = x, y = var, fill = PC)) +
    geom_bar(stat = 'identity', position = 'stack') +
    coord_flip() +
    ylab('Variance') +
    xlab('') +
    theme(axis.text.y = element_blank(), axis.ticks.y = element_blank())
  res <- list()
  res$loadings <- chart_loadings
  res$var_expl <- chart_var_expl
  return(res)
}


chart_capm <- function(ret, freq, plot_fit_line = FALSE) {

  df <- data.frame(x = ann_vol(ret, freq), y = geo_ret(ret, freq),
                   asset = colnames(ret)[2:ncol(ret)])
  if (plot_fit_line) {
    plot_core <- ggplot(df, aes(x = x, y = y, label = asset)) +
      geom_point(size = 2) +
      geom_smooth(method = 'loess', formula = 'y ~ x')
  } else {
    plot_core <- ggplot(df, aes(x = x, y = y, color = asset, label = asset)) +
      geom_point(size = 2)
  }
  plot_core +
    ggrepel::geom_text_repel() +
    scale_x_continuous(labels = fPercent) +
    scale_y_continuous(labels = fPercent) +
    ylab('Geometric Return') +
    xlab('Volatility') +
    theme(legend.position = 'none')
}


chart_up_down_capt <- function(fund, bench, freq) {


}