# xtsExtra: Extensions to xts during GSOC-2012
#
# Copyright (C) 2012 Michael Weylandt: michael.weylandt@gmail.com
#
# Scatterplot code taken from plot.zoo in the CRAN zoo package
# Thanks to A. Zeilis & G.Grothendieck
#
# 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 3 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/>.
# To do:
# REMOVE par() ARGS FROM FORMALS AND INSTEAD TREAT ... BETTER [Still need to do "type"]
# I think layout is working, but need to turn off x/y labels smartly when things are adjacent
# Handle not adjacent cases
#
# DO LAYOUT WITHOUT USING LAYOUT -- NEED TO BE ABLE TO MOVE BETWEEN PLOTS WHEN ADDING LINES?
# GET LAYOUT TO SUPPORT ADJACENT COLUMNS
# HANDLE xlim AS ISO8601 AS WELL
# legend.loc
# COLOR GRADIENT FOR SCATTERPLOT CASE
# Combine OHLC and multi-panel (i.e., if passed cbind(SPY, AGG))
# candle.col is not supported?
# ylab.loc = c("left", "right", "out","in","flip","above") -- above kills panel alignment automatically
# Refactor plotting functionality into some non-exported bits
# It stopped handling ylab when I did the axis hardcoding -- should be smarter
## How I really want to handle screens
## Give user ultimate flexibility in setting up screens combining them as desired with layout-like interface
## Go by rows on matrix and whenever number of panels changes, add new time axis
## E.g. layout(matrix(c(1,1,1,1), ncol = 2) has one time axis
## E.g. layout(matrix(c(1,2,1,2), ncol = 2) has one time axis
## E.g. layout(matrix(c(1,2,1,3), ncol = 2) has three time axes -- one underneath the first set of panels, two more for each of the second row
## E.g. layout(matrix(c(1,2,3,1,4,5), ncol=2) has three time axes -- one underneath the first set of panels, two more for each of the third row [since shared with second]
# UNEXPORTED AND I THINK NOW SUPERCEDED
`old.plot.xts` <- function(x, y = NULL,
screens, screens.layout,
auto.grid=TRUE,
major.ticks='auto', minor.ticks=TRUE,
major.format=TRUE,
bar.col='grey', candle.col='white',
xy.labels = FALSE, xy.lines = NULL,
...) {
# Restore old par() options from what I change in here
old.par <- par(no.readonly = TRUE)
on.exit(par(old.par))
dots <- list(...)
setParGlb <- function(arg, default){
# See if par was passed through ...
# if so, use it, else use default
#
# Also strip from dots once it has been handled directly
# This is for "global" parameters
# See setParCol for ones which are columnwise (series-wise)
arg <- deparse(substitute(arg))
r <- if(arg %in% names(dots)){
r <- dots[[arg]]
dots[[arg]] <- NULL
assign("dots", dots, parent.frame())
r
} else {
default
}
}
setParCol <- function(arg, default, screens){
# See if par was passed through ...
# if so, use it, else use default
#
# Also strip from dots once it has been handled directly
# This is for column(series)-wise parameters
# Returns a list where each list gives the colwise parameters per panel
# Only used currently for time series columnwise
arg <- deparse(substitute(arg))
r <- if(arg %in% names(dots)){
r <- dots[[arg]]
dots[[arg]] <- NULL
assign("dots",dots, parent.frame())
r
} else {
return(default)
}
split(rep(r, length.out = length(screens)), screens)
}
setParScr <- function(arg, default, screens){
# See if par was passed through ...
# if so, use it, else use default
#
# Also strip from dots once it has been handled directly
# This is for column(series)-wise parameters
# Returns a list where each list gives the colwise parameters per panel
# Only used currently for time series screenwise
arg <- deparse(substitute(arg))
r <- if(arg %in% names(dots)){
r <- dots[[arg]]
dots[[arg]] <- NULL
assign("dots",dots, parent.frame())
r
} else {
default
}
rep(r, length.out = length(screens))
}
## if y supplied: scatter plot y ~ x
if(!is.null(y)) {
if(NCOL(x) > 1 || NCOL(y) > 1) stop("Scatter plots only for univariate series")
# Am I catching these early enough
xlab <- setParGlb(xlab, deparse(substitute(x)))
ylab <- setParGlb(ylab, deparse(substitute(y)))
main <- setParGlb(main, paste(xlab, "vs.", ylab))
log <- setParGlb(log, '')
cex <- setParGlb(cex, 0.7)
x <- try.xts(x); y <- try.xts(y)
xy.xts <- merge(x, y, join = "inner")
xy <- coredata(xy.xts)
xy <- xy.coords(xy[,1], xy[,2])
xlim <- setParGlb(xlim, range(xy$x[is.finite(xy$x)]))
ylim <- setParGlb(xlim, range(xy$y[is.finite(xy$y)]))
do.lab <- if(is.logical(xy.labels)) xy.labels else TRUE
if(is.null(xy.lines)) xy.lines <- do.lab
ptype <- setParGlb(type, if(do.lab) "n" else "p")
type <- setParGlb(type, if(do.lab) "c" else "l")
do.call("plot.default", c(xy[1:2], list(type = ptype, main = main, xlab = xlab,
ylab = ylab, xlim = xlim, ylim = ylim, log = log), dots))
if(do.lab) do.call("text",
c(xy[1:2], dots, list(cex = cex, labels = if(!is.logical(xy.labels)) xy.labels else index2char(index(xy.xts)))))
if(xy.lines) do.call("lines", c(xy[1:2], list(type = type), dots))
assign(".plot.xts", recordPlot(), .GlobalEnv)
return(invisible(xy.xts))
}
## Else : no y, only x
main <- setParGlb(main, deparse(substitute(x)))
xlab <- setParGlb(xlab, '')
axes <- setParGlb(axes, TRUE)
x <- try.xts(x)
# Catch OHLC case independently -- will violate DRY but that seems ok for now
if("type" %in% names(dots) && dots[["type"]] %in% c('candles','bars')){
type <- setParGlb(type, 'candles') # This default doesn't really matter since we can't get here without it existing already
if(!xts:::is.OHLC(x)) stop(type, '-chart not supported for non-OHLC series')
if(type == 'bars') stop('OHLC bars not yet supported.')
# Handle OHLC candles
x <- x[,xts:::has.OHLC(x, TRUE)]
ylab <- setParGlb(ylab, '')
log <- setParGlb(log, '')
ep <- axTicksByTime(x, major.ticks, format.labels = major.format)
xy <- list(x = .index(x), y = seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = NROW(x)))
do.call("plot", c(list(x = xy$x, y = xy$y, type = "n", axes=FALSE, xlab = xlab, ylab = ylab, main = main, log = log), dots))
if(auto.grid) {
abline(v=xy$x[ep], col='grey', lty=4)
grid(NA,NULL)
}
if(axes) {
if(minor.ticks)
axis(1, at=xy$x, labels=FALSE, col='#BBBBBB')
axis(1, at=xy$x[ep], labels=names(ep), las=1, lwd=1, mgp=c(3,2,0))
axis(2)
}
xts:::plot.ohlc.candles(x, bar.col = bar.col, candle.col = candle.col)
box()
assign(".plot.xts",recordPlot(),.GlobalEnv)
return(invisible(reclass(x)))
} else {
# Else need to do layout plots
# By default one screen per panel
screens <- factor(if(missing(screens)) 1:NCOL(x) else rep(screens, length.out = NCOL(x)))
if(missing(screens.layout)){
screens.layout <- seq_along(levels(screens))
}
#####
#
# SOME CODE TO MAKE SURE screens.layout IS LEGAL
#
#####
ep <- axTicksByTime(x,major.ticks, format.labels=major.format)
col <- setParCol(col, lapply(split(seq_len(NCOL(x)), screens), rank), screens)
lwd <- setParCol(lwd, split(rep(1, NCOL(x)), screens), screens)
type <- setParCol(type, split(rep('l', length(screens)), screens), screens)
ylab <- setParScr(ylab, if(NCOL(x) == 1 || length(levels(screens)) == 1) "" else
if(!is.null(colnames(x))) colnames(x) else paste("Column", seq_len(NCOL(x))), screens)
log <- setParScr(log, '', screens)
par(mar = c(0,0,0,0), oma = c(4, 6, 4, 4))
layout(screens.layout) # BETTER TO DO THIS MANUALLY WITH PAR()
# For now, loop over screens and do plots automatically
for(scrn in seq_along(levels(screens))){
x.temp <- x[, which(screens == scrn)]
xy <- list(x = .index(x.temp), y = seq(min(x.temp, na.rm = TRUE), max(x.temp, na.rm = TRUE), length.out = NROW(x)))
do.call("plot", c(xy[1:2], list(type = "n", axes=FALSE, xlab = "", ylab = ylab[scrn], log = log[scrn]), dots))
if(auto.grid) {
abline(v=xy$x[ep], col='grey', lty=4)
grid(NA,NULL)
}
if(axes) {
if(minor.ticks)
axis(1, at=xy$x, labels=FALSE, col='#BBBBBB')
axis(1, at=xy$x[ep], labels=names(ep), las=1, lwd=1, mgp=c(3,2,0))
axis(2)
}
for(column in seq_len(NCOL(x.temp))){
lines(x.temp[, column], type = type[[scrn]][column], col = col[[scrn]][column], lwd = lwd[[scrn]][column])
}
box()
}
}
title(main, outer = TRUE)
assign(".plot.xts",recordPlot(),.GlobalEnv)
return(invisible(reclass(x)))
}
#setup.grid <- function(x){
# # Sets up the axis background for the plot
#}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.