From noreply at r-forge.r-project.org Mon Sep 1 02:11:43 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 1 Sep 2014 02:11:43 +0200 (CEST)
Subject: [Xts-commits] r842 - pkg/xtsExtra/R
Message-ID: <20140901001143.19707183BF0@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-01 02:11:42 +0200 (Mon, 01 Sep 2014)
New Revision: 842
Modified:
pkg/xtsExtra/R/plot2.R
Log:
fixes bug #5894 xaxis incomplete
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-08-31 18:09:28 UTC (rev 841)
+++ pkg/xtsExtra/R/plot2.R 2014-09-01 00:11:42 UTC (rev 842)
@@ -392,7 +392,7 @@
#}
# compute the x-axis ticks
- cs$add(expression(atbt <- axTicksByTime(xdata[xsubset]),
+ cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]),
segments(atbt, #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][1],
atbt, #axTicksByTime2(xdata[xsubset]),
@@ -543,7 +543,7 @@
NROW(xdata[xsubset]), y_grid_lines(ylim),
col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)),
# x-axis grid lines
- expression(atbt <- axTicksByTime(xdata[xsubset]),
+ expression(atbt <- axTicksByTime2(xdata[xsubset]),
segments(atbt, #axTicksByTime2(xdata[xsubset]),
ylim[1],
atbt, #axTicksByTime2(xdata[xsubset]),
From noreply at r-forge.r-project.org Mon Sep 1 18:31:00 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 1 Sep 2014 18:31:00 +0200 (CEST)
Subject: [Xts-commits] r843 - in pkg/xtsExtra: . R sandbox
Message-ID: <20140901163100.7826918761B@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-01 18:30:59 +0200 (Mon, 01 Sep 2014)
New Revision: 843
Modified:
pkg/xtsExtra/NAMESPACE
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
adding legend functionality
Modified: pkg/xtsExtra/NAMESPACE
===================================================================
--- pkg/xtsExtra/NAMESPACE 2014-09-01 00:11:42 UTC (rev 842)
+++ pkg/xtsExtra/NAMESPACE 2014-09-01 16:30:59 UTC (rev 843)
@@ -20,6 +20,7 @@
export("addLines")
export("addReturns")
export("addRollingPerformance")
+export("addLegend")
S3method(print, replot_xts)
S3method(plot, replot_xts)
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-01 00:11:42 UTC (rev 842)
+++ pkg/xtsExtra/R/plot2.R 2014-09-01 16:30:59 UTC (rev 843)
@@ -47,6 +47,68 @@
barplot.default(t(positives), add=TRUE, col=colorset, axisnames=FALSE, axes=FALSE)
barplot.default(t(negatives), add=TRUE, col=colorset, axisnames=FALSE, axes=FALSE)
}
+ if(!is.null(legend.loc)){
+ yrange <- range(na.omit(x))
+ nobs <- NROW(x)
+ switch(legend.loc,
+ topleft = {
+ xjust <- 0
+ yjust <- 1
+ lx <- 1
+ ly <- yrange[2]
+ },
+ left = {
+ xjust <- 0
+ yjust <- 0.5
+ lx <- 1
+ ly <- sum(yrange) / 2
+ },
+ bottomleft = {
+ xjust <- 0
+ yjust <- 0
+ lx <- 1
+ ly <- yrange[1]
+ },
+ top = {
+ xjust <- 0.5
+ yjust <- 1
+ lx <- nobs / 2
+ ly <- yrange[2]
+ },
+ center = {
+ xjust <- 0.5
+ yjust <- 0.5
+ lx <- nobs / 2
+ ly <- sum(yrange) / 2
+ },
+ bottom = {
+ xjust <- 0.5
+ yjust <- 0
+ lx <- nobs / 2
+ ly <- yrange[1]
+ },
+ topright = {
+ xjust <- 1
+ yjust <- 1
+ lx <- nobs
+ ly <- yrange[2]
+ },
+ right = {
+ xjust <- 1
+ yjust <- 0.5
+ lx <- nobs
+ ly <- sum(yrange) / 2
+ },
+ bottomright = {
+ xjust <- 1
+ yjust <- 0
+ lx <- nobs
+ ly <- yrange[1]
+ }
+ )
+ legend(x=lx, y=ly, legend=colnames(x), xjust=xjust, yjust=yjust,
+ fill=colorset[1:NCOL(x)], bty="n")
+ }
}
# function from Peter Carl to add labels to the plot window
@@ -141,7 +203,8 @@
format.labels=TRUE,
shading=1,
bg.col="#FFFFFF",
- grid2="#F5F5F5"){
+ 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
@@ -218,7 +281,8 @@
format.labels=format.labels,
shading=shading,
bg.col=bg.col,
- grid2=grid2)
+ grid2=grid2,
+ legend.loc=legend.loc)
if(i < length(chunks))
print(p)
}
@@ -302,7 +366,6 @@
cs$Env$theme$srt <- srt
cs$Env$theme$xaxis.las <- xaxis.las
cs$Env$theme$cex.axis <- cex.axis
- #cs$Env$theme$legend.loc <- legend.loc
#cs$Env$theme$label.bg <- label.bg
#cs$Env$theme$coarse.time <- coarse.time
cs$Env$format.labels <- format.labels
@@ -313,6 +376,7 @@
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()
@@ -484,7 +548,8 @@
lend=lend,
colorset=theme$colorset,
up.col=theme$up.col,
- dn.col=theme$dn.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=2,
@@ -527,7 +592,8 @@
lend=lend,
colorset=theme$colorset,
up.col=theme$up.col,
- dn.col=theme$dn.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) {
@@ -580,7 +646,8 @@
lend=lend,
colorset=theme$colorset,
up.col=theme$up.col,
- dn.col=theme$dn.col)),expr=TRUE)
+ dn.col=theme$dn.col,
+ legend.loc=legend.loc)),expr=TRUE)
assign(".xts_chob", cs, .plotxtsEnv)
}
@@ -926,3 +993,98 @@
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
plot_object
}
+
+addLegend <- function(legend.loc="center", ncol=1, ...){
+ lenv <- new.env()
+ lenv$main <- ""
+
+ plot_object <- current.xts_chob()
+ ncalls <- length(plot_object$Env$call_list)
+ plot_object$Env$call_list[[ncalls+1]] <- match.call()
+
+ # add the frame for drawdowns info
+ plot_object$add_frame(ylim=c(0,1),asp=0.25)
+ plot_object$next_frame()
+ text.exp <- expression(text(x=1, y=0.3, labels=main,
+ col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
+ plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
+
+ # add frame for the legend panel
+ plot_object$add_frame(ylim=c(0,1),asp=0.8,fixed=TRUE)
+ plot_object$next_frame()
+
+ if(!is.null(legend.loc)){
+ yrange <- c(0,1)
+ nobs <- plot_object$Env$nobs
+ switch(legend.loc,
+ topleft = {
+ xjust <- 0
+ yjust <- 1
+ lx <- 1
+ ly <- yrange[2]
+ },
+ left = {
+ xjust <- 0
+ yjust <- 0.5
+ lx <- 1
+ ly <- sum(yrange) / 2
+ },
+ bottomleft = {
+ xjust <- 0
+ yjust <- 0
+ lx <- 1
+ ly <- yrange[1]
+ },
+ top = {
+ xjust <- 0.5
+ yjust <- 1
+ lx <- nobs / 2
+ ly <- yrange[2]
+ },
+ center = {
+ xjust <- 0.5
+ yjust <- 0.5
+ lx <- nobs / 2
+ ly <- sum(yrange) / 2
+ },
+ bottom = {
+ xjust <- 0.5
+ yjust <- 0
+ lx <- nobs / 2
+ ly <- yrange[1]
+ },
+ topright = {
+ xjust <- 1
+ yjust <- 1
+ lx <- nobs
+ ly <- yrange[2]
+ },
+ right = {
+ xjust <- 1
+ yjust <- 0.5
+ lx <- nobs
+ ly <- sum(yrange) / 2
+ },
+ bottomright = {
+ xjust <- 1
+ yjust <- 0
+ lx <- nobs
+ ly <- yrange[1]
+ }
+ )
+ }
+ nc <- NCOL(plot_object$Env$xdata)
+ lenv$lx <- lx
+ lenv$ly <- ly
+ lenv$xjust <- xjust
+ lenv$yjust <- yjust
+ lenv$colorset <- plot_object$Env$theme$colorset[1:nc]
+ lenv$names <- plot_object$Env$column_names
+ lenv$nc <- ncol
+ # add expression for legend
+ exp <- expression(legend(x=lx, y=ly, legend=names, xjust=xjust, yjust=yjust,
+ fill=colorset, ncol=nc, bty="n"))
+
+ plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
+ plot_object
+}
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-01 00:11:42 UTC (rev 842)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-01 16:30:59 UTC (rev 843)
@@ -16,7 +16,7 @@
# small multiples, line plot of each column
plot2_xts(R, multi.panel=TRUE)
-plot2_xts(R, multi.panel=TRUE, y.axis.same=FALSE)
+plot2_xts(R, multi.panel=TRUE, yaxis.same=FALSE)
layout(matrix(1:2))
plot2_xts(R, multi.panel=2, type="h")
@@ -89,6 +89,26 @@
plot2_xts(R, yaxis.left=TRUE, yaxis.right=FALSE)
plot2_xts(R, grid.ticks.lwd=1, grid.ticks.lty="solid", grid.col="black")
+# examples with legend functionality
+R <- edhec[,1:10]
+foo <- function(x){
+ CumReturns(R = x)
+}
+plot2_xts(R, FUN=foo)
+addLegend(ncol = 4)
+
+plot2_xts(R, FUN=foo, legend.loc="topleft")
+plot2_xts(R, FUN=foo, legend.loc="left")
+plot2_xts(R, FUN=foo, legend.loc="bottomleft")
+
+plot2_xts(R, FUN=foo, legend.loc="top")
+plot2_xts(R, FUN=foo, legend.loc="center")
+plot2_xts(R, FUN=foo, legend.loc="bottom")
+
+plot2_xts(R, FUN=foo, legend.loc="topright")
+plot2_xts(R, FUN=foo, legend.loc="right")
+plot2_xts(R, FUN=foo, legend.loc="bottomright")
+
##### scratch area #####
# Should we have a theme object, as in quantmod, that sets all of the basic
# parameters such as lty, lwd, las, cex, colorset, element.color, etc?
From noreply at r-forge.r-project.org Fri Sep 5 15:12:14 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 5 Sep 2014 15:12:14 +0200 (CEST)
Subject: [Xts-commits] r844 - pkg/xts/R
Message-ID: <20140905131214.4C7B81864A3@r-forge.r-project.org>
Author: bodanker
Date: 2014-09-05 15:12:13 +0200 (Fri, 05 Sep 2014)
New Revision: 844
Modified:
pkg/xts/R/index.R
Log:
- Fix bug #5891. Thanks to Garrett See for the report and patch.
Modified: pkg/xts/R/index.R
===================================================================
--- pkg/xts/R/index.R 2014-09-01 16:30:59 UTC (rev 843)
+++ pkg/xts/R/index.R 2014-09-05 13:12:13 UTC (rev 844)
@@ -106,45 +106,35 @@
}
`.indexsec` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$sec
- as.POSIXlt(.POSIXct(.index(x)))$sec
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$sec
}
`.indexmin` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$min
- as.POSIXlt(.POSIXct(.index(x)))$min
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$min
}
`.indexhour` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$hour
- as.POSIXlt(.POSIXct(.index(x)))$hour
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$hour
}
`.indexmday` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$mday
- as.POSIXlt(.POSIXct(.index(x)))$mday
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$mday
}
`.indexmon` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$mon
- as.POSIXlt(.POSIXct(.index(x)))$mon
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$mon
}
`.indexyear` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$year
- as.POSIXlt(.POSIXct(.index(x)))$year
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$year
}
`.indexwday` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$wday
- as.POSIXlt(.POSIXct(.index(x)))$wday
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$wday
}
`.indexbday` <- function(x) {
# is business day T/F
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$wday %% 6 > 0
- as.POSIXlt(.POSIXct(.index(x)))$wday %% 6 > 0
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$wday %% 6 > 0
}
`.indexyday` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$yday
- as.POSIXlt(.POSIXct(.index(x)))$yday
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$yday
}
`.indexisdst` <- function(x) {
- #as.POSIXlt( structure( .index(x), class=c('POSIXt','POSIXct')) )$isdst
- as.POSIXlt(.POSIXct(.index(x)))$isdst
+ as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$isdst
}
`.indexDate` <- `.indexday` <- function(x) {
.index(x) %/% 86400L
From noreply at r-forge.r-project.org Sat Sep 6 17:22:46 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sat, 6 Sep 2014 17:22:46 +0200 (CEST)
Subject: [Xts-commits] r845 - pkg/xts/R
Message-ID: <20140906152246.B97F3187538@r-forge.r-project.org>
Author: bodanker
Date: 2014-09-06 17:22:46 +0200 (Sat, 06 Sep 2014)
New Revision: 845
Modified:
pkg/xts/R/index.R
Log:
- Re-fix bug #5893 (r838); use isOrdered(x,,strictly=FALSE)
Modified: pkg/xts/R/index.R
===================================================================
--- pkg/xts/R/index.R 2014-09-05 13:12:13 UTC (rev 844)
+++ pkg/xts/R/index.R 2014-09-06 15:22:46 UTC (rev 845)
@@ -75,7 +75,7 @@
else attr(x, 'index') <- as.numeric(as.POSIXct(value))
# ensure new index is sorted
- if(!isOrdered(.index(x)))
+ if(!isOrdered(.index(x), strictly=FALSE))
stop("new index needs to be sorted")
# set the .indexCLASS/tclass attribute to the end-user specified class
From noreply at r-forge.r-project.org Tue Sep 9 01:53:45 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 9 Sep 2014 01:53:45 +0200 (CEST)
Subject: [Xts-commits] r846 - in pkg/xtsExtra: . R sandbox
Message-ID: <20140908235345.70B6D18761B@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-09 01:53:44 +0200 (Tue, 09 Sep 2014)
New Revision: 846
Modified:
pkg/xtsExtra/NAMESPACE
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
refactor addLines function and add support for points
Modified: pkg/xtsExtra/NAMESPACE
===================================================================
--- pkg/xtsExtra/NAMESPACE 2014-09-06 15:22:46 UTC (rev 845)
+++ pkg/xtsExtra/NAMESPACE 2014-09-08 23:53:44 UTC (rev 846)
@@ -18,6 +18,7 @@
export("xtsExtraTheme")
export("addDrawdowns")
export("addLines")
+export("addLines2")
export("addReturns")
export("addRollingPerformance")
export("addLegend")
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-06 15:22:46 UTC (rev 845)
+++ pkg/xtsExtra/R/plot2.R 2014-09-08 23:53:44 UTC (rev 846)
@@ -19,17 +19,18 @@
colorset=1:10,
up.col=NULL,
dn.col=NULL,
- legend.loc=NULL){
+ legend.loc=NULL,
+ pch=1){
if(is.null(up.col)) up.col <- "green"
if(is.null(dn.col)) dn.col <- "red"
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")
- } else if(type == "l") {
+ } 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="l", lend=lend, col=colorset[i], lty=lty[i], lwd=lwd[i])
+ lines(1:NROW(x), x[,i], type=type, lend=lend, col=colorset[i], lty=lty[i], lwd=lwd[i], pch=pch)
}
} else if(type == "bar"){
# This does not work correctly
@@ -736,117 +737,217 @@
plot_object
}
-# based on quantmod::add_TA
-addLines <- function(x, main="", order=NULL, on=NA, legend="auto",
- yaxis=list(NULL,NULL),
- col=1, type="l", ...) {
+addLines2 <- function(x, main="", on=NA, type="l", pch=0, ...){
lenv <- new.env()
lenv$main <- main
- lenv$plot_ta <- function(x, ta, on, type, col,...) {
+ lenv$plot_lines <- function(x, ta, on, type, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
- if(all(is.na(on))) {
- # x-axis grid lines based on Env$xdata and Env$xsubset
+ colorset <- x$Env$theme$colorset
+ if(all(is.na(on))){
+ # Add x-axis grid lines
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3],
axTicksByTime2(xdata[xsubset]),
par("usr")[4],
col=x$Env$theme$grid)
}
- if(is.logical(ta)) {
- ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset]
- shade <- shading(as.logical(ta,drop=FALSE))
- if(length(shade$start) > 0) # all FALSE cause zero-length results
- rect(shade$start-1/3, par("usr")[3] ,shade$end+1/3, par("usr")[4], col=col,...)
- } else {
- # we can add points that are not necessarily at the points
- # on the main series
- subset.range <- paste(start(x$Env$xdata[x$Env$xsubset]),
- end(x$Env$xdata[x$Env$xsubset]),sep="/")
- ta.adj <- merge(n=.xts(1:NROW(x$Env$xdata[x$Env$xsubset]),
- .index(x$Env$xdata[x$Env$xsubset]), tzone=indexTZ(x$Env$xdata)),ta)[subset.range]
- ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
- ta.y <- ta.adj[,-1]
- chart.lines(ta.y, colorset=col, type=type)
- }
+ # we can add points that are not necessarily at the points
+ # on the main series
+ subset.range <- paste(start(xdata[xsubset]),
+ end(xdata[xsubset]),sep="/")
+ ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
+ .index(xdata[xsubset]),
+ tzone=indexTZ(xdata)),ta)[subset.range]
+ ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
+ ta.y <- ta.adj[,-1]
+ chart.lines(ta.y, type=type, colorset=colorset, pch=pch)
}
- lenv$xdata <- x
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
- names(list(x=x,order=order,on=on,legend=legend,
- type=type,col=col,...)),
- list(x=x,order=order,on=on,legend=legend,
- type=type,col=col,...))
- exp <- parse(text=gsub("list","plot_ta",
+ names(list(x=x,on=on,type=type,pch=pch,...)),
+ list(x=x,on=on,type=type,pch=pch,...))
+ exp <- parse(text=gsub("list","plot_lines",
as.expression(substitute(list(x=current.xts_chob(),
- ta=get("x"),on=on,
- type=type,col=col,...)))),
+ ta=get("x"),
+ on=on,
+ type=type,
+ pch=pch,
+ ...)))),
srcfile=NULL)
+
plot_object <- current.xts_chob()
ncalls <- length(plot_object$Env$call_list)
plot_object$Env$call_list[[ncalls+1]] <- match.call()
+
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
- # if(is.logical(x)) no.update <- TRUE else no.update <- FALSE
- no.update <- TRUE
- # this merge isn't going to work if x isn't in xdata range. Something like:
- # na.approx(merge(n=.xts(1:NROW(xdata),.index(xdata)),ta)[,1])
- # should allow for any time not in the original to be merged in.
- # probably need to subset xdata _before_ merging, else subset will be wrong
- #
- #tav <- merge(x, xdata, join="right",retside=c(TRUE,FALSE))
- #lenv$xdata <- tav
- #tav <- tav[xsubset]
- lenv$col <- col
+ no.update <- FALSE
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
+ ylim <- range(na.omit(lenv$xdata[xsubset]))
+ lenv$ylim <- ylim
- if(is.na(on)) {
- plot_object$add_frame(ylim=c(0,1),asp=0.2)
+ if(is.na(on)){
+ # add the frame for drawdowns info
+ plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1,
- y=0.3,
- labels=main,
- col=c(1,col),adj=c(0,0),cex=0.9,offset=0,pos=4))
+ text.exp <- expression(text(x=1, y=0.3, labels=main,
+ col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
- plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1) # need to have a value set for ylim
+ # add frame for the actual drawdowns data
+ plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
plot_object$next_frame()
- # add grid lines, using custom function for MACD gridlines
- lenv$grid_lines <- function(xdata,xsubset) {
- pretty(range(xdata[xsubset]))
+
+ # 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]]
}
- exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
- col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
- # add axis labels/boxes
- expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
- noquote(format(grid_lines(xdata,xsubset),justify="right")),
- col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE)),
- expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
- noquote(format(grid_lines(xdata,xsubset),justify="right")),
- col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE)))
- plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
- } else {
+
+ # NOTE 'exp' was defined earlier as chart.lines
+ exp <- c(exp,
+ # y-axis grid lines
+ expression(segments(1,y_grid_lines(ylim),
+ NROW(xdata[xsubset]), y_grid_lines(ylim),
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)))
+ if(plot_object$Env$theme$lylab){
+ exp <- c(exp,
+ # y-axis labels/boxes
+ expression(text(1-1/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(plot_object$Env$theme$rylab){
+ exp <- c(exp,
+ expression(text(NROW(xdata[xsubset])+1/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)))
+ }
+ plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
+ } else {
for(i in 1:length(on)) {
plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable?
- lenv$grid_lines <- function(xdata,xsubset) {
- pretty(range(xdata[xsubset]))
- }
- exp <- c(exp,
- # LHS
- #expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
- # noquote(format(grid_lines(xdata,xsubset),justify="right")),
- # col=theme$labels,offset=0,pos=4,cex=0.9)),
- # RHS
- expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
- noquote(format(grid_lines(xdata,xsubset),justify="right")),
- col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
- #}
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
}
}
plot_object
-} #}}}
+}
+# based on quantmod::add_TA
+# addLines <- function(x, main="", order=NULL, on=NA, legend="auto",
+# yaxis=list(NULL,NULL),
+# col=1, type="l", ...) {
+# lenv <- new.env()
+# lenv$main <- main
+# lenv$plot_ta <- function(x, ta, on, type, col,...) {
+# xdata <- x$Env$xdata
+# xsubset <- x$Env$xsubset
+# if(all(is.na(on))) {
+# # x-axis grid lines based on Env$xdata and Env$xsubset
+# segments(axTicksByTime2(xdata[xsubset]),
+# par("usr")[3],
+# axTicksByTime2(xdata[xsubset]),
+# par("usr")[4],
+# col=x$Env$theme$grid)
+# }
+# if(is.logical(ta)) {
+# ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset]
+# shade <- shading(as.logical(ta,drop=FALSE))
+# if(length(shade$start) > 0) # all FALSE cause zero-length results
+# rect(shade$start-1/3, par("usr")[3] ,shade$end+1/3, par("usr")[4], col=col,...)
+# } else {
+# # we can add points that are not necessarily at the points
+# # on the main series
+# subset.range <- paste(start(x$Env$xdata[x$Env$xsubset]),
+# end(x$Env$xdata[x$Env$xsubset]),sep="/")
+# ta.adj <- merge(n=.xts(1:NROW(x$Env$xdata[x$Env$xsubset]),
+# .index(x$Env$xdata[x$Env$xsubset]), tzone=indexTZ(x$Env$xdata)),ta)[subset.range]
+# ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
+# ta.y <- ta.adj[,-1]
+# chart.lines(ta.y, colorset=col, type=type)
+# }
+# }
+# lenv$xdata <- x
+# # map all passed args (if any) to 'lenv' environment
+# mapply(function(name,value) { assign(name,value,envir=lenv) },
+# names(list(x=x,order=order,on=on,legend=legend,
+# type=type,col=col,...)),
+# list(x=x,order=order,on=on,legend=legend,
+# type=type,col=col,...))
+# exp <- parse(text=gsub("list","plot_ta",
+# as.expression(substitute(list(x=current.xts_chob(),
+# ta=get("x"),on=on,
+# type=type,col=col,...)))),
+# srcfile=NULL)
+# plot_object <- current.xts_chob()
+# ncalls <- length(plot_object$Env$call_list)
+# plot_object$Env$call_list[[ncalls+1]] <- match.call()
+# xdata <- plot_object$Env$xdata
+# xsubset <- plot_object$Env$xsubset
+# # if(is.logical(x)) no.update <- TRUE else no.update <- FALSE
+# no.update <- TRUE
+# # this merge isn't going to work if x isn't in xdata range. Something like:
+# # na.approx(merge(n=.xts(1:NROW(xdata),.index(xdata)),ta)[,1])
+# # should allow for any time not in the original to be merged in.
+# # probably need to subset xdata _before_ merging, else subset will be wrong
+# #
+# #tav <- merge(x, xdata, join="right",retside=c(TRUE,FALSE))
+# #lenv$xdata <- tav
+# #tav <- tav[xsubset]
+# lenv$col <- col
+# lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
+#
+# if(is.na(on)) {
+# plot_object$add_frame(ylim=c(0,1),asp=0.2)
+# plot_object$next_frame()
+# text.exp <- expression(text(x=1,
+# y=0.3,
+# labels=main,
+# col=c(1,col),adj=c(0,0),cex=0.9,offset=0,pos=4))
+# plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
+#
+# plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1) # need to have a value set for ylim
+# plot_object$next_frame()
+# # add grid lines, using custom function for MACD gridlines
+# lenv$grid_lines <- function(xdata,xsubset) {
+# pretty(range(xdata[xsubset]))
+# }
+# exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
+# col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
+# # add axis labels/boxes
+# expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
+# noquote(format(grid_lines(xdata,xsubset),justify="right")),
+# col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE)),
+# expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
+# noquote(format(grid_lines(xdata,xsubset),justify="right")),
+# col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE)))
+# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
+# } else {
+# for(i in 1:length(on)) {
+# plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable?
+# lenv$grid_lines <- function(xdata,xsubset) {
+# pretty(range(xdata[xsubset]))
+# }
+# exp <- c(exp,
+# # LHS
+# #expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
+# # noquote(format(grid_lines(xdata,xsubset),justify="right")),
+# # col=theme$labels,offset=0,pos=4,cex=0.9)),
+# # RHS
+# expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
+# noquote(format(grid_lines(xdata,xsubset),justify="right")),
+# col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
+# #}
+# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
+# }
+# }
+# plot_object
+# } #}}}
+
addReturns <- function(type="h", main=NULL, ylim=NULL){
# This just plots the raw returns data
lenv <- new.env()
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-06 15:22:46 UTC (rev 845)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-08 23:53:44 UTC (rev 846)
@@ -109,6 +109,32 @@
plot2_xts(R, FUN=foo, legend.loc="right")
plot2_xts(R, FUN=foo, legend.loc="bottomright")
+
+plot2_xts(R, FUN=foo)
+xtsExtra:::addLines2(R[,1])
+
+plot2_xts(R, FUN="CumReturns")
+addLines2(R[,1], type="h")
+
+plot2_xts(R, FUN="CumReturns")
+tmp1 <- tmp2 <- R[,1]
+tmp1[,1] <- 1.5
+
+tmp2[,1] <- 1
+
+tmp <- CumReturns(R[,1])
+tmp3 <- tmp[seq(from=1, to=NROW(R), by=10),]
+
+addLines2(tmp1, on=1)
+addLines2(tmp2, on=1, type="p", pch=5)
+addLines2(tmp3, on=1, type="p", pch=2)
+
+
+# png("~/Documents/foo.png")
+# plot2_xts(R, FUN="CumReturns")
+# addDrawdowns()
+# dev.off()
+
##### scratch area #####
# Should we have a theme object, as in quantmod, that sets all of the basic
# parameters such as lty, lwd, las, cex, colorset, element.color, etc?
From noreply at r-forge.r-project.org Wed Sep 10 00:38:15 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 10 Sep 2014 00:38:15 +0200 (CEST)
Subject: [Xts-commits] r847 - in pkg/xtsExtra: R man sandbox
Message-ID: <20140909223815.57B481876AE@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-10 00:38:14 +0200 (Wed, 10 Sep 2014)
New Revision: 847
Added:
pkg/xtsExtra/man/plot2_xts.Rd
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
adding first draft of help file for plot2
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-08 23:53:44 UTC (rev 846)
+++ pkg/xtsExtra/R/plot2.R 2014-09-09 22:38:14 UTC (rev 847)
@@ -171,6 +171,54 @@
theme
}
+#' 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 colorset 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.
+#'
+#'
plot2_xts <- function(x,
y=NULL,
...,
Added: pkg/xtsExtra/man/plot2_xts.Rd
===================================================================
--- pkg/xtsExtra/man/plot2_xts.Rd (rev 0)
+++ pkg/xtsExtra/man/plot2_xts.Rd 2014-09-09 22:38:14 UTC (rev 847)
@@ -0,0 +1,97 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{plot2_xts}
+\alias{plot2_xts}
+\title{Time series Plotting}
+\usage{
+plot2_xts(x, y = NULL, ..., subset = "", FUN = NULL, panels = NULL,
+ multi.panel = FALSE, colorset = 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)
+}
+\arguments{
+\item{x}{xts object}
+
+\item{y}{NULL, not used}
+
+\item{\dots}{any passthrough parameters to FUN}
+
+\item{subset}{character vector of length one of the subset range using subsetting as in \code{\link{xts}}}
+
+\item{FUN}{function to apply to \code{x} and plot}
+
+\item{panels}{character vector of expressions to plot as panels}
+
+\item{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.}
+
+\item{colorset}{color palette to use, set by default to rational choices}
+
+\item{up.col}{color for positive bars if \code{type="h"}}
+
+\item{dn.col}{color for positive bars if \code{type="h"}}
+
+\item{type}{the type of plot to be drawn, same as in \code{\link{plot}}}
+
+\item{lty}{set the line type, same as in plot}
+
+\item{lwd}{set the line width, same as in plot}
+
+\item{lend}{set the line end style, same as in plot}
+
+\item{main}{main title}
+
+\item{clev}{level for shading, not currently used}
+
+\item{cex}{not currently used}
+
+\item{cex.axis}{}
+
+\item{mar}{set the margins, same as in par}
+
+\item{srt}{rotation for the y axis labels}
+
+\item{xaxis.las}{rotation for the x axis labels}
+
+\item{ylim}{the range of the y axis}
+
+\item{yaxis.same}{TRUE/FALSE. If TRUE, the y axis is drawn with the same ylim for multiple panels}
+
+\item{yaxis.left}{if TRUE, draws the y axis on the left}
+
+\item{yaxis.right}{if TRUE, draws the y axis on the right}
+
+\item{grid.ticks.on}{period to draw the grid ticks on}
+
+\item{grid.ticks.lwd}{line width of the grid}
+
+\item{grid.ticks.lty}{line type of the grid}
+
+\item{grid.col}{color of the grid}
+
+\item{labels.col}{color of the axis labels}
+
+\item{format.labels}{not currently used}
+
+\item{shading}{not currently used}
+
+\item{bg.col}{not currently used}
+
+\item{grid2}{color for secondary x axis grid}
+
+\item{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.}
+}
+\description{
+Plotting for xts objects.
+TODO: description, details, and examples
+}
+
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-08 23:53:44 UTC (rev 846)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-09 22:38:14 UTC (rev 847)
@@ -11,8 +11,10 @@
# assign to a variable and then print it results in a plot
x <- plot2_xts(R)
+y <- addReturns()
+x
class(x)
-x
+y
# small multiples, line plot of each column
plot2_xts(R, multi.panel=TRUE)
@@ -35,7 +37,7 @@
plot2_xts(R, multi.panel=TRUE, type="h")
# Replicate charts.PerformanceSummary
-plot2_xts(R, FUN="CumReturns")
+plot2_xts(R, FUN=CumReturns)
addReturns(type="h")
addDrawdowns()
@@ -43,8 +45,9 @@
plot2_xts(R, FUN="CumReturns",
panels=c("addReturns(type='h')", "addDrawdowns()"))
+R <- edhec[,1:8]
layout(matrix(1:4, 2, 2))
-plot2_xts(R, multi.panel=1, FUN="CumReturns",
+plot2_xts(R, multi.panel=2, FUN="CumReturns",
panels=c("addReturns(type='h')", "addDrawdowns()"))
layout(matrix(1))
@@ -81,6 +84,7 @@
x$Env$call_list
x$Env$call_list[[1]]
+R <- edhec[,1:4]
plot2_xts(R, FUN="CumReturns")
plot2_xts(R, FUN="CumReturns", lty=1:4)
plot2_xts(R, FUN="CumReturns", lty=1:4, lwd=c(3, 1, 1, 1))
@@ -130,10 +134,10 @@
addLines2(tmp3, on=1, type="p", pch=2)
-# png("~/Documents/foo.png")
-# plot2_xts(R, FUN="CumReturns")
-# addDrawdowns()
-# dev.off()
+png("~/Documents/foo.png")
+plot2_xts(R, FUN="CumReturns")
+addDrawdowns()
+dev.off()
##### scratch area #####
# Should we have a theme object, as in quantmod, that sets all of the basic
From noreply at r-forge.r-project.org Wed Sep 10 20:01:57 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 10 Sep 2014 20:01:57 +0200 (CEST)
Subject: [Xts-commits] r848 - in pkg/xtsExtra: . R
Message-ID: <20140910180157.2308118649E@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-10 20:01:56 +0200 (Wed, 10 Sep 2014)
New Revision: 848
Modified:
pkg/xtsExtra/NAMESPACE
pkg/xtsExtra/R/plot2.R
Log:
fixing export for addLines
Modified: pkg/xtsExtra/NAMESPACE
===================================================================
--- pkg/xtsExtra/NAMESPACE 2014-09-09 22:38:14 UTC (rev 847)
+++ pkg/xtsExtra/NAMESPACE 2014-09-10 18:01:56 UTC (rev 848)
@@ -18,7 +18,6 @@
export("xtsExtraTheme")
export("addDrawdowns")
export("addLines")
-export("addLines2")
export("addReturns")
export("addRollingPerformance")
export("addLegend")
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-09 22:38:14 UTC (rev 847)
+++ pkg/xtsExtra/R/plot2.R 2014-09-10 18:01:56 UTC (rev 848)
@@ -785,7 +785,7 @@
plot_object
}
-addLines2 <- function(x, main="", on=NA, type="l", pch=0, ...){
+addLines <- function(x, main="", on=NA, type="l", pch=0, ...){
lenv <- new.env()
lenv$main <- main
lenv$plot_lines <- function(x, ta, on, type, ...){
From noreply at r-forge.r-project.org Fri Sep 12 15:34:22 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 12 Sep 2014 15:34:22 +0200 (CEST)
Subject: [Xts-commits] r849 - pkg/xtsExtra/R
Message-ID: <20140912133422.43D371876C0@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-12 15:34:21 +0200 (Fri, 12 Sep 2014)
New Revision: 849
Modified:
pkg/xtsExtra/R/plot2.R
Log:
adding warning message if type="h" is specified for multivariate series
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-10 18:01:56 UTC (rev 848)
+++ pkg/xtsExtra/R/plot2.R 2014-09-12 13:34:21 UTC (rev 849)
@@ -688,6 +688,8 @@
}
}
} 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,
@@ -1030,6 +1032,9 @@
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
+ if(type == "h" & NCOL(xdata) > 1)
+ warning("only the univariate series will be plotted")
+
# add data to the local environment
lenv$xdata <- xdata
lenv$xsubset <- xsubset
From noreply at r-forge.r-project.org Sat Sep 13 00:16:50 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sat, 13 Sep 2014 00:16:50 +0200 (CEST)
Subject: [Xts-commits] r850 - in pkg/xtsExtra: . R sandbox
Message-ID: <20140912221650.BB85E187527@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-13 00:16:50 +0200 (Sat, 13 Sep 2014)
New Revision: 850
Modified:
pkg/xtsExtra/NAMESPACE
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
adding the addLines function to add event lines
Modified: pkg/xtsExtra/NAMESPACE
===================================================================
--- pkg/xtsExtra/NAMESPACE 2014-09-12 13:34:21 UTC (rev 849)
+++ pkg/xtsExtra/NAMESPACE 2014-09-12 22:16:50 UTC (rev 850)
@@ -14,13 +14,17 @@
S3method(barplot, xts)
export("plot2_xts")
+export("addSeries")
+export("addPoints")
+export("addLines")
+export("addLegend")
+
export("chart_pars")
export("xtsExtraTheme")
export("addDrawdowns")
-export("addLines")
export("addReturns")
export("addRollingPerformance")
-export("addLegend")
+
S3method(print, replot_xts)
S3method(plot, replot_xts)
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-12 13:34:21 UTC (rev 849)
+++ pkg/xtsExtra/R/plot2.R 2014-09-12 22:16:50 UTC (rev 850)
@@ -113,16 +113,16 @@
}
# function from Peter Carl to add labels to the plot window
-add_label <- function(xfrac, yfrac, label, pos=4, ylog, ...) {
- u <- par("usr")
- x <- u[1] + xfrac * (u[2] - u[1])
- y <- u[4] - yfrac * (u[4] - u[3])
- if(ylog){
- text(x, 10^y, label, pos = pos, ...)
- } else {
- text(x, y, label, pos = pos, ...)
- }
-}
+# add_label <- function(xfrac, yfrac, label, pos=4, ylog, ...) {
+# u <- par("usr")
+# x <- u[1] + xfrac * (u[2] - u[1])
+# y <- u[4] - yfrac * (u[4] - u[3])
+# if(ylog){
+# text(x, 10^y, label, pos = pos, ...)
+# } else {
+# text(x, y, label, pos = pos, ...)
+# }
+# }
# chart_Series {{{
# Updated: 2010-01-15
@@ -787,10 +787,11 @@
plot_object
}
-addLines <- function(x, main="", on=NA, type="l", pch=0, ...){
+
+addSeries <- function(x, main="", on=NA, type="l", lty=1, lwd=1, pch=0, ...){
lenv <- new.env()
lenv$main <- main
- lenv$plot_lines <- function(x, ta, on, type, ...){
+ lenv$plot_lines <- function(x, ta, on, type, lty, lwd, pch, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
colorset <- x$Env$theme$colorset
@@ -811,17 +812,19 @@
tzone=indexTZ(xdata)),ta)[subset.range]
ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
ta.y <- ta.adj[,-1]
- chart.lines(ta.y, type=type, colorset=colorset, pch=pch)
+ chart.lines(ta.y, type=type, colorset=colorset, lty=lty, lwd=lwd, pch=pch)
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
- names(list(x=x,on=on,type=type,pch=pch,...)),
- list(x=x,on=on,type=type,pch=pch,...))
+ names(list(x=x,on=on,type=type,lty=lty,lwd=lwd,pch=pch,...)),
+ list(x=x,on=on,type=type,lty=lty,lwd=lwd,pch=pch,...))
exp <- parse(text=gsub("list","plot_lines",
as.expression(substitute(list(x=current.xts_chob(),
ta=get("x"),
on=on,
type=type,
+ lty=lty,
+ lwd=lwd,
pch=pch,
...)))),
srcfile=NULL)
@@ -845,7 +848,7 @@
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
- # add frame for the actual drawdowns data
+ # add frame for the data
plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
plot_object$next_frame()
@@ -887,6 +890,162 @@
plot_object
}
+addPoints <- function(x, main="", on=NA, pch=0, ...){
+ addSeries(x, main=main, on=on, type="p", pch=pch, ...)
+}
+
+
+addLines <- function(event.dates, event.labels=NULL, date.format="%Y-%m-%d", main="", on=NA, lty=1, lwd=1, col=1, ...){
+ # add checks for event.dates and event.labels
+ if(!is.null(event.labels))
+ if(length(event.dates) != length(event.labels)) stop("length of event.dates must match length of event.labels")
+
+ lenv <- new.env()
+ lenv$main <- main
+ lenv$plot_event_lines <- function(x, event.dates, event.labels, date.format, on, lty, lwd, col, ...){
+ xdata <- x$Env$xdata
+ xsubset <- x$Env$xsubset
+ colorset <- x$Env$theme$colorset
+ if(all(is.na(on))){
+ # Add x-axis grid lines
+ segments(axTicksByTime2(xdata[xsubset]),
+ par("usr")[3],
+ axTicksByTime2(xdata[xsubset]),
+ par("usr")[4],
+ col=x$Env$theme$grid)
+ }
+ ypos <- x$Env$ylim[[2*on]][2]
+ # create a new xts object out of event.dates
+ event.dates.xts <- xts(rep(999, length(event.dates)), order.by=as.Date(event.dates, format=date.format))
+ # we can add points that are not necessarily at the points on the main series
+ subset.range <- paste(start(xdata[xsubset]),
+ end(xdata[xsubset]),sep="/")
+ ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
+ .index(xdata[xsubset]),
+ tzone=indexTZ(xdata)),event.dates.xts)[subset.range]
+ ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
+ ta.y <- ta.adj[,-1]
+ event.ind <- which(ta.y == 999)
+ abline(v=event.ind, col=col, lty=lty, lwd=lwd)
+ text(x=event.ind, y=ypos, labels=event.labels, offset=.2, pos=2, , srt=90, col=1)
+ }
+
+ plot_object <- current.xts_chob()
+ ncalls <- length(plot_object$Env$call_list)
+ plot_object$Env$call_list[[ncalls+1]] <- match.call()
+
+ if(is.na(on[1])){
+ # map all passed args (if any) to 'lenv' environment
+ mapply(function(name,value) { assign(name,value,envir=lenv) },
+ names(list(event.dates=event.dates,event.labels=event.labels,date.format=date.format,on=on,lty=lty,lwd=lwd,col=col,...)),
+ list(event.dates=event.dates,event.labels=event.labels,date.format=date.format,on=on,lty=lty,lwd=lwd,col=col,...))
+ exp <- parse(text=gsub("list","plot_event_lines",
+ as.expression(substitute(list(x=current.xts_chob(),
+ event.dates=event.dates,
+ event.labels=event.labels,
+ date.format=date.format,
+ on=on,
+ lty=lty,
+ lwd=lwd,
+ col=col,
+ ...)))),
+ srcfile=NULL)
+
+ xdata <- plot_object$Env$xdata
+ xsubset <- plot_object$Env$xsubset
+ no.update <- FALSE
+ lenv$xdata <- xdata
+ ylim <- range(na.omit(xdata))
+ lenv$ylim <- ylim
+
+ # add the frame for drawdowns info
+ plot_object$add_frame(ylim=c(0,1),asp=0.25)
+ plot_object$next_frame()
+ text.exp <- expression(text(x=1, y=0.3, labels=main,
+ col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
+ plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
+
+ # add frame for the data
+ plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
+ plot_object$next_frame()
+
+ # 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(1,y_grid_lines(ylim),
+ NROW(xdata[xsubset]), y_grid_lines(ylim),
+ col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)))
+ if(plot_object$Env$theme$lylab){
+ exp <- c(exp,
+ # y-axis labels/boxes
+ expression(text(1-1/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(plot_object$Env$theme$rylab){
+ exp <- c(exp,
+ expression(text(NROW(xdata[xsubset])+1/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)))
+ }
+ plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
+ } else {
+ for(i in 1:length(on)) {
+ ind <- on[i]
+ no.update <- FALSE
+ # map all passed args (if any) to 'lenv' environment
+ mapply(function(name,value) { assign(name,value,envir=lenv) },
+ names(list(event.dates=event.dates,event.labels=event.labels,date.format=date.format,on=ind,lty=lty,lwd=lwd,col=col,...)),
+ list(event.dates=event.dates,event.labels=event.labels,date.format=date.format,on=ind,lty=lty,lwd=lwd,col=col,...))
+ exp <- parse(text=gsub("list","plot_event_lines",
+ as.expression(substitute(list(x=current.xts_chob(),
+ event.dates=event.dates,
+ event.labels=event.labels,
+ date.format=date.format,
+ on=ind,
+ lty=lty,
+ lwd=lwd,
+ col=col,
+ ...)))),
+ srcfile=NULL)
+
+ plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable?
+ plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
+ }
+ }
+ plot_object
+}
+
+
+# # Needed for finding aligned dates for event lines and period areas
+# rownames = as.Date(time(y))
+# rownames = format(strptime(rownames,format = date.format.in), date.format)
+# # Add event.lines before drawing the data
+# # This only labels the dates it finds
+# if(!is.null(event.lines)) {
+# event.ind = NULL
+# for(event in 1:length(event.lines)){
+# event.ind = c(event.ind, grep(event.lines[event], rownames))
+# }
+# number.event.labels = ((length(event.labels)-length(event.ind) + 1):length(event.labels))
+#
+# abline(v = event.ind, col = event.color, lty = 2)
+# if(!is.null(event.labels)) {
+# text(x=event.ind,y=ylim[2], label = event.labels[number.event.labels], offset = .2, pos = 2, cex = cex.labels, srt=90, col = event.color)
+# }
+# }
+
+
+
# based on quantmod::add_TA
# addLines <- function(x, main="", order=NULL, on=NA, legend="auto",
# yaxis=list(NULL,NULL),
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-12 13:34:21 UTC (rev 849)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-12 22:16:50 UTC (rev 850)
@@ -40,6 +40,8 @@
plot2_xts(R, FUN=CumReturns)
addReturns(type="h")
addDrawdowns()
+addLines(c("1999-01-01", "2000-01-01", "2005-01-01"), c("foo", "bar", "pizza"), on=1:3)
+addLines(c("1999-01-01", "2000-01-01", "2005-01-01"))
plot2_xts(R, FUN="CumReturns",
@@ -134,11 +136,20 @@
addLines2(tmp3, on=1, type="p", pch=2)
-png("~/Documents/foo.png")
-plot2_xts(R, FUN="CumReturns")
-addDrawdowns()
-dev.off()
+stock.str='AAPL'
+initDate="2011-01-01"
+endDate="2012-12-31"
+getSymbols(stock.str,from=initDate,to=endDate, src="yahoo")
+plot2_xts(Ad(AAPL))
+addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1)
+addLines(c("2011-03-04", "2012-01-10", "2012-07-28"), on=1)
+addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1)
+# png("~/Documents/foo.png")
+# plot2_xts(R, FUN="CumReturns")
+# addDrawdowns()
+# dev.off()
+
##### scratch area #####
# Should we have a theme object, as in quantmod, that sets all of the basic
# parameters such as lty, lwd, las, cex, colorset, element.color, etc?
From noreply at r-forge.r-project.org Sat Sep 13 00:36:00 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sat, 13 Sep 2014 00:36:00 +0200 (CEST)
Subject: [Xts-commits] r851 - in pkg/xtsExtra: . R man sandbox
Message-ID: <20140912223600.E5A651876C8@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-13 00:36:00 +0200 (Sat, 13 Sep 2014)
New Revision: 851
Removed:
pkg/xtsExtra/man/plot2_xts.Rd
Modified:
pkg/xtsExtra/NAMESPACE
pkg/xtsExtra/R/plot.R
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/man/plot.xts.Rd
pkg/xtsExtra/sandbox/test_plot2.R
Log:
s/plot2_xts/plot
Modified: pkg/xtsExtra/NAMESPACE
===================================================================
--- pkg/xtsExtra/NAMESPACE 2014-09-12 22:16:50 UTC (rev 850)
+++ pkg/xtsExtra/NAMESPACE 2014-09-12 22:36:00 UTC (rev 851)
@@ -8,12 +8,12 @@
## Graphics
export("plot.xts")
-export("barplot.xts")
-export("default.panel")
+#export("barplot.xts")
+#export("default.panel")
S3method(plot, xts)
-S3method(barplot, xts)
+#S3method(barplot, xts)
-export("plot2_xts")
+#export("plot2_xts")
export("addSeries")
export("addPoints")
export("addLines")
Modified: pkg/xtsExtra/R/plot.R
===================================================================
--- pkg/xtsExtra/R/plot.R 2014-09-12 22:16:50 UTC (rev 850)
+++ pkg/xtsExtra/R/plot.R 2014-09-12 22:36:00 UTC (rev 851)
@@ -1,529 +1,529 @@
-# xtsExtra: Extensions to xts during GSOC-2012
-#
-# Copyright (C) 2012 Michael Weylandt: michael.weylandt at 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 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 .
-
-`plot.xts` <- function(x, y = NULL, screens = 'auto', layout.screens = 'auto', ...,
- yax.loc = c("none", "out", "in", "flip", "left", "right", "top"),
- auto.grid = TRUE, major.ticks = 'auto', minor.ticks = TRUE, major.format = TRUE,
- bar.col.up = 'white', bar.col.dn ='red', candle.col='black',
- xy.labels = FALSE, xy.lines = NULL, ylim = 'auto', panel = default.panel,
- auto.legend = FALSE, legend.names = colnames(x), legend.loc = "topleft",
- legend.pars = NULL, events, blocks, nc, nr) {
-
- # Set cex.lab early to a reasonable default; this allows user to still override
- if(length(screens) > 1L || (NCOL(x) > 1L && identical(screens, "auto"))) par(cex.lab = 0.8)
-
- # Restore old par() options from what I change in here
- old.par <- par(no.readonly = TRUE)
-
- on.exit(par(old.par))
- on.exit(assign(".plot.xts", recordPlot(), .GlobalEnv), add = TRUE)
-
- dots <- list(...)
-
- do.call(par, dots[!(names(dots) %in%
- c("col", "type", "lwd", "pch", "log", "cex", "ylab", "main", "axes", "xlab", "lty"))])
-
- ## if y supplied: scatter plot y ~ x
- if(!is.null(y)) {
-
- xlab <- if("xlab" %in% names(dots)) dots[["xlab"]] else deparse(substitute(x))
- ylab <- if("ylab" %in% names(dots)) dots[["ylab"]] else deparse(substitute(y))
-
- if(NCOL(x) > 1L || NCOL(y) > 1L){
- layout(matrix(seq_len(NCOL(x)*NCOL(y)),ncol = NCOL(x), nrow = NCOL(y)))
- par(mar = c(2,2,2,2), oma = c(0,0,3,0))
-
- for(i in seq_len(NCOL(x))){
- for(j in seq_len(NCOL(y))){
- do_scatterplot(x[,i], y[,j], xy.labels, xy.lines, xlab = "", ylab = "", ...,
- main = paste(names(x)[i],"vs.",names(y)[j]))
- }
- }
-
- mtext(paste(xlab, "vs.", ylab), outer = TRUE, line = 0)
-
- return(invisible(merge(x,y)))
- } else {
- return(do_scatterplot(x,y, xy.labels, xy.lines, xlab, ylab, ...))
- }
- }
-
- ## Else : no y, only x
-
- # Need to catch this one early before try.xts forces evaluation
- main <- if(!("main" %in% names(dots))) deparse(substitute(x)) else dots[["main"]]
-
- x <- try.xts(x)
-
- if("xlim" %in% names(dots)){
- xlim <- dots[["xlim"]]
-
- if(is.timeBased(xlim)){
- if(length(xlim) != 2L) stop("Need endpoints only for xlim")
- xlim <- do.call(paste0("as.",indexClass(x))[1L], list(xlim))
- x <- x[(index(x) > xlim[1L]) & (index(x) < xlim[2L]), , drop = FALSE]
- }
- if(is.numeric(xlim)){
- warning("Using xlim as row indices -- provide timeBased xlim",
- "if you wish to subset that way")
- x <- x[xlim[1L]:xlim[2L], drop = FALSE]
- }
- if(is.character(xlim)){
- x <- x[xlim, , drop = FALSE]
- }
- }
-
- yax.loc <- match.arg(yax.loc)
-
- # Catch OHLC case independently
- if("type" %in% names(dots) && dots[["type"]] %in% c('candles','bars')){
-
- type <- dots[["type"]]
-
- if(!xts:::is.OHLC(x)) stop(type, '-chart not supported for non-OHLC series')
-
- do_plot.ohlc(x, bar.col.up = bar.col.up, bar.col.dn = bar.col.dn,
- candle.col = candle.col, major.ticks = major.ticks,
- minor.ticks = minor.ticks, auto.grid = auto.grid,
- major.format = major.format, main = main,
- candles = (type == "candles"), events = events,
- blocks = blocks, yax.loc = yax.loc, ylim = ylim, ...)
-
- } else {
- # Else need to do layout plots
- screens <- do_layout(x, screens = screens, layout.screens = layout.screens,
- yax.loc = yax.loc, nc = nc, nr = nr, ylim = ylim)
-
- layout.screens <- screens[["layout.screens"]]
- have_x_axis <- screens[["have_x_axis"]]
- have_y_axis <- screens[["have_y_axis"]]
- ylab.axis <- screens[["ylab.axis"]]
- ylim <- screens[["ylim"]]
- screens <- screens[["screens"]]
-
- x.split <- split.xts.by.cols(x, screens)
-
- # Set panelwise parameters here
- ylab <- dots[["ylab"]]
- if(is.null(ylab)) {
- if(is.null(names(x)))
- ylab <- ""
- else
- ylab <- split(names(x), screens)
- }
-
- log <- dots[["log"]]
- if(is.null(log)) log <- ""
-
- if(auto.legend) legend.names <- split(legend.names, screens)
-
- # For now, loop over screens one by one constructing relevant elements
- for(i in seq_along(levels((screens)))){
- x.plot <- x.split[[i]]
-
- col.panel <- get.elm.from.dots("col", dots, screens, i)
- pch.panel <- get.elm.from.dots("pch", dots, screens, i)
- cex.panel <- get.elm.from.dots("cex", dots, screens, i)
- lwd.panel <- get.elm.from.dots("lwd", dots, screens, i)
- type.panel <- get.elm.from.dots("type", dots, screens, i)
- lty.panel <- get.elm.from.dots("lty", dots, screens, i)
-
- log.panel <- get.elm.recycle(log, i)[[1L]]
- ylab.panel <- get.elm.recycle(ylab, i)[[1L]]
-
- panel.panel <- match.fun(if(length(panel) > 1L) get.elm.recycle(panel, i) else panel)
-
- # Note that do_add.grid also sets up axes and what not
- do_add.grid(x.plot, major.ticks, major.format, minor.ticks,
- auto.grid = auto.grid, ylab = ylab.panel, log = log.panel,
- have_x_axis = have_x_axis[i], have_y_axis = have_y_axis[i],
- ylab.axis = ylab.axis[which.max(layout.screens == i)], # Use which.max to get first hit
- events = events, blocks = blocks,
- yax.loc = yax.loc, ylim = get.elm.recycle(ylim, i))
-
- legend.pars.add <- do_add.panel(x.plot, panel = panel.panel, col = col.panel, lwd = lwd.panel,
- pch = pch.panel, type = type.panel, cex = cex.panel, lty = lty.panel)
-
- if(auto.legend && !is.na(get.elm.recycle(legend.loc,i)))
- do.call(do_add.legend, c(legend.names = list(legend.names[[i]]),
- legend.loc = get.elm.recycle(legend.loc, i),
- legend.pars.add, legend.pars))
- }
-
- }
- title(main, outer = TRUE) # outer = length(levels(screens)) > 1L)
- return(invisible(reclass(x)))
-}
-
-do_scatterplot <- function(x, y, xy.labels, xy.lines, xlab, ylab, main,
- log, cex, xlim, ylim, type, pch, col, ...){
-
- if(missing(main)) main <- paste(xlab, "vs.", ylab)
- if(missing(log)) log <- ''
- if(missing(cex)) cex <- 0.8
- if(missing(pch)) pch <- 1L
- if(missing(col)) col <- 1L
-
- x <- try.xts(x); y <- try.xts(y)
-
- xy.xts <- merge(x, y, join = "inner")
-
- xy <- coredata(xy.xts)
-
- xy <- xy.coords(xy[,1L], xy[,2L])
-
- if(missing(xlim)) xlim <- range(xy$x[is.finite(xy$x)], na.rm = TRUE)
- if(missing(ylim)) ylim <- range(xy$y[is.finite(xy$y)], na.rm = TRUE)
-
- do.lab <- if(is.logical(xy.labels)) xy.labels else TRUE
-
- if(is.null(xy.lines)) xy.lines <- do.lab
-
- ptype <- if(missing(type)){if(do.lab) "n" else "p"} else type
- type <- if(missing(type)){if(do.lab) "c" else "l"} else type
-
- plot(xy[1:2], type = ptype, main = main, xlab = xlab,
- ylab = ylab, xlim = xlim, ylim = ylim, log = log, pch = pch, col = col)
-
- if(do.lab) text(xy[1:2], cex = cex, labels = if(!is.logical(xy.labels))
- xy.labels else index2char(index(xy.xts)), col = col)
-
- if(xy.lines) segments(xy[[1L]][-NROW(xy[[1L]])],xy[[2L]][-NROW(xy[[2L]])],
- xy[[1L]][-1L],xy[[2L]][-1L], col = col)
-
- return(invisible(xy.xts))
-}
-
-do_layout <- function(x, screens, layout.screens, yax.loc, nc, nr, ylim){
- # By default one screen per panel
- screens <- factor(if(identical(screens,"auto")) seq_len(NCOL(x)) else
- rep(screens, length.out = NCOL(x)))
-
- if(identical(layout.screens, "auto")){
- layout.screens <- seq_along(levels(screens))
- if(!missing(nc) && !missing(nr))
- layout.screens <- matrix(layout.screens, ncol = nc, nrow = nrow)
- if(missing(nc) && !missing(nr))
- layout.screens <- matrix(layout.screens, nrow = nr)
- if(!missing(nc) && missing(nr))
- layout.screens <- matrix(layout.screens, ncol = nc)
- }
-
- if(is.list(layout.screens)) {
- layout.args <- layout.screens[-1L]
- layout.screens <- layout.screens[[1L]]
- }
-
- layout.screens <- as.matrix(layout.screens)
-
- have_x_axis <- logical(length(levels(screens)))
- for(i in seq_len(NROW(layout.screens))){
- if(i == NROW(layout.screens)){
- have_x_axis[layout.screens[i,]] <- TRUE
- } else {
- if(!identical(as.logical(diff(layout.screens[i, ])),
- as.logical(diff(layout.screens[i + 1L,])))){
- have_x_axis[layout.screens[i,]] <- TRUE
- }
- }
- }
-
- have_y_axis <- logical(length(levels(screens)))
- for(i in seq_len(NCOL(layout.screens))){
- if(i == 1L){
- have_y_axis[layout.screens[,i]] <- TRUE
- } else {
- if(!identical(as.logical(diff(layout.screens[ ,i - 1L])),
- as.logical(diff(layout.screens[ ,i])))){
- have_y_axis[layout.screens[,i]] <- TRUE
- }
- }
- }
-
- # Here we handle y-axis labeling case by case and mark when margins are needed
- # From this part, we return a vector ylab.axis giving L/R/None marks for y-labels
- # Margins are set appropriately back in main function body
-
- ylab.axis <- layout.screens
-
- if(yax.loc == "none") ylab.axis[] <- "none"
-
- # If labels are set to left/right we need them in all panels
- if(yax.loc == "right" || yax.loc == "left") {
- have_y_axis[] <- TRUE # Since forcing labels, we write a y-axis everywhere
-
- ylab.axis[] <- yax.loc
- }
-
- if(yax.loc == "out" || yax.loc == "in"){
- if(NCOL(layout.screens) != 2L) stop("yax.loc not consistent with layout -- too many columns.")
- # If labels are set to out we need them for outer panels only
- # If labels are set to in we need them for inner panels only
- ylab.axis[,1L] <- if(yax.loc == "out") "left" else "right"
- ylab.axis[,2L] <- if(yax.loc == "out") "right" else "left"
- have_y_axis[] <- TRUE # Axes for all if TRUE
- }
-
- # If labels are set to flip we do a little bit of work to arrange them
- if(yax.loc == "flip") {
- for(i in seq_len(NCOL(ylab.axis)))
- ylab.axis[,i] <- rep(c("left","right"), length.out = NROW(ylab.axis))
- have_y_axis[] <- TRUE
- }
-
- if(yax.loc == "top"){
- ylab.axis[] <- yax.loc
- have_y_axis[] <- TRUE
- have_x_axis[] <- TRUE
- }
-
- # Moving internal margin code to the panel-wise setup, leaving oma (outer) margin here
- if(length(levels(screens)) > 1L) par(oma = c(1,1,4,1))
- if(yax.loc == "none") par(oma = c(1,4,4,3))
- if(length(levels(screens)) == 1L && yax.loc != "none") par(oma = c(1,1,4,1))
-
- if(identical(ylim,'fixed')){
- ylim <- list(range(x, na.rm = TRUE))
- } else if(identical(ylim, 'auto')){
- if(yax.loc == "none") {
- ylim <- lapply((1:NROW(layout.screens))[!duplicated(layout.screens)], function(y) {
- do.call(range,
- list(split.xts.by.cols(x, screens)[layout.screens[y,]], na.rm = TRUE))})
- } else {
- ylim <- lapply(split.xts.by.cols(x, screens), function(x) range(x, na.rm = TRUE))
- }
- } else{
- if(!is.matrix(ylim)) dim(ylim) <- c(1L, NROW(ylim))
- ylim <- lapply(1:NROW(ylim), function(x) ylim[x,1:2])
- }
-
- # Would like to use do.call and as.list so pro-users can pass widths and heights
- # to layout -- currently undocumented behavior
- # do.call("layout", as.list(layout.screens))
- # Currently I add a little bit extra height to those screens with x-axes
- if(length(layout.screens) > 1L){
- if(!exists("layout.args")) {
- layout(layout.screens, heights = 1 + 0.05*NROW(unique(layout.screens)) *
- apply(layout.screens, 1L ,function(j) any(have_x_axis[j])))
- # More dirty hacking.... still not perfect
- } else {
- do.call(layout, c(list(layout.screens), layout.args))
- }
- }
-
- return(list(layout.screens = layout.screens, screens = screens, have_x_axis = have_x_axis,
- have_y_axis = have_y_axis, ylab.axis = ylab.axis, ylim = ylim))
-}
-
-do_add.grid <- function(x, major.ticks, major.format, minor.ticks, axes,
- auto.grid, xlab, ylab, log, have_x_axis, have_y_axis,
- ylab.axis, events, blocks, yax.loc, ylim, ...){
-
- # Set Margins for each panel here!
- if(yax.loc == "flip"){
- par(mar = have_x_axis*c(3.4, 0, 0, 0) + c(0, 4.5, 0, 4.5))
- } else {
- par(mar = have_x_axis*c(3.4,0,0,0) +
- switch(ylab.axis,
- none = c(0, 0, 0, 0),
- left = c(0, 4.5, 0, 1.5),
- right = c(0, 1.5, 0, 4.5),
- top = c(0, 4.5, 1.5, 1.5)))
- }
- # Plotting Defaults
- if(missing(axes)) axes <- TRUE
- if(missing(ylab)) ylab <- ''
- if(missing(xlab)) xlab <- ''
- if(missing(log)) log <- ''
-
- xy <- list(x = .index(x), y = seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = NROW(x)))
-
- plot(xy$x, xy$y, type = "n", axes = FALSE, xlab = xlab, ylab = '', log = log, ylim = ylim)
-
- mtext(side = 2 + 2*(ylab.axis == "right") + 1*(ylab.axis == "top"), text = if(ylab.axis == "none") "" else ylab,
- line = 3 - 2.5*(ylab.axis == "top"), cex = par("cex.lab"), col = par("col.lab"))
- ep <- axTicksByTime(x, major.ticks, format.labels = major.format)
-
- if(!missing(blocks)){
- do_add.shading(blocks, ylim)
- }
-
- if(!missing(events)){
- do_add.event(events, ylim)
- }
-
- if(auto.grid) {
- abline(v = xy$x[ep], col = 'grey', lty = 4L)
- grid(NA, NULL)
- }
-
- if(axes) {
- if(have_x_axis){
- if(minor.ticks) axis(1L, at = xy$x, labels = FALSE, col = par("col.axis"))
- axis(1L, at = xy$x[ep], labels = names(ep), lwd = 1L, col = par("col.axis"),
- mgp = if(any(grepl("\n",names(ep), fixed = TRUE))) c(3, 2, 0) else c(3,1,0))
- # Not sure why I have to force col.axis but it seems I do
- }
- if(have_y_axis){
- axis(2L + 2L*(ylab.axis == "right"), col = par("col.axis"))
- }
- }
-
- box()
-}
-
-do_add.panel <- function(x, col, pch, cex, lwd, type, panel, lty, ...){
-
- if(is.null(col)) col <- seq_len(NCOL(x))
- if(is.null(pch)) pch <- 1L
- if(is.null(cex)) cex <- 1L
- if(is.null(lwd)) lwd <- 1L
- if(is.null(type)) type <- "l"
- if(is.null(lty)) lty <- 1L
-
- panel(.index(x), x, col = col, pch = pch, type = type,
- lwd = lwd, cex = cex, lty = lty)
-
- list(col = col, pch = pch, cex = cex, lwd = lwd, type = type, lty = lty)
-}
-
-do_add.shading <- function(blocks, y){
- yrng <- c(0, -3*max(y), 3*min(y), 3*max(y), -3*min(y)) # Dirty Hack
-
- for(j in seq_along(blocks[["start.time"]])){
- rect(as.POSIXct(get.elm.recycle(blocks[["start.time"]], j)), max(yrng),
- as.POSIXct(get.elm.recycle(blocks[["end.time"]], j)), min(yrng),
- col = if(!is.null(blocks[["col"]]))
- get.elm.recycle(blocks[["col"]],j) else "lightblue1",
- border = NA)
- }
-}
-
-do_add.event <- function(events, y){
-
- getFromEvents <- function(prop, j, default){
- if(!is.null(events[[prop]])) get.elm.recycle(events[[prop]],j) else default
- }
-
- for(j in seq_along(events[["time"]])){
-
- time <- as.POSIXct(get.elm.recycle(events[["time"]],j))
- label <- get.elm.recycle(events[["label"]], j)
-
- col <- getFromEvents("col", j, "red")
- lty <- getFromEvents("lty", j, 2)
-
- y.adj <- getFromEvents("y.adj", j, 0)
- offset <- getFromEvents("offset", j, 0.2)
- pos <- getFromEvents("pos", j, 2)
-
- text(x = time, y = max(y) - y.adj, label = label,
- offset = offset, pos = pos, srt = 90, col = col)
- abline(v = time, col = col, lty = lty)
- }
-}
-
-do_add.legend <- function(legend.names, legend.loc, col, lwd, pch, cex, type, lty, ...){
- do.call(legend, list(
- x = legend.loc,
- legend = legend.names,
- col = col,
- lwd = ifelse(!(type %in% c("n","p")), lwd, NA),
- pch = ifelse(type %in% c("p","b","o"), pch, NA),
- cex = cex,
- lty = lty, ...))
-}
-
-do_plot.ohlc <- function(x, bar.col.up, bar.col.dn, candle.col, major.ticks,
- minor.ticks, major.format, auto.grid,
- candles, events, blocks, yax.loc, ylim, ...){
-
- if(exists(".QUANTMOD_MESSAGE", .GlobalEnv) && get(".QUANTMOD_MESSAGE", .GlobalEnv)) {
- message("Note that CRAN Package quantmod provides much better OHLC charting.\n",
- "This message will show once per session.")
- # Help page says not to use assignInMyNamespace() so we'll do it manually in .GlobalEnv
- # Also, it was only introduced in R 2.15 so probably better to remove it
- assign(".QUANTMOD_MESSAGE", FALSE, envir = .GlobalEnv)
- }
-
- if(identical(ylim, 'auto') || identical(ylim, 'fixed')) ylim <- range(x, na.rm = TRUE)
-
- # Extract OHLC Columns and order them
- x <- x[,xts:::has.OHLC(x, TRUE)]
- par(oma = c(1,4,4,3))
- do_add.grid(x, major.ticks = major.ticks, major.format = major.format,
- minor.ticks = minor.ticks, auto.grid = auto.grid,
- have_x_axis = TRUE, have_y_axis = TRUE, ylab.axis = "none",
- events = events, blocks = blocks, yax.loc = yax.loc, ylim = ylim, ...)
-
- width = .2*deltat(x)
-
- # Better to do this with xts:::Op etc when moved to xts package?
- if(candles) rect(.index(x) - width/4, x[,2L], .index(x) + width/4, x[,3L],
- col = candle.col, border = candle.col)
-
- # Bars for all OHLC
- rect(.index(x) - width, x[, 1L], .index(x) + width, x[, 4L],
- col = ifelse(x[,4L] > x[,1L], bar.col.up, bar.col.dn), border = candle.col)
-
- return(invisible(reclass(x)))
-}
-
-# split.xts which returns an xts instead of a zoo
-split.xts.by.cols <- function(x, f){
- lapply(split(seq_len(NCOL(x)), f), function(cols) x[,cols])
-}
-
-get.elm.recycle <- function(vec, n){
- j <- n %% length(vec)
- vec[[if(j) j else length(vec)]]
-}
-
-get.elm.from.dots <- function(par, dots, screens, n){
- # Return NULL if par is not supplied
- if(!(par %in% names(dots))) return(NULL)
-
- # Repeat par to length of screens and take n-th screen
- if(length(screens) == 1L){
- par <- rep(list(dots[[par]]), length.out = length(screens))
- } else {
- par <- rep(dots[[par]], length.out = length(screens))
- }
-
- par <- split(par, screens)
-
- j <- n %% length(par)
- par[[if(j) j else length(par)]]
-}
-
-default.panel <- function(index, x, col, pch, cex, lwd, type, lty){
- # This unexported function exists only to provide a
- # default panel function within plot.xts
- for(j in seq_len(NCOL(x))){
- col.t <- get.elm.recycle(col, j)
- pch.t <- get.elm.recycle(pch, j)
- cex.t <- get.elm.recycle(cex, j)
- lwd.t <- get.elm.recycle(lwd, j)
- type.t <- get.elm.recycle(type, j)
- lty.t <- get.elm.recycle(lty, j)
- lines(index, x[,j], col = col.t, pch = pch.t, type = type.t,
- lwd = lwd.t, cex = cex.t, lty = lty.t)
- }
-}
+# # xtsExtra: Extensions to xts during GSOC-2012
+# #
+# # Copyright (C) 2012 Michael Weylandt: michael.weylandt at 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 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 .
+#
+# `plot.xts` <- function(x, y = NULL, screens = 'auto', layout.screens = 'auto', ...,
+# yax.loc = c("none", "out", "in", "flip", "left", "right", "top"),
+# auto.grid = TRUE, major.ticks = 'auto', minor.ticks = TRUE, major.format = TRUE,
+# bar.col.up = 'white', bar.col.dn ='red', candle.col='black',
+# xy.labels = FALSE, xy.lines = NULL, ylim = 'auto', panel = default.panel,
+# auto.legend = FALSE, legend.names = colnames(x), legend.loc = "topleft",
+# legend.pars = NULL, events, blocks, nc, nr) {
+#
+# # Set cex.lab early to a reasonable default; this allows user to still override
+# if(length(screens) > 1L || (NCOL(x) > 1L && identical(screens, "auto"))) par(cex.lab = 0.8)
+#
+# # Restore old par() options from what I change in here
+# old.par <- par(no.readonly = TRUE)
+#
+# on.exit(par(old.par))
+# on.exit(assign(".plot.xts", recordPlot(), .GlobalEnv), add = TRUE)
+#
+# dots <- list(...)
+#
+# do.call(par, dots[!(names(dots) %in%
+# c("col", "type", "lwd", "pch", "log", "cex", "ylab", "main", "axes", "xlab", "lty"))])
+#
+# ## if y supplied: scatter plot y ~ x
+# if(!is.null(y)) {
+#
+# xlab <- if("xlab" %in% names(dots)) dots[["xlab"]] else deparse(substitute(x))
+# ylab <- if("ylab" %in% names(dots)) dots[["ylab"]] else deparse(substitute(y))
+#
+# if(NCOL(x) > 1L || NCOL(y) > 1L){
+# layout(matrix(seq_len(NCOL(x)*NCOL(y)),ncol = NCOL(x), nrow = NCOL(y)))
+# par(mar = c(2,2,2,2), oma = c(0,0,3,0))
+#
+# for(i in seq_len(NCOL(x))){
+# for(j in seq_len(NCOL(y))){
+# do_scatterplot(x[,i], y[,j], xy.labels, xy.lines, xlab = "", ylab = "", ...,
+# main = paste(names(x)[i],"vs.",names(y)[j]))
+# }
+# }
+#
+# mtext(paste(xlab, "vs.", ylab), outer = TRUE, line = 0)
+#
+# return(invisible(merge(x,y)))
+# } else {
+# return(do_scatterplot(x,y, xy.labels, xy.lines, xlab, ylab, ...))
+# }
+# }
+#
+# ## Else : no y, only x
+#
+# # Need to catch this one early before try.xts forces evaluation
+# main <- if(!("main" %in% names(dots))) deparse(substitute(x)) else dots[["main"]]
+#
+# x <- try.xts(x)
+#
+# if("xlim" %in% names(dots)){
+# xlim <- dots[["xlim"]]
+#
+# if(is.timeBased(xlim)){
+# if(length(xlim) != 2L) stop("Need endpoints only for xlim")
+# xlim <- do.call(paste0("as.",indexClass(x))[1L], list(xlim))
+# x <- x[(index(x) > xlim[1L]) & (index(x) < xlim[2L]), , drop = FALSE]
+# }
+# if(is.numeric(xlim)){
+# warning("Using xlim as row indices -- provide timeBased xlim",
+# "if you wish to subset that way")
+# x <- x[xlim[1L]:xlim[2L], drop = FALSE]
+# }
+# if(is.character(xlim)){
+# x <- x[xlim, , drop = FALSE]
+# }
+# }
+#
+# yax.loc <- match.arg(yax.loc)
+#
+# # Catch OHLC case independently
+# if("type" %in% names(dots) && dots[["type"]] %in% c('candles','bars')){
+#
+# type <- dots[["type"]]
+#
+# if(!xts:::is.OHLC(x)) stop(type, '-chart not supported for non-OHLC series')
+#
+# do_plot.ohlc(x, bar.col.up = bar.col.up, bar.col.dn = bar.col.dn,
+# candle.col = candle.col, major.ticks = major.ticks,
+# minor.ticks = minor.ticks, auto.grid = auto.grid,
+# major.format = major.format, main = main,
+# candles = (type == "candles"), events = events,
+# blocks = blocks, yax.loc = yax.loc, ylim = ylim, ...)
+#
+# } else {
+# # Else need to do layout plots
+# screens <- do_layout(x, screens = screens, layout.screens = layout.screens,
+# yax.loc = yax.loc, nc = nc, nr = nr, ylim = ylim)
+#
+# layout.screens <- screens[["layout.screens"]]
+# have_x_axis <- screens[["have_x_axis"]]
+# have_y_axis <- screens[["have_y_axis"]]
+# ylab.axis <- screens[["ylab.axis"]]
+# ylim <- screens[["ylim"]]
+# screens <- screens[["screens"]]
+#
+# x.split <- split.xts.by.cols(x, screens)
+#
+# # Set panelwise parameters here
+# ylab <- dots[["ylab"]]
+# if(is.null(ylab)) {
+# if(is.null(names(x)))
+# ylab <- ""
+# else
+# ylab <- split(names(x), screens)
+# }
+#
+# log <- dots[["log"]]
+# if(is.null(log)) log <- ""
+#
+# if(auto.legend) legend.names <- split(legend.names, screens)
+#
+# # For now, loop over screens one by one constructing relevant elements
+# for(i in seq_along(levels((screens)))){
+# x.plot <- x.split[[i]]
+#
+# col.panel <- get.elm.from.dots("col", dots, screens, i)
+# pch.panel <- get.elm.from.dots("pch", dots, screens, i)
+# cex.panel <- get.elm.from.dots("cex", dots, screens, i)
+# lwd.panel <- get.elm.from.dots("lwd", dots, screens, i)
+# type.panel <- get.elm.from.dots("type", dots, screens, i)
+# lty.panel <- get.elm.from.dots("lty", dots, screens, i)
+#
+# log.panel <- get.elm.recycle(log, i)[[1L]]
+# ylab.panel <- get.elm.recycle(ylab, i)[[1L]]
+#
+# panel.panel <- match.fun(if(length(panel) > 1L) get.elm.recycle(panel, i) else panel)
+#
+# # Note that do_add.grid also sets up axes and what not
+# do_add.grid(x.plot, major.ticks, major.format, minor.ticks,
+# auto.grid = auto.grid, ylab = ylab.panel, log = log.panel,
+# have_x_axis = have_x_axis[i], have_y_axis = have_y_axis[i],
+# ylab.axis = ylab.axis[which.max(layout.screens == i)], # Use which.max to get first hit
+# events = events, blocks = blocks,
+# yax.loc = yax.loc, ylim = get.elm.recycle(ylim, i))
+#
+# legend.pars.add <- do_add.panel(x.plot, panel = panel.panel, col = col.panel, lwd = lwd.panel,
+# pch = pch.panel, type = type.panel, cex = cex.panel, lty = lty.panel)
+#
+# if(auto.legend && !is.na(get.elm.recycle(legend.loc,i)))
+# do.call(do_add.legend, c(legend.names = list(legend.names[[i]]),
+# legend.loc = get.elm.recycle(legend.loc, i),
+# legend.pars.add, legend.pars))
+# }
+#
+# }
+# title(main, outer = TRUE) # outer = length(levels(screens)) > 1L)
+# return(invisible(reclass(x)))
+# }
+#
+# do_scatterplot <- function(x, y, xy.labels, xy.lines, xlab, ylab, main,
+# log, cex, xlim, ylim, type, pch, col, ...){
+#
+# if(missing(main)) main <- paste(xlab, "vs.", ylab)
+# if(missing(log)) log <- ''
+# if(missing(cex)) cex <- 0.8
+# if(missing(pch)) pch <- 1L
+# if(missing(col)) col <- 1L
+#
+# x <- try.xts(x); y <- try.xts(y)
+#
+# xy.xts <- merge(x, y, join = "inner")
+#
+# xy <- coredata(xy.xts)
+#
+# xy <- xy.coords(xy[,1L], xy[,2L])
+#
+# if(missing(xlim)) xlim <- range(xy$x[is.finite(xy$x)], na.rm = TRUE)
+# if(missing(ylim)) ylim <- range(xy$y[is.finite(xy$y)], na.rm = TRUE)
+#
+# do.lab <- if(is.logical(xy.labels)) xy.labels else TRUE
+#
+# if(is.null(xy.lines)) xy.lines <- do.lab
+#
+# ptype <- if(missing(type)){if(do.lab) "n" else "p"} else type
+# type <- if(missing(type)){if(do.lab) "c" else "l"} else type
+#
+# plot(xy[1:2], type = ptype, main = main, xlab = xlab,
+# ylab = ylab, xlim = xlim, ylim = ylim, log = log, pch = pch, col = col)
+#
+# if(do.lab) text(xy[1:2], cex = cex, labels = if(!is.logical(xy.labels))
+# xy.labels else index2char(index(xy.xts)), col = col)
+#
+# if(xy.lines) segments(xy[[1L]][-NROW(xy[[1L]])],xy[[2L]][-NROW(xy[[2L]])],
+# xy[[1L]][-1L],xy[[2L]][-1L], col = col)
+#
+# return(invisible(xy.xts))
+# }
+#
+# do_layout <- function(x, screens, layout.screens, yax.loc, nc, nr, ylim){
+# # By default one screen per panel
+# screens <- factor(if(identical(screens,"auto")) seq_len(NCOL(x)) else
+# rep(screens, length.out = NCOL(x)))
+#
+# if(identical(layout.screens, "auto")){
+# layout.screens <- seq_along(levels(screens))
+# if(!missing(nc) && !missing(nr))
+# layout.screens <- matrix(layout.screens, ncol = nc, nrow = nrow)
+# if(missing(nc) && !missing(nr))
+# layout.screens <- matrix(layout.screens, nrow = nr)
+# if(!missing(nc) && missing(nr))
+# layout.screens <- matrix(layout.screens, ncol = nc)
+# }
+#
+# if(is.list(layout.screens)) {
+# layout.args <- layout.screens[-1L]
+# layout.screens <- layout.screens[[1L]]
+# }
+#
+# layout.screens <- as.matrix(layout.screens)
+#
+# have_x_axis <- logical(length(levels(screens)))
+# for(i in seq_len(NROW(layout.screens))){
+# if(i == NROW(layout.screens)){
+# have_x_axis[layout.screens[i,]] <- TRUE
+# } else {
+# if(!identical(as.logical(diff(layout.screens[i, ])),
+# as.logical(diff(layout.screens[i + 1L,])))){
+# have_x_axis[layout.screens[i,]] <- TRUE
+# }
+# }
+# }
+#
+# have_y_axis <- logical(length(levels(screens)))
+# for(i in seq_len(NCOL(layout.screens))){
+# if(i == 1L){
+# have_y_axis[layout.screens[,i]] <- TRUE
+# } else {
+# if(!identical(as.logical(diff(layout.screens[ ,i - 1L])),
+# as.logical(diff(layout.screens[ ,i])))){
+# have_y_axis[layout.screens[,i]] <- TRUE
+# }
+# }
+# }
+#
+# # Here we handle y-axis labeling case by case and mark when margins are needed
+# # From this part, we return a vector ylab.axis giving L/R/None marks for y-labels
+# # Margins are set appropriately back in main function body
+#
+# ylab.axis <- layout.screens
+#
+# if(yax.loc == "none") ylab.axis[] <- "none"
+#
+# # If labels are set to left/right we need them in all panels
+# if(yax.loc == "right" || yax.loc == "left") {
+# have_y_axis[] <- TRUE # Since forcing labels, we write a y-axis everywhere
+#
+# ylab.axis[] <- yax.loc
+# }
+#
+# if(yax.loc == "out" || yax.loc == "in"){
+# if(NCOL(layout.screens) != 2L) stop("yax.loc not consistent with layout -- too many columns.")
+# # If labels are set to out we need them for outer panels only
+# # If labels are set to in we need them for inner panels only
+# ylab.axis[,1L] <- if(yax.loc == "out") "left" else "right"
+# ylab.axis[,2L] <- if(yax.loc == "out") "right" else "left"
+# have_y_axis[] <- TRUE # Axes for all if TRUE
+# }
+#
+# # If labels are set to flip we do a little bit of work to arrange them
+# if(yax.loc == "flip") {
+# for(i in seq_len(NCOL(ylab.axis)))
+# ylab.axis[,i] <- rep(c("left","right"), length.out = NROW(ylab.axis))
+# have_y_axis[] <- TRUE
+# }
+#
+# if(yax.loc == "top"){
+# ylab.axis[] <- yax.loc
+# have_y_axis[] <- TRUE
+# have_x_axis[] <- TRUE
+# }
+#
+# # Moving internal margin code to the panel-wise setup, leaving oma (outer) margin here
+# if(length(levels(screens)) > 1L) par(oma = c(1,1,4,1))
+# if(yax.loc == "none") par(oma = c(1,4,4,3))
+# if(length(levels(screens)) == 1L && yax.loc != "none") par(oma = c(1,1,4,1))
+#
+# if(identical(ylim,'fixed')){
+# ylim <- list(range(x, na.rm = TRUE))
+# } else if(identical(ylim, 'auto')){
+# if(yax.loc == "none") {
+# ylim <- lapply((1:NROW(layout.screens))[!duplicated(layout.screens)], function(y) {
+# do.call(range,
+# list(split.xts.by.cols(x, screens)[layout.screens[y,]], na.rm = TRUE))})
+# } else {
+# ylim <- lapply(split.xts.by.cols(x, screens), function(x) range(x, na.rm = TRUE))
+# }
+# } else{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/xts -r 851
From noreply at r-forge.r-project.org Sat Sep 13 02:38:03 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sat, 13 Sep 2014 02:38:03 +0200 (CEST)
Subject: [Xts-commits] r852 - in pkg/xtsExtra: sandbox vignettes
Message-ID: <20140913003803.C2AFD187642@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-13 02:38:03 +0200 (Sat, 13 Sep 2014)
New Revision: 852
Added:
pkg/xtsExtra/sandbox/xtsPlots.Rnw
Removed:
pkg/xtsExtra/vignettes/xtsPlots.Rnw
Log:
moving vignette using old plot syntax to sandbox folder
Added: pkg/xtsExtra/sandbox/xtsPlots.Rnw
===================================================================
--- pkg/xtsExtra/sandbox/xtsPlots.Rnw (rev 0)
+++ pkg/xtsExtra/sandbox/xtsPlots.Rnw 2014-09-13 00:38:03 UTC (rev 852)
@@ -0,0 +1,207 @@
+%\VignetteIndexEntry{xts: Extensible Time Series}
+\documentclass{article}
+\usepackage[parfill]{parskip}
+\usepackage{subfigure}
+\usepackage{hyperref}
+\hypersetup{colorlinks,%
+ citecolor=black,%
+ linkcolor=blue,%
+ urlcolor=blue,%
+ }
+
+\newcommand{\code}[1]{\texttt{#1}}
+\newcommand{\R}{\texttt{R}~}
+\newcommand{\CRAN}{\texttt{CRAN}~}
+\newcommand{\pkg}[1]{\textbf{#1}}
+
+\title{\bf xts Plots }
+\author{Michael Weylandt}
+\date{\today}
+
+<>=
+library(xtsExtra)
+options(width = 70)
+@
+
+
+\begin{document}
+\SweaveOpts{concordance=TRUE}
+
+\maketitle
+\tableofcontents
+
+\section{Introduction}
+As part of the Google Summer of Code 2012, the plotting functionalities availble for \code{xts} objects has been greatly extended. This new plotitng functionality is currently available in a package \pkg{xtsExtra} available off R-forge and is under active development. Care has been taken not to break back compatability with the published \code{xts::plot.xts} available from the \CRAN version of \pkg{xts} while providing a new and powerful set of plotting routines for time-oriented data.
+
+While care has been taken to make sure the new \code{plot.xts} behaves intuitively, flexibility does come at a price of some API complexity and this document is provided as a guide for both developers and advanced users who may wish to make use of the extended capabilities. Note that this document may lag development from time to time and is subject to non-back-compatible change.
+
+The \code{xts} time series class was designed to provide users and developers an intuitive and transparent platform for time series analysis in \R~\cite{R}. While the functions described in this document will only be called automatically when used on \code{xts} objects, the \code{reclass} paradigm described in the \pkg{xts} vignette \cite{xts} is used internally, so that all time series classes may make use of advanced plotting capabilities.
+
+\section{plot.xts}
+\label{sec:plot}
+
+\section{barplot.xts}
+The second of the graphical primitives provided in \pkg{xtsExtra} is a \code{barplot} method, adapted from Peter Carl's code in \pkg{PerformanceAnalytics}~\cite{PerformanceAnalytics}. Implemented as an exported and registered method of the \code{S3} generic \code{barplot}, \code{barplot.xts} has the following arguments:
+
+<<>>=
+names(formals(barplot.xts))
+@
+
+Let us examine these arguments in order.
+\begin{description}
+\item[\code{height}] So called for compatability with \code{graphics::barplot}, this should be an \code{xts}-ible object as it will be converted by \code{xts::try.xts} internally.
+\item[\code{stacked}] Defaulting to \code{TRUE}, this defines whether a \emph{stacked} barplot should be produced. In the author's opinion, stacked barplots are to be preferred for time-oriented barplots as they align observations into a single vertical unit.
+\item[\code{scale}] Defaulting to \code{FALSE}, this applies the transform \code{x <- x / rowSums(x)} to data; this transform is useful for seeing how the relative makeup of \code{height} changes over time. Currently, if \code{any(height < 0)}, this option throws an error. It is also likely to cause problems if \code{any(rowSums(height) == 0)}.
+\item[\code{auto.legend}] Defaulting to \code{TRUE}, this places a legend underneath the barplot. Column names are used as the legend labels. Attractive defaults have been chosen, but for more detailed control, the user is encouraged to add the legend himself using the unexported \code{xtsExtra::do\_barplot.legend}, as described below.
+\item[\code{major.format}] Control the format of the time axis labels; see the details \code{?strptime} for formatting codes. If left as the default (\code{TRUE}), \code{axTicksByTime} attempts to automatically pick an appropriate labelling convention.
+\item[\code{ylim}] Control the $y$-axis limits of the resulting plot. If default (\code{NULL}), the limits will be chosen automatically. Expect handling to be moved to \code{...} in future development.
+\item[\code{space}] Specifies the width of the interbar spacing ; not currently supported for plots with \code{stacked = FALSE}. Possibly will be reworked to provide more robust support in light of the $x$-axis spacing given by the index of the \code{xts} class.
+\item[\code{cex.*}] These arguments control the size of various labels. Expect their handling to be moved to use \code{...} and \code{par} arguments in future development.
+\item[\code{xaxis}] Defaulting to \code{TRUE}, should an $x$-axis and labels be drawn?
+\item[\code{box.color}] Defaulting to \code{"black"}, gives the color of less important plot elements, such as the outside boundaries and the legend box. Some authors prefer \code{box.color = "darkgray"} for a softer appearance.
+\item[\code{xlab, ylab}] Labels for the $x$- and $y$-axes. Expect their handling to be moved to \code{...} in future development.
+\item[\code{major.ticks, minor.ticks}] See the fuller description of these arguments given for \code{plot.xts} (Section \ref{sec:plot}).
+\item[\code{col}] Color of the bars. If missing, defaults to \code{col = seq\_len(NCOL(height))} chosen according to the somewhat unattractive \R defaults provided by \code{palette}. See more on color palettes below.
+\end{description}
+
+\subsection{Time Oriented Barplots}
+We begin by creating an example of an \code{xts} barplot and then we discuss its construction in more detail.
+<<>>=
+x <- xts(matrix(abs(rnorm(72)), ncol = 6), Sys.Date() + 1:12)
+colnames(x) <- LETTERS[1:6]
+barplot(x)
+@
+\begin{figure}[htb]
+<>=
+barplot(x)
+@
+\caption{\code{barplot(x)}}
+\label{fig:basic.barplot}
+\end{figure}
+producing the plot in figure \ref{fig:basic.barplot}.
+
+We note immediately that, by default, the produced barplot is a so-called ``stacked'' barplot, corresponding to \code{beside = FALSE} in the default \code{barplot} method. An advantage of this display is that observations for each time period are aligned vertically; a current limitation of the barplot code is that $x$-axis spacing does not accurately reflect irregularities in the underlying data, as in figure \ref{fig:skipping.barplot}.
+\begin{figure}[htb]
+<>=
+barplot(x[c(1:5, 12),])
+@
+\caption{\code{barplot(x[c(1:5,12),])}}
+\label{fig:skipping.barplot}
+\end{figure}
+We see in both the preceeding plots that the default axis labels accurately reflect the underlying daily periodicity of our data set, as with \code{plot.xts} more control could be had by passing a format string to \code{major.format}. E.g., to remove year labelling, we would pass \code{major.format = "\%b \%d"} to print names of the format ``Jul 25.''
+
+Note that negative values are stacked underneath the $x$-axis following the exampleof\code{barchart} in the \pkg{lattice} package.
+
+\subsection{Scaled and Unstacked Plots}
+A limitation of stacked barplots is that the eye is naturally drawn to the size of the bar, rather than the widths of the bands which comprise it. Further, while it is possible to compare the size of the bottom stripe, comparing the higher stripes is more difficult as they do not generally share a common baseline. Graphics experts like Cleveland~\cite{Cleveland} and Tufte~\cite{Tufte} use of the trellis or small multiples paradigm to avoid these problems.\footnote{See, e.g., \code{barchart} in the recommended \pkg{lattice} package.} Over and against their better judgement, we provide two possible customizations to address these concerns.
+
+In certain applications, e.g., asset class weights in finance, shifting population dynamics in ecology, or server load balance in IT, it is sometimes of greater interest to see how the relative make-up of quantities change over time rather than the scale of those quantities. For those cases, \code{barplot.xts} can be used with the option \code{scale = TRUE} which applies the transform \code{x <- x / rowSums(x)} before plotting.
+
+For example, the data created above can be interpreted as asset classes and we can show the effect of the scaled plots.
+<<>>=
+colnames(x) <- c("Equity", "Fixed Income", "Commodities",
+ "FX","Convertibles","Alternatives")
+@
+producing \ref{fig:scaled.barplot}.
+\begin{figure}[htb]
+\subfigure[Unscaled Plot]{
+<>=
+barplot(x, scale = FALSE)
+@
+}
+\subfigure[Scaled Plot]{
+<>=
+barplot(x, scale = TRUE)
+@
+}
+\caption{Scaled Barplots}
+\label{fig:scaled.barplot}
+\end{figure}
+
+Currently, quantity scaling is only supported for non-negative data. For data of alternating sign, the scale transform is not uniquely defined and is, as such, left to the user. Two common choices are given here, but not implemented within the package.
+<>=
+scale1 <- function(x){x/rowSums(abs(x))}
+scale2 <- function(x){
+ ## Can this be vectorized?
+ for(j in seq_len(NROW(x))){
+ x[j, x[j,] > 0] <- x[j, x[j,] > 0] / sum(x[j, x[j,] > 0])
+ x[j, x[j,] < 0] <- -1 * x[j, x[j,] < 0] / sum(x[j, x[j,] < 0])
+ }
+ x
+}
+@
+\code{scale1()} transforms \code{x} such that the height of each bar is \code{1}, as with the non-negative scale transform. Since bars may now contain negative quantities, the entirety of the bar will shift up and down as a linear transform of its sum. This rescaling is helpful in seeing how the total value transforms over time. % FIXME: Put that more eloquently
+
+\code{scale2()} scales both the positive and negative row elements to sum to \code{1} independently. This is useful in more specialized circumstances, such as examing exposures of a long-short portfolio.
+
+If absolute quantities are of interest, it is sometimes desirable to create a time-oriented barplot without stacked bars, that is, with each data point being anchored on the $x$-axis. To do so, we simply use \code{stacked = FALSE}, which corresponds to \code{beside = TRUE} in the default method of \code{barplot}. This method has the slight disadvantage of no longer aligning simultaneous observations along the time axis, but can be helpful if properly interpreted, as shown in figure \ref{fig:barplot.unstacked}.
+\begin{figure}[htb]
+<>=
+barplot(x, stacked = FALSE)
+@
+\caption{\code{barplot(x, stacked = FALSE)}}
+\label{fig:barplot.unstacked}
+\end{figure}
+
+Note that the form of the unstacked barplot is subject to change as the author is not entirely happy with it.
+
+\subsection{Color Pallettes}
+The color pallete defaulted to by \code{barplot.xts} is, in the eyes of many, somewhat garish; in the particular case of barplots, the eye is too strongly drawn to the brighter elements, particularly the green and purple, causing misinterpretation. \pkg{PerformanceAnalytics} provides four chosen color pallettes to mitigate this effect and we document them here. Their use is highly recommended:
+<<>>=
+rainbow6equal <- c("#BF4D4D", "#BFBF4D", "#4DBF4D", "#4DBFBF",
+ "#4D4DBF", "#BF4DBF")
+rainbow8equal <- c("#BF4D4D", "#BFA34D", "#86BF4D", "#4DBF69",
+ "#4DBFBF", "#4D69BF", "#864DBF", "#BF4DA3")
+rainbow10equal <- c("#BF4D4D", "#BF914D", "#A8BF4D", "#63BF4D",
+ "#4DBF7A", "#4DBFBF", "#4D7ABF", "#634DBF",
+ "#A84DBF", "#BF4D91")
+rainbow12equal <- c("#BF4D4D", "#BF864D", "#BFBF4D", "#86BF4D",
+ "#4DBF4D", "#4DBF86", "#4DBFBF", "#4D86BF",
+ "#4D4DBF", "#864DBF", "#BF4DBF", "#BF4D86")
+@
+For more advanced pallete construction, see the \CRAN packages \pkg{RColorBrewer} and \pkg{colorspace}.
+\clearpage
+\begin{thebibliography}{99}
+\bibitem{zoo} Achim Zeileis and Gabor Grothendieck (2005): \\
+\emph{ zoo: S3 Infrastructure for Regular and Irregular Time Series.} \\
+Journal of Statistical Software, 14(6), 1-27. \\
+\url{http://www.jstatsoft.org/v14/i06/}
+
+\bibitem{ISO} International Organization for Standardization (2004):\\
+\emph{ISO 8601: Data elements and interchage formats ---
+ Information interchange --- Representation of dates and time}\\
+\url{http://www.iso.org}
+
+\bibitem{R} R Development Core Team: \\
+\emph{R: A Language and Environment for Statistical Computing}, \\
+R Foundation for Statistical Computing, Vienna, Austria. \\
+ISBN 3-900051-07-0\\
+\url{http://www.R-project.org}
+
+\bibitem{quantmod} Jeffrey A. Ryan (2008):
+\emph{quantmod: Quantitative Financial Modelling Framework.}\\
+R package version 0.3-5. \\
+\url{http://www.quantmod.com} \\
+\url{http://r-forge.r-project.org/projects/quantmod}
+
+\bibitem{xts} Jeffrey A. Ryan \& Joshua M. Ulrich (2008):\\
+\emph{xts: Extensible Time Series}\\
+R package version 0.8-7. \\
+\url{http://r-forge.r-project.org/projects/xts/}
+
+\bibitem{PerformanceAnalytics} Peter Carl and Brian G. Peterson (2012):\\
+\emph{PerformanceAnalytics: Econometric tools for performance and risk analysis.},\\
+R package version 1.0.4.5\\
+\url{http://r-forge.r-project.org/projects/returnanalytics/}
+
+\bibitem{Cleveland} Cleveland, W.S. (1994):\\
+\emph{The Elements of Graphing Data}\\
+Summit, NJ: Hobart Press.
+
+\bibitem{Tufte} Tufte, Edward R. (2001):\\
+\emph{The Visual Display of Quantitative Information, 2nd. ed}.\\
+Chesire, CN: The Graphics Press.\\
+See also \url{http://www.edwardtufte.com}.
+
+\end{thebibliography}
+\end{document}
Deleted: pkg/xtsExtra/vignettes/xtsPlots.Rnw
===================================================================
--- pkg/xtsExtra/vignettes/xtsPlots.Rnw 2014-09-12 22:36:00 UTC (rev 851)
+++ pkg/xtsExtra/vignettes/xtsPlots.Rnw 2014-09-13 00:38:03 UTC (rev 852)
@@ -1,207 +0,0 @@
-%\VignetteIndexEntry{xts: Extensible Time Series}
-\documentclass{article}
-\usepackage[parfill]{parskip}
-\usepackage{subfigure}
-\usepackage{hyperref}
-\hypersetup{colorlinks,%
- citecolor=black,%
- linkcolor=blue,%
- urlcolor=blue,%
- }
-
-\newcommand{\code}[1]{\texttt{#1}}
-\newcommand{\R}{\texttt{R}~}
-\newcommand{\CRAN}{\texttt{CRAN}~}
-\newcommand{\pkg}[1]{\textbf{#1}}
-
-\title{\bf xts Plots }
-\author{Michael Weylandt}
-\date{\today}
-
-<>=
-library(xtsExtra)
-options(width = 70)
-@
-
-
-\begin{document}
-\SweaveOpts{concordance=TRUE}
-
-\maketitle
-\tableofcontents
-
-\section{Introduction}
-As part of the Google Summer of Code 2012, the plotting functionalities availble for \code{xts} objects has been greatly extended. This new plotitng functionality is currently available in a package \pkg{xtsExtra} available off R-forge and is under active development. Care has been taken not to break back compatability with the published \code{xts::plot.xts} available from the \CRAN version of \pkg{xts} while providing a new and powerful set of plotting routines for time-oriented data.
-
-While care has been taken to make sure the new \code{plot.xts} behaves intuitively, flexibility does come at a price of some API complexity and this document is provided as a guide for both developers and advanced users who may wish to make use of the extended capabilities. Note that this document may lag development from time to time and is subject to non-back-compatible change.
-
-The \code{xts} time series class was designed to provide users and developers an intuitive and transparent platform for time series analysis in \R~\cite{R}. While the functions described in this document will only be called automatically when used on \code{xts} objects, the \code{reclass} paradigm described in the \pkg{xts} vignette \cite{xts} is used internally, so that all time series classes may make use of advanced plotting capabilities.
-
-\section{plot.xts}
-\label{sec:plot}
-
-\section{barplot.xts}
-The second of the graphical primitives provided in \pkg{xtsExtra} is a \code{barplot} method, adapted from Peter Carl's code in \pkg{PerformanceAnalytics}~\cite{PerformanceAnalytics}. Implemented as an exported and registered method of the \code{S3} generic \code{barplot}, \code{barplot.xts} has the following arguments:
-
-<<>>=
-names(formals(barplot.xts))
-@
-
-Let us examine these arguments in order.
-\begin{description}
-\item[\code{height}] So called for compatability with \code{graphics::barplot}, this should be an \code{xts}-ible object as it will be converted by \code{xts::try.xts} internally.
-\item[\code{stacked}] Defaulting to \code{TRUE}, this defines whether a \emph{stacked} barplot should be produced. In the author's opinion, stacked barplots are to be preferred for time-oriented barplots as they align observations into a single vertical unit.
-\item[\code{scale}] Defaulting to \code{FALSE}, this applies the transform \code{x <- x / rowSums(x)} to data; this transform is useful for seeing how the relative makeup of \code{height} changes over time. Currently, if \code{any(height < 0)}, this option throws an error. It is also likely to cause problems if \code{any(rowSums(height) == 0)}.
-\item[\code{auto.legend}] Defaulting to \code{TRUE}, this places a legend underneath the barplot. Column names are used as the legend labels. Attractive defaults have been chosen, but for more detailed control, the user is encouraged to add the legend himself using the unexported \code{xtsExtra::do\_barplot.legend}, as described below.
-\item[\code{major.format}] Control the format of the time axis labels; see the details \code{?strptime} for formatting codes. If left as the default (\code{TRUE}), \code{axTicksByTime} attempts to automatically pick an appropriate labelling convention.
-\item[\code{ylim}] Control the $y$-axis limits of the resulting plot. If default (\code{NULL}), the limits will be chosen automatically. Expect handling to be moved to \code{...} in future development.
-\item[\code{space}] Specifies the width of the interbar spacing ; not currently supported for plots with \code{stacked = FALSE}. Possibly will be reworked to provide more robust support in light of the $x$-axis spacing given by the index of the \code{xts} class.
-\item[\code{cex.*}] These arguments control the size of various labels. Expect their handling to be moved to use \code{...} and \code{par} arguments in future development.
-\item[\code{xaxis}] Defaulting to \code{TRUE}, should an $x$-axis and labels be drawn?
-\item[\code{box.color}] Defaulting to \code{"black"}, gives the color of less important plot elements, such as the outside boundaries and the legend box. Some authors prefer \code{box.color = "darkgray"} for a softer appearance.
-\item[\code{xlab, ylab}] Labels for the $x$- and $y$-axes. Expect their handling to be moved to \code{...} in future development.
-\item[\code{major.ticks, minor.ticks}] See the fuller description of these arguments given for \code{plot.xts} (Section \ref{sec:plot}).
-\item[\code{col}] Color of the bars. If missing, defaults to \code{col = seq\_len(NCOL(height))} chosen according to the somewhat unattractive \R defaults provided by \code{palette}. See more on color palettes below.
-\end{description}
-
-\subsection{Time Oriented Barplots}
-We begin by creating an example of an \code{xts} barplot and then we discuss its construction in more detail.
-<<>>=
-x <- xts(matrix(abs(rnorm(72)), ncol = 6), Sys.Date() + 1:12)
-colnames(x) <- LETTERS[1:6]
-barplot(x)
-@
-\begin{figure}[htb]
-<>=
-barplot(x)
-@
-\caption{\code{barplot(x)}}
-\label{fig:basic.barplot}
-\end{figure}
-producing the plot in figure \ref{fig:basic.barplot}.
-
-We note immediately that, by default, the produced barplot is a so-called ``stacked'' barplot, corresponding to \code{beside = FALSE} in the default \code{barplot} method. An advantage of this display is that observations for each time period are aligned vertically; a current limitation of the barplot code is that $x$-axis spacing does not accurately reflect irregularities in the underlying data, as in figure \ref{fig:skipping.barplot}.
-\begin{figure}[htb]
-<>=
-barplot(x[c(1:5, 12),])
-@
-\caption{\code{barplot(x[c(1:5,12),])}}
-\label{fig:skipping.barplot}
-\end{figure}
-We see in both the preceeding plots that the default axis labels accurately reflect the underlying daily periodicity of our data set, as with \code{plot.xts} more control could be had by passing a format string to \code{major.format}. E.g., to remove year labelling, we would pass \code{major.format = "\%b \%d"} to print names of the format ``Jul 25.''
-
-Note that negative values are stacked underneath the $x$-axis following the exampleof\code{barchart} in the \pkg{lattice} package.
-
-\subsection{Scaled and Unstacked Plots}
-A limitation of stacked barplots is that the eye is naturally drawn to the size of the bar, rather than the widths of the bands which comprise it. Further, while it is possible to compare the size of the bottom stripe, comparing the higher stripes is more difficult as they do not generally share a common baseline. Graphics experts like Cleveland~\cite{Cleveland} and Tufte~\cite{Tufte} use of the trellis or small multiples paradigm to avoid these problems.\footnote{See, e.g., \code{barchart} in the recommended \pkg{lattice} package.} Over and against their better judgement, we provide two possible customizations to address these concerns.
-
-In certain applications, e.g., asset class weights in finance, shifting population dynamics in ecology, or server load balance in IT, it is sometimes of greater interest to see how the relative make-up of quantities change over time rather than the scale of those quantities. For those cases, \code{barplot.xts} can be used with the option \code{scale = TRUE} which applies the transform \code{x <- x / rowSums(x)} before plotting.
-
-For example, the data created above can be interpreted as asset classes and we can show the effect of the scaled plots.
-<<>>=
-colnames(x) <- c("Equity", "Fixed Income", "Commodities",
- "FX","Convertibles","Alternatives")
-@
-producing \ref{fig:scaled.barplot}.
-\begin{figure}[htb]
-\subfigure[Unscaled Plot]{
-<>=
-barplot(x, scale = FALSE)
-@
-}
-\subfigure[Scaled Plot]{
-<>=
-barplot(x, scale = TRUE)
-@
-}
-\caption{Scaled Barplots}
-\label{fig:scaled.barplot}
-\end{figure}
-
-Currently, quantity scaling is only supported for non-negative data. For data of alternating sign, the scale transform is not uniquely defined and is, as such, left to the user. Two common choices are given here, but not implemented within the package.
-<>=
-scale1 <- function(x){x/rowSums(abs(x))}
-scale2 <- function(x){
- ## Can this be vectorized?
- for(j in seq_len(NROW(x))){
- x[j, x[j,] > 0] <- x[j, x[j,] > 0] / sum(x[j, x[j,] > 0])
- x[j, x[j,] < 0] <- -1 * x[j, x[j,] < 0] / sum(x[j, x[j,] < 0])
- }
- x
-}
-@
-\code{scale1()} transforms \code{x} such that the height of each bar is \code{1}, as with the non-negative scale transform. Since bars may now contain negative quantities, the entirety of the bar will shift up and down as a linear transform of its sum. This rescaling is helpful in seeing how the total value transforms over time. % FIXME: Put that more eloquently
-
-\code{scale2()} scales both the positive and negative row elements to sum to \code{1} independently. This is useful in more specialized circumstances, such as examing exposures of a long-short portfolio.
-
-If absolute quantities are of interest, it is sometimes desirable to create a time-oriented barplot without stacked bars, that is, with each data point being anchored on the $x$-axis. To do so, we simply use \code{stacked = FALSE}, which corresponds to \code{beside = TRUE} in the default method of \code{barplot}. This method has the slight disadvantage of no longer aligning simultaneous observations along the time axis, but can be helpful if properly interpreted, as shown in figure \ref{fig:barplot.unstacked}.
-\begin{figure}[htb]
-<>=
-barplot(x, stacked = FALSE)
-@
-\caption{\code{barplot(x, stacked = FALSE)}}
-\label{fig:barplot.unstacked}
-\end{figure}
-
-Note that the form of the unstacked barplot is subject to change as the author is not entirely happy with it.
-
-\subsection{Color Pallettes}
-The color pallete defaulted to by \code{barplot.xts} is, in the eyes of many, somewhat garish; in the particular case of barplots, the eye is too strongly drawn to the brighter elements, particularly the green and purple, causing misinterpretation. \pkg{PerformanceAnalytics} provides four chosen color pallettes to mitigate this effect and we document them here. Their use is highly recommended:
-<<>>=
-rainbow6equal <- c("#BF4D4D", "#BFBF4D", "#4DBF4D", "#4DBFBF",
- "#4D4DBF", "#BF4DBF")
-rainbow8equal <- c("#BF4D4D", "#BFA34D", "#86BF4D", "#4DBF69",
- "#4DBFBF", "#4D69BF", "#864DBF", "#BF4DA3")
-rainbow10equal <- c("#BF4D4D", "#BF914D", "#A8BF4D", "#63BF4D",
- "#4DBF7A", "#4DBFBF", "#4D7ABF", "#634DBF",
- "#A84DBF", "#BF4D91")
-rainbow12equal <- c("#BF4D4D", "#BF864D", "#BFBF4D", "#86BF4D",
- "#4DBF4D", "#4DBF86", "#4DBFBF", "#4D86BF",
- "#4D4DBF", "#864DBF", "#BF4DBF", "#BF4D86")
-@
-For more advanced pallete construction, see the \CRAN packages \pkg{RColorBrewer} and \pkg{colorspace}.
-\clearpage
-\begin{thebibliography}{99}
-\bibitem{zoo} Achim Zeileis and Gabor Grothendieck (2005): \\
-\emph{ zoo: S3 Infrastructure for Regular and Irregular Time Series.} \\
-Journal of Statistical Software, 14(6), 1-27. \\
-\url{http://www.jstatsoft.org/v14/i06/}
-
-\bibitem{ISO} International Organization for Standardization (2004):\\
-\emph{ISO 8601: Data elements and interchage formats ---
- Information interchange --- Representation of dates and time}\\
-\url{http://www.iso.org}
-
-\bibitem{R} R Development Core Team: \\
-\emph{R: A Language and Environment for Statistical Computing}, \\
-R Foundation for Statistical Computing, Vienna, Austria. \\
-ISBN 3-900051-07-0\\
-\url{http://www.R-project.org}
-
-\bibitem{quantmod} Jeffrey A. Ryan (2008):
-\emph{quantmod: Quantitative Financial Modelling Framework.}\\
-R package version 0.3-5. \\
-\url{http://www.quantmod.com} \\
-\url{http://r-forge.r-project.org/projects/quantmod}
-
-\bibitem{xts} Jeffrey A. Ryan \& Joshua M. Ulrich (2008):\\
-\emph{xts: Extensible Time Series}\\
-R package version 0.8-7. \\
-\url{http://r-forge.r-project.org/projects/xts/}
-
-\bibitem{PerformanceAnalytics} Peter Carl and Brian G. Peterson (2012):\\
-\emph{PerformanceAnalytics: Econometric tools for performance and risk analysis.},\\
-R package version 1.0.4.5\\
-\url{http://r-forge.r-project.org/projects/returnanalytics/}
-
-\bibitem{Cleveland} Cleveland, W.S. (1994):\\
-\emph{The Elements of Graphing Data}\\
-Summit, NJ: Hobart Press.
-
-\bibitem{Tufte} Tufte, Edward R. (2001):\\
-\emph{The Visual Display of Quantitative Information, 2nd. ed}.\\
-Chesire, CN: The Graphics Press.\\
-See also \url{http://www.edwardtufte.com}.
-
-\end{thebibliography}
-\end{document}
From noreply at r-forge.r-project.org Wed Sep 17 02:32:37 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 17 Sep 2014 02:32:37 +0200 (CEST)
Subject: [Xts-commits] r853 - pkg/xtsExtra/R
Message-ID: <20140917003237.9121A1875DC@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-17 02:32:32 +0200 (Wed, 17 Sep 2014)
New Revision: 853
Modified:
pkg/xtsExtra/R/plot2.R
Log:
Adding col as an argument to addSeries. Fixing bug to better handle data with NAs.
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-13 00:38:03 UTC (rev 852)
+++ pkg/xtsExtra/R/plot2.R 2014-09-17 00:32:32 UTC (rev 853)
@@ -49,7 +49,7 @@
barplot.default(t(negatives), add=TRUE, col=colorset, axisnames=FALSE, axes=FALSE)
}
if(!is.null(legend.loc)){
- yrange <- range(na.omit(x))
+ yrange <- range(x, na.rm=TRUE)
nobs <- NROW(x)
switch(legend.loc,
topleft = {
@@ -284,13 +284,13 @@
R <- try(do.call(fun, .formals), silent=TRUE)
if(inherits(R, "try-error")) {
message(paste("FUN function failed with message", R))
- ylim <- range(na.omit(x[subset]))
+ ylim <- range(x[subset], na.rm=TRUE)
} else {
- ylim <- range(na.omit(R[subset]))
+ ylim <- range(R[subset], na.rm=TRUE)
}
} else {
# set the ylim based on the data passed into the x argument
- ylim <- range(na.omit(x[subset]))
+ ylim <- range(x[subset], na.rm=TRUE)
}
}
}
@@ -378,8 +378,8 @@
if(frame %% 2 == 0 && !fixed) {
lenv <- attr(x,"env")
if(is.list(lenv)) lenv <- lenv[[1]]
- min.tmp <- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE)
- max.tmp <- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE)
+ 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)
}
})
@@ -477,16 +477,16 @@
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(na.omit(cs$Env$R[subset])),fixed=TRUE)))
+ 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(na.omit(cs$Env$R[,1][subset])),fixed=TRUE)))
+ 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(na.omit(cs$Env$R[subset])),fixed=TRUE)))
+ cs$set_ylim(list(structure(range(cs$Env$R[subset], na.rm=TRUE),fixed=TRUE)))
}
- cs$Env$constant_ylim <- range(na.omit(cs$Env$R[subset]))
+ 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)))
@@ -588,7 +588,7 @@
if(yaxis.same){
lenv$ylim <- cs$Env$constant_ylim
} else {
- lenv$ylim <- range(na.omit(cs$Env$R[,1][subset]))
+ lenv$ylim <- range(cs$Env$R[,1][subset], na.rm=TRUE)
}
exp <- expression(chart.lines(xdata,
type=type,
@@ -616,7 +616,7 @@
if(yaxis.same){
lenv$ylim <- cs$Env$constant_ylim
} else {
- lenv$ylim <- range(na.omit(cs$Env$R[,i][subset]))
+ lenv$ylim <- range(cs$Env$R[,i][subset], na.rm=TRUE)
}
lenv$type <- cs$Env$type
@@ -761,7 +761,7 @@
# add frame for the actual drawdowns data
if(is.null(ylim)) {
- ylim <- range(na.omit(lenv$xdata[xsubset]))
+ ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
}
plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
@@ -788,13 +788,17 @@
}
-addSeries <- function(x, main="", on=NA, type="l", lty=1, lwd=1, pch=0, ...){
+addSeries <- function(x, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=0, ...){
lenv <- new.env()
lenv$main <- main
- lenv$plot_lines <- function(x, ta, on, type, lty, lwd, pch, ...){
+ lenv$plot_lines <- function(x, ta, on, type, col, lty, lwd, pch, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
- colorset <- x$Env$theme$colorset
+ if(is.null(col)){
+ colorset <- x$Env$theme$colorset
+ } else {
+ colorset <- col
+ }
if(all(is.na(on))){
# Add x-axis grid lines
segments(axTicksByTime2(xdata[xsubset]),
@@ -816,13 +820,14 @@
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
- names(list(x=x,on=on,type=type,lty=lty,lwd=lwd,pch=pch,...)),
- list(x=x,on=on,type=type,lty=lty,lwd=lwd,pch=pch,...))
+ names(list(x=x,on=on,type=type,col=col,lty=lty,lwd=lwd,pch=pch,...)),
+ list(x=x,on=on,type=type,col=col,lty=lty,lwd=lwd,pch=pch,...))
exp <- parse(text=gsub("list","plot_lines",
as.expression(substitute(list(x=current.xts_chob(),
ta=get("x"),
on=on,
type=type,
+ col=col,
lty=lty,
lwd=lwd,
pch=pch,
@@ -837,7 +842,7 @@
xsubset <- plot_object$Env$xsubset
no.update <- FALSE
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
- ylim <- range(na.omit(lenv$xdata[xsubset]))
+ ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
if(is.na(on)){
@@ -955,7 +960,7 @@
xsubset <- plot_object$Env$xsubset
no.update <- FALSE
lenv$xdata <- xdata
- ylim <- range(na.omit(xdata))
+ ylim <- range(xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
# add the frame for drawdowns info
@@ -1209,7 +1214,7 @@
# add frame for the actual data
if(is.null(ylim)) {
- ylim <- range(na.omit(lenv$xdata[xsubset]))
+ ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
}
plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
@@ -1281,7 +1286,7 @@
# add frame for the actual drawdowns data
if(is.null(ylim)) {
- ylim <- range(na.omit(lenv$xdata[xsubset]))
+ ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
}
plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE)
From noreply at r-forge.r-project.org Wed Sep 17 05:21:19 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 17 Sep 2014 05:21:19 +0200 (CEST)
Subject: [Xts-commits] r854 - in pkg/xtsExtra: R man
Message-ID: <20140917032119.CEE2A1876A4@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-17 05:21:19 +0200 (Wed, 17 Sep 2014)
New Revision: 854
Added:
pkg/xtsExtra/man/addLegend.Rd
pkg/xtsExtra/man/addLines.Rd
pkg/xtsExtra/man/addPoints.Rd
pkg/xtsExtra/man/addSeries.Rd
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/man/plot.xts.Rd
Log:
adding some documentation for add* functions
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-17 00:32:32 UTC (rev 853)
+++ pkg/xtsExtra/R/plot2.R 2014-09-17 03:21:19 UTC (rev 854)
@@ -217,8 +217,7 @@
#' @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,
...,
@@ -787,7 +786,18 @@
plot_object
}
-
+#' 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}.
+#' @param type the type of plot to be drawn, same as in \code{\link{plot}}.
+#' @param col color palette to use, set by default to rational choices.
+#' @param lty set the line type, same as in \code{\link{plot}}.
+#' @param lwd set the line width, same as in \code{\link{plot}}.
+#' @param pch the type of plot to be drawn, same as in \code{\link{plot}}.
+#' @param \dots any other passthrough parameters. Not currently used.
+#' @author Ross Bennett
addSeries <- function(x, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=0, ...){
lenv <- new.env()
lenv$main <- main
@@ -895,11 +905,37 @@
plot_object
}
-addPoints <- function(x, main="", on=NA, pch=0, ...){
- addSeries(x, main=main, on=on, type="p", pch=pch, ...)
+#' Add time series of points 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}.
+#' @param col color palette to use, set by default to rational choices.
+#' @param pch the type of plot to be drawn, same as in \code{\link{plot}}.
+#' @param \dots any other passthrough parameters. Not currently used.
+#' @author Ross Bennett
+addPoints <- function(x, main="", on=NA, col=NULL, pch=0, ...){
+ addSeries(x, main=main, on=on, type="p", col=col, pch=pch, ...)
}
-
+#' Add vertical lines to an existing xts plot
+#'
+#' @param event.lines character vector of dates. Vertical lines will be drawn
+#' to indicate that an event happened during that time period. \code{event.lines} should
+#' be a vector of dates (e.g., \code{c("09/03","05/06"))} formatted the same as
+#' \code{date.format}. This function matches the re-formatted row names (dates) with
+#' the events.list, so to get a match the formatting needs to be correct.
+#' @param event.labels character vector of event labels corresponding to
+#' \code{event.lines}. This will apply text labels (e.g.,
+#' \code{c("This Event", "That Event")} to the vertical lines drawn.
+#' @param date.format format for the dates in \code{event.lines}.
+#' @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}.
+#' @param lty set the line type, same as in \code{\link{plot}}.
+#' @param lwd set the line width, same as in \code{\link{plot}}.
+#' @param col color palette to use, set by default to rational choices.
+#' @param \dots any other passthrough parameters. Not currently used.
+#' @author Ross Bennett
addLines <- function(event.dates, event.labels=NULL, date.format="%Y-%m-%d", main="", on=NA, lty=1, lwd=1, col=1, ...){
# add checks for event.dates and event.labels
if(!is.null(event.labels))
@@ -1312,6 +1348,14 @@
plot_object
}
+#' Add Legend
+#'
+#' @param legend.loc legend.loc places a legend into one of nine locations on
+#' the chart: bottomright, bottom, bottomleft, left, topleft, top, topright,
+#' right, or center.
+#' @param ncol number of columns for the legend
+#' @param \dots any other passthrough parameters. Not currently used.
+#' @author Ross Bennett
addLegend <- function(legend.loc="center", ncol=1, ...){
lenv <- new.env()
lenv$main <- ""
Added: pkg/xtsExtra/man/addLegend.Rd
===================================================================
--- pkg/xtsExtra/man/addLegend.Rd (rev 0)
+++ pkg/xtsExtra/man/addLegend.Rd 2014-09-17 03:21:19 UTC (rev 854)
@@ -0,0 +1,23 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{addLegend}
+\alias{addLegend}
+\title{Add Legend}
+\usage{
+addLegend(legend.loc = "center", ncol = 1, ...)
+}
+\arguments{
+\item{legend.loc}{legend.loc places a legend into one of nine locations on
+the chart: bottomright, bottom, bottomleft, left, topleft, top, topright,
+right, or center.}
+
+\item{ncol}{number of columns for the legend}
+
+\item{\dots}{any other passthrough parameters. Not currently used.}
+}
+\description{
+Add Legend
+}
+\author{
+Ross Bennett
+}
+
Added: pkg/xtsExtra/man/addLines.Rd
===================================================================
--- pkg/xtsExtra/man/addLines.Rd (rev 0)
+++ pkg/xtsExtra/man/addLines.Rd 2014-09-17 03:21:19 UTC (rev 854)
@@ -0,0 +1,40 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{addLines}
+\alias{addLines}
+\title{Add vertical lines to an existing xts plot}
+\usage{
+addLines(event.dates, event.labels = NULL, date.format = "\%Y-\%m-\%d",
+ main = "", on = NA, lty = 1, lwd = 1, col = 1, ...)
+}
+\arguments{
+\item{event.lines}{character vector of dates. Vertical lines will be drawn
+to indicate that an event happened during that time period. \code{event.lines} should
+be a vector of dates (e.g., \code{c("09/03","05/06"))} formatted the same as
+\code{date.format}. This function matches the re-formatted row names (dates) with
+the events.list, so to get a match the formatting needs to be correct.}
+
+\item{event.labels}{character vector of event labels corresponding to
+\code{event.lines}. This will apply text labels (e.g.,
+\code{c("This Event", "That Event")} to the vertical lines drawn.}
+
+\item{date.format}{format for the dates in \code{event.lines}.}
+
+\item{main}{main title for a new panel if drawn.}
+
+\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.}
+
+\item{lty}{set the line type, same as in \code{\link{plot}}.}
+
+\item{lwd}{set the line width, same as in \code{\link{plot}}.}
+
+\item{col}{color palette to use, set by default to rational choices.}
+
+\item{\dots}{any other passthrough parameters. Not currently used.}
+}
+\description{
+Add vertical lines to an existing xts plot
+}
+\author{
+Ross Bennett
+}
+
Added: pkg/xtsExtra/man/addPoints.Rd
===================================================================
--- pkg/xtsExtra/man/addPoints.Rd (rev 0)
+++ pkg/xtsExtra/man/addPoints.Rd 2014-09-17 03:21:19 UTC (rev 854)
@@ -0,0 +1,27 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{addPoints}
+\alias{addPoints}
+\title{Add time series of points to an existing xts plot}
+\usage{
+addPoints(x, main = "", on = NA, col = NULL, pch = 0, ...)
+}
+\arguments{
+\item{x}{an xts object to plot.}
+
+\item{main}{main title for a new panel if drawn.}
+
+\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.}
+
+\item{col}{color palette to use, set by default to rational choices.}
+
+\item{pch}{the type of plot to be drawn, same as in \code{\link{plot}}.}
+
+\item{\dots}{any other passthrough parameters. Not currently used.}
+}
+\description{
+Add time series of points to an existing xts plot
+}
+\author{
+Ross Bennett
+}
+
Added: pkg/xtsExtra/man/addSeries.Rd
===================================================================
--- pkg/xtsExtra/man/addSeries.Rd (rev 0)
+++ pkg/xtsExtra/man/addSeries.Rd 2014-09-17 03:21:19 UTC (rev 854)
@@ -0,0 +1,34 @@
+% Generated by roxygen2 (4.0.1): do not edit by hand
+\name{addSeries}
+\alias{addSeries}
+\title{Add a time series to an existing xts plot}
+\usage{
+addSeries(x, main = "", on = NA, type = "l", col = NULL, lty = 1,
+ lwd = 1, pch = 0, ...)
+}
+\arguments{
+\item{x}{an xts object to plot.}
+
+\item{main}{main title for a new panel if drawn.}
+
+\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.}
+
+\item{type}{the type of plot to be drawn, same as in \code{\link{plot}}.}
+
+\item{col}{color palette to use, set by default to rational choices.}
+
+\item{lty}{set the line type, same as in \code{\link{plot}}.}
+
+\item{lwd}{set the line width, same as in \code{\link{plot}}.}
+
+\item{pch}{the type of plot to be drawn, same as in \code{\link{plot}}.}
+
+\item{\dots}{any other passthrough parameters. Not currently used.}
+}
+\description{
+Add a time series to an existing xts plot
+}
+\author{
+Ross Bennett
+}
+
Modified: pkg/xtsExtra/man/plot.xts.Rd
===================================================================
--- pkg/xtsExtra/man/plot.xts.Rd 2014-09-17 00:32:32 UTC (rev 853)
+++ pkg/xtsExtra/man/plot.xts.Rd 2014-09-17 03:21:19 UTC (rev 854)
@@ -3,8 +3,8 @@
\alias{plot.xts}
\title{Time series Plotting}
\usage{
-\method{plot}{xts}(x, y = NULL, ..., subset = "", FUN = NULL, panels = NULL,
- multi.panel = FALSE, colorset = 1:12, up.col = "green",
+\method{plot}{xts}(x, y = NULL, ..., subset = "", FUN = NULL,
+ panels = NULL, multi.panel = FALSE, colorset = 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,
@@ -94,4 +94,7 @@
Plotting for xts objects.
TODO: description, details, and examples
}
+\author{
+Ross Bennett
+}
From noreply at r-forge.r-project.org Wed Sep 17 23:14:06 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 17 Sep 2014 23:14:06 +0200 (CEST)
Subject: [Xts-commits] r855 - pkg/xtsExtra/R
Message-ID: <20140917211407.09E09186BFF@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-17 23:14:06 +0200 (Wed, 17 Sep 2014)
New Revision: 855
Added:
pkg/xtsExtra/R/axTicksByTime2.R
Log:
copy axTicksByTime2.R from quantmod
Added: pkg/xtsExtra/R/axTicksByTime2.R
===================================================================
--- pkg/xtsExtra/R/axTicksByTime2.R (rev 0)
+++ pkg/xtsExtra/R/axTicksByTime2.R 2014-09-17 21:14:06 UTC (rev 855)
@@ -0,0 +1,61 @@
+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
+}
+
From noreply at r-forge.r-project.org Sun Sep 21 15:53:51 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sun, 21 Sep 2014 15:53:51 +0200 (CEST)
Subject: [Xts-commits] r856 - in pkg/xtsExtra: R sandbox
Message-ID: <20140921135351.612F01875AD@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-21 15:53:51 +0200 (Sun, 21 Sep 2014)
New Revision: 856
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
changes for non-equally spaced time based x-axis
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-17 21:14:06 UTC (rev 855)
+++ pkg/xtsExtra/R/plot2.R 2014-09-21 13:53:51 UTC (rev 856)
@@ -23,14 +23,19 @@
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")
+ # 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=colorset[i], lty=lty[i], lwd=lwd[i], pch=pch)
+ # lines(1:NROW(x), x[,i], type=type, lend=lend, col=colorset[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=colorset[i], lty=lty[i], lwd=lwd[i], pch=pch)
}
} else if(type == "bar"){
# This does not work correctly
@@ -50,60 +55,61 @@
}
if(!is.null(legend.loc)){
yrange <- range(x, na.rm=TRUE)
- nobs <- NROW(x)
+ # nobs <- NROW(x)
+ chob.xlim <- xx$Env$xlim
switch(legend.loc,
topleft = {
xjust <- 0
yjust <- 1
- lx <- 1
+ lx <- chob.xlim[1]
ly <- yrange[2]
},
left = {
xjust <- 0
yjust <- 0.5
- lx <- 1
+ lx <- chob.xlim[1]
ly <- sum(yrange) / 2
},
bottomleft = {
xjust <- 0
yjust <- 0
- lx <- 1
+ lx <- chob.xlim[1]
ly <- yrange[1]
},
top = {
xjust <- 0.5
yjust <- 1
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- yrange[2]
},
center = {
xjust <- 0.5
yjust <- 0.5
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- sum(yrange) / 2
},
bottom = {
xjust <- 0.5
yjust <- 0
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- yrange[1]
},
topright = {
xjust <- 1
yjust <- 1
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- yrange[2]
},
right = {
xjust <- 1
yjust <- 0.5
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- sum(yrange) / 2
},
bottomright = {
xjust <- 1
yjust <- 0
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- yrange[1]
}
)
@@ -363,7 +369,9 @@
x <- "" #1:NROW(Env$xdata)
}
Env$xsubset <<- x
- set_xlim(c(1,NROW(Env$xdata[Env$xsubset])))
+ # 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'))
@@ -446,6 +454,12 @@
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)
+
# Compute transformation if specified by panel argument
# rough prototype for calling a function for the main "panel"
if(!is.null(FUN)){
@@ -467,8 +481,11 @@
}
# Set xlim based on the raw returns data passed into function
- cs$set_xlim(c(1,NROW(cs$Env$xdata[subset])))
+ # 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.
@@ -505,9 +522,9 @@
# compute the x-axis ticks
cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]),
- segments(atbt, #axTicksByTime2(xdata[xsubset]),
+ segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][1],
- atbt, #axTicksByTime2(xdata[xsubset]),
+ 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)
@@ -518,11 +535,12 @@
# add observation level ticks on x-axis if < 400 obs.
cs$add(expression(if(NROW(xdata[xsubset])<400)
- {axis(1,at=1:NROW(xdata[xsubset]),labels=FALSE,col=theme$grid2,tcl=0.3)}),expr=TRUE)
+ {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=axt, #axTicksByTime(xdata[xsubset]),
+ 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)),
@@ -532,8 +550,8 @@
#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(1-1/3,0.5,main,font=2,col='#444444',offset=0,cex=1.1,pos=4)),
- expression(text(NROW(xdata[xsubset]),0.5,
+ 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)
@@ -553,13 +571,15 @@
}
# add y-axis grid lines and labels
- exp <- expression(segments(1, y_grid_lines(get_ylim()[[2]]),
- NROW(xdata[xsubset]), y_grid_lines(get_ylim()[[2]]),
+ 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(1-1/3-max(strwidth(y_grid_lines(get_ylim()[[2]]))),
+ expression(text(xlim[1]-0.5-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,
@@ -568,7 +588,8 @@
if(yaxis.right){
exp <- c(exp,
# right y-axis labels
- expression(text(NROW(R[xsubset])+1/3, y_grid_lines(get_ylim()[[2]]),
+ expression(text(xlim[2]+0.5,
+ 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)))
@@ -600,7 +621,7 @@
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=2,
+ 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))
@@ -622,7 +643,7 @@
# Add a small frame
cs$add_frame(ylim=c(0,1),asp=0.25)
cs$next_frame()
- text.exp <- expression(text(x=1,
+ text.exp <- expression(text(x=xlim[1],
y=0.5,
labels="",
adj=c(0,0),cex=0.9,offset=0,pos=4))
@@ -653,33 +674,36 @@
# NOTE 'exp' was defined earlier as chart.lines
exp <- c(exp,
# y-axis grid lines
- expression(segments(1,y_grid_lines(ylim),
- NROW(xdata[xsubset]), y_grid_lines(ylim),
+ 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(atbt, #axTicksByTime2(xdata[xsubset]),
+ segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]),
ylim[1],
- atbt, #axTicksByTime2(xdata[xsubset]),
+ 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(1-1/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim),
+ expression(text(xlim[1]-0.5-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(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim),
+ expression(text(xlim[2]+0.5, 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=2,
+ 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))
@@ -725,9 +749,10 @@
xsubset <- x$Env$xsubset
colorset <- x$Env$theme$colorset
# Add x-axis grid lines
- segments(axTicksByTime2(xdata[xsubset]),
+ atbt <- axTicksByTime2(xdata[xsubset])
+ segments(x$Env$xycoords$x[atbt],
par("usr")[3],
- axTicksByTime2(xdata[xsubset]),
+ x$Env$xycoords$x[atbt],
par("usr")[4],
col=x$Env$theme$grid)
drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset]
@@ -754,7 +779,7 @@
# add the frame for drawdowns info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -772,14 +797,19 @@
p[p > ylim[1] & p < ylim[2]]
}
# add y-axis gridlines and labels
- exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]),grid_lines(ylim),
+ exp <- c(expression(segments(xlim[1],
+ grid_lines(ylim),
+ xlim[2],
+ grid_lines(ylim),
col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(1-1/3-max(strwidth(grid_lines(ylim))),grid_lines(ylim),
+ expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(NROW(xdata[xsubset])+1/3,grid_lines(ylim),
+ expression(text(xlim[2]+0.5,
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
@@ -811,9 +841,10 @@
}
if(all(is.na(on))){
# Add x-axis grid lines
- segments(axTicksByTime2(xdata[xsubset]),
+ atbt <- axTicksByTime2(xdata[xsubset])
+ segments(x$Env$xycoords$x[atbt],
par("usr")[3],
- axTicksByTime2(xdata[xsubset]),
+ x$Env$xycoords$x[atbt],
par("usr")[4],
col=x$Env$theme$grid)
}
@@ -859,7 +890,7 @@
# add the frame for drawdowns info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -877,20 +908,24 @@
# NOTE 'exp' was defined earlier as chart.lines
exp <- c(exp,
# y-axis grid lines
- expression(segments(1,y_grid_lines(ylim),
- NROW(xdata[xsubset]), y_grid_lines(ylim),
+ 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)))
if(plot_object$Env$theme$lylab){
exp <- c(exp,
# y-axis labels/boxes
- expression(text(1-1/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim),
+ expression(text(xlim[1]-0.5-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(plot_object$Env$theme$rylab){
exp <- c(exp,
- expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim),
+ expression(text(xlim[2]+0.5,
+ 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)))
@@ -949,9 +984,10 @@
colorset <- x$Env$theme$colorset
if(all(is.na(on))){
# Add x-axis grid lines
- segments(axTicksByTime2(xdata[xsubset]),
+ atbt <- axTicksByTime2(xdata[xsubset])
+ segments(x$Env$xycoords$x[atbt],
par("usr")[3],
- axTicksByTime2(xdata[xsubset]),
+ x$Env$xycoords$x[atbt],
par("usr")[4],
col=x$Env$theme$grid)
}
@@ -967,8 +1003,8 @@
ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
ta.y <- ta.adj[,-1]
event.ind <- which(ta.y == 999)
- abline(v=event.ind, col=col, lty=lty, lwd=lwd)
- text(x=event.ind, y=ypos, labels=event.labels, offset=.2, pos=2, , srt=90, col=1)
+ abline(v=x$Env$xycoords$x[event.ind], col=col, lty=lty, lwd=lwd)
+ text(x=x$Env$xycoords$x[event.ind], y=ypos, labels=event.labels, offset=.2, pos=2, , srt=90, col=1)
}
plot_object <- current.xts_chob()
@@ -1002,7 +1038,7 @@
# add the frame for drawdowns info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -1020,20 +1056,24 @@
# NOTE 'exp' was defined earlier as chart.lines
exp <- c(exp,
# y-axis grid lines
- expression(segments(1,y_grid_lines(ylim),
- NROW(xdata[xsubset]), y_grid_lines(ylim),
+ 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)))
if(plot_object$Env$theme$lylab){
exp <- c(exp,
# y-axis labels/boxes
- expression(text(1-1/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim),
+ expression(text(xlim[1]-0.5-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(plot_object$Env$theme$rylab){
exp <- c(exp,
- expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim),
+ expression(text(xlim[2]+0.5,
+ 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)))
@@ -1209,9 +1249,10 @@
up.col <- x$Env$theme$up.col
dn.col <- x$Env$theme$dn.col
# Add x-axis grid lines
- segments(axTicksByTime2(xdata[xsubset]),
+ atbt <- axTicksByTime2(xdata[xsubset])
+ segments(x$Env$xycoords$x[atbt],
par("usr")[3],
- axTicksByTime2(xdata[xsubset]),
+ x$Env$xycoords$x[atbt],
par("usr")[4],
col=x$Env$theme$grid)
chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col)
@@ -1244,7 +1285,7 @@
# add the frame for time series info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -1262,14 +1303,18 @@
p[p > ylim[1] & p < ylim[2]]
}
# add y-axis gridlines and labels
- exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]),
+ exp <- c(expression(segments(xlim[1],
+ grid_lines(ylim),
+ xlim[2],
grid_lines(ylim),col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(1-1/3-max(strwidth(grid_lines(ylim))),grid_lines(ylim),
+ expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(NROW(xdata[xsubset])+1/3,grid_lines(ylim),
+ expression(text(xlim[2]+0.5,
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
@@ -1316,7 +1361,7 @@
# add the frame for drawdowns info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -1334,14 +1379,18 @@
p[p > ylim[1] & p < ylim[2]]
}
# add y-axis gridlines and labels
- exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]),
+ exp <- c(expression(segments(xlim[1],
+ grid_lines(ylim),
+ xlim[2],
grid_lines(ylim),col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(1-1/3-max(strwidth(grid_lines(ylim))),grid_lines(ylim),
+ expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(NROW(xdata[xsubset])+1/3,grid_lines(ylim),
+ expression(text(xlim[2]+1/3,
+ grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE)
@@ -1367,7 +1416,7 @@
# add the frame for drawdowns info
plot_object$add_frame(ylim=c(0,1),asp=0.25)
plot_object$next_frame()
- text.exp <- expression(text(x=1, y=0.3, labels=main,
+ text.exp <- expression(text(x=xlim[1], y=0.3, labels=main,
col=1,adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
@@ -1378,59 +1427,60 @@
if(!is.null(legend.loc)){
yrange <- c(0,1)
nobs <- plot_object$Env$nobs
+ chob.xlim <- plot_object$Env$xlim
switch(legend.loc,
topleft = {
xjust <- 0
yjust <- 1
- lx <- 1
+ lx <- chob.xlim[1]
ly <- yrange[2]
},
left = {
xjust <- 0
yjust <- 0.5
- lx <- 1
+ lx <- chob.xlim[1]
ly <- sum(yrange) / 2
},
bottomleft = {
xjust <- 0
yjust <- 0
- lx <- 1
+ lx <- chob.xlim[1]
ly <- yrange[1]
},
top = {
xjust <- 0.5
yjust <- 1
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- yrange[2]
},
center = {
xjust <- 0.5
yjust <- 0.5
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- sum(yrange) / 2
},
bottom = {
xjust <- 0.5
yjust <- 0
- lx <- nobs / 2
+ lx <- (chob.xlim[1] + chob.xlim[2]) / 2
ly <- yrange[1]
},
topright = {
xjust <- 1
yjust <- 1
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- yrange[2]
},
right = {
xjust <- 1
yjust <- 0.5
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- sum(yrange) / 2
},
bottomright = {
xjust <- 1
yjust <- 0
- lx <- nobs
+ lx <- chob.xlim[2]
ly <- yrange[1]
}
)
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-17 21:14:06 UTC (rev 855)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-21 13:53:51 UTC (rev 856)
@@ -141,10 +141,16 @@
endDate="2012-12-31"
getSymbols(stock.str,from=initDate,to=endDate, src="yahoo")
plot(Ad(AAPL))
-addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1)
-addLines(c("2011-03-04", "2012-01-10", "2012-07-28"), on=1)
-addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1)
+addSeries(Ad(AAPL)["2012-05-28/"]-10, on=1, col = "red")
+xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1)
+xtsExtra::addLines(c("2011-03-04", "2012-01-10", "2012-07-28"), on=1)
+xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28"))
+aapl <- Ad(AAPL)
+plot(aapl)
+aapl["2011-07/2012-07"] <- NA
+plot(aapl)
+
# png("~/Documents/foo.png")
# plot(R, FUN="CumReturns")
# addDrawdowns()
From noreply at r-forge.r-project.org Sun Sep 21 16:13:40 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sun, 21 Sep 2014 16:13:40 +0200 (CEST)
Subject: [Xts-commits] r857 - in pkg/xtsExtra: R sandbox
Message-ID: <20140921141340.DE1C61848D6@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-21 16:13:40 +0200 (Sun, 21 Sep 2014)
New Revision: 857
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
minor adjustment to y-label offset
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-21 13:53:51 UTC (rev 856)
+++ pkg/xtsExtra/R/plot2.R 2014-09-21 14:13:40 UTC (rev 857)
@@ -459,6 +459,7 @@
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"
@@ -579,7 +580,7 @@
if(yaxis.left){
exp <- c(exp,
# left y-axis labels
- expression(text(xlim[1]-0.5-max(strwidth(y_grid_lines(get_ylim()[[2]]))),
+ 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,
@@ -588,7 +589,7 @@
if(yaxis.right){
exp <- c(exp,
# right y-axis labels
- expression(text(xlim[2]+0.5,
+ 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,
@@ -689,7 +690,7 @@
if(yaxis.left){
exp <- c(exp,
# y-axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(y_grid_lines(ylim))),
+ 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,
@@ -697,7 +698,7 @@
}
if(yaxis.right){
exp <- c(exp,
- expression(text(xlim[2]+0.5, y_grid_lines(ylim),
+ 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)))
@@ -804,11 +805,11 @@
col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))),
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(xlim[2]+0.5,
+ expression(text(xlim[2]+xstep*2/3,
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
@@ -916,7 +917,7 @@
if(plot_object$Env$theme$lylab){
exp <- c(exp,
# y-axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(y_grid_lines(ylim))),
+ 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,
@@ -924,7 +925,7 @@
}
if(plot_object$Env$theme$rylab){
exp <- c(exp,
- expression(text(xlim[2]+0.5,
+ 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,
@@ -1064,7 +1065,7 @@
if(plot_object$Env$theme$lylab){
exp <- c(exp,
# y-axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(y_grid_lines(ylim))),
+ 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,
@@ -1072,7 +1073,7 @@
}
if(plot_object$Env$theme$rylab){
exp <- c(exp,
- expression(text(xlim[2]+0.5,
+ 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,
@@ -1309,11 +1310,11 @@
grid_lines(ylim),col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))),
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(xlim[2]+0.5,
+ expression(text(xlim[2]+xstep*2/3,
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
@@ -1385,11 +1386,11 @@
grid_lines(ylim),col=theme$grid)),
exp, # NOTE 'exp' was defined earlier
# add axis labels/boxes
- expression(text(xlim[1]-0.5-max(strwidth(grid_lines(ylim))),
+ expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))),
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)),
- expression(text(xlim[2]+1/3,
+ expression(text(xlim[2]+xstep*2/3,
grid_lines(ylim),
noquote(format(grid_lines(ylim),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)))
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-21 13:53:51 UTC (rev 856)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-21 14:13:40 UTC (rev 857)
@@ -40,8 +40,8 @@
plot(R, FUN=CumReturns)
addReturns(type="h")
addDrawdowns()
-addLines(c("1999-01-01", "2000-01-01", "2005-01-01"), c("foo", "bar", "pizza"), on=1:3)
-addLines(c("1999-01-01", "2000-01-01", "2005-01-01"))
+xtsExtra::addLines(c("1999-01-01", "2000-01-01", "2005-01-01"), c("foo", "bar", "pizza"), on=1:3)
+xtsExtra::addLines(c("1999-01-01", "2000-01-01", "2005-01-01"))
plot(R, FUN="CumReturns",
From noreply at r-forge.r-project.org Sun Sep 21 16:29:37 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sun, 21 Sep 2014 16:29:37 +0200 (CEST)
Subject: [Xts-commits] r858 - in pkg/xtsExtra: R sandbox
Message-ID: <20140921142937.3337A1876D5@r-forge.r-project.org>
Author: rossbennett34
Date: 2014-09-21 16:29:36 +0200 (Sun, 21 Sep 2014)
New Revision: 858
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
adding args for addLegend
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-09-21 14:13:40 UTC (rev 857)
+++ pkg/xtsExtra/R/plot2.R 2014-09-21 14:29:36 UTC (rev 858)
@@ -1403,10 +1403,14 @@
#' @param legend.loc legend.loc places a legend into one of nine locations on
#' the chart: bottomright, bottom, bottomleft, left, topleft, top, topright,
#' right, or center.
+#' @param legend.names character vector of names for the legend. If \code{NULL},
+#' the column names of the current plot object are used.
+#' @param colorset fill colorset for the legend. If \code{NULL},
+#' the colorset of the current plot object data is used.
#' @param ncol number of columns for the legend
#' @param \dots any other passthrough parameters. Not currently used.
#' @author Ross Bennett
-addLegend <- function(legend.loc="center", ncol=1, ...){
+addLegend <- function(legend.loc="center", legend.names=NULL, colorset=NULL, ncol=1, ...){
lenv <- new.env()
lenv$main <- ""
@@ -1491,8 +1495,16 @@
lenv$ly <- ly
lenv$xjust <- xjust
lenv$yjust <- yjust
- lenv$colorset <- plot_object$Env$theme$colorset[1:nc]
- lenv$names <- plot_object$Env$column_names
+ if(!is.null(colorset)){
+ lenv$colorset <- colorset[1:nc]
+ } else {
+ lenv$colorset <- plot_object$Env$theme$colorset[1:nc]
+ }
+ if(!is.null(legend.names)){
+ lenv$names <- legend.names
+ } else {
+ lenv$names <- plot_object$Env$column_names
+ }
lenv$nc <- ncol
# add expression for legend
exp <- expression(legend(x=lx, y=ly, legend=names, xjust=xjust, yjust=yjust,
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-09-21 14:13:40 UTC (rev 857)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-09-21 14:29:36 UTC (rev 858)
@@ -102,6 +102,7 @@
}
plot(R, FUN=foo)
addLegend(ncol = 4)
+addLegend(legend.names = c("foo", "bar"), colorset = c(1,2), ncol=2)
plot(R, FUN=foo, legend.loc="topleft")
plot(R, FUN=foo, legend.loc="left")
From noreply at r-forge.r-project.org Mon Sep 22 16:43:25 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 22 Sep 2014 16:43:25 +0200 (CEST)
Subject: [Xts-commits] r859 - pkg/xts/src
Message-ID: <20140922144325.D5B7B1874ED@r-forge.r-project.org>
Author: bodanker
Date: 2014-09-22 16:43:25 +0200 (Mon, 22 Sep 2014)
New Revision: 859
Modified:
pkg/xts/src/toperiod.c
Log:
- Fix bug #5937 (to.period error when name=NULL)
Modified: pkg/xts/src/toperiod.c
===================================================================
--- pkg/xts/src/toperiod.c 2014-09-21 14:29:36 UTC (rev 858)
+++ pkg/xts/src/toperiod.c 2014-09-22 14:43:25 UTC (rev 859)
@@ -261,9 +261,9 @@
SET_STRING_ELT(newcolnames, 1, mkChar("High"));
SET_STRING_ELT(newcolnames, 2, mkChar("Low"));
SET_STRING_ELT(newcolnames, 3, mkChar("Close"));
- if(INTEGER(hasVolume))
+ if(INTEGER(hasVolume)[0])
SET_STRING_ELT(newcolnames, 4, mkChar("Volume"));
- if(INTEGER(hasVolume))
+ if(INTEGER(hasAdjusted)[0])
SET_STRING_ELT(newcolnames, 5, mkChar("Adjusted"));
SET_VECTOR_ELT(dimnames, 1, newcolnames);
}