[Xts-commits] r866 - pkg/xts/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Dec 30 04:32:31 CET 2014
Author: rossbennett34
Date: 2014-12-30 04:32:31 +0100 (Tue, 30 Dec 2014)
New Revision: 866
Added:
pkg/xts/R/modify.args.R
Modified:
pkg/xts/R/plot.R
pkg/xts/R/zzz.R
Log:
porting functions/files from xtsExtra to xts for plot.xts
Added: pkg/xts/R/modify.args.R
===================================================================
--- pkg/xts/R/modify.args.R (rev 0)
+++ pkg/xts/R/modify.args.R 2014-12-30 03:32:31 UTC (rev 866)
@@ -0,0 +1,65 @@
+
+modify.args <- function(formals, arglist, ..., dots=FALSE)
+{
+ # modify.args function from quantstrat
+
+ # avoid evaluating '...' to make things faster
+ dots.names <- eval(substitute(alist(...)))
+
+ if(missing(arglist))
+ arglist <- NULL
+ arglist <- c(arglist, dots.names)
+
+ # see 'S Programming' p. 67 for this matching
+
+ # nothing to do if arglist is empty; return formals
+ if(!length(arglist))
+ return(formals)
+
+ argnames <- names(arglist)
+ if(!is.list(arglist) && !is.null(argnames) && !any(argnames == ""))
+ stop("'arglist' must be a *named* list, with no names == \"\"")
+
+ .formals <- formals
+ onames <- names(.formals)
+
+ pm <- pmatch(argnames, onames, nomatch = 0L)
+ #if(any(pm == 0L))
+ # message(paste("some arguments stored for", fun, "do not match"))
+ names(arglist[pm > 0L]) <- onames[pm]
+ .formals[pm] <- arglist[pm > 0L]
+
+ # include all elements from arglist if function formals contain '...'
+ if(dots && !is.null(.formals$...)) {
+ dotnames <- names(arglist[pm == 0L])
+ .formals[dotnames] <- arglist[dotnames]
+ #.formals$... <- NULL # should we assume we matched them all?
+ }
+ .formals
+}
+
+# This is how it is used in quantstrat in applyIndicators()
+# # replace default function arguments with indicator$arguments
+# .formals <- formals(indicator$name)
+# .formals <- modify.args(.formals, indicator$arguments, dots=TRUE)
+# # now add arguments from parameters
+# .formals <- modify.args(.formals, parameters, dots=TRUE)
+# # now add dots
+# .formals <- modify.args(.formals, NULL, ..., dots=TRUE)
+# # remove ... to avoid matching multiple args
+# .formals$`...` <- NULL
+#
+# tmp_val <- do.call(indicator$name, .formals)
+
+
+###############################################################################
+# R (http://r-project.org/) Numeric Methods for Optimization of Portfolios
+#
+# Copyright (c) 2004-2014 Brian G. Peterson, Peter Carl, Ross Bennett, Kris Boudt
+#
+# This library is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: utils.R 3302 2014-01-19 19:52:42Z braverock $
+#
+###############################################################################
Modified: pkg/xts/R/plot.R
===================================================================
--- pkg/xts/R/plot.R 2014-12-26 18:01:34 UTC (rev 865)
+++ pkg/xts/R/plot.R 2014-12-30 03:32:31 UTC (rev 866)
@@ -1,108 +1,1430 @@
-#
-# xts: eXtensible time-series
-#
-# Copyright (C) 2008 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
-#
-# Contributions from 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 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/>.
+# Environment for our xts chart objects (xts_chob)
+# .plotxtsEnv <- new.env()
-`plot.xts` <- function(x, y=NULL,
- type='l', auto.grid=TRUE,
- major.ticks='auto', minor.ticks=TRUE,
- major.format=TRUE,
- bar.col='grey', candle.col='white',
- ann=TRUE, axes=TRUE,
- ...) {
- series.title <- deparse(substitute(x))
+axTicksByTime2 <- function (x, ticks.on = "auto", k = 1, labels = TRUE,
+ format.labels = TRUE, ends = TRUE,
+ gt = 2, lt = 25){
+ if (timeBased(x))
+ x <- xts(rep(1, length(x)), x)
+ #tick.opts <- c("years", "months", "days", "hours",
+ # "minutes", "seconds")
+ tick.opts <- c("years", "months", "weeks", "days")
+ tick.k.opts <- c(1,1,1,1)
+ if (ticks.on %in% tick.opts) {
+ cl <- ticks.on[1]
+ ck <- k
+ }
+ else {
+ tick.opts <- paste(tick.opts, tick.k.opts)
+ is <- structure(rep(0, length(tick.opts)), .Names = tick.opts)
+ for (i in 1:length(tick.opts)) {
+ y <- strsplit(tick.opts[i], " ")[[1]]
+ ep <- endpoints(x, y[1], as.numeric(y[2]))
+ if(i>1 && is[i-1] == length(ep)-1)
+ break
+ is[i] <- length(ep) - 1
+ if (is[i] > lt)
+ break
+ }
+ nms <- rev(names(is)[which(is > gt & is < lt)])[1]
+ cl <- strsplit(nms, " ")[[1]][1]
+ ck <- as.numeric(strsplit(nms, " ")[[1]][2])
+ }
+ if (is.na(cl) || is.na(ck) || is.null(cl)) {
+ return(c(1,NROW(x)))
+ #ep <- NULL
+ }
+ else ep <- endpoints(x, cl, ck)
+ if (ends)
+ ep <- ep + c(rep(1, length(ep) - 1), 0)
+ if (labels) {
+ if (is.logical(format.labels) || is.character(format.labels)) {
+ unix <- ifelse(.Platform$OS.type == "unix", TRUE,
+ FALSE)
+ #time.scale <- periodicity(x)$scale
+ #fmt <- ifelse(unix, "%n%b%n%Y", "%b %Y")
+ fmt <- switch(cl,
+ "years"="%Y",
+ "months"="%b",
+ "days"="%d",
+ "weeks"="W%W",
+ "hours"="%H:%M",
+ "minutes"="%H:%M:%S",
+ "seconds"="%H:%M:%S")
+ if(ndays(x) > 1 && cl %in% c("hours","minutes","seconds")) {
+ fmt <- paste("%b-%d",fmt)
+ }
+ names(ep) <- format(index(x)[ep], fmt)
+ }
+ else names(ep) <- as.character(index(x)[ep])
+ }
+ ep
+}
- #time.scale <- periodicity(x)$scale
- ep <- axTicksByTime(x,major.ticks, format.labels=major.format)
+current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv))
- otype <- type
+chart.lines <- function(x,
+ type="l",
+ lty=1,
+ lwd=2,
+ lend=1,
+ col=1:10,
+ up.col=NULL,
+ dn.col=NULL,
+ legend.loc=NULL,
+ pch=1){
+ if(is.null(up.col)) up.col <- "green"
+ if(is.null(dn.col)) dn.col <- "red"
+ xx <- current.xts_chob()
+ if(type == "h"){
+ colors <- ifelse(x[,1] < 0, dn.col, up.col)
+ # lines(1:NROW(x),x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h")
+ # non-equally spaced x-axis
+ lines(xx$Env$xycoords$x,x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h")
+ } else if(type == "l" || type == "p") {
+ if(length(lty) == 1) lty <- rep(lty, NCOL(x))
+ if(length(lwd) == 1) lwd <- rep(lwd, NCOL(x))
+ for(i in NCOL(x):1){
+ # lines(1:NROW(x), x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch)
+ # non-equally spaced x-axis
+ lines(xx$Env$xycoords$x, x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch)
+ }
+ } else if(type == "bar"){
+ # This does not work correctly
+ # The geometry of the x-axis and y-axis is way off with stacked bar plot and
+ # the x-axis is off for unstacked bar plot
+ # We may need a separate function to do this correctly because of the
+ # different geometry/dimensions with stacked and unstacked barplots
+ positives = negatives = x
+ for(column in 1:NCOL(x)){
+ for(row in 1:NROW(x)){
+ positives[row,column] = max(0, x[row,column])
+ negatives[row,column] = min(0, x[row,column])
+ }
+ }
+ barplot.default(t(positives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE)
+ barplot.default(t(negatives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE)
+ }
+ if(!is.null(legend.loc)){
+ yrange <- range(x, na.rm=TRUE)
+ # nobs <- NROW(x)
+ chob.xlim <- xx$Env$xlim
+ switch(legend.loc,
+ topleft = {
+ xjust <- 0
+ yjust <- 1
+ lx <- chob.xlim[1]
+ ly <- yrange[2]
+ },
+ left = {
+ xjust <- 0
+ yjust <- 0.5
+ lx <- chob.xlim[1]
+ ly <- sum(yrange) / 2
+ },
+ bottomleft = {
+ xjust <- 0
+ yjust <- 0
+ lx <- chob.xlim[1]
+ ly <- yrange[1]
+ },
+ top = {
+ xjust <- 0.5
+ yjust <- 1
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
+ ly <- yrange[2]
+ },
+ center = {
+ xjust <- 0.5
+ yjust <- 0.5
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
+ ly <- sum(yrange) / 2
+ },
+ bottom = {
+ xjust <- 0.5
+ yjust <- 0
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
+ ly <- yrange[1]
+ },
+ topright = {
+ xjust <- 1
+ yjust <- 1
+ lx <- chob.xlim[2]
+ ly <- yrange[2]
+ },
+ right = {
+ xjust <- 1
+ yjust <- 0.5
+ lx <- chob.xlim[2]
+ ly <- sum(yrange) / 2
+ },
+ bottomright = {
+ xjust <- 1
+ yjust <- 0
+ lx <- chob.xlim[2]
+ ly <- yrange[1]
+ }
+ )
+ legend(x=lx, y=ly, legend=colnames(x), xjust=xjust, yjust=yjust,
+ fill=col[1:NCOL(x)], bty="n")
+ }
+}
- if(is.OHLC(x) && type %in% c('candles','bars')) {
- x <- x[,has.OHLC(x, TRUE)]
- xycoords <- list(x=.index(x), y=seq(min(x),max(x),length.out=NROW(x)))
- type <- "n"
+
+# xtsExtraTheme <- function(){
+# theme <-list(col=list(bg="#FFFFFF",
+# label.bg="#F0F0F0",
+# grid="darkgray", #grid="#F0F0F0",
+# grid2="#F5F5F5",
+# ticks="#999999",
+# labels="#333333",
+# line.col="darkorange",
+# dn.col="red",
+# up.col="green",
+# dn.border="#333333",
+# up.border="#333333",
+# colorset=1:10),
+# shading=1,
+# format.labels=TRUE,
+# coarse.time=TRUE,
+# rylab=TRUE,
+# lylab=TRUE,
+# grid.ticks.lwd=1,
+# grid.ticks.on="months")
+# theme
+# }
+
+# based on quantmod::chart_Series
+#' Time series Plotting
+#'
+#' Plotting for xts objects.
+#' TODO: description, details, and examples
+#'
+#' @param x xts object
+#' @param y NULL, not used
+#' @param \dots any passthrough parameters to FUN
+#' @param subset character vector of length one of the subset range using subsetting as in \code{\link{xts}}
+#' @param FUN function to apply to \code{x} and plot
+#' @param panels character vector of expressions to plot as panels
+#' @param multi.panel TRUE/FALSE or an integer less than or equal to the number
+#' of columns in the data set. If TRUE, each column of the data is plotted in a
+#' separate panel. For example, if \code{multi.panel = 2}, then the data
+#' will be plotted in groups of 2 columns and each group is plotted in a
+#' separate panel.
+#' @param col color palette to use, set by default to rational choices
+#' @param up.col color for positive bars if \code{type="h"}
+#' @param dn.col color for positive bars if \code{type="h"}
+#' @param type the type of plot to be drawn, same as in \code{\link{plot}}
+#' @param lty set the line type, same as in plot
+#' @param lwd set the line width, same as in plot
+#' @param lend set the line end style, same as in plot
+#' @param main main title
+#' @param clev level for shading, not currently used
+#' @param cex not currently used
+#' @param cex.axis
+#' @param mar set the margins, same as in par
+#' @param srt rotation for the y axis labels
+#' @param xaxis.las rotation for the x axis labels
+#' @param ylim the range of the y axis
+#' @param yaxis.same TRUE/FALSE. If TRUE, the y axis is drawn with the same ylim for multiple panels
+#' @param yaxis.left if TRUE, draws the y axis on the left
+#' @param yaxis.right if TRUE, draws the y axis on the right
+#' @param grid.ticks.on period to draw the grid ticks on
+#' @param grid.ticks.lwd line width of the grid
+#' @param grid.ticks.lty line type of the grid
+#' @param grid.col color of the grid
+#' @param labels.col color of the axis labels
+#' @param format.labels not currently used
+#' @param shading not currently used
+#' @param bg.col not currently used
+#' @param grid2 color for secondary x axis grid
+#' @param legend.loc places a legend into one of nine locations on the chart:
+#' bottomright, bottom, bottomleft, left, topleft, top, topright, right, or
+#' center. Default NULL does not draw a legend.
+#' @author Ross Bennett
+plot.xts <- function(x,
+ y=NULL,
+ ...,
+ subset="",
+ FUN=NULL,
+ panels=NULL,
+ multi.panel=FALSE,
+ col=1:12,
+ up.col="green",
+ dn.col="red",
+ type="l",
+ lty=1,
+ lwd=2,
+ lend=1,
+ main=deparse(substitute(x)),
+ clev=0,
+ cex=0.6,
+ cex.axis=0.9,
+ mar=c(3,2,0,2),
+ srt=0,
+ xaxis.las=0,
+ ylim=NULL,
+ yaxis.same=TRUE,
+ yaxis.left=TRUE,
+ yaxis.right=TRUE,
+ grid.ticks.on="months",
+ grid.ticks.lwd=1,
+ grid.ticks.lty=1,
+ grid.col="darkgray",
+ labels.col="#333333",
+ format.labels=TRUE,
+ shading=1,
+ bg.col="#FFFFFF",
+ grid2="#F5F5F5",
+ legend.loc=NULL){
+
+ # 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))
+
+ if(!is.null(panels) && nchar(panels) > 0){
+ # we will plot the panels, but not plot the returns by column
+ multi.panel <- FALSE
+ } else {
+ # we will plot the returns by column, but not the panels
+ multi.panel <- TRUE
+ panels <- NULL
+
+ if(yaxis.same){
+ # If we want the same y-axis and a FUN is specified, we need to
+ # apply the transformation first to compute the range for the y-axis
+ if(!is.null(FUN) && nchar(FUN) > 0){
+ fun <- match.fun(FUN)
+ .formals <- formals(fun)
+ .formals <- modify.args(formals=.formals, arglist=list(...), dots=TRUE)
+ if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=x, dots=TRUE)
+ .formals$... <- NULL
+ R <- try(do.call(fun, .formals), silent=TRUE)
+ if(inherits(R, "try-error")) {
+ message(paste("FUN function failed with message", R))
+ ylim <- range(x[subset], na.rm=TRUE)
+ } else {
+ ylim <- range(R[subset], na.rm=TRUE)
+ }
+ } else {
+ # set the ylim based on the data passed into the x argument
+ 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,
+ FUN=FUN,
+ panels=panels,
+ multi.panel=multi.panel,
+ col=col,
+ up.col=up.col,
+ dn.col=dn.col,
+ type=type,
+ lty=lty,
+ lwd=lwd,
+ lend=lend,
+ main=main,
+ clev=clev,
+ cex=cex,
+ cex.axis=cex.axis,
+ mar=mar,
+ srt=srt,
+ xaxis.las=xaxis.las,
+ ylim=ylim,
+ yaxis.same=yaxis.same,
+ yaxis.left=yaxis.left,
+ yaxis.right=yaxis.right,
+ 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,
+ shading=shading,
+ bg.col=bg.col,
+ grid2=grid2,
+ legend.loc=legend.loc)
+ if(i < length(chunks))
+ print(p)
+ }
+ # NOTE: return here so we don't draw another chart
+ return(p)
+ }
+
+ cs <- new.replot_xts()
+ if(is.null(grid.ticks.on)) {
+ xs <- x[subset]
+ major.grid <- c(years=nyears(xs),
+ months=nmonths(xs),
+ days=ndays(xs))
+ grid.ticks.on <- names(major.grid)[rev(which(major.grid < 30))[1]]
+ } #else grid.ticks.on <- theme$grid.ticks.on
+ #label.bg <- theme$col$label.bg
+
+ # define a subset function
+ cs$subset <- function(x) {
+ if(FALSE) {set_ylim <- get_ylim <- set_xlim <- Env <-function(){} } # appease R parser?
+ if(missing(x)) {
+ x <- "" #1:NROW(Env$xdata)
+ }
+ Env$xsubset <<- x
+ # set_xlim(c(1,NROW(Env$xdata[Env$xsubset])))
+ # non equally spaced x-axis
+ set_xlim(range(Env$xycoords$x, na.rm=TRUE))
+ ylim <- get_ylim()
+ for(y in seq(2,length(ylim),by=2)) {
+ if(!attr(ylim[[y]],'fixed'))
+ ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE)
+ }
+ lapply(Env$actions,
+ function(x) {
+ frame <- abs(attr(x, "frame"))
+ fixed <- attr(ylim[[frame]],'fixed')
+ #fixed <- attr(x, "fixed")
+ if(frame %% 2 == 0 && !fixed) {
+ lenv <- attr(x,"env")
+ if(is.list(lenv)) lenv <- lenv[[1]]
+ min.tmp <- min(ylim[[frame]][1],range(lenv$xdata[Env$xsubset], na.rm=TRUE)[1],na.rm=TRUE)
+ max.tmp <- max(ylim[[frame]][2],range(lenv$xdata[Env$xsubset], na.rm=TRUE)[2],na.rm=TRUE)
+ ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed)
+ }
+ })
+ # reset all ylim values, by looking for range(env[[1]]$xdata)
+ # xdata should be either coming from Env or if lenv, lenv
+ set_ylim(ylim)
+ }
+ environment(cs$subset) <- environment(cs$get_asp)
+
+ # add theme and charting parameters to Env
+ if(multi.panel){
+ cs$set_asp(NCOL(x))
} else {
- if(NCOL(x) > 1) warning('only the univariate series will be plotted')
- if(is.null(y))
- xycoords <- xy.coords(.index(x), x[,1])
+ cs$set_asp(3)
}
+ cs$Env$cex <- cex
+ cs$Env$mar <- mar
+ cs$Env$clev = min(clev+0.01,1) # (0,1]
+ cs$Env$theme$shading <- shading
+ cs$Env$theme$up.col <- up.col
+ cs$Env$theme$dn.col <- dn.col
+ if (hasArg(colorset)){
+ cs$Env$theme$col <- match.call(expand.dots=TRUE)$colorset
+ } else {
+ cs$Env$theme$col <- col
+ }
+ cs$Env$theme$rylab <- yaxis.right
+ cs$Env$theme$lylab <- yaxis.left
+ cs$Env$theme$bg <- bg.col
+ cs$Env$theme$grid <- grid.col
+ cs$Env$theme$grid2 <- grid2
+ cs$Env$theme$labels <- labels.col
+ cs$Env$theme$srt <- srt
+ cs$Env$theme$xaxis.las <- xaxis.las
+ cs$Env$theme$cex.axis <- cex.axis
+ cs$Env$format.labels <- format.labels
+ cs$Env$grid.ticks.on <- grid.ticks.on
+ cs$Env$grid.ticks.lwd <- grid.ticks.lwd
+ cs$Env$grid.ticks.lty <- grid.ticks.lty
+ cs$Env$type <- type
+ cs$Env$lty <- lty
+ cs$Env$lwd <- lwd
+ cs$Env$lend <- lend
+ cs$Env$legend.loc <- legend.loc
+ cs$Env$call_list <- list()
+ cs$Env$call_list[[1]] <- match.call()
+
+ # Do some checks on x
+ if(is.character(x))
+ stop("'x' must be a time-series object")
+
+ # If we detect an OHLC object, we should call quantmod::chart_Series
+
+ # 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
+
+ # non equally spaced x-axis
+ xycoords <- xy.coords(.index(cs$Env$xdata[cs$Env$xsubset]),
+ cs$Env$xdata[cs$Env$xsubset][,1])
+ cs$Env$xycoords <- xycoords
+ cs$Env$xlim <- range(xycoords$x, na.rm=TRUE)
+ cs$Env$xstep <- diff(xycoords$x[1:2])
+
+ # Compute transformation if specified by panel argument
+ # rough prototype for calling a function for the main "panel"
+ if(!is.null(FUN)){
+ fun <- match.fun(FUN)
+ .formals <- formals(fun)
+ .formals <- modify.args(formals=.formals, arglist=list(...), dots=TRUE)
+ if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=x, dots=TRUE)
+ if("x" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, x=x, dots=TRUE)
+ .formals$... <- NULL
+ R <- try(do.call(fun, .formals), silent=TRUE)
+ if(inherits(R, "try-error")) {
+ message(paste("FUN function failed with message", R))
+ cs$Env$R <- x
+ } else {
+ cs$Env$R <- R
+ }
+ } else {
+ cs$Env$R <- x
+ }
+
+ # Set xlim based on the raw returns data passed into function
+ # cs$set_xlim(c(1,NROW(cs$Env$xdata[subset])))
+ # non equally spaced x-axis
+ cs$set_xlim(cs$Env$xlim)
+
+
+ # Set ylim based on the transformed data
+ # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or
+ # which is best.
+ if(is.null(ylim)){
+ if(isTRUE(multi.panel)){
+ if(yaxis.same){
+ # set the ylim for the first panel based on all the data
+ cs$set_ylim(list(structure(range(cs$Env$R[subset], na.rm=TRUE),fixed=TRUE)))
+ } else {
+ # set the ylim for the first panel based on the first column
+ cs$set_ylim(list(structure(range(cs$Env$R[,1][subset], na.rm=TRUE),fixed=TRUE)))
+ }
+ } else {
+ # set the ylim based on all the data if this is not a multi.panel plot
+ cs$set_ylim(list(structure(range(cs$Env$R[subset], na.rm=TRUE),fixed=TRUE)))
+ }
+ cs$Env$constant_ylim <- range(cs$Env$R[subset], na.rm=TRUE)
+ } else {
+ # use the ylim arg passed in
+ cs$set_ylim(list(structure(ylim, fixed=TRUE)))
+ cs$Env$constant_ylim <- ylim
+ }
+
+ cs$set_frame(1,FALSE)
+ # axis_ticks function to label lower frequency ranges/grid lines
+ #cs$Env$axis_ticks <- function(xdata,xsubset) {
+ # ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 +
+ # last(axTicksByTime2(xdata[xsubset],labels=TRUE),-1)
+ # if(min(diff(ticks)) < max(strwidth(names(ticks)))) {
+ # ticks <- unname(ticks)
+ # }
+ # ticks
+ #}
+
+ # compute the x-axis ticks
+ cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]),
+ segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
+ get_ylim()[[2]][1],
+ xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
+ get_ylim()[[2]][2],
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)),
+ clip=FALSE,expr=TRUE)
+
+ # Add frame for the chart "header" to display the name and start/end dates
+ cs$add_frame(0,ylim=c(0,1),asp=0.5)
+ cs$set_frame(1)
+
+ # add observation level ticks on x-axis if < 400 obs.
+ cs$add(expression(if(NROW(xdata[xsubset])<400)
+ {axis(1,at=xycoords$x,labels=FALSE,col=theme$grid2,tcl=0.3)}),expr=TRUE)
+
+ # add "month" or "month.abb"
+ cs$add(expression(axt <- axTicksByTime(xdata[xsubset],format.labels=format.labels),
+ axis(1,
+ at=xycoords$x[axt], #axTicksByTime(xdata[xsubset]),
+ labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)),
+ las=theme$xaxis.las, lwd.ticks=1, mgp=c(3,1.5,0),
+ tcl=-0.4, cex.axis=theme$cex.axis)),
+ expr=TRUE)
+
+ # add main and start/end dates
+ #if((isTRUE(multi.panel)) | (multi.panel == 1) | (NCOL(x) == 1))
+ # cs$Env$main <- cs$Env$column_names[1] else cs$Env$main <- main
+
+ text.exp <- c(expression(text(xlim[1],0.5,main,font=2,col='#444444',offset=0,cex=1.1,pos=4)),
+ expression(text(xlim[2],0.5,
+ paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "),
+ col=1,adj=c(0,0),pos=2)))
+ cs$add(text.exp, env=cs$Env, expr=TRUE)
+
+ cs$set_frame(2)
+ # define function for y-axis labels
+ #cs$Env$grid_lines <- function(xdata, xsubset) {
+ # ylim <- range(xdata[xsubset])
+ # p <- pretty(ylim, 5)
+ # p[p > ylim[1] & p < ylim[2]]
+ #}
+
+ cs$Env$y_grid_lines <- function(ylim) {
+ #pretty(range(xdata[xsubset]))
+ p <- pretty(ylim,5)
+ p[p > ylim[1] & p < ylim[2]]
+ }
+
+ # add y-axis grid lines and labels
+ exp <- expression(segments(xlim[1],
+ y_grid_lines(get_ylim()[[2]]),
+ xlim[2],
+ y_grid_lines(get_ylim()[[2]]),
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty))
+ if(yaxis.left){
+ exp <- c(exp,
+ # left y-axis labels
+ expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(get_ylim()[[2]]))),
+ y_grid_lines(get_ylim()[[2]]),
+ noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")),
+ col=theme$labels, srt=theme$srt, offset=0, pos=4,
+ cex=theme$cex.axis, xpd=TRUE)))
+ }
+ if(yaxis.right){
+ exp <- c(exp,
+ # right y-axis labels
+ expression(text(xlim[2]+xstep*2/3,
+ y_grid_lines(get_ylim()[[2]]),
+ noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")),
+ col=theme$labels, srt=theme$srt, offset=0, pos=4,
+ cex=theme$cex.axis, xpd=TRUE)))
+ }
+ cs$add(exp, env=cs$Env, expr=TRUE)
+
+ # add main series
+ cs$set_frame(2)
+ if(isTRUE(multi.panel)){
+ # We need to plot the first "panel" here because the plot area is
+ # set up based on the code above
+ lenv <- new.env()
+ lenv$xdata <- cs$Env$R[,1][subset]
+ lenv$label <- colnames(cs$Env$R[,1])
+ lenv$type <- cs$Env$type
+ if(yaxis.same){
+ lenv$ylim <- cs$Env$constant_ylim
+ } else {
+ lenv$ylim <- range(cs$Env$R[,1][subset], na.rm=TRUE)
+ }
+ exp <- expression(chart.lines(xdata,
+ type=type,
+ lty=lty,
+ lwd=lwd,
+ lend=lend,
+ col=theme$col,
+ up.col=theme$up.col,
+ dn.col=theme$dn.col,
+ legend.loc=legend.loc))
+ # Add expression for the main plot
+ cs$add(exp, env=c(lenv,cs$Env), expr=TRUE)
+ text.exp <- expression(text(x=xycoords$x[2],
+ y=ylim[2]*0.9,
+ labels=label,
+ adj=c(0,0),cex=1,offset=0,pos=4))
+ cs$add(text.exp,env=c(lenv, cs$Env),expr=TRUE)
+
+ if(NCOL(cs$Env$xdata) > 1){
+ for(i in 2:NCOL(cs$Env$xdata)){
+ # create a local environment
+ lenv <- new.env()
+ lenv$xdata <- cs$Env$R[,i][subset]
+ lenv$label <- cs$Env$column_names[i]
+ if(yaxis.same){
+ lenv$ylim <- cs$Env$constant_ylim
+ } else {
+ lenv$ylim <- range(cs$Env$R[,i][subset], na.rm=TRUE)
+ }
+ lenv$type <- cs$Env$type
+
+ # Add a small frame
+ cs$add_frame(ylim=c(0,1),asp=0.25)
+ cs$next_frame()
+ text.exp <- expression(text(x=xlim[1],
+ y=0.5,
+ labels="",
+ adj=c(0,0),cex=0.9,offset=0,pos=4))
+ cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE)
+
+ # Add the frame for the sub-plots
+ # Set the ylim based on the (potentially) transformed data in cs$Env$R
+ cs$add_frame(ylim=lenv$ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE)
+ cs$next_frame()
+
+ exp <- expression(chart.lines(xdata[xsubset],
+ type=type,
+ lty=lty,
+ lwd=lwd,
+ lend=lend,
+ col=theme$col,
+ up.col=theme$up.col,
+ dn.col=theme$dn.col,
+ legend.loc=legend.loc))
+
+ # define function to plot the y-axis grid lines
+ lenv$y_grid_lines <- function(ylim) {
+ #pretty(range(xdata[xsubset]))
+ p <- pretty(ylim,5)
+ p[p > ylim[1] & p < ylim[2]]
+ }
+
+ # NOTE 'exp' was defined earlier as chart.lines
+ exp <- c(exp,
+ # y-axis grid lines
+ expression(segments(xlim[1],
+ y_grid_lines(ylim),
+ xlim[2],
+ y_grid_lines(ylim),
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)),
+ # x-axis grid lines
+ expression(atbt <- axTicksByTime2(xdata[xsubset]),
+ segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
+ ylim[1],
+ xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
+ ylim[2],
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)))
+ if(yaxis.left){
+ exp <- c(exp,
+ # y-axis labels/boxes
+ expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(ylim))),
+ y_grid_lines(ylim),
+ noquote(format(y_grid_lines(ylim),justify="right")),
+ col=theme$labels, srt=theme$srt, offset=0,
+ pos=4, cex=theme$cex.axis, xpd=TRUE)))
+ }
+ if(yaxis.right){
+ exp <- c(exp,
+ expression(text(xlim[2]+xstep*2/3, y_grid_lines(ylim),
+ noquote(format(y_grid_lines(ylim),justify="right")),
+ col=theme$labels, srt=theme$srt, offset=0,
+ pos=4, cex=theme$cex.axis, xpd=TRUE)))
+ }
+ cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE)
+ text.exp <- expression(text(x=xycoords$x[2],
+ y=ylim[2]*0.9,
+ labels=label,
+ adj=c(0,0),cex=1,offset=0,pos=4))
+ cs$add(text.exp,env=c(lenv, cs$Env),expr=TRUE)
+ }
+ }
+ } else {
+ if(type == "h" & NCOL(x) > 1)
+ warning("only the univariate series will be plotted")
+ cs$add(expression(chart.lines(R[xsubset],
+ type=type,
+ lty=lty,
+ lwd=lwd,
+ lend=lend,
+ col=theme$col,
+ up.col=theme$up.col,
+ dn.col=theme$dn.col,
+ legend.loc=legend.loc)),expr=TRUE)
+ 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
+}
- plot(xycoords$x, xycoords$y, type=type, axes=FALSE, ann=FALSE, ...)
+#' Add a time series to an existing xts plot
+#'
+#' @param x an xts object to plot.
+#' @param main main title for a new panel if drawn.
+#' @param on panel number to draw on. A new panel will be drawn if \code{on=NA}.
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/xts -r 866
More information about the Xts-commits
mailing list