R/plot_wfoweights.R

Defines functions plot_wfoweights

Documented in plot_wfoweights

#
# FILE plot_wfoweights.R
#'
#' Plot WFO weights as a stacked bar chart.
#'
#' bla bla bla
#'
#' @param object       A WFO object from wfo_statfolio.  Alternatively, this can be an xts matrix
#'                     of weights, where each column is an asset, each row is a date and each element
#'                     represents the weigth of that asset on that date.
#'
#' @param lineobject   An xts matrix representing one or multiple lines (normally an equity curve)
#'                     to be plotted on top of the asset weights.  The y axis is normalized to show
#'                     the relative change in value. NOTE:  No NAs are allowed in this matrix, otherwise
#'                     it will not plot.
#'
#' @param monthend     Logical.  This is used to offset the weight bar plots if a strategy trades at the
#'                     end of the month. When set to TRUE, the asset allocation will be shown on the
#'                     following month in the weight bar chart. If an equity curve is plotted as an overlay
#'                     (lineobject is set to an xts), the timeframe will start at the beginning of the
#'                     first month shown, and end at the end of the last month show.  This ensures that
#'                     the equity curves shown roughly line up over the asset allocations for the month.
#'                     Default is FALSE.
#'
#' @param minrange     The minimum y range to plot lineobjects expressed as a percentage.  This is used
#'                     to ensure small range equity curves are not expanded across the entire plot to
#'                     give the impression of large changes when, in reality, the equity curve change
#'                     was tiny.  Default is 10 percent, expressed as 0.10.  NOT USED.
#'
#' @param yrange       If an equity curve is plotted, this sets the Y axis range on the plot.
#'                     Default is NA, which means the y range is automatically calculated.
#'
#' @return  Does not explicitly return anything.  This is a plotting function.
#'
#' @export
plot_wfoweights <- function(object, colorset = NULL, plot_assets = NA, legendcols = 4,
                            main = "Portfolio Asset Weights", lineobject = NA,
                            lineobj_col = c("black", "red", "green"), space = 0.1,
                            cex.legend = 0.8, cex.main = 1, cex.axis = 0.8,
                            ylab = "Portfolio Weight", mar = c(1.3,4,4,2)+.1,
                            lmar = c(0,6,0,6), monthend = FALSE, minrange = 0.1,
                            cex.lab = 1, yrange = NA, testmode = FALSE,
                            assets_traded = TRUE, las = 1, xlab = NULL, ...) {

  # ######################################################
  # # For Testing Only
  # library(ResilientPortfolio)
  # colorset     = make_colors(alpha = "7F")
  # plot_assets  = NA
  # legendcols   = 4
  # main         = "Portfolio Asset Weights"
  # cex.legend   = 0.8
  # cex.main     = 1
  # cex.axis     = 0.8
  # cex.lab      = 1
  # assets_traded = FALSE
  # testmode     = FALSE
  # space        = 0
  # ylab          = "Portfolio Weight (%)"
  # xlab         = NULL
  # mar           = c(1.3,4,4,6)+.1   # B,L,T,R
  # lmar         = c(0,6,0,6)
  # monthend     = TRUE
  # minrange     = 0.1
  # yrange       = c(-50, 20)
  # las          = 1
  #
  # object       = extractWeights(wfo_dataquarters)[1:6, ]
  # lineobject   = xts_data[, c("SPY", "BND")]
  # lineobj_col  = c("black", "red", "green")
  # ######################################################

  # Save output device parameters
  parmar <- par()$mar


  if(length(lineobject) > 1) line_overlay = TRUE else line_overlay = FALSE
  sprint("line_overlay = %s", line_overlay)

  if(any(class(object) %in% "optimize.portfolio.rebalancing"))
    rebal_weights <- extractWeights(object)
  else
    rebal_weights <- object    # assume an xts of weights

  index(rebal_weights) <- as.Date(index(rebal_weights))

  #----------------------------------------------------------
  # Adjust the dates if monthend is TRUE, by offsetting
  # by one month
  # Ensure month-end days are adjusted when offsetting.
  #----------------------------------------------------------
  rebaldates <- ymd(index(rebal_weights))
  if(monthend) {
    rebaldates <- rebaldates %m+% months(1)
    rebaldates <- floor_date(rebaldates, "months")
    Ndates     <- length(rebaldates)
    rebaldates[Ndates] <- ceiling_date(rebaldates[Ndates], "months") - ddays(1)
  }

  index(rebal_weights) <- rebaldates


  #---------------------------------------------------------
  # Ensure at least 3 weight dates to plot
  #---------------------------------------------------------
  if(nrow(rebal_weights) < 3) {
    sprint("Not Enough WFO dates to plot weights.  Must exceed 3 WFO dates.")
    sprint(" >>> SKIPPING PLOTTING OF WEIGHTS.")
    return(NULL)
  }


  asset_sums    <- apply(rebal_weights, 2, sum)
  asset_sums    <- asset_sums[asset_sums > 0]
  asset_names   <- names(asset_sums)


  #---------------------------------------------------------
  # Plot a subset of all assets, if specified
  #---------------------------------------------------------
  if(!is.na(plot_assets[[1]]))
    asset_names <- asset_names[asset_names %in% plot_assets]

  Nassets       <- length(asset_names)
  print(asset_names)

  if(assets_traded) main  <- paste(main, "\nNumber of Securities Traded: ", Nassets)

  #----------------------------------------------------------
  # Specify legend size and number of columns as needed
  #----------------------------------------------------------
  #Nassets = 2
  #asset_names <- asset_names[1:Nassets]

  modulo       <- Nassets %/% legendcols
  legend_cols  <- max(modulo, legendcols)
  cex.legend2  <- cex.legend - modulo * 0.025


  #------------------------------------------------------------
  # Set up default parameters for Stacked Bar Chart
  #------------------------------------------------------------
  w             = rebal_weights[, asset_names]
  #if(space == 0) inside <- FALSE else inside <- TRUE

  if(is.null(cex.main))   cex.main   = 1
  if(is.null(cex.axis))   cex.axis   = 0.8
  if(is.null(cex.lab))    cex.lab    = 1
  #if(is.null(cex.labels)) cex.labels = 0.8  #

  xaxis         = TRUE
  legend.loc    = "under"
  element.color = "darkgray"
  unstacked     = TRUE


  ylim          = NULL
  date.format   = "%b %y"
  major.ticks   = 'auto'
  minor.ticks   = TRUE
  xaxis.labels  = NULL


  ##################################################################################
  # The following reuses code from chart.StackedBar.xts from PerformanceAnalytics
  ##################################################################################

  w = checkData(w)
  w.columns = ncol(w)
  w.rows = nrow(w)

  time.scale = periodicity(w)$scale
  ep = axTicksByTime(w, major.ticks, format.labels = date.format)
  ep1 = ep
  posn = barplot(w, plot=FALSE, space=space)
  for(i in 1:length(ep))
    ep1[i] = posn[ep[i]]

  if(is.null(colorset))
    colorset=1:w.columns

  if(is.null(xlab)) minmargin = 3 else
    minmargin = 5

  # multiple columns being passed into 'w', so we'll stack the bars and put a legend underneith
  if(!is.null(legend.loc) ){
    if(legend.loc =="under") {# put the legend under the chart
      #op <- par(no.readonly=TRUE)
      layout(rbind(1,2), heights=c(6,1.5), widths=1)
      op <- par(mar=mar) # set the margins of the first panel
      # c(bottom, left, top, right)
    }

  }

  # Brute force solution for plotting negative values in the bar charts:
  positives = w
  for(column in 1:ncol(w)){
    for(row in 1:nrow(w)){
      positives[row,column]=max(0,w[row,column])
    }
  }

  negatives = w
  for(column in 1:ncol(w)){
    for(row in 1:nrow(w)){
      negatives[row,column]=min(0,w[row,column])
    }
  }
  # Set ylim accordingly
  if(is.null(ylim)){
    ymax=max(0,apply(positives,FUN=sum,MARGIN=1))
    ymin=min(0,apply(negatives,FUN=sum,MARGIN=1))
    ylim=c(ymin,ymax)
  }

  barplot(t(positives), col=colorset, space=space, axisnames = FALSE,
          axes = FALSE, ylim=ylim, main = main, cex.main = cex.main,
          cex.names = cex.lab, cex.axis = cex.axis)

  barplot(t(negatives), add=TRUE, col=colorset, space=space, las = las, xlab = xlab,
          cex.names = cex.lab, axes = FALSE, axisnames = FALSE, ylim=ylim,
          main = main, cex.main = cex.main, cex.axis = cex.axis, ...)

  #------------------------------------------------------------------
  # Y axis on the left (weights), plot the X axis
  #------------------------------------------------------------------
  axis(2, col = element.color, las = las, cex.axis = cex.axis)
  # title(ylab = ylab, cex.lab = cex.lab)
  mtext(ylab, side = 2, line = 2.5 * cex.axis, cex = cex.lab)

  if (xaxis) {
    if(minor.ticks)
      axis(1, at=posn, labels=FALSE, col='#BBBBBB')
    label.height = .25 + cex.axis * apply(t(names(ep1)),1, function(X) max(strheight(X, units="in")/par('cin')[2]) )
    if(is.null(xaxis.labels))
      xaxis.labels = names(ep1)
    else
      ep1 = 1:length(xaxis.labels)
    axis(1, at=ep1, labels=xaxis.labels, las=las, lwd=1, mgp=c(3,label.height,0),
         cex.axis = cex.axis)

  }

  #--------------------------------------------------------
  # Overlay a line plot equity curve
  #--------------------------------------------------------
  if(line_overlay) {
    index(lineobject) <- as.Date(index(lineobject))
    lastceiling <- ceiling_date(index(last(rebal_weights)), "months") - ddays(1)
    timeframe   <- paste0(index(first(rebal_weights)), "/", lastceiling)

    lineobject  <- lineobject[timeframe, ]
    lineobj_mth <- lineobject[index(rebal_weights), ]

    #------------------------------------------------------------------
    # Normalize, scale and shift the equity curves to plot overlaid
    # Calculate the Y axis range and related offset.
    #------------------------------------------------------------------
    normec    <- apply(lineobject, 2, function(x) x / as.numeric(x[1])- 1) * 100

    boxmin    <- space    # Start at the edge of the first box
    boxmax    <- nrow(rebal_weights) * (1 + space)  # To end of last box
    boxrange  <- boxmax

    #-------------------------------------------------------------------------
    # Adjust X plotting range if lineobject doesn't end at monthend
    # Leave 2 days wiggle room in case month ends on a weekend.
    #-------------------------------------------------------------------------
    if(index(last(lineobject)) < lastceiling - ddays(2)) {
      unplotteddays <- as.numeric(lastceiling - index(last(lineobject)))
      boxmax        <- boxmax - (1 + space)  * unplotteddays / 30
    }

    npts      <- nrow(lineobject)
    xpts      <- seq(from = boxmin, to = boxmax, length.out = npts)

    lineobj_col <- recycle(lineobj_col, ncol(normec))

    # Set up new plotting region, with proper X and Y ranges
    # in two extreme corners
    par(new = TRUE)
    if(is.na(yrange[[1]])) yrange <- range(normec)
    plot(x = c(boxmin, boxrange), y = yrange, axes=F, xlab=NA, ylab=NA,
         type = "n") #, yaxp = c(range(ypretty), 9))

    # Horizontal line at starting equity curve level for reference
    lines(x = c(boxmin, boxrange), y = rep(as.numeric(normec[1,1]), 2),
          lty = "dashed", col = "blue")

    # Plot all equity curves
    for(i in 1:ncol(normec))
      lines(x = xpts, y = as.numeric(normec[, i]), lwd = 3, col = lineobj_col[i])

    # Right axis
    axis(side = 4, las = 1, cex.axis = cex.axis)
    mtext("Gains / Losses (%)", side = 4, line = 3 * cex.axis, cex = cex.lab)

  }

  #################################



  box(col = element.color)

  if(!is.null(legend.loc)){
    if(legend.loc =="under"){ # draw the legend under the chart
      op <- par(mar=lmar) # set the margins of the second panel
      # c(bottom, left, top, right)
      plot.new()
      if(w.columns < legend_cols)  # max number of columns in legend
        ncol= w.columns
      else
        ncol = legend_cols

      if(line_overlay) {
        # legend with line overlay information
        legend("left", legend=colnames(w), cex = cex.legend2, fill=colorset,
               ncol=ncol, box.col=element.color, border.col = element.color,
               title = expression(bold("Asset Weights Legend")))

        legend("right", legend = colnames(lineobject), cex = cex.legend2,
               fill = lineobj_col, ncol = 1, box.col = element.color,
               border.col = element.color, title = expression(bold("Line Legend")))

      } else {
        # legend without line overlay
        legend("center", legend=colnames(w), cex = cex.legend2, fill=colorset,
               ncol=ncol, box.col=element.color, border.col = element.color)
      }

    } # if legend.loc is null, then do nothing
  }

  # Reset par and layout as before function call
  if(!testmode) {
    par(mar = parmar)
    layout(matrix(1), height = 1, widths = 1)
  }

}
jeanmarcgp/ResilientPortfolio documentation built on April 8, 2018, 5:43 p.m.