#
# xts: eXtensible time-series
#
# Copyright (C) 2009-2015 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
# Contributions from Ross Bennett and Joshua M. Ulrich
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv))
# Current design
#
# There is a main plot object that contains the plot title (and optional
# timespan), the x-axis labels and tick marks, and a list of 'panel' objects.
# The main plot object contains the objects/functions below.
#
# * Env: an environment holds all the plot information.
# * add_main_header(): add the main plot header
# * add_main_xaxis(): add the x-axis labels and ticks to the main plot.
# * new_panel(): create a new panel and add it to the plot.
# * get_xcoords(): get the x-coordinate values for the plot.
# * get_panel(): get a specific panel.
# * get_last_action_panel(): get the panel that had the last rendered action.
# * new_environment: create a new environment with 'Env' as its parent.
# Functions that aren't intended to be called externally:
#
# * update_panels(): re-calculate the x-axis and y-axis values.
# * render_panels(): render all the plot panels.
# * x_grid_lines(): plot the x-axis grid lines.
# * create_ylim(): create y-axis max/min, handling when max(x) == min(x).
# The panel object is composed of the following fields:
#
# * id: the numeric index of the panel in the plot's list of panels.
# * asp: the x/y aspect ratio for the panel (relative vertical size).
# * ylim: the ylim of the panel when it was created.
# * ylim_render: the ylim of the panel to use when rendering.
# * use_fixed_ylim: do not update the panel ylim based on all panels data
# * header: the panel title.
# * actions: a list of expressions used to render the panel.
# * add_action(): a function to add an action to the list.
#
# The panel has the 'yaxis_expr' expression for rendering the y-axis min/max
# values, labels, and grid lines/ticks. It also contains the x-axis grid
# expression because we need the y-axis min/max values to know where to draw
# the x-axis grid lines on the panel.
# Other notes
#
# Environments created by new_environment() (e.g. the 'lenv') are children of
# Env, so expressions evaluated in 'lenv' will look in Env for anything not
# found in 'lenv'.
#
# Visual representation of plot structure
#
# ____________________________________________________________________________
# / \
# | plot object / window |
# | |
# | ______________________________________________________________________ |
# | / \ |
# | | panel #1 | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | header frame | | |
# | | \__________________________________________________________________/ | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | series frame | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | \__________________________________________________________________/ | |
# | \______________________________________________________________________/ |
# | |
# | ______________________________________________________________________ |
# | / \ |
# | | panel #2 | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | header frame | | |
# | | \__________________________________________________________________/ | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | series frame | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | \__________________________________________________________________/ | |
# | \______________________________________________________________________/ |
# | |
# \____________________________________________________________________________/
#
# Currently not necessary, but potentially very useful:
# http://www.fromthebottomoftheheap.net/2011/07/23/passing-non-graphical-parameters-to-graphical-functions-using/
chart.lines <- function(x,
type="l",
lty=1,
lwd=2,
lend=1,
col=NULL,
up.col=NULL,
dn.col=NULL,
legend.loc=NULL,
log=FALSE,
...){
xx <- current.xts_chob()
switch(type,
h={
# use up.col and dn.col if specified
if (!is.null(up.col) && !is.null(dn.col)){
colors <- ifelse(x[,1] < 0, dn.col, up.col)
} else {
colors <- if (is.null(col)) 1 else col
}
if (length(colors) < nrow(x[,1]))
colors <- colors[1]
# x-coordinates for this column
xcoords <- xx$get_xcoords(x[,1])
lines(xcoords,x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h",...)
},
p=, l=, b=, c=, o=, s=, S=, n={
if(is.null(col))
col <- xx$Env$theme$col
if(length(lty) < NCOL(x)) lty <- rep(lty, length.out = NCOL(x))
if(length(lwd) < NCOL(x)) lwd <- rep(lwd, length.out = NCOL(x))
if(length(col) < NCOL(x)) col <- rep(col, length.out = NCOL(x))
for(i in NCOL(x):1) {
# x-coordinates for this column
xcoords <- xx$get_xcoords(x[,i])
xi <- x[,i]
if (isTRUE(log)) xi <- log(xi)
lines(xcoords, xi, type=type, lend=lend, col=col[i],
lty=lty[i], lwd=lwd[i], ...)
}
},
{
# default case
warning(paste(type, "not recognized. Type must be one of
'p', 'l', 'b, 'c', 'o', 'h', 's', 'S', 'n'.
plot.xts supports the same types as plot.default,
see ?plot for valid arguments for type"))
}
)
if(!is.null(legend.loc)){
lc <- legend.coords(legend.loc, xx$Env$xlim, range(x, na.rm=TRUE))
legend(x=lc$x, y=lc$y, legend=colnames(x), xjust=lc$xjust, yjust=lc$yjust,
fill=col[1:NCOL(x)], bty="n")
}
}
add.par.from.dots <- function(call., ...) {
stopifnot(is.call(call.))
# from graphics:::.Pars
parnames <- c("xlog","ylog","adj","ann","ask","bg","bty","cex","cex.axis",
"cex.lab","cex.main","cex.sub","cin","col","col.axis","col.lab",
"col.main","col.sub","cra","crt","csi","cxy","din","err",
"family", "fg","fig","fin","font","font.axis","font.lab",
"font.main","font.sub","lab","las","lend","lheight","ljoin",
"lmitre","lty","lwd","mai","mar","mex","mfcol","mfg","mfrow",
"mgp","mkh","new","oma","omd","omi","page","pch","pin","plt",
"ps","pty","smo","srt","tck","tcl","usr","xaxp","xaxs","xaxt",
"xpd","yaxp","yaxs","yaxt","ylbias")
dots <- list(...)
argnames <- names(dots)
pm <- match(argnames, parnames, nomatch = 0L)
call.list <- as.list(call.)
# only pass the args from dots ('...') that are in parnames
as.call(c(call.list, dots[pm > 0L]))
}
isNullOrFalse <- function(x) {
is.null(x) || identical(x, FALSE)
}
# Main plot.xts method.
# author: Ross Bennett (adapted from Jeffrey Ryan's chart_Series)
plot.xts <- function(x,
y=NULL,
...,
subset="",
panels=NULL,
multi.panel=FALSE,
col=1:8,
up.col=NULL,
dn.col=NULL,
bg="#FFFFFF",
type="l",
lty=1,
lwd=2,
lend=1,
main=deparse(substitute(x)),
main.timespan=TRUE,
observation.based=FALSE,
log=FALSE,
ylim=NULL,
yaxis.same=TRUE,
yaxis.left=TRUE,
yaxis.right=TRUE,
yaxis.ticks=5,
major.ticks="auto",
minor.ticks=NULL,
grid.ticks.on="auto",
grid.ticks.lwd=1,
grid.ticks.lty=1,
grid.col="darkgray",
labels.col="#333333",
format.labels=TRUE,
grid2="#F5F5F5",
legend.loc=NULL,
extend.xaxis=FALSE){
# Small multiples with multiple pages behavior occurs when multi.panel is
# an integer. (i.e. multi.panel=2 means to iterate over the data in a step
# size of 2 and plot 2 panels on each page
# Make recursive calls and return
if(is.numeric(multi.panel)){
multi.panel <- min(NCOL(x), multi.panel)
idx <- seq.int(1L, NCOL(x), 1L)
chunks <- split(idx, ceiling(seq_along(idx)/multi.panel))
# allow color and line attributes for each panel in a multi.panel plot
if(length(lty) < ncol(x)) lty <- rep(lty, length.out = ncol(x))
if(length(lwd) < ncol(x)) lwd <- rep(lwd, length.out = ncol(x))
if(length(col) < ncol(x)) col <- rep(col, length.out = ncol(x))
if(!is.null(panels) && nchar(panels) > 0){
# we will plot the panels, but not plot the data by column
multi.panel <- FALSE
} else {
# we will plot the data by column, but not the panels
multi.panel <- TRUE
panels <- NULL
# set the ylim based on the data passed into the x argument
if(yaxis.same)
ylim <- range(x[subset], na.rm=TRUE)
}
for(i in 1:length(chunks)){
tmp <- chunks[[i]]
p <- plot.xts(x=x[,tmp],
y=y,
...=...,
subset=subset,
panels=panels,
multi.panel=multi.panel,
col=col[tmp],
up.col=up.col,
dn.col=dn.col,
bg=bg,
type=type,
lty=lty[tmp],
lwd=lwd[tmp],
lend=lend,
main=main,
observation.based=observation.based,
log=log,
ylim=ylim,
yaxis.same=yaxis.same,
yaxis.left=yaxis.left,
yaxis.right=yaxis.right,
yaxis.ticks=yaxis.ticks,
major.ticks=major.ticks,
minor.ticks=minor.ticks,
grid.ticks.on=grid.ticks.on,
grid.ticks.lwd=grid.ticks.lwd,
grid.ticks.lty=grid.ticks.lty,
grid.col=grid.col,
labels.col=labels.col,
format.labels=format.labels,
grid2=grid2,
legend.loc=legend.loc,
extend.xaxis=extend.xaxis)
if(i < length(chunks))
print(p)
}
# NOTE: return here so we don't draw another chart
return(p)
}
cs <- new.replot_xts()
# major.ticks shouldn't be null so we'll set major.ticks here if it is null
if(is.null(major.ticks)) {
xs <- x[subset]
mt <- c(years=nyears(xs),
months=nmonths(xs),
days=ndays(xs))
major.ticks <- names(mt)[rev(which(mt < 30))[1]]
}
# add theme and charting parameters to Env
plot.call <- match.call(expand.dots=TRUE)
cs$Env$theme <-
list(up.col = up.col,
dn.col = dn.col,
col = col,
rylab = yaxis.right,
lylab = yaxis.left,
bg = bg,
grid = grid.col,
grid2 = grid2,
labels = labels.col,
# String rotation in degrees. See comment about 'crt'. Only supported by text()
srt = if (hasArg("srt")) eval.parent(plot.call$srt) else 0,
# Rotation of axis labels:
# 0: parallel to the axis (default),
# 1: horizontal,
# 2: perpendicular to the axis,
# 3: vertical
las = if (hasArg("las")) eval.parent(plot.call$las) else 0,
# magnification for axis annotation relative to current 'cex' value
cex.axis = if (hasArg("cex.axis")) eval.parent(plot.call$cex.axis) else 0.9)
# /theme
# multiplier to magnify plotting text and symbols
cs$Env$cex <- if (hasArg("cex")) eval.parent(plot.call$cex) else 0.6
# lines of margin to the 4 sides of the plot: c(bottom, left, top, right)
cs$Env$mar <- if (hasArg("mar")) eval.parent(plot.call$mar) else c(3,2,0,2)
# check for colorset or col argument
# if col has a length of 1, replicate to NCOL(x) so we can keep it simple
# and color each line by its index in col
if(hasArg("colorset")) col <- eval.parent(plot.call$colorset)
if(length(col) < ncol(x)) col <- rep(col, length.out = ncol(x))
cs$Env$format.labels <- format.labels
cs$Env$yaxis.ticks <- yaxis.ticks
cs$Env$major.ticks <- if (isTRUE(major.ticks)) "auto" else major.ticks
cs$Env$minor.ticks <- if (isTRUE(minor.ticks)) "auto" else minor.ticks
cs$Env$grid.ticks.on <- if (isTRUE(grid.ticks.on)) "auto" else grid.ticks.on
cs$Env$grid.ticks.lwd <- grid.ticks.lwd
cs$Env$grid.ticks.lty <- grid.ticks.lty
cs$Env$type <- type
# if lty or lwd has a length of 1, replicate to NCOL(x) so we can keep it
# simple and draw each line with attributes by index
if(length(lty) < ncol(x)) lty <- rep(lty, length.out = ncol(x))
if(length(lwd) < ncol(x)) lwd <- rep(lwd, length.out = ncol(x))
cs$Env$lty <- lty
cs$Env$lwd <- lwd
cs$Env$lend <- lend
cs$Env$legend.loc <- legend.loc
cs$Env$extend.xaxis <- extend.xaxis
cs$Env$observation.based <- observation.based
cs$Env$log <- isTRUE(log)
# Do some checks on x
if(is.character(x))
stop("'x' must be a time-series object")
# Raw returns data passed into function
cs$Env$xdata <- x
cs$Env$xsubset <- subset
cs$Env$column_names <- colnames(x)
cs$Env$nobs <- NROW(cs$Env$xdata)
cs$Env$main <- main
cs$Env$main.timespan <- main.timespan
cs$Env$ylab <- if (hasArg("ylab")) eval.parent(plot.call$ylab) else ""
xdata_ylim <- cs$create_ylim(cs$Env$xdata[subset,])
if(isTRUE(multi.panel)){
n_cols <- NCOL(cs$Env$xdata)
asp <- ifelse(n_cols > 1, n_cols, 3)
if (hasArg("yaxis.same") && hasArg("ylim") && !is.null(ylim)) {
warning("only 'ylim' or 'yaxis.same' should be provided; using 'ylim'")
}
for(i in seq_len(n_cols)) {
# create a local environment for each panel
lenv <- cs$new_environment()
lenv$xdata <- cs$Env$xdata[subset,i]
lenv$type <- cs$Env$type
if (is.null(ylim)) {
if (yaxis.same) {
lenv$ylim <- xdata_ylim # set panel ylim using all columns
lenv$use_fixed_ylim <- FALSE # update panel ylim when rendering
} else {
panel_ylim <- cs$create_ylim(lenv$xdata)
lenv$ylim <- panel_ylim # set panel ylim using this column
lenv$use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
} else {
lenv$ylim <- ylim # use the ylim argument value
lenv$use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
# allow color and line attributes for each panel in a multi.panel plot
lenv$lty <- cs$Env$lty[i]
lenv$lwd <- cs$Env$lwd[i]
lenv$col <- cs$Env$theme$col[i]
lenv$log <- isTRUE(log)
exp <- quote(chart.lines(xdata[xsubset],
type=type,
lty=lty,
lwd=lwd,
lend=lend,
col=col,
log=log,
up.col=theme$up.col,
dn.col=theme$dn.col,
legend.loc=legend.loc))
exp <- as.expression(add.par.from.dots(exp, ...))
# create the panels
this_panel <-
cs$new_panel(lenv$ylim,
asp = asp,
envir = lenv,
header = cs$Env$column_names[i],
draw_left_yaxis = yaxis.left,
draw_right_yaxis = yaxis.right,
use_fixed_ylim = lenv$use_fixed_ylim,
use_log_yaxis = log)
# plot data
this_panel$add_action(exp, env = lenv)
}
} else {
if(type == "h" && NCOL(x) > 1)
warning("only the univariate series will be plotted")
if (is.null(ylim)) {
yrange <- xdata_ylim # set ylim using all columns
use_fixed_ylim <- FALSE # update panel ylim when rendering
} else {
yrange <- ylim # use the ylim argument value
use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
# create the chart's main panel
main_panel <-
cs$new_panel(ylim = yrange,
asp = 3,
envir = cs$Env,
header = "",
use_fixed_ylim = use_fixed_ylim,
draw_left_yaxis = yaxis.left,
draw_right_yaxis = yaxis.right,
use_log_yaxis = log)
exp <- quote(chart.lines(xdata[xsubset],
type=type,
lty=lty,
lwd=lwd,
lend=lend,
col=theme$col,
log=log,
up.col=theme$up.col,
dn.col=theme$dn.col,
legend.loc=legend.loc))
exp <- as.expression(add.par.from.dots(exp, ...))
main_panel$add_action(exp)
assign(".xts_chob", cs, .plotxtsEnv)
}
# Plot the panels or default to a simple line chart
if(!is.null(panels) && nchar(panels) > 0) {
panels <- parse(text=panels, srcfile=NULL)
for( p in 1:length(panels)) {
if(length(panels[p][[1]][-1]) > 0) {
cs <- eval(panels[p])
} else {
cs <- eval(panels[p])
}
}
}
assign(".xts_chob", cs, .plotxtsEnv)
cs
}
# apply a function to the xdata in the xts chob and add a panel with the result
addPanel <- function(FUN, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=1, ...){
# get the chob and the raw data (i.e. xdata)
chob <- current.xts_chob()
# xdata will be passed as first argument to FUN
xdata <- chob$Env$xdata
fun <- match.fun(FUN)
.formals <- formals(fun)
if("..." %in% names(.formals)) {
# Just call do.call if FUN has '...'
x <- try(do.call(fun, c(list(xdata), list(...)), quote=TRUE), silent=TRUE)
} else {
# Otherwise, ensure we only pass relevant args to FUN
.formals <- modify.args(formals=.formals, arglist=list(...))
.formals[[1]] <- quote(xdata)
x <- try(do.call(fun, .formals), silent=TRUE)
}
if(inherits(x, "try-error")) {
message(paste("FUN function failed with message", x))
return(NULL)
}
addSeriesCall <- quote(addSeries(x = x, main = main, on = on,
type = type, col = col, lty = lty, lwd = lwd, pch = pch))
addSeriesCall <- add.par.from.dots(addSeriesCall, ...)
eval(addSeriesCall)
}
# Add a time series to an existing xts plot
# author: Ross Bennett
addSeries <- function(x, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=1, ...){
plot_object <- current.xts_chob()
lenv <- plot_object$new_environment()
lenv$plot_lines <- function(x, ta, on, type, col, lty, lwd, pch, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
xDataSubset <- xdata[xsubset]
# we can add points that are not necessarily at the points
# on the main series, but need to ensure the new series only
# has index values within the xdata subset
if(xsubset == "") {
subset.range <- xsubset
} else {
fmt <- "%Y-%m-%d %H:%M:%OS6"
subset.range <- paste(format(start(xDataSubset), fmt),
format(end(xDataSubset), fmt), sep = "/")
}
xds <- .xts(, .index(xDataSubset), tzone=tzone(xdata))
ta.y <- merge(ta, xds)[subset.range]
if (!isTRUE(x$Env$extend.xaxis)) {
xi <- .index(ta.y)
xc <- .index(xds)
xsubset <- which(xi >= xc[1] & xi <= xc[length(xc)])
ta.y <- ta.y[xsubset]
}
chart.lines(ta.y, type=type, col=col, lty=lty, lwd=lwd, pch=pch, ...)
}
# get tag/value from dots
expargs <- substitute(alist(ta=x,
on=on,
type=type,
col=col,
lty=lty,
lwd=lwd,
pch=pch,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_lines),
x = quote(current.xts_chob()),
expargs))
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(hasArg("ylim")) {
ylim <- eval.parent(substitute(alist(...))$ylim)
} else {
ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
if(all(ylim == 0)) ylim <- c(-1, 1)
}
lenv$ylim <- ylim
if(is.na(on[1])){
# add series to a new panel
use_log <- isTRUE(eval.parent(substitute(alist(...))$log))
this_panel <- plot_object$new_panel(lenv$ylim,
asp = 1,
envir = lenv,
header = main,
use_log_yaxis = use_log)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Add time series of lines to an existing xts plot
# author: Ross Bennett
lines.xts <- function(x, ..., main="", on=0, col=NULL, type="l", lty=1, lwd=1, pch=1){
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- current.xts_chob()$get_last_action_panel()$id
addSeries(x, ...=..., main=main, on=on, type=type, col=col, lty=lty, lwd=lwd, pch=pch)
}
# Add time series of points to an existing xts plot
# author: Ross Bennett
points.xts <- function(x, ..., main="", on=0, col=NULL, pch=1){
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- current.xts_chob()$get_last_action_panel()$id
addSeries(x, ...=..., main=main, on=on, type="p", col=col, pch=pch)
}
# Add vertical lines to an existing xts plot
# author: Ross Bennett
addEventLines <- function(events, main="", on=0, lty=1, lwd=1, col=1, ...){
events <- try.xts(events)
plot_object <- current.xts_chob()
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- plot_object$get_last_action_panel()$id
if(nrow(events) > 1){
if(length(lty) == 1) lty <- rep(lty, nrow(events))
if(length(lwd) == 1) lwd <- rep(lwd, nrow(events))
if(length(col) == 1) col <- rep(col, nrow(events))
}
lenv <- plot_object$new_environment()
lenv$plot_event_lines <- function(x, events, on, lty, lwd, col, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ypos <- x$get_panel(on)$ylim[2] * 0.995
# we can add points that are not necessarily at the points on the main series
subset.range <-
paste(format(start(xdata[xsubset]), "%Y%m%d %H:%M:%OS6"),
format(end(xdata[xsubset]), "%Y%m%d %H:%M:%OS6"),
sep = "/")
ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
.index(xdata[xsubset]),
tzone=tzone(xdata)),
.xts(rep(1, NROW(events)),# use numeric for the merge
.index(events)))[subset.range]
# should we not merge and only add events that are in index(xdata)?
ta.y <- ta.adj[,-1]
# the merge should result in NAs for any object that is not in events
event.ind <- which(!is.na(ta.y))
abline(v=x$get_xcoords()[event.ind], col=col, lty=lty, lwd=lwd)
text(x=x$get_xcoords()[event.ind], y=ypos,
labels=as.character(events[,1]),
col=x$Env$theme$labels, ...)
}
# get tag/value from dots
expargs <- substitute(alist(events=events,
on=on,
lty=lty,
lwd=lwd,
col=col,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_event_lines),
x = quote(current.xts_chob()),
expargs))
if(is.na(on[1])){
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- xdata
ylim <- range(xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
# add series to a new panel
this_panel <- plot_object$new_panel(lenv$ylim,
asp = 1,
envir = lenv,
header = main)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Add legend to an existing xts plot
# author: Ross Bennett
addLegend <- function(legend.loc="topright", legend.names=NULL, col=NULL, ncol=1, on=0, ...){
plot_object <- current.xts_chob()
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- plot_object$get_last_action_panel()$id
lenv <- plot_object$new_environment()
lenv$plot_legend <- function(x, legend.loc, legend.names, col, ncol, on, bty, text.col, ...){
if(is.na(on[1])){
yrange <- c(0, 1)
} else {
panel <- x$get_panel(on)
yrange <- panel$ylim_render
}
# this just gets the data of the main plot
# TODO: get the data of panels[on]
if(is.null(ncol)){
ncol <- NCOL(x$Env$xdata)
}
if(is.null(col)){
col <- x$Env$theme$col[1:NCOL(x$Env$xdata)]
}
if(is.null(legend.names)){
legend.names <- x$Env$column_names
}
if(missing(bty)){
bty <- "n"
}
if(missing(text.col)){
text.col <- x$Env$theme$labels
}
lc <- legend.coords(legend.loc, x$Env$xlim, yrange)
legend(x=lc$x, y=lc$y, legend=legend.names, xjust=lc$xjust, yjust=lc$yjust,
ncol=ncol, col=col, bty=bty, text.col=text.col, ...)
}
# get tag/value from dots
expargs <- substitute(alist(legend.loc=legend.loc,
legend.names=legend.names,
col=col,
ncol=ncol,
on=on,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_legend),
x = quote(current.xts_chob()),
expargs))
# if on[1] is NA, then add a new frame for the legend
if(is.na(on[1])){
# add legend to a new panel
this_panel <- plot_object$new_panel(ylim = c(0, 1),
asp = 0.8,
envir = lenv,
header = "")
# legend data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Determine legend coordinates based on legend location,
# range of x values and range of y values
legend.coords <- function(legend.loc, xrange, yrange) {
switch(legend.loc,
topleft = list(xjust = 0, yjust = 1, x = xrange[1], y = yrange[2]),
left = list(xjust = 0, yjust = 0.5, x = xrange[1], y = sum(yrange) / 2),
bottomleft = list(xjust = 0, yjust = 0, x = xrange[1], y = yrange[1]),
top = list(xjust = 0.5, yjust = 1, x = (xrange[1] + xrange[2]) / 2, y = yrange[2]),
center = list(xjust = 0.5, yjust = 0.5, x = (xrange[1] + xrange[2]) / 2, y = sum(yrange) / 2),
bottom = list(xjust = 0.5, yjust = 0, x = (xrange[1] + xrange[2]) / 2, y = yrange[1]),
topright = list(xjust = 1, yjust = 1, x = xrange[2], y = yrange[2]),
right = list(xjust = 1, yjust = 0.5, x = xrange[2], y = sum(yrange) / 2),
bottomright = list(xjust = 1, yjust = 0, x = xrange[2], y = yrange[1])
)
}
# Add a polygon to an existing xts plot
# author: Ross Bennett
addPolygon <- function(x, y=NULL, main="", on=NA, col=NULL, ...){
# add polygon to xts plot based on http://dirk.eddelbuettel.com/blog/2011/01/16/
# some simple checks
x <- try.xts(x)
if(!is.null(y)) stop("y is not null")
if(ncol(x) > 2) warning("more than 2 columns detected in x, only the first 2 will be used")
plot_object <- current.xts_chob()
lenv <- plot_object$new_environment()
lenv$plot_lines <- function(x, ta, on, col, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
xDataSubset <- xdata[xsubset]
if(is.null(col)) col <- x$Env$theme$col
# we can add points that are not necessarily at the points
# on the main series, but need to ensure the new series only
# has index values within the xdata subset
if(xsubset == "") {
subset.range <- xsubset
} else {
fmt <- "%Y-%m-%d %H:%M:%OS6"
subset.range <- paste(format(start(xDataSubset), fmt),
format(end(xDataSubset), fmt), sep = "/")
}
xds <- .xts(, .index(xDataSubset), tzone=tzone(xdata))
ta.y <- merge(ta, xds)[subset.range]
# NAs in the coordinates break the polygon which is not the behavior we want
ta.y <- na.omit(ta.y)
# x coordinates
n <- seq_len(NROW(ta.y))
xx <- x$get_xcoords(ta.y)[c(1, n, rev(n))]
# y coordinates upper and lower
# assume first column is upper and second column is lower y coords for
# initial prototype
yu <- as.vector(coredata(ta.y[,1]))
yl <- as.vector(coredata(ta.y[,2]))
polygon(x=xx, y=c(yl[1], yu, rev(yl)), border=NA, col=col, ...)
}
# get tag/value from dots
expargs <- substitute(alist(ta=x,
col=col,
on=on,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_lines),
x = quote(current.xts_chob()),
expargs))
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(hasArg("ylim")) {
ylim <- eval.parent(substitute(alist(...))$ylim)
} else {
ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
if(all(ylim == 0)) ylim <- c(-1, 1)
}
lenv$ylim <- ylim
if(is.na(on[1])){
# add series to a new panel
this_panel <- plot_object$new_panel(ylim = lenv$ylim,
asp = 1,
envir = lenv,
header = main)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}# polygon
# Based on quantmod/R/replot.R
new.replot_xts <- function(panel=1,asp=1,xlim=c(1,10),ylim=list(structure(c(1,10),fixed=FALSE))) {
# global variables
# 'Env' is mainly the environment for the plot window, but some elements are for panels/frames
Env <- new.env()
Env$active_panel_i <- panel
Env$asp <- 1
Env$xlim <- xlim # vector: c(min, max) (same for every panel)
Env$last_action_panel_id <- 1
# getters
get_ylim <- function() { update_panels(); get_active_panel()[["ylim_render"]] }
get_xlim <- function() { update_panels(); Env$xlim }
get_active_panel <- function() { get_panel(Env$active_panel_i) }
get_last_action_panel <- function() { get_panel(Env$last_action_panel_id) }
get_panel <- function(n)
{
if (n == 0) {
get_last_action_panel()
} else if (n > 0) {
Env$panels[[n]]
} else {
stop("'n' must be a positive integer")
}
}
add_panel_action <-
function(id,
expr,
env,
clip = TRUE,
where = c("last", "first", "background"),
...)
{
if (id < 0) {
where <- "first"
} else {
where <- match.arg(where)
}
this_panel <- get_panel(abs(id))
this_panel$add_action(expr, env, clip, where, ...)
}
create_ylim <-
function(x, const_y_mult = 0.2)
{
# Create y-axis limits from 'x'. Jitter the max/min limits by
# 'const_y_mult' if the max/min values are the same.
lim <- range(x, na.rm = TRUE)
if(isTRUE(all.equal(lim[1L], lim[2L]))) {
# if max and min are the same
if(lim[1L] == 0) {
lim <- c(-1, 1)
} else {
lim <- lim[1L] * c(1 - const_y_mult, 1 + const_y_mult)
}
}
return(lim)
}
# loop over panels and then actions
render_panels <-
function()
{
update_panels()
# all panel header/series asp pairs
all_asp <- lapply(Env$panels, function(p) p[["asp"]])
all_asp <- do.call(c, all_asp)
# panel header asp is always 5% of the total asp
panel_header_asp <- 0.05 * sum(all_asp)
# update panel header asp values
header_loc <- seq(1, length(all_asp), by = 2)
all_asp[header_loc] <- panel_header_asp
# main header asp is always 4% of the grand total asp
main_title_asp <- 0.04 * sum(all_asp)
all_asp <- c(main_title_asp, all_asp)
n_asp <- length(all_asp)
# render main plot header and x-axis
plot.window(Env$xlim, c(0, 1))
clip(par("usr")[1], par("usr")[2], 0, 1)
eval(Env$main_header_expr, Env) # header
eval(Env$main_xaxis_expr, Env) # x-axis
# render each panel
for (panel_n in seq_along(Env$panels)) {
panel <- Env$panels[[panel_n]]
# set the current active panel for the entire plot
Env$active_panel_i <- panel_n
is_header <- TRUE # header is always the first action
for (action in panel$actions) {
if (is_header) {
is_header <- FALSE
asp <- panel_header_asp
asp_n <- 2 * panel_n
ylim <- c(0, 1)
} else {
asp <- panel$asp["series"]
asp_n <- 2 * panel_n + 1
ylim <- panel$ylim_render
}
# scaled ylim
ylim_scale <- all_asp / asp * abs(diff(ylim))
ymin_adj <- sum(ylim_scale[-seq_len(asp_n)])
ymax_adj <- sum(ylim_scale[-(asp_n:n_asp)])
scaled_ylim <- c(ylim[1] - ymin_adj, ylim[2] + ymax_adj)
plot.window(Env$xlim, scaled_ylim)
if (attr(action, "clip")) {
clip(par("usr")[1], par("usr")[2], ylim[1], ylim[2])
}
action_env <- attr(action, "env")
eval(action, action_env)
}
}
}
get_xcoords <- function(xts_object = NULL, at_posix = FALSE) {
# unique index for all series (always POSIXct)
xcoords <- Env$xycoords$x
if (!is.null(xts_object)) {
# get the x-coordinates for the observations in xts_object
temp_xts <- .xts(seq_along(xcoords), xcoords, tzone = tzone(xts_object))
xcoords <- merge(temp_xts, xts_object,
fill = na.locf, # for duplicate index values
join = "right", retside = c(TRUE, FALSE))
if (!isTRUE(Env$extend.xaxis)) {
xc <- Env$xycoords$x
xi <- .index(xcoords)
xsubset <- which(xi >= xc[1] & xi <= xc[length(xc)])
xcoords <- xcoords[xsubset]
}
if(Env$observation.based && !at_posix) {
result <- drop(coredata(xcoords))
} else {
result <- .index(xcoords)
}
} else {
if(Env$observation.based && !at_posix) {
result <- seq_along(xcoords)
} else {
result <- xcoords
}
}
return(result)
}
# main plot header
Env$main_header_expr <- expression({
local({
text(x = xlim[1],
y = 1.0,
labels = main,
adj = c(0, 1),
cex = 1.1,
col = theme$labels,
font = 2)
if (main.timespan) {
text(x = xlim[2],
y = 1.0,
labels = paste(start(xdata[xsubset]),
end(xdata[xsubset]), sep = " / "),
adj = c(1, 1),
cex = 1,
col = theme$labels,
font = NULL)
}
}, new.env(TRUE, Env))
})
# main plot x-axis
Env$main_xaxis_expr <- expression({
local({
# add observation level ticks on x-axis if < 400 obs.
if (NROW(xdata[xsubset]) < 400) {
axis(1,
at = get_xcoords(),
labels = FALSE,
las = theme$las,
lwd.ticks = NULL,
mgp = NULL,
tcl = 0.3,
cex.axis = theme$cex.axis,
col = theme$labels,
col.axis = theme$grid2)
}
# and major and/or minor x-axis ticks and labels
xcoords <- get_xcoords()
x_index <- get_xcoords(at_posix = TRUE)
x_data <- .xts(, x_index, tzone = tzone(xdata))[xsubset]
use_major <- !isNullOrFalse(major.ticks)
use_minor <- !isNullOrFalse(minor.ticks)
types <- c("major", "minor")[c(use_major, use_minor)]
for (type in types) {
if (type== "major") {
axt <- axTicksByTime(x_data,
ticks.on = major.ticks,
format.labels = format.labels)
labels <- names(axt)
lwd.ticks <- 1.5
} else {
axt <- axTicksByTime(x_data,
ticks.on = minor.ticks,
format.labels = format.labels)
labels <- FALSE
lwd.ticks <- 0.75
}
axis(1,
at = xcoords[axt],
labels = labels,
las = theme$las,
lwd.ticks = lwd.ticks,
mgp = c(3,1.5,0),
tcl = -0.4,
cex.axis = theme$cex.axis,
col = theme$labels,
col.axis = theme$labels)
}
}, new.env(TRUE, Env))
})
# panel functionality
Env$panels <- list()
new_panel <-
function(ylim,
asp,
envir,
header,
...,
use_fixed_ylim = FALSE,
draw_left_yaxis = NULL,
draw_right_yaxis = NULL,
use_log_yaxis = FALSE,
title_timespan = FALSE)
{
panel <- new.env(TRUE, envir)
panel$id <- length(Env$panels) + 1
panel$asp <- c(header = 0.25, series = asp)
panel$ylim <- ylim
panel$ylim_render <- ylim
panel$use_fixed_ylim <- isTRUE(use_fixed_ylim)
panel$draw_left_yaxis <- ifelse(is.null(draw_left_yaxis), Env$theme$lylab, draw_left_yaxis)
panel$draw_right_yaxis <- ifelse(is.null(draw_right_yaxis), Env$theme$rylab, draw_right_yaxis)
panel$use_log_yaxis <- isTRUE(use_log_yaxis)
panel$header <- header
### actions
panel$actions <- list()
panel$add_action <-
function(expr,
env = Env,
clip = TRUE,
where = c("last", "first", "background"),
...)
{
if (!is.expression(expr)) {
expr <- as.expression(expr)
}
action <- structure(expr, clip = clip, env = env, ...)
panel$actions <-
switch(match.arg(where),
last = {
# after all the existing actions
append(panel$actions, list(action))
},
first = {
# after the header and grid lines
append(panel$actions, list(action), after = 3)
},
background = {
# after the header (which must be the 1st panel action)
append(panel$actions, list(action), after = 1)
})
Env$last_action_panel_id <<- panel$id
}
### header
# NOTE: this must be the 1st action for a panel
header_expr <-
expression({
text(x = xlim[1],
y = 0.3,
labels = header,
adj = c(0, 0),
pos = 4,
offset = 0,
cex = 0.9,
col = theme$labels,
font = NULL)
})
panel$add_action(header_expr, env = panel)
### y-axis
yaxis_expr <- expression({
if (use_fixed_ylim) {
# use the ylim argument
yl <- ylim
} else {
# use the updated ylim based on all panel data
yl <- ylim_render
}
# y-axis grid line labels and locations
if (use_log_yaxis) {
ylim_series <- exp(ylim_render)
# labels are based on the raw series values
grid_lbl <- pretty(ylim_series, Env$yaxis.ticks)
grid_lbl <- grid_lbl[grid_lbl >= ylim_series[1] & grid_lbl <= ylim_series[2]]
# locations are based on the log series values
grid_loc <- log(grid_lbl)
} else {
grid_loc <- pretty(yl, Env$yaxis.ticks)
grid_loc <- grid_loc[grid_loc >= yl[1] & grid_loc <= yl[2]]
grid_lbl <- grid_loc
}
# draw y-axis grid lines
segments(x0 = xlim[1], y0 = grid_loc,
x1 = xlim[2], y1 = grid_loc,
col = theme$grid,
lwd = grid.ticks.lwd,
lty = grid.ticks.lty)
# draw left y-axis grid labels
if (draw_left_yaxis) {
text(x = xlim[1],
y = grid_loc,
labels = format(grid_lbl, justify = "right"),
col = theme$labels,
srt = theme$srt,
offset = 0.5,
pos = 2,
cex = theme$cex.axis,
xpd = TRUE)
}
# draw right y-axis grid labels
if (draw_right_yaxis) {
text(x = xlim[2],
y = grid_loc,
labels = format(grid_lbl, justify = "right"),
col = theme$labels,
srt = theme$srt,
offset = 0.5,
pos = 4,
cex = theme$cex.axis,
xpd = TRUE)
}
# draw y-axis label
title(ylab = ylab[1], mgp = c(1, 1, 0))
})
panel$add_action(yaxis_expr, env = panel)
# x-axis grid
xaxis_action <- expression(x_grid_lines(xdata, grid.ticks.on, par("usr")[3:4]))
panel$add_action(xaxis_action, env = panel)
# append the new panel to the panel list
Env$panels <- append(Env$panels, list(panel))
return(panel)
}
update_panels <- function(headers=TRUE) {
# Recalculate each panel's 'ylim_render' value based on the
# 'xdata' of every action in the panel
for (panel_n in seq_along(Env$panels)) {
panel <- get_panel(panel_n)
if (!panel$use_fixed_ylim) {
# set 'ylim_render' to +/-Inf when ylim is NOT fixed, so
# it will be updated to include all the panel's data
panel$ylim_render <- c(Inf, -Inf)
# calculate a new ylim based on all the panel's data
for (action in panel$actions) {
action_env <- attr(action, "env")
action_data <- action_env$xdata
if (!is.null(action_data)) {
# some actions (e.g. addLegend) do not have 'xdata'
dat.range <- create_ylim(action_data[Env$xsubset])
# calculate new ylim based on the combination of the panel's
# original ylim and the action's 'xdata' ylim
new_ylim <-
c(min(panel$ylim[1], dat.range, na.rm = TRUE),
max(panel$ylim[2], dat.range, na.rm = TRUE))
# set to new ylim values
panel$ylim_render <- new_ylim
}
}
}
if (panel$use_log_yaxis) {
panel$ylim_render <- log(panel$ylim_render)
}
}
update_xaxis <- function(panel, x_axis)
{
# Create x-axis values using index values from data from all panels
for (action in panel$actions) {
action_env <- attr(action, "env")
action_data <- action_env$xdata
if (!is.null(action_data)) {
# some actions (e.g. addLegend) do not have 'xdata'
action_xaxis <- .index(action_data[Env$xsubset])
new_xaxis <- sort(unique(c(x_axis, action_xaxis)))
if (isTRUE(Env$extend.xaxis)) {
result <- new_xaxis
} else {
xaxis_rng <- range(x_axis, na.rm = TRUE)
result <- new_xaxis[new_xaxis >= xaxis_rng[1L] &
new_xaxis <= xaxis_rng[2L]]
}
}
}
return(result)
}
x_axis <- .index(Env$xdata[Env$xsubset])
for (panel in Env$panels) {
x_axis <- update_xaxis(panel, x_axis)
}
# Create x/y coordinates using the combined x-axis index
Env$xycoords <- xy.coords(x_axis, seq_along(x_axis))
if (Env$observation.based) {
Env$xlim <- c(1, length(get_xcoords()))
} else {
Env$xlim <- range(get_xcoords(), na.rm = TRUE)
}
}
# return
replot_env <- new.env()
class(replot_env) <- c("replot_xts","environment")
replot_env$Env <- Env
replot_env$new_panel <- new_panel
replot_env$get_xcoords <- get_xcoords
replot_env$update_panels <- update_panels
replot_env$render_panels <- render_panels
replot_env$get_panel <- get_panel
replot_env$add_panel_action <- add_panel_action
replot_env$get_xlim <- get_xlim
replot_env$get_ylim <- get_ylim
replot_env$create_ylim <- create_ylim
replot_env$get_last_action_panel <- get_last_action_panel
replot_env$new_environment <- function() { new.env(TRUE, Env) }
# function to plot the x-axis grid lines
replot_env$Env$x_grid_lines <- function(x, ticks.on, ylim)
{
if (isNullOrFalse(ticks.on)) {
invisible()
} else {
if (isTRUE(ticks.on)) ticks.on <- "auto"
xcoords <- get_xcoords()
x_index <- get_xcoords(at_posix = TRUE)
atbt <- axTicksByTime(.xts(, x_index, tzone = tzone(x)),
ticks.on = ticks.on)
segments(xcoords[atbt], ylim[1L],
xcoords[atbt], ylim[2L],
col = Env$theme$grid,
lwd = Env$grid.ticks.lwd,
lty = Env$grid.ticks.lty)
}
}
return(replot_env)
}
str.replot_xts <- function(object, ...) {
print(str(unclass(object)))
}
print.replot_xts <- function(x, ...) plot(x,...)
plot.replot_xts <- function(x, ...) {
# must set the background color before calling plot.new
obg <- par(bg = x$Env$theme$bg)
plot.new()
assign(".xts_chob",x,.plotxtsEnv)
# only reasonable way to fix X11/quartz issue
ocex <- par(cex = if(.Device == "X11") x$Env$cex else x$Env$cex * 1.5)
omar <- par(mar = x$Env$mar)
oxpd <- par(xpd = FALSE)
usr <- par("usr")
# reset par
on.exit(par(xpd = oxpd$xpd, cex = ocex$cex, mar = omar$mar, bg = obg$bg))
x$render_panels()
do.call("clip", as.list(usr)) # reset clipping region
invisible(x$Env$actions)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.