[Xts-commits] r806 - in pkg/xtsExtra: R sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jul 8 00:44:59 CEST 2014
Author: rossbennett34
Date: 2014-07-08 00:44:59 +0200 (Tue, 08 Jul 2014)
New Revision: 806
Modified:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/sandbox/test_plot2.R
Log:
Modifying the structure of the xts chob to work better with multiples and panels
Modified: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R 2014-07-03 21:07:28 UTC (rev 805)
+++ pkg/xtsExtra/R/plot2.R 2014-07-07 22:44:59 UTC (rev 806)
@@ -7,7 +7,7 @@
# This function is modeled after quantmod::new.replot
Env <- new.env()
- # Not exactly sure what frame is doing
+ # Not exactly sure what frame is doing or if I need it
Env$frame <- frame
# Env$asp <- asp
@@ -27,14 +27,14 @@
# Env$frame <<- frame
# #set_window(clip) # change actual window
# }
- set_frame <- function(frame) { Env$frame <<- frame }
+ # set_frame <- function(frame) { Env$frame <<- frame }
# set_asp <- function(asp) { Env$asp <<- asp }
set_xlim <- function(xlim) { Env$xlim <<- xlim }
set_ylim <- function(ylim) { Env$ylim <<- ylim }
set_pad <- function(pad) { Env$pad1 <<- pad[1]; Env$pad3 <<- pad[2] }
##### getters #####
- get_frame <- function(frame) { Env$frame }
+ # get_frame <- function(frame) { Env$frame }
# get_asp <- function(asp) { Env$asp }
get_xlim <- function(xlim) { Env$xlim }
get_ylim <- function(ylim) { Env$ylim }
@@ -43,15 +43,19 @@
# panels is a list where each element (i.e. slot) is what we want to evaluate
Env$panels <- list()
- # add an expression to Env$panels (i.e. Env$actions in quantmod)
- add <- function(x, env=Env, expr=FALSE, ...) {
+ # add an expression to Env$panels (i.e. similar to Env$actions in quantmod)
+ add <- function(x, env=Env, expr=FALSE, panel=NULL, ...) {
if(!expr) {
x <- match.call()$x
}
# each element in the Env$panels list is an object with "frame" and "env"
# as environments
- a <- structure(x, frame=Env$frame, env=env, ...)
- Env$panels[[length(Env$panels)+1]] <<- a
+ a <- structure(x, env=env, ...)
+ if(is.null(panel)){
+ Env$panels[[length(Env$panels)+1]] <<- a
+ } else {
+ Env$panels[[panel]] <<- a
+ }
}
# create a new environment that contains Env as one of its elements
@@ -60,14 +64,14 @@
plotxts_env$Env <- Env
# add the setters to the plotxts_env environment
- plotxts_env$set_frame <- set_frame
+ # plotxts_env$set_frame <- set_frame
# plotxts_env$set_asp <- set_asp
plotxts_env$set_xlim <- set_xlim
plotxts_env$set_ylim <- set_ylim
plotxts_env$set_pad <- set_pad
# add the getters to the plotxts_env environment
- plotxts_env$get_frame <- get_frame
+ # plotxts_env$get_frame <- get_frame
# plotxts_env$get_asp <- get_asp
plotxts_env$get_xlim <- get_xlim
plotxts_env$get_ylim <- get_ylim
@@ -101,13 +105,40 @@
# or chart to work with specifying multiples
# cs$set_xaxis()
- cs$set_frame(1)
# Default plot behavior
- # Can we just call chart.TimeSeries like this?
- # This is a temporary workaround for this prototype
- cs$Env$.formals <- formals(chart.TimeSeries)
- cs$Env$.formals <- modify.args(cs$Env$.formals, arglist=list(...), dots=TRUE)
- cs$Env$.formals$`...` <- NULL
+ # create a local environment to add the ...
+
+
+ if(isTRUE(byColumn)){
+ cnames <- colnames(R)
+ for(i in 1:NCOL(R)){
+ lenv <- new.env()
+ lenv$args <- formals(chart.TimeSeries)
+ lenv$args <- modify.args(lenv$args, R=R[,i], dots=TRUE)
+ lenv$args <- modify.args(lenv$args, arglist=list(...), dots=TRUE)
+ lenv$args$xaxis <- FALSE
+ lenv$args$ylim <- cs$Env$ylim[[1]]
+ lenv$args$main <- ""
+ lenv$args$ylab <- cnames[i]
+ # Plot the y axis on the right for even panels
+ if(i %% 2 == 0){
+ lenv$args$yaxis.right <- TRUE
+ } else {
+ lenv$args$yaxis.right <- FALSE
+ }
+ lenv$args$`...` <- NULL
+ cs$add(expression(do.call(chart.TimeSeries, args)), env=c(lenv, cs$Env), expr=TRUE)
+ }
+ } else {
+ lenv <- new.env()
+ lenv$args <- formals(chart.TimeSeries)
+ lenv$args <- modify.args(lenv$args, R=R, dots=TRUE)
+ lenv$args <- modify.args(lenv$args, arglist=list(...), dots=TRUE)
+ lenv$args$xaxis <- FALSE
+ lenv$args$`...` <- NULL
+ cs$add(expression(do.call(chart.TimeSeries, args)), env=c(lenv, cs$Env), expr=TRUE)
+ }
+
assign(".xts_chob", cs, .plotxtsEnv)
cs
}
@@ -117,57 +148,92 @@
plot.plotxts <- function(x, ...){
# Restore old par() options from what I change in here
- old.par <- par()
- on.exit(par(old.par))
+ # old.par <- par()
+ # on.exit(par(old.par))
- plot.new()
+ # plot.new()
# Here we assign x to the .plotxtsEnv
# x should have all of the data we need for plotting, layouts, etc
assign(".xts_chob", x, .plotxtsEnv)
- .formals <- x$Env$.formals
- R <- x$Env$R
+ # .formals <- x$Env$.formals
+ # R <- x$Env$R
pad1 <- x$Env$pad1
pad3 <- x$Env$pad3
- # This is an ugly hack to get the basic prototype working
- if(isTRUE(x$Env$byColumn)){
- layout(matrix(seq.int(from=1, to=NCOL(R), by=1L)), widths=1, heights=1)
- .formals$xaxis <- FALSE
- .formals$main <- ""
- .formals$ylim <- x$Env$ylim[[1]]
- for(i in 1:NCOL(R)){
+ par.list <- list(list(mar=c(pad1, 4, 2, 3)),
+ list(mar=c(pad1, 4, pad3, 3)),
+ list(mar=c(5, 4, pad3, 3)))
+
+ # Evaluate the expression in the Env$panels list
+ npanels <- length(x$Env$panels)
+
+ if(npanels > 1) {
+ do.call('par',par.list[[1]])
+ } else {
+ par(mar=c(5,4,4,2))
+ }
+
+ # set up the layout (should we also check if a layout has been passed in?)
+ if(npanels > 1){
+ # layout(matrix(1:x,x,1,byrow=TRUE), widths=1, heights=c(3,rep(1,x-2),1.60))
+ # this works for the default plotting case, but needs to be flexible so
+ # we can deal with the default multiples as well as panels
+ layout(matrix(1:npanels, npanels, 1, byrow=TRUE), widths=1, heights=1)
+ }
+
+ # Loop through the list in panels and evaluate each expression in its
+ # respective environment
+ for(i in 1:npanels){
+ if(npanels >= 1){
if(i == 1){
- # 0 margin on the bottom
- par(mar=c(pad1, 4, 4, 2))
- } else if(i == NCOL(R)){
- par(mar=c(5, 4, pad3, 2))
+ do.call('par', par.list[[1]])
+ } else if(i == npanels){
+ do.call('par', par.list[[3]])
} else {
- # 0 margin on the top and bottom
- par(mar=c(pad1, 4, pad3, 2))
+ do.call('par', par.list[[2]])
}
- .formals <- modify.args(.formals, R=R[,i], dots=TRUE)
- do.call(chart.TimeSeries, .formals)
}
- ep <- xtsExtra:::axTicksByTime(R)
- cex.axis = 1
- label.height = cex.axis *(.5 + apply(t(names(ep)),1, function(X) max(strheight(X, units="in")/par('cin')[2]) ))
- xaxis.labels = names(ep)
- axis(1, at=ep, labels=xaxis.labels, las=1, lwd=1, mgp=c(3,label.height,0))
- } else {
- .formals <- modify.args(.formals, R=R, dots=TRUE)
- do.call(chart.TimeSeries, .formals)
+ aob <- x$Env$panels[[i]]
+ env <- attr(aob, "env")
+ if(is.list(env)) {
+ # if env is c(lenv, Env), convert to list
+ env <- unlist(lapply(env, function(x) eapply(x, eval)), recursive=FALSE)
+ }
+ eval(aob, env)
}
- # Evaluate the expression in the Env$panels list
- npanels <- length(x$Env$panels)
- if(npanels > 0){
- for(i in 1:npanels){
- env <- attr(x$Env$panels[[i]], "env")
- eval(x$Env$panels[[i]], env)
- }
- }
+ # add the x-axis at the very end here
+ ep <- xtsExtra:::axTicksByTime(x$Env$R)
+ cex.axis <- 0.8
+ label.height <- cex.axis *(.5 + apply(t(names(ep)),1, function(X) max(strheight(X, units="in")/par('cin')[2]) ))
+ xaxis.labels <- names(ep)
+ axis(1, at=ep, labels=xaxis.labels, las=1, lwd=1, mgp=c(3,label.height,0))
+ layout(1)
}
+# This is an ugly hack to get the basic prototype working
+# if(isTRUE(x$Env$byColumn)){
+# layout(matrix(seq.int(from=1, to=NCOL(R), by=1L)), widths=1, heights=1)
+# .formals$xaxis <- FALSE
+# .formals$main <- ""
+# .formals$ylim <- x$Env$ylim[[1]]
+# for(i in 1:NCOL(R)){
+# if(i == 1){
+# # 0 margin on the bottom
+# par(mar=c(pad1, 4, 4, 2))
+# } else if(i == NCOL(R)){
+# par(mar=c(5, 4, pad3, 2))
+# } else {
+# # 0 margin on the top and bottom
+# par(mar=c(pad1, 4, pad3, 2))
+# }
+# .formals <- modify.args(.formals, R=R[,i], dots=TRUE)
+# do.call(chart.TimeSeries, .formals)
+# }
+# } else {
+# .formals <- modify.args(.formals, R=R, dots=TRUE)
+# do.call(chart.TimeSeries, .formals)
+# }
Modified: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-03 21:07:28 UTC (rev 805)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-07 22:44:59 UTC (rev 806)
@@ -18,12 +18,13 @@
plot2_xts(R, byColumn=TRUE)
title("Edhec Returns")
+charts.TimeSeries(R)
+
x <- current.chob()
# Get the structure of the environments
ls.str(x)
ls.str(x$Env)
-
##### scratch area #####
# Should we have a theme object 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