[Xts-commits] r805 - in pkg/xtsExtra: . R sandbox
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 3 23:07:29 CEST 2014
Author: rossbennett34
Date: 2014-07-03 23:07:28 +0200 (Thu, 03 Jul 2014)
New Revision: 805
Added:
pkg/xtsExtra/R/plot2.R
pkg/xtsExtra/R/utils.R
pkg/xtsExtra/sandbox/
pkg/xtsExtra/sandbox/test_plot2.R
Modified:
pkg/xtsExtra/
pkg/xtsExtra/.Rbuildignore
Log:
Adding prototype that roughly follows the quantmod::chart_Series approach
Property changes on: pkg/xtsExtra
___________________________________________________________________
Added: svn:ignore
+ .Rproj.user
.Rhistory
.RData
xtsExtra.Rproj
Modified: pkg/xtsExtra/.Rbuildignore
===================================================================
--- pkg/xtsExtra/.Rbuildignore 2014-05-17 21:03:47 UTC (rev 804)
+++ pkg/xtsExtra/.Rbuildignore 2014-07-03 21:07:28 UTC (rev 805)
@@ -18,3 +18,5 @@
man/indexClass\.Rd
man/stl\.xts\.Rd
man/xtsdf\.Rd
+^.*\.Rproj$
+^\.Rproj\.user$
Added: pkg/xtsExtra/R/plot2.R
===================================================================
--- pkg/xtsExtra/R/plot2.R (rev 0)
+++ pkg/xtsExtra/R/plot2.R 2014-07-03 21:07:28 UTC (rev 805)
@@ -0,0 +1,173 @@
+
+
+# Environment for our xts chart objects
+.plotxtsEnv <- new.env()
+
+new.chob <- function(frame=1, xlim=c(1,10), ylim=list(structure(c(1,10), fixed=FALSE))){
+ # This function is modeled after quantmod::new.replot
+ Env <- new.env()
+
+ # Not exactly sure what frame is doing
+ Env$frame <- frame
+ # Env$asp <- asp
+
+ # xlim should always remain constant and be used for each subsequent plot
+ Env$xlim <- xlim
+
+ # ylim is a list where
+ # ylim[[1]] --> data[[1]], ..., ylim[[n]] --> data[[n]]
+ Env$ylim <- ylim
+
+
+ Env$pad1 <- 0.25 # bottom padding per frame
+ Env$pad3 <- 0.25 # top padding per frame
+
+ ##### setters #####
+ # set_frame <- function(frame,clip=TRUE) {
+ # Env$frame <<- frame
+ # #set_window(clip) # change actual window
+ # }
+ 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_asp <- function(asp) { Env$asp }
+ get_xlim <- function(xlim) { Env$xlim }
+ get_ylim <- function(ylim) { Env$ylim }
+ get_pad <- function() c(Env$pad1,Env$pad3)
+
+ # 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, ...) {
+ 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
+ }
+
+ # create a new environment that contains Env as one of its elements
+ plotxts_env <- new.env()
+ class(plotxts_env) <- c("plotxts", "environment")
+ plotxts_env$Env <- Env
+
+ # add the setters to the plotxts_env environment
+ 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_asp <- get_asp
+ plotxts_env$get_xlim <- get_xlim
+ plotxts_env$get_ylim <- get_ylim
+ plotxts_env$get_pad <- get_pad
+
+ plotxts_env$add <- add
+ #plotxts_env$add_frame <- add_frame
+ #plotxts_env$update_frames <- update_frames
+ #plotxts_env$add_frame <- add_frame
+ #plotxts_env$next_frame <- next_frame
+ return(plotxts_env)
+}
+
+# get the current chart object
+current.chob <- function(){ invisible(get(".xts_chob", .plotxtsEnv)) }
+
+# obviously need a better function name here
+plot2_xts <- function(R, byColumn=FALSE, ...){
+ # this function is modeled after quantmod::chart_Series
+ # initialize a new chart object
+ cs <- new.chob()
+
+ # Env$R will hold the original returns object passed in
+ cs$Env$R <- R
+ cs$Env$byColumn <- byColumn
+
+ cs$set_xlim(c(1, NROW(cs$Env$R)))
+ cs$set_ylim(list(structure(range(na.omit(cs$Env$R)),fixed=FALSE)))
+
+ # We should also do stuff here to get a common x-axis to use for each panel
+ # 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
+ assign(".xts_chob", cs, .plotxtsEnv)
+ cs
+}
+
+# print/plot
+print.plotxts <- function(x, ...) plot.plotxts(x,...)
+plot.plotxts <- function(x, ...){
+
+ # Restore old par() options from what I change in here
+ old.par <- par()
+ on.exit(par(old.par))
+
+ 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
+ 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)){
+ 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)
+ }
+ 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)
+ }
+
+ # 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)
+ }
+ }
+}
+
+
Added: pkg/xtsExtra/R/utils.R
===================================================================
--- pkg/xtsExtra/R/utils.R (rev 0)
+++ pkg/xtsExtra/R/utils.R 2014-07-03 21:07:28 UTC (rev 805)
@@ -0,0 +1,65 @@
+
+modify.args <- function(formals, arglist, ..., dots=FALSE)
+{
+ # modify.args function from quantstrat
+
+ # avoid evaluating '...' to make things faster
+ dots.names <- eval(substitute(alist(...)))
+
+ if(missing(arglist))
+ arglist <- NULL
+ arglist <- c(arglist, dots.names)
+
+ # see 'S Programming' p. 67 for this matching
+
+ # nothing to do if arglist is empty; return formals
+ if(!length(arglist))
+ return(formals)
+
+ argnames <- names(arglist)
+ if(!is.list(arglist) && !is.null(argnames) && !any(argnames == ""))
+ stop("'arglist' must be a *named* list, with no names == \"\"")
+
+ .formals <- formals
+ onames <- names(.formals)
+
+ pm <- pmatch(argnames, onames, nomatch = 0L)
+ #if(any(pm == 0L))
+ # message(paste("some arguments stored for", fun, "do not match"))
+ names(arglist[pm > 0L]) <- onames[pm]
+ .formals[pm] <- arglist[pm > 0L]
+
+ # include all elements from arglist if function formals contain '...'
+ if(dots && !is.null(.formals$...)) {
+ dotnames <- names(arglist[pm == 0L])
+ .formals[dotnames] <- arglist[dotnames]
+ #.formals$... <- NULL # should we assume we matched them all?
+ }
+ .formals
+}
+
+# This is how it is used in quantstrat in applyIndicators()
+# # replace default function arguments with indicator$arguments
+# .formals <- formals(indicator$name)
+# .formals <- modify.args(.formals, indicator$arguments, dots=TRUE)
+# # now add arguments from parameters
+# .formals <- modify.args(.formals, parameters, dots=TRUE)
+# # now add dots
+# .formals <- modify.args(.formals, NULL, ..., dots=TRUE)
+# # remove ... to avoid matching multiple args
+# .formals$`...` <- NULL
+#
+# tmp_val <- do.call(indicator$name, .formals)
+
+
+###############################################################################
+# R (http://r-project.org/) Numeric Methods for Optimization of Portfolios
+#
+# Copyright (c) 2004-2014 Brian G. Peterson, Peter Carl, Ross Bennett, Kris Boudt
+#
+# This library is distributed under the terms of the GNU Public License (GPL)
+# for full details see the file COPYING
+#
+# $Id: utils.R 3302 2014-01-19 19:52:42Z braverock $
+#
+###############################################################################
Added: pkg/xtsExtra/sandbox/test_plot2.R
===================================================================
--- pkg/xtsExtra/sandbox/test_plot2.R (rev 0)
+++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-03 21:07:28 UTC (rev 805)
@@ -0,0 +1,47 @@
+
+
+
+data(edhec)
+R <- edhec[,1:5]
+
+
+chart.TimeSeries(R)
+plot2_xts(R)
+
+chart.TimeSeries(R, auto.grid=FALSE)
+plot2_xts(R, auto.grid=FALSE)
+
+chart.TimeSeries(R, minor.ticks=FALSE)
+plot2_xts(R, minor.ticks=FALSE)
+
+
+plot2_xts(R, byColumn=TRUE)
+title("Edhec Returns")
+
+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?
+
+# chart specification (i.e. the xts chob)
+
+# behaviors
+# default (similar to chart.TimeSeries)
+# small multiples
+# panels
+# chart specifications
+# - specifications for common charts (e.g. charts.PerformanceSummary)
+
+# what is he doing with frame and asp in chart_Series?
+# what are the following variables used ofr
+# frame
+# asp
+# clip
+
+# http://www.lemnica.com/esotericR/Introducing-Closures/
+
More information about the Xts-commits
mailing list