R/DataViz.R

In alejandro-sotolongo/InvMgmt:

#' @export
chartPCA <- function(fund, market_ret, rf, n_pc = 3) {
  ret <- combineRet(fund, market_ret, freq = 'd', method = 'matrix')
  eret <- excessRet(ret, rf, 'd')
  p <- eret %>%
    select(-date) %>%
    cor() %>%
    psych::pca(nfactors = ncol(ret) - 1)
  xload <- p$loadings[,]
  pc_names <- sort(abs(xload[1, ]), decreasing = TRUE)[1:n_pc] %>%
    names()
  plotload <- xload[, pc_names] %>%
    as_tibble() %>%
    add_column(asset = rownames(xload)) %>%
    pivot_longer(cols = -asset, values_to = 'value', names_to = 'pc') %>%
    mutate(pc = factor(pc, unique(pc)),
           asset = factor(asset, unique(asset)),
           asset = forcats::fct_rev(asset))
  ggplot(plotload, aes(x = asset, y = value)) +
    geom_bar(stat = 'identity', position = 'dodge') +
    facet_wrap(pc ~., ncol = 1) +
    coord_flip()
}

#' @export
chartWealth <- function(ret, init_val = 1, end_val_lbl = FALSE) {
  dat <- checkRet(ret) %>%
    wealthIndex(init_val) %>%
    tidyRet() %>%
    rename(value = ret)
  date_start <- ret %>% .$date %>% min()
  date_end <- ret %>% .$date %>% max()
  viz <- ggplot(dat, aes(x = date, y = value, color = asset)) +
    geom_line() +
    labs(color = '', title = 'Wealth Index',
         subtitle = paste0(date_start, ' to ', date_end)) +
    ylab('') + xlab('')
  if (end_val_lbl) {
    end_val <- dat %>%
      filter(date == date_end)
    viz <- viz +
      ggrepel::geom_label_repel(
        data = end_val,
        mapping = aes(x = date, y = value, label = asset)) +
      theme(legend.position = 'none')
  }
  return(viz)
}

#' @export
chartDrawdown <- function(ret, end_val_lbl = FALSE) {
  dat <- checkRet(ret) %>%
    drawdown() %>%
    reshape2::melt(id = 'date')
  viz <- ggplot(dat, aes(x = date, y = value, color = variable)) +
    geom_line() +
    labs(color = '', title = 'Drawdowns',
         subtitle = paste0(ret$date[1], ' to ', ret$date[nrow(ret)])) +
    ylab('') + xlab('')
  if (end_val_lbl) {
    end_val <- dat %>%
      filter(date == ret$date[nrow(ret)])
    viz <- viz +
      ggrepel::geom_label_repel(
        data = end_val,
        mapping = aes(x = date, y = value, label = variable)) +
      theme(legend.position = 'none')
  }
  return(viz)
}

#' @export
chartRollSd <- function(ret, freq, roll_win, include_drawdown = FALSE,
                        end_val_lbl = FALSE) {
  roll_vol <- checkRet(ret) %>%
    rollSd(freq, roll_win)
  if (include_drawdown) {
    dd <- checkRet(ret) %>%
      drawdown()
    dat <- left_join(roll_vol, dd, by = 'date') %>%
      reshape2::melt(id = 'date') %>%
      add_column(stat = NA) %>%
      mutate(variable = as.character(variable),
             variable = substr(variable, 1, nchar(variable) - 2))
    mid <- nrow(dat) / 2
    dat$stat[1:mid] <- 'Rolling Volatility'
    dat$stat[(mid + 1):nrow(dat)] <- 'Drawdowns'
    dat$stat <- factor(dat$stat, levels = c('Rolling Volatility', 'Drawdowns'))
    viz <- ggplot(dat, aes(x = date, y = value, color = variable)) +
      geom_line() +
      facet_wrap(.~stat, ncol = 1, scales = 'free') +
      scale_y_continuous(labels = scales::percent) +
      labs(color = '', title = 'Rolling Volatility and Drawdowns',
           subtitle = paste0(ret$date[1], ' to ', ret$date[nrow(ret)]))
  } else {
    dat <- reshape2::melt(roll_vol, id = 'date')
    viz <- ggplot(dat, aes(x = date, y = value, color = variable)) +
      geom_line() +
      scale_y_continuous(labels = scales::percent) +
      labs(color = '', title = 'Rolling Volatility',
           subtitle = paste0(ret$date[1], ' to ', ret$date[nrow(ret)]))
  }
  return(viz)
}

#' @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
chartCone <- function(ret, e_mu, e_sigma, freq) {
  n_obs <- nrow(ret)
  path <- wealthIndex(ret)
  colnames(path) <- c('date', 'value')
  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
chartCorr <- function(xcor, lbl = NULL, text_size = 2.5) {
  if (nrow(xcor) > 26) {
    stop('corPlot is for 26 or fewer 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
chartPDF <- function(ret, freq, last_n_ret = 5) {
  ret <- changeFreq(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
freqToStr <- function(x) {
  switch (tolower(x),
    d = 'Days',
    w = 'Weeks',
    m = 'Months',
    q = 'Quarters',
    a = 'Years'
  )
}

#' @export
chartDendro <- function(ret, use_pca = TRUE, lbl = NULL) {
  if (is.null(lbl)) {
    lbl <- colnames(ret)[2:ncol(ret)]
  } else {
    if(length(lbl) != length(asset)) {
      stop('number of lables nust equal number of assets')
    }
  }
  xcor <- cor(ret[, 2:ncol(ret)], use = 'pairwise.complete.obs')
  if (use_pca) {
    p <- pcaCov(xcor)
    meas <- diag(sqrt(p$latent)) %*% t(p$coeff)
    dist_res <- dist(t(meas), method = 'euclidean')
  } else {
    dist_res <- dist(xcor)
  }
  hc <- hclust(dist_res)
  plot(hc, labels = lbl, cex = 0.8)
}


#' @export
chartRollUniReg <- function(fund, bench, rf, freq, roll_win) {
  res <- rollReg(fund, bench, rf, freq, roll_win)[[1]]
  colnames(res) <- c('date', 'Resid.', 'Beta', 'R^2')
  res <- res %>%
    mutate(Resid. = Resid. * freqToScale(freq))
  tidy_res <- pivot_longer(res, -date, values_to = 'value') %>%
    mutate(name = factor(name, c('Resid.', 'Beta', 'R^2')))
  ggplot(tidy_res, aes(x = date, y = value, color = name)) +
    geom_path() +
    facet_wrap(name ~., ncol = 1, scales = 'free') +
    scale_y_continuous(labels = scales::percent) +
    labs(color = '', title = 'Rolling Regression',
         subtitle = paste0(min(res$date), ' to ', max(res$date))) +
    ylab('') + xlab('') +
    theme(legend.position = 'none')
}


#' @export
fPercent <- function(x, digits = 2) {
  x_fmt <- formatC(x * 100, digits = digits, format = 'f')
  x_fmt_abs <- formatC(abs(x) * 100, digits = digits, format = 'f')
  x_per <- paste0(x_fmt, '%')
  less_0 <- x < 0
  less_0[is.na(less_0)] <- FALSE
  x_per[less_0] <- paste0('(', x_fmt_abs[less_0], '%)')
  x_per[x_per == ' NA%'] <- '-'
  return(x_per)
}

#' @export
fNum <- function(x, digits = 2) {
  x <- formatC(x, digits = 2, format = 'f', big.mark = ',')
  x[x == ' NA'] <- '-'
  return(x)
}