R/gg_charts_2.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Produces a plot of cumulative performance and drawdown over time given
#' a history of returns.
#' @param r.xts an XTS object with period returns for each column;
#' function will compute cumulative return and drawdowns for each item.
#' @param ptitle a plot title string, default empty string
#' @param geometric whether cumulative returns should use geometric method
#' @param drawdown_minima color for drawdown minima marker lines,
#' default NA for none
#' @return \code{ggplot2} object for further manipulation
#' @seealso PerformanceAnalytics::charts.PerformanceSummary,
#' directlabels, dplyr, tidyr, magrittr, ggplot2
#' @examples
#' \dontrun{
#' pr <- blotter::PortfReturns(acct_name)
#' colnames(pr) <- gsub(".DailyEndEq", "", colnames(pr))
#' pr$Theoretical <- rowSums(pr)
#' p <-gg_charts_summary_2(pr$Theoretical,
#'                        ptitle = "Theoretical Returns",
#'                        drawdown.minima = "gray")
#' p
#' }
gg_charts_summary_2 <- function(r.xts,
                                ptitle = "",
                                geometric = TRUE,
                                drawdown_minima = NA) {

  require(magrittr,quietly = TRUE)

  # dodges command check complaints
  Series <- Value <- Date <- Plot <- NULL

  # clean
  r.xts <- stats::na.omit(zoo::na.locf(r.xts))

  # cumulative return
  c.xts <- if ( geometric ) {
    cumprod(1 + r.xts)
  } else {
    1 + cumsum(r.xts)
  }

  # drawdowns
  d.xts <- do.call(cbind, lapply(1:ncol(c.xts), function(j) {
    cx <- cummax(c.xts[, j])
    c.xts[, j] / cx # removed dd assignment
  }))

  # tagged dataframes to facilitate facet grid subsetting
  pc <- data.frame(Date = zoo::index(c.xts),
                   Plot = "Cumulative",
                   c.xts,
                   stringsAsFactors = FALSE)
  pd <- data.frame(Date = zoo::index(d.xts),
                   Plot = "Drawdowns",
                   d.xts,
                   stringsAsFactors = FALSE)
  pf <- dplyr::bind_rows(pc, pd) %>%
    tidyr::gather(Series, Value, 3:ncol(pc)) %>%
    na.omit

  mindd <- min(d.xts, na.rm = TRUE)

  # facet plot
  p <- ggplot2::ggplot(pf,
                       ggplot2::aes(x = Date,
                                    y = Value,
                                    color = Series,
                                    fill = Series)) +
    ggplot2::geom_line(data = subset(pf, Plot == "Cumulative")) +
    ggplot2::geom_line(data = subset(pf, Plot == "Drawdowns")) +
    ggplot2::facet_grid(Plot~., scales = "free_y", space = "free_y") +
    ggplot2::ggtitle(ptitle) +
    ggplot2::xlab(NULL) +
    ggplot2::ylab(NULL) +
    ggplot2::theme(strip.text.y = ggplot2::element_text(size = 10))
  if ( ! is.na(drawdown_minima) ) {
    p <- p +
      ggplot2::geom_hline(ggplot2::aes(yintercept = mindd),
                          data = subset(pf, Plot == "Drawdowns"),
                          color = drawdown_minima,
                          linetype = "dashed")
  }
  return(p)
}