R/DataViz.R

In alejandro-sotolongo/InvTools:

#' @title Cone Chart of Cumulative Wealth
#'
#' @param ret data.frame or tibble containing time-series of returns with the
#' date in the first column
#' @param e_mu expected return of time-seires (annualized)
#' @param e_sigma expected standard deviation of time-series (annualized)
#' @param freq frequency of time-series
#'
#' @export
coneChart <- function(ret, e_mu, e_sigma, freq) {
  n_obs <- nrow(ret)
  path <- wealthIndex(ret)
  mult <- freqToScale(freq)
  e_mu <- e_mu / mult
  e_sigma <- e_sigma / sqrt(mult)
  mu_path <- c(0, e_mu * 1:n_obs)
  sigma_path <- c(0, e_sigma  * sqrt(1:n_obs))
  dat <- tibble(
    Date = path$date,
    `Return Path` = log(path$value),
    `Expected Center Path` = mu_path,
    `Up 1 Sigma` = mu_path + sigma_path,
    `Up 2 Sigma` = mu_path + 2 * sigma_path,
    `Down 1 Sigma` = mu_path -  sigma_path,
    `Down 2 Sigma` = mu_path - 2 * sigma_path)
  plotdat <- reshape2::melt(dat, id = 'Date')
  plotdat$variable <- factor(
    x = plotdat$variable,
    levels = c('Return Path', 'Expected Center Path', 'Down 1 Sigma',
               'Down 2 Sigma', 'Up 1 Sigma', 'Up 2 Sigma'))
  ggplot(data = plotdat, aes(x = Date, y = value, color = variable)) +
    geom_line() +
    scale_color_manual(values = c('black', 'darkgrey', 'skyblue',
                                  'dodgerblue3', 'brown', 'indianred3')) +
    labs(color = '',
         subtitle = paste0('E[mu] = ', fPercent(e_mu * mult),
                           ' E[sigma] = ', fPercent(e_sigma * sqrt(mult)),
                           '  |  ',
                           format(ret$date[1], '%b %Y'), ' to ',
                           format(ret$date[length(ret$date)], '%b %Y')),
         title = 'Cumulative Return Path') +
    ylab('') + xlab('') +
    theme_bw() +
    theme(plot.subtitle = element_text(color = 'grey34'))
}

#' @export
corPlot <- function(xcor, lbl = NULL, text_size = 2.5) {
  if (nrow(xcor) > 26) {
    stop('corPlot is for 26 or less variables')
  }
  cordf <- as.data.frame(xcor)
  if (is.null(lbl)) {
    lbl <- colnames(cordf)
  }
  cordf <- cordf %>%
    add_column(Name = paste0(lbl, '-', LETTERS[1:length(lbl)]), .before = 1)
  colnames(cordf) <- c('Name', LETTERS[1:length(lbl)])
  plotdat <- cordf %>%
    reshape2::melt(id = 'Name') %>%
    mutate(lbl = formatC(value, digits = 2, format = 'f'),
           Name = factor(Name, unique(Name))) %>%
    arrange(desc(Name))
  ggplot(data = plotdat,
         mapping = aes(x = variable, y = Name, fill = value, label = lbl)) +
    geom_tile(colour="gray90", size=1.5, stat="identity") +
    scale_x_discrete(position = 'top') +
    scale_y_discrete(limits = unique(plotdat$Name)) +
    scale_fill_gradient(
      low = "white",
      high = "dodgerblue",
      space = "Lab",
      na.value = "gray90") +
    geom_text(size = text_size) +
    xlab('') + ylab('') +
    labs(fill = '') +
    theme_minimal() +
    theme(axis.text.y = element_text(size = 7), legend.position = 'none')
}

#' @export
denPlot <- function(ret, freq, last_n_ret = 5) {
  ret <- changeTimeSeriesFreq(ret, freq)
  den <- density(ret[[2]])
  last_n <- data.frame(x = ret[(nrow(ret) - last_n_ret + 1):nrow(ret), 2],
                       y = rep(max(den$y) / 2, last_n_ret))
  colnames(last_n) <- c('x', 'y')
  dat <- data.frame(
    x = den$x,
    y = den$y
  )
  ggplot(dat, aes(x = x, y = y)) +
    geom_area() +
    geom_point(aes(x = x, y = y,col = paste0('Last ', last_n_ret, ' ',
                                             freqToStr(freq),  ' Returns')),
                   data = last_n) +
    scale_x_continuous(labels = scales::percent) +
    scale_color_manual(values = 'darkcyan') +
    labs(col = '') +
    ylab('Emperical Density') +
    xlab(paste0(freqToStr(freq), ' Return'))  +
    geom_vline(xintercept = 0, color = 'white')
}

#' @export
regPlot <- function(asset_list, factor_list, rf, freq, factor_lbl,
                    plot_lbl = FALSE) {
  fa <- ffaReg(asset_list, factor_list, rf, freq)
  fa_summ <- fa$reg_summ_num
  colnames(fa_summ)[2:(1 + length(factor_lbl))] <- factor_lbl
  fa_tstat <- fa$t_stat %>%
    add_column(`Adj. R-squared` = fa_summ$`Adj. R-squared`)
  colnames(fa_tstat)[2:(1 + length(factor_lbl))] <- factor_lbl
  summ_flat <- reshape2::melt(fa_summ, id = 'Name', value.name = 'Beta')
  tstat_flat <- reshape2::melt(fa_tstat, id = 'Name',  value.name = 'Tstat')
  plotdat <- left_join(summ_flat, tstat_flat, by = c('variable', 'Name')) %>%
    mutate(Tstat = abs(Tstat) > 2) %>%
    mutate(Name = factor(Name, levels = unique(Name))) %>%
    mutate(variable = factor(variable, levels = unique(variable))) %>%
    arrange(desc(Name), desc(variable)) %>%
    mutate(BetaFmt = fNum(Beta))
  g <- ggplot(plotdat, aes(x = variable, y = Beta, fill = Tstat)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    facet_wrap(.~Name, ncol = 2) +
    scale_x_discrete(limits = unique(plotdat$variable)) +
    scale_fill_manual(values = c('darkgrey', 'dodgerblue3')) +
    labs(fill = 'Abs T-stat > 2', title = 'Regression Summary') +
    xlab('') +
    ylab('') +
    coord_flip()
  if (plot_lbl) {
    g <- g +
      geom_label(aes(label = BetaFmt), size = 2.5, color = 'white',
                 show.legend = FALSE)
  }
  return(g)
}

#' @export
portHistWgt <- function(port) {
  hist_wgt <- port$reb$hist_wgt
  lbl <- sapply(port$asset_list, '[[', 'meta')['provider_id', ] %>%
    unlist() %>%
    gsub(pattern = ' US Equity', replacement = '') %>%
    gsub(pattern = ' Index', replacement = '')
  colnames(hist_wgt) <- c('date', lbl)
  plotdat <- reshape2::melt(hist_wgt, id = 'date')
  ggplot(plotdat, aes(x = date, y = value, fill = variable)) +
    geom_area() +
    geom_line(position = 'stack') +
    labs(fill = 'Asset') +
    theme_minimal()
}

#' @export
portCurrWgt <- function(port) {
  all_cap_wgt <- port$reb$hist_wgt[nrow(port$reb$hist_wgt), -1] %>%
    simplify2array()
  cap_wgt <- all_cap_wgt[all_cap_wgt != 0]
  asset_list <- port$asset_list[all_cap_wgt != 0]
  ret <- assetToRet(asset_list)
  xcov <- cov(ret[(nrow(ret) - 89):nrow(ret), -1],
              use = 'pairwise.complete.obs')
  risk_wgt <- riskWgt(cap_wgt, xcov)
  meta <- sapply(asset_list, '[[', 'meta')
  wgt <- tibble(Name = unlist(meta['name', ]),
                Strategy = unlist(meta['asset_class', ]),
                `Cap Wgt` = cap_wgt,
                `Risk Wgt` = array(risk_wgt)) %>%
    arrange(Strategy)
  wgt_fmt <- wgt %>%
    mutate(`Cap Wgt` = fPercent(`Cap Wgt`),
           `Risk Wgt` = fPercent(`Risk Wgt`))
  tbl <- kable(wgt_fmt) %>%
    kable_styling(latex_options = 'striped', font_size = 9) %>%
    row_spec(0, bold = TRUE)
  plotdat <- wgt %>%
    add_column(CapFmt = wgt_fmt$`Cap Wgt`) %>%
    add_column(RiskFmt = wgt_fmt$`Risk Wgt`) %>%
    arrange(desc(Strategy)) %>%
    mutate(Name = factor(Name, levels = Name))
  gcap <- ggplot(plotdat, aes(x = Name, y = `Cap Wgt`, fill = Strategy,
                              label = CapFmt)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    geom_label(size = 2, nudge_y = -0.025, show.legend = FALSE) +
    scale_y_continuous(labels = scales::percent) +
    xlab('') + ylab('') +
    labs(title = 'Capital Weight') +
    coord_flip() +
    theme(text = element_text(size = 8))
  grisk <- ggplot(plotdat, aes(x = Name, y = `Risk Wgt`, fill = Strategy,
                               label = RiskFmt)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    geom_label(size = 2, nudge_y = -0.025, show.legend = FALSE) +
    scale_y_continuous(labels = scales::percent) +
    xlab('') + ylab('') +
    labs(title = 'Risk Weight') +
    coord_flip() +
    theme(text = element_text(size = 8))
  res <- list()
  res$tbl <- tbl
  res$plot_cap <- gcap
  res$plot_risk <- grisk
  return(res)
}

#' @export
fundPCA <- function(fund, universe, lbl = NULL) {
  if (is.null(lbl)) {
    lbl <- sapply(c(fund, universe), '[[', 'meta')['provider_id', ] %>%
      unlist() %>%
      gsub(pattern = ' US Equity', replacement = '') %>%
      gsub(pattern = ' Index', replacement = '')
  }
  ret <- assetToRet(c(fund, universe), trunc_incept = TRUE)
  colnames(ret) <- c('date', lbl)
  p <- princomp(na.omit(ret[, 2:ncol(ret)]), cor = TRUE)
  fund_load <- data.frame(Comp = names(p$loadings[1, ]),
                          Value = p$loadings[1, ],
                          row.names = NULL,
                          stringsAsFactors = FALSE) %>%
    arrange(desc(Value))
  if (nrow(fund_load) > 5) {
    fund_load <- fund_load[1:5, ]
  }
  all_load <- data.frame(p$loadings[, fund_load$Comp])
  dat <- data.frame(all_load) %>%
    add_column(Name = lbl) %>%
    reshape2::melt(id = 'Name') %>%
    mutate(Name = factor(Name, levels = unique(Name)))
  ggplot(dat, aes(x = Name, y = value, fill = Name)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    facet_wrap(.~ variable, ncol = 1) +
    labs(fill = '', title = 'PCA', subtitle = 'Top 5 Fund Loadings') +
    ylab('') +
    xlab('') +
    theme(axis.text.x = element_blank(),
          axis.ticks.x = element_blank())
}

#' @export
updownScatter <- function(fund, bench) {
  ret <- assetToRet(c(fund, bench), trunc_incept = TRUE)
  colnames(ret) <- c('date', 'fund', 'bench')
  dat <- ret %>%
    mutate(direction = ifelse(bench >= 0, 'up', 'down'))
  g <- ggplot(dat, aes(x = bench, y = fund, col = date)) +
    geom_point() +
    facet_wrap(.~ direction, scales = 'free_x', ncol = 1) +
    xlab('Benchmark') +
    ylab('Fund') +
    scale_x_continuous(labels = scales::percent) +
    scale_y_continuous(labels = scales::percent) +
    geom_smooth()
  upreg <- lm(fund ~ bench, dat %>% filter(direction == 'up') %>% na.omit())
  downreg <- lm(fund ~ bench, dat %>% filter(direction == 'down') %>% na.omit())
  upbeta <- upreg$coefficients[2]
  downbeta <- downreg$coefficients[2]
  res <- list()
  res$plot <- g
  res$upbeta <- upbeta
  res$downbeta <- downbeta
  res$upreg <- upreg
  res$downreg <- downreg
  return(res)
}

#' @export
breakScatter <- function(fund, bench, n = 5) {
  ret <- assetToRet(c(fund, bench), freq, trunc_incept = TRUE) %>%
    na.omit()
  colnames(ret) <- c('date', 'fund', 'bench')
  breaks <- quantile(ret[, 'bench'], cumsum(rep(1 / n, n)))
  lbl <- as.character(1:n)
  dat <- ret %>%
    mutate(group = ifelse(bench < breaks[1], lbl[1], NA))
  for (i_break in 2:n) {
    is_break <- dat$bench > breaks[i_break - 1] & dat$bench <= breaks[i_break]
    dat$group[is_break] <- lbl[i_break]
  }
  dat <- dat %>% mutate(group = factor(group, lbl))
  scatt <- ggplot(dat, aes(x = bench, y = fund, col = date)) +
    geom_point() +
    geom_smooth() +
    facet_wrap(.~ group, scales = 'free') +
    scale_x_continuous(labels = scales::percent) +
    scale_y_continuous(labels = scales::percent)
  groupdat <- dat %>%
    group_by(group) %>%
    summarize_at(vars(-date), vecGeoRet) %>%
    reshape2::melt(id = 'group')
  bar <- ggplot(groupdat, aes(x = group, y = value, fill = variable)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    scale_fill_manual(values = c('skyblue3', 'grey34')) +
    scale_y_continuous(labels = scales::percent) +
    xlab('Return Group: Lowest to Highest') +
    ylab('Geometric Return') +
    labs(fill = '')
  res <- list()
  res$scatt <- scatt
  res$bar <- bar
  return(res)
}