[Xts-commits] r843 - in pkg/xtsExtra: . R sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Sep 1 18:31:00 CEST 2014
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?
More information about the Xts-commits
mailing list