From noreply at r-forge.r-project.org Thu Jul 3 23:07:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Jul 2014 23:07:29 +0200 (CEST) Subject: [Xts-commits] r805 - in pkg/xtsExtra: . R sandbox Message-ID: <20140703210729.55D7118747C@r-forge.r-project.org> 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/ + From noreply at r-forge.r-project.org Tue Jul 8 00:44:59 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Jul 2014 00:44:59 +0200 (CEST) Subject: [Xts-commits] r806 - in pkg/xtsExtra: R sandbox Message-ID: <20140707224459.C82A018473D@r-forge.r-project.org> 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? From noreply at r-forge.r-project.org Wed Jul 9 01:09:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Jul 2014 01:09:41 +0200 (CEST) Subject: [Xts-commits] r807 - in pkg/xtsExtra: R sandbox Message-ID: <20140708230941.A403818061F@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-09 01:09:41 +0200 (Wed, 09 Jul 2014) New Revision: 807 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: Adding prototype for layouts and panels Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-07 22:44:59 UTC (rev 806) +++ pkg/xtsExtra/R/plot2.R 2014-07-08 23:09:41 UTC (rev 807) @@ -89,7 +89,10 @@ current.chob <- function(){ invisible(get(".xts_chob", .plotxtsEnv)) } # obviously need a better function name here -plot2_xts <- function(R, byColumn=FALSE, ...){ +#' @param xts object of returns +#' @param byColumn +#' @param layout a layout specification created with \code{\link{chartLayout}} +plot2_xts <- function(R, panels=NULL, byColumn=FALSE, layout=NULL, ...){ # this function is modeled after quantmod::chart_Series # initialize a new chart object cs <- new.chob() @@ -97,7 +100,9 @@ # Env$R will hold the original returns object passed in cs$Env$R <- R cs$Env$byColumn <- byColumn + cs$Env$layout <- layout + cs$set_xlim(c(1, NROW(cs$Env$R))) cs$set_ylim(list(structure(range(na.omit(cs$Env$R)),fixed=FALSE))) @@ -108,10 +113,12 @@ # Default plot behavior # create a local environment to add the ... - + # the main plot will be added as an expression to Env$panels if(isTRUE(byColumn)){ cnames <- colnames(R) for(i in 1:NCOL(R)){ + # create a local environment to add the args for chart.TimeSeries and + # add as an expression lenv <- new.env() lenv$args <- formals(chart.TimeSeries) lenv$args <- modify.args(lenv$args, R=R[,i], dots=TRUE) @@ -130,6 +137,7 @@ cs$add(expression(do.call(chart.TimeSeries, args)), env=c(lenv, cs$Env), expr=TRUE) } } else { + # create a local environment to add the args for chart.TimeSeries lenv <- new.env() lenv$args <- formals(chart.TimeSeries) lenv$args <- modify.args(lenv$args, R=R, dots=TRUE) @@ -148,8 +156,8 @@ 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(c("mar", "oma")) + on.exit(par(old.par)) # plot.new() @@ -162,34 +170,37 @@ pad1 <- x$Env$pad1 pad3 <- x$Env$pad3 - par.list <- list(list(mar=c(pad1, 4, 2, 3)), + par.list <- list(list(mar=c(pad1, 4, pad3, 3), oma=c(3.5, 0, 4, 0)), list(mar=c(pad1, 4, pad3, 3)), - list(mar=c(5, 4, pad3, 3))) + list(mar=c(pad1, 4, pad3, 3))) - # Evaluate the expression in the Env$panels list + # Set the layout based on the number of panels or layout object npanels <- length(x$Env$panels) + equal.heights <- ifelse(isTRUE(x$Env$byColumn), TRUE, FALSE) + if(is.null(x$Env$layout)){ + cl <- updateLayout(npanels, equal.heights) + } else { + # The user has passed in something for layout + if(!inherits(x$Env$layout, "chart.layout")){ + cl <- updateLayout(npanels, equal.heights) + } else { + cl <- x$Env$layout + } + } + do.call(layout, cl) if(npanels > 1) { - do.call('par',par.list[[1]]) + do.call(par, par.list[[1]]) } else { - par(mar=c(5,4,4,2)) + # Use the default + par(mar=c(5,4,4,2)+0.1) } - # 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){ - do.call('par', par.list[[1]]) - } else if(i == npanels){ + if(npanels > 1){ + if(i == npanels){ do.call('par', par.list[[3]]) } else { do.call('par', par.list[[2]]) @@ -205,35 +216,62 @@ } # add the x-axis at the very end here + # We should functionalize this and provide for different options to plot + # the x-axis as in quantmod or as in chart.TimeSeries 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]) )) + label.height <- cex.axis * (0.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) + axis(1, at=ep, labels=xaxis.labels, las=1, lwd=1, mgp=c(3, label.height, 0)) + + # reset the layout + layout(matrix(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) -# } +# layout functions modeled after quantmod +chartLayout <- function(mat, widths, heights){ + structure(list(mat=mat, + widths=widths, + heights=heights), + class="chart.layout") +} +updateLayout <- function(x, equal.heights=FALSE){ + # x : number of panels + if(x==1) { + mat <- matrix(1) + wd <- 1 + ht <- 1 + } else { + mat <- matrix(1:x, x, 1, byrow=TRUE) + wd <- 1 + if(equal.heights){ + ht <- 1 + } else { + # ht <- c(3,rep(1,x-2),1.60) + ht <- c(3,rep(1,x-2),1) + } + } + chartLayout(mat, wd, ht) +} + +addDrawdowns <- function(geometric=TRUE, ...){ + lenv <- new.env() + lenv$plot_drawdowns <- function(x, geometric, ...) { + xdata <- x$Env$R + drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric) + chart.TimeSeries(drawdowns, ..., xaxis=FALSE, main="") + } + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(geometric=geometric, ...)), + list(geometric=geometric, ...)) + exp <- parse(text=gsub("list","plot_drawdowns", + as.expression(substitute(list(x=current.chob(), + geometric=geometric, ...)))), + srcfile=NULL) + plot_object <- current.chob() + plot_object$add(exp, env=c(lenv, plot_object$Env), expr=TRUE) + plot_object +} + + Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-07 22:44:59 UTC (rev 806) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-08 23:09:41 UTC (rev 807) @@ -6,28 +6,41 @@ chart.TimeSeries(R) + +# The main title gets messed up when adding panels plot2_xts(R) +x <- current.chob() +ls.str(x) +ls.str(x$Env) +addDrawdowns() +addDrawdowns() +x <- current.chob() +ls.str(x) +ls.str(x$Env) + + chart.TimeSeries(R, auto.grid=FALSE) plot2_xts(R, auto.grid=FALSE) -chart.TimeSeries(R, minor.ticks=FALSE) -plot2_xts(R, minor.ticks=FALSE) - +charts.TimeSeries(R) plot2_xts(R, byColumn=TRUE) title("Edhec Returns") -charts.TimeSeries(R) +cl <- chartLayout(matrix(1:5), 1, c(2,2,1,1,1)) +plot2_xts(R, byColumn=TRUE, layout=cl) +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? +# 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? # chart specification (i.e. the xts chob) @@ -39,7 +52,7 @@ # - 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 +# what are the following variables used for # frame # asp # clip From noreply at r-forge.r-project.org Thu Jul 10 01:34:56 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 10 Jul 2014 01:34:56 +0200 (CEST) Subject: [Xts-commits] r808 - pkg/xtsExtra/R Message-ID: <20140709233456.4443E187554@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-10 01:34:55 +0200 (Thu, 10 Jul 2014) New Revision: 808 Added: pkg/xtsExtra/R/replot_xts.R Modified: pkg/xtsExtra/R/plot2.R Log: Modifying plot2_xts based more closely on replot and chart_Series in quantmod Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-08 23:09:41 UTC (rev 807) +++ pkg/xtsExtra/R/plot2.R 2014-07-09 23:34:55 UTC (rev 808) @@ -1,277 +1,335 @@ - # 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() +current.chob <- function() invisible(get(".xts_chob",.plotxtsEnv)) + +# based on quantmod R/chart_Series.R + +# chart_pars {{{ +chart_pars <- function() { + list(cex=0.6, mar=c(3,1,0,1)) +} # }}} + +chart.lines <- function(x, colorset=1:12){ + for(i in 1:NCOL(x)) + lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1) +} + +# chart_Series {{{ +# Updated: 2010-01-15 +# +# chart_Series now uses a new graphical extension +# called 'replot'. This enables the accumulation +# of 'actions', in the form of (unevaluated) R +# expressions, to be stored within a replot object. +# This object is an R closure, which contains +# all the methods which are needed to perform +# graphical operations. +# +# Ideally all behavior is consistent with the +# original quantmod:::chartSeries, except the +# undesireable ones. +# +# chart_Series <- function(x, +# name=deparse(substitute(x)), +# type="candlesticks", +# subset="", +# TA="", +# pars=chart_pars(), theme=chart_theme(), +# clev=0, +# ...) + +xtsExtraTheme <- function(){ + theme <-list(col=list(bg="#FFFFFF", + label.bg="#F0F0F0", + grid="#F0F0F0", + grid2="#F5F5F5", + ticks="#999999", + labels="#333333", + line.col="darkorange", + dn.col="red", + up.col=NA, + dn.border="#333333", + up.border="#333333"), + shading=1, + format.labels=TRUE, + coarse.time=TRUE, + rylab=TRUE, + lylab=TRUE, + grid.ticks.lwd=1, + grid.ticks.on="months") + theme +} + +plot2_xts <- function(x, + name=deparse(substitute(x)), + subset="", + clev=0, + pars=chart_pars(), theme=xtsExtraTheme(), + ...){ + cs <- new.replot_xts() + #cex <- pars$cex + #mar <- pars$mar + line.col <- theme$col$line.col + up.col <- theme$col$up.col + dn.col <- theme$col$dn.col + up.border <- theme$col$up.border + dn.border <- theme$col$dn.border + format.labels <- theme$format.labels + if(is.null(theme$grid.ticks.on)) { + xs <- x[subset] + major.grid <- c(years=nyears(xs), + months=nmonths(xs), + days=ndays(xs)) + grid.ticks.on <- names(major.grid)[rev(which(major.grid < 30))[1]] + } else grid.ticks.on <- theme$grid.ticks.on + label.bg <- theme$col$label.bg - # Not exactly sure what frame is doing or if I need it - 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. similar to Env$actions in quantmod) - add <- function(x, env=Env, expr=FALSE, panel=NULL, ...) { - if(!expr) { - x <- match.call()$x + # define a subset function + cs$subset <- function(x) { + if(FALSE) {set_ylim <- get_ylim <- set_xlim <- Env <-function(){} } # appease R parser? + if(missing(x)) { + x <- "" #1:NROW(Env$xdata) } - # each element in the Env$panels list is an object with "frame" and "env" - # as environments - a <- structure(x, env=env, ...) - if(is.null(panel)){ - Env$panels[[length(Env$panels)+1]] <<- a - } else { - Env$panels[[panel]] <<- a + Env$xsubset <<- x + set_xlim(c(1,NROW(Env$xdata[Env$xsubset]))) + ylim <- get_ylim() + for(y in seq(2,length(ylim),by=2)) { + if(!attr(ylim[[y]],'fixed')) + ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE) } + lapply(Env$actions, + function(x) { + frame <- abs(attr(x, "frame")) + fixed <- attr(ylim[[frame]],'fixed') + #fixed <- attr(x, "fixed") + if(frame %% 2 == 0 && !fixed) { + lenv <- attr(x,"env") + if(is.list(lenv)) lenv <- lenv[[1]] + min.tmp <- min(ylim[[frame]][1],range(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) + ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed) + } + }) + # reset all ylim values, by looking for range(env[[1]]$xdata) + # xdata should be either coming from Env or if lenv, lenv + set_ylim(ylim) } + environment(cs$subset) <- environment(cs$get_asp) + if(is.character(x)) + stop("'x' must be a time-series object") - # 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 + # If we detect an OHLC object, we should call quantmod::chart_Series + #if(is.OHLC(x)) { + # cs$Env$xdata <- OHLC(x) + # if(has.Vo(x)) + # cs$Env$vo <- Vo(x) + #} else - # 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 + cs$Env$xdata <- x + #subset <- match(.index(x[subset]), .index(x)) + cs$Env$xsubset <- subset + cs$Env$cex <- pars$cex + cs$Env$mar <- pars$mar + cs$set_asp(3) + cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) + cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE))) + cs$set_frame(1,FALSE) + cs$Env$clev = min(clev+0.01,1) # (0,1] + cs$Env$theme$bbands <- theme$bbands + cs$Env$theme$shading <- theme$shading + cs$Env$theme$line.col <- theme$col$line.col + cs$Env$theme$up.col <- up.col + cs$Env$theme$dn.col <- dn.col + cs$Env$theme$up.border <- up.border + cs$Env$theme$dn.border <- dn.border + cs$Env$theme$rylab <- theme$rylab + cs$Env$theme$lylab <- theme$lylab + cs$Env$theme$bg <- theme$col$bg + cs$Env$theme$grid <- theme$col$grid + cs$Env$theme$grid2 <- theme$col$grid2 + cs$Env$theme$labels <- "#333333" + cs$Env$theme$label.bg <- label.bg + cs$Env$format.labels <- format.labels + cs$Env$ticks.on <- grid.ticks.on + cs$Env$grid.ticks.lwd <- theme$grid.ticks.lwd + #cs$Env$type <- type - # 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 -#' @param xts object of returns -#' @param byColumn -#' @param layout a layout specification created with \code{\link{chartLayout}} -plot2_xts <- function(R, panels=NULL, byColumn=FALSE, layout=NULL, ...){ - # 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$Env$layout <- layout - - - 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() - - # Default plot behavior - # create a local environment to add the ... - - # the main plot will be added as an expression to Env$panels - if(isTRUE(byColumn)){ - cnames <- colnames(R) - for(i in 1:NCOL(R)){ - # create a local environment to add the args for chart.TimeSeries and - # add as an expression - 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) + # axis_ticks function to label lower frequency ranges/grid lines + cs$Env$axis_ticks <- function(xdata,xsubset) { + ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 + + last(axTicksByTime2(xdata[xsubset],labels=TRUE),-1) + if(!theme$coarse.time || length(ticks) == 1) + return(unname(ticks)) + if(min(diff(ticks)) < max(strwidth(names(ticks)))) { + ticks <- unname(ticks) } - } else { - # create a local environment to add the args for chart.TimeSeries - 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) + ticks } + # need to add if(upper.x.label) to allow for finer control + cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(atbt, #axTicksByTime2(xdata[xsubset]), + get_ylim()[[2]][1], + atbt, #axTicksByTime2(xdata[xsubset]), + get_ylim()[[2]][2], col=theme$grid, lwd=grid.ticks.lwd), + axt <- axis_ticks(xdata,xsubset), + text(as.numeric(axt), + par('usr')[3]-0.2*min(strheight(axt)), + names(axt),xpd=TRUE,cex=0.9,pos=3)), + clip=FALSE,expr=TRUE) + cs$set_frame(-1) + # background of main window + #cs$add(expression(rect(par("usr")[1], + # par("usr")[3], + # par("usr")[2], + # par("usr")[4],border=NA,col=theme$bg)),expr=TRUE) + cs$add_frame(0,ylim=c(0,1),asp=0.2) + cs$set_frame(1) - assign(".xts_chob", cs, .plotxtsEnv) - cs -} - -# print/plot -print.plotxts <- function(x, ...) plot.plotxts(x,...) -plot.plotxts <- function(x, ...){ + # 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) - # Restore old par() options from what I change in here - old.par <- par(c("mar", "oma")) - on.exit(par(old.par)) + # add "month" or "month.abb" + cs$add(expression(axt <- axTicksByTime(xdata[xsubset],format.labels=format.labels), + axis(1,at=axt, #axTicksByTime(xdata[xsubset]), + labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)), + las=1,lwd.ticks=1,mgp=c(3,1.5,0),tcl=-0.4,cex.axis=.9)), + expr=TRUE) + cs$Env$name <- name + text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)), + expression(text(NROW(xdata[xsubset]),0.5, + paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), + col=1,adj=c(0,0),pos=2))) + cs$add(text.exp, env=cs$Env, expr=TRUE) + cs$set_frame(2) - # plot.new() + cs$Env$axis_labels <- function(xdata,xsubset,scale=5) { + axTicksByValue(na.omit(xdata[xsubset])) + } + cs$Env$make_pretty_labels <- function(ylim) { + p <- pretty(ylim,10) + p[p > ylim[1] & p < ylim[2]] + } + #cs$add(assign("five",rnorm(10))) # this gets re-evaled each update, though only to test + #cs$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE) + #cs$add(expression(assign("alabels", pretty(range(xdata[xsubset],na.rm=TRUE)))),expr=TRUE) + #cs$add(expression(assign("alabels", pretty(get_ylim(get_frame())[[2]],10))),expr=TRUE) + cs$add(expression(assign("alabels", make_pretty_labels(get_ylim(get_frame())[[2]]))),expr=TRUE) - # 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) + # add $1 grid lines if appropriate + #cs$set_frame(-2) - # .formals <- x$Env$.formals - # R <- x$Env$R - pad1 <- x$Env$pad1 - pad3 <- x$Env$pad3 + # add minor y-grid lines + #cs$add(expression(if(diff(range(xdata[xsubset],na.rm=TRUE)) < 50) + # segments(1,seq(min(xdata[xsubset]%/%1,na.rm=TRUE), + # max(xdata[xsubset]%/%1,na.rm=TRUE),1), + # length(xsubset), + # seq(min(xdata[xsubset]%/%1,na.rm=TRUE), + # max(xdata[xsubset]%/%1,na.rm=TRUE),1), + # col=theme$grid2, lty="dotted")), expr=TRUE) - par.list <- list(list(mar=c(pad1, 4, pad3, 3), oma=c(3.5, 0, 4, 0)), - list(mar=c(pad1, 4, pad3, 3)), - list(mar=c(pad1, 4, pad3, 3))) + cs$set_frame(2) + # add main y-grid lines + cs$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE) - # Set the layout based on the number of panels or layout object - npanels <- length(x$Env$panels) - equal.heights <- ifelse(isTRUE(x$Env$byColumn), TRUE, FALSE) - if(is.null(x$Env$layout)){ - cl <- updateLayout(npanels, equal.heights) - } else { - # The user has passed in something for layout - if(!inherits(x$Env$layout, "chart.layout")){ - cl <- updateLayout(npanels, equal.heights) - } else { - cl <- x$Env$layout - } + # left axis labels + if(theme$lylab) { + cs$add(expression(text(1-1/3-max(strwidth(alabels)), + alabels, #axis_labels(xdata,xsubset), + noquote(format(alabels,justify="right")), + col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE) } - do.call(layout, cl) - if(npanels > 1) { - do.call(par, par.list[[1]]) - } else { - # Use the default - par(mar=c(5,4,4,2)+0.1) + # right axis labels + if(theme$rylab) { + cs$add(expression(text(NROW(xdata[xsubset])+1/3, + alabels, + noquote(format(alabels,justify="right")), + col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE) } - # Loop through the list in panels and evaluate each expression in its - # respective environment - for(i in 1:npanels){ - if(npanels > 1){ - if(i == npanels){ - do.call('par', par.list[[3]]) - } else { - do.call('par', par.list[[2]]) - } - } - 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) - } + # add main series + cs$set_frame(2) + cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) + assign(".xts_chob", cs, .plotxtsEnv) - # add the x-axis at the very end here - # We should functionalize this and provide for different options to plot - # the x-axis as in quantmod or as in chart.TimeSeries - ep <- xtsExtra:::axTicksByTime(x$Env$R) - cex.axis <- 0.8 - label.height <- cex.axis * (0.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)) + # handle TA="add_Vo()" as we would interactively FIXME: allow TA=NULL to work + #if(!is.null(TA) && nchar(TA) > 0) { + # TA <- parse(text=TA, srcfile=NULL) + # for( ta in 1:length(TA)) { + # if(length(TA[ta][[1]][-1]) > 0) { + # cs <- eval(TA[ta]) + # } else { + # cs <- eval(TA[ta]) + # } + # } + #} - # reset the layout - layout(matrix(1)) -} + assign(".xts_chob", cs, .plotxtsEnv) + cs +} #}}} -# layout functions modeled after quantmod -chartLayout <- function(mat, widths, heights){ - structure(list(mat=mat, - widths=widths, - heights=heights), - class="chart.layout") -} - -updateLayout <- function(x, equal.heights=FALSE){ - # x : number of panels - if(x==1) { - mat <- matrix(1) - wd <- 1 - ht <- 1 - } else { - mat <- matrix(1:x, x, 1, byrow=TRUE) - wd <- 1 - if(equal.heights){ - ht <- 1 - } else { - # ht <- c(3,rep(1,x-2),1.60) - ht <- c(3,rep(1,x-2),1) - } - } - chartLayout(mat, wd, ht) -} - addDrawdowns <- function(geometric=TRUE, ...){ + # added in wilder=TRUE to handle missingness behavior in original TTR::RSI call lenv <- new.env() lenv$plot_drawdowns <- function(x, geometric, ...) { - xdata <- x$Env$R - drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric) - chart.TimeSeries(drawdowns, ..., xaxis=FALSE, main="") + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] + x.pos <- 1:NROW(drawdowns) + #theme <- x$Env$theme$rsi + # vertical grid lines + #segments(axTicksByTime2(xdata[xsubset]), + # par("usr")[3], #min(-10,range(na.omit(macd))[1]), + # axTicksByTime2(xdata[xsubset]), + # par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid) + # col=x$Env$theme$grid) + chart.lines(drawdowns) } mapply(function(name,value) { assign(name,value,envir=lenv) }, - names(list(geometric=geometric, ...)), - list(geometric=geometric, ...)) + names(list(geometric=geometric,...)), + list(geometric=geometric,...)) exp <- parse(text=gsub("list","plot_drawdowns", as.expression(substitute(list(x=current.chob(), - geometric=geometric, ...)))), + geometric=geometric,...)))), srcfile=NULL) + plot_object <- current.chob() - plot_object$add(exp, env=c(lenv, plot_object$Env), expr=TRUE) + xsubset <- plot_object$Env$xsubset + drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) + print(drawdowns) + print(range(drawdowns)) + plot_object$add_frame(ylim=c(0,1),asp=0.2) + plot_object$next_frame() + lenv$xdata <- drawdowns #structure(drawdowns,.Dimnames=list(NULL, "drawdowns")) + #text.exp <- expression(text(c(1, + # 1+strwidth(paste("RSI(",n,"):",sep=""))), + # 0.3, + # c(paste("RSI(",n,"):",sep=""), + # round(last(xdata[xsubset]),5)), + # col=c(1,theme$rsi$col$rsi),adj=c(0,0),cex=0.9,offset=0,pos=4)) + #plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE) + #plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) + + #plot_object$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) + plot_object$add_frame(ylim=range(drawdowns),asp=1,fixed=TRUE) + plot_object$next_frame() + + # add grid lines + #lenv$grid_lines <- function(xdata,x) { c(RSIdn,RSIup) } + # add grid lines + #exp <- c(expression(segments(1, grid_lines(xdata,xsubset), + # NROW(xdata[xsubset]), grid_lines(xdata,xsubset), col=theme$grid)),exp, + # 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)), + # 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))) + plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE) plot_object } - Added: pkg/xtsExtra/R/replot_xts.R =================================================================== --- pkg/xtsExtra/R/replot_xts.R (rev 0) +++ pkg/xtsExtra/R/replot_xts.R 2014-07-09 23:34:55 UTC (rev 808) @@ -0,0 +1,284 @@ + +# R/replot.R in quantmod with only minor edits to change class name to +# replot_xts and use the .plotxtsEnv instead of the .plotEnv in quantmod + +# replot {{{ +new.replot_xts <- function(frame=1,asp=1,xlim=c(1,10),ylim=list(structure(c(1,10),fixed=FALSE))) { + # global variables + Env <- new.env() + Env$frame <- frame + Env$asp <- asp + #Env$usr <- par("usr") + Env$xlim <- xlim + Env$ylim <- ylim + Env$pad1 <- -0 # bottom padding per frame + Env$pad3 <- 0 # top padding per frame + if(length(asp) != length(ylim)) + stop("'ylim' and 'asp' must be the same length") + + + # setters + set_frame <- function(frame,clip=TRUE) { + Env$frame <<- frame; + set_window(clip); # change actual window + } + 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] } + reset_ylim <- function() { + ylim <- get_ylim() + ylim <- rep(list(c(Inf,-Inf)),length(ylim)) + #ylim[[1]] <- range(OHLC(Env$xdata)[x]) # main data + lapply(Env$actions, + function(x) { + frame <- attr(x, "frame") + if(frame > 0) { + lenv <- attr(x,"env") + if(is.list(lenv)) lenv <- lenv[[1]] + ylim[[frame]][1] <<- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE) + ylim[[frame]][2] <<- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE) + } + }) + # reset all ylim values, by looking for range(env[[1]]$xdata) + # xdata should be either coming from Env or if lenv lenv + set_ylim(ylim) + } + + # 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) + + # scale ylim based on current frame, and asp values + scale_ranges <- function(frame, asp, ranges) + { + asp/asp[frame] * abs(diff(ranges[[frame]])) + } + # set_window prepares window for drawing + set_window <- function(clip=TRUE,set=TRUE) + { + frame <- Env$frame + frame <- abs(frame) + asp <- Env$asp + xlim <- Env$xlim + ylim <- lapply(Env$ylim, function(x) structure(x + (diff(x) * c(Env$pad1, Env$pad3)),fixed=attr(x,"fixed"))) + sr <- scale_ranges(frame, asp, ylim) + if(frame == 1) { + win <- list(xlim, c((ylim[[frame]][1] - sum(sr[-1])), ylim[[frame]][2])) + } else + if(frame == length(ylim)) { + win <- list(xlim, c(ylim[[frame]][1], ylim[[frame]][2] + sum(sr[-length(sr)]))) + } else { + win <- list(xlim, c(ylim[[frame]][1] - sum(sr[-(1:frame)]), + ylim[[frame]][2] + sum(sr[-(frame:length(sr))]))) + } + if(!set) return(win) + do.call("plot.window",win) + if(clip) clip(par("usr")[1],par("usr")[2],ylim[[frame]][1],ylim[[frame]][2]) + } + + get_actions <- function(frame) { + actions <- NULL + for(i in 1:length(Env$actions)) { + if(abs(attr(Env$actions[[i]],"frame"))==frame) + actions <- c(actions, Env$actions[i]) + } + actions + } + + # add_frame: + # append a plot frame to the plot window + add_frame <- function(after, ylim=c(0,0), asp=0, fixed=FALSE) { + if(missing(after)) + after <- max(abs(sapply(Env$actions, function(x) attr(x,"frame")))) + for(i in 1:length(Env$actions)) { + cframe <- attr(Env$actions[[i]],"frame") + if(cframe > 0 && cframe > after) + attr(Env$actions[[i]], "frame") <- cframe+1L + if(cframe < 0 && cframe < -after) + attr(Env$actions[[i]], "frame") <- cframe-1L + } + Env$ylim <- append(Env$ylim,list(structure(ylim,fixed=fixed)),after) + Env$asp <- append(Env$asp,asp,after) + } + update_frames <- function(headers=TRUE) { + # use subset code here, without the subset part. + from_by <- ifelse(headers,2,1) + ylim <- get_ylim() + for(y in seq(from_by,length(ylim),by=from_by)) { + if(!attr(ylim[[y]],'fixed')) + ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE) + } + lapply(Env$actions, + function(x) { + if(!is.null(attr(x,"no.update")) && attr(x, "no.update")) + return(NULL) + frame <- abs(attr(x, "frame")) + fixed <- attr(ylim[[frame]],'fixed') + #fixed <- attr(x, "fixed") + if(frame %% from_by == 0 && !fixed) { + lenv <- attr(x,"env") + if(is.list(lenv)) lenv <- lenv[[1]] + dat.range <- range(na.omit(lenv$xdata[Env$xsubset])) + min.tmp <- min(ylim[[frame]][1],dat.range,na.rm=TRUE) + max.tmp <- max(ylim[[frame]][2],dat.range,na.rm=TRUE) + ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed) + } + }) + # reset all ylim values, by looking for range(env[[1]]$xdata) + # xdata should be either coming from Env or if lenv, lenv + set_ylim(ylim) + } + remove_frame <- function(frame) { + rm.frames <- NULL + max.frame <- max(abs(sapply(Env$actions, function(x) attr(x,"frame")))) + for(i in 1:length(Env$actions)) { + cframe <- attr(Env$actions[[i]],"frame") + if(abs(attr(Env$actions[[i]],"frame"))==frame) + rm.frames <- c(rm.frames, i) + if(cframe > 0 && cframe > frame) { + attr(Env$actions[[i]], "frame") <- cframe-1L + } + if(cframe < 0 && cframe < -frame) { + attr(Env$actions[[i]], "frame") <- cframe+1L + } + } + if(frame > max.frame) { + Env$frame <- max.frame + } else Env$frame <- max.frame-1 + Env$ylim <- Env$ylim[-frame] + Env$asp <- Env$asp[-frame] + if(!is.null(rm.frames)) + Env$actions <- Env$actions[-rm.frames] + } + next_frame <- function() { + set_frame(max(abs(sapply(Env$actions,function(x) attr(x,"frame"))))+1L) + } + move_frame <- function() {} + + # actions + Env$actions <- list() + + # aplot + add <- replot <- function(x,env=Env,expr=FALSE,clip=TRUE,...) { + if(!expr) { + x <- match.call()$x + } + a <- structure(x,frame=Env$frame,clip=clip,env=env,...) + Env$actions[[length(Env$actions)+1]] <<- a + } + + # prepare window to draw + #set_window() + # return + replot_env <- new.env() + class(replot_env) <- c("replot_xts","environment") + replot_env$Env <- Env + replot_env$set_window <- set_window + replot_env$add <- add + replot_env$replot <- replot + replot_env$get_actions <- get_actions + replot_env$subset <- subset + replot_env$update_frames <- update_frames + replot_env$set_frame <- set_frame + replot_env$get_frame <- get_frame + replot_env$next_frame <- next_frame + replot_env$add_frame <- add_frame + replot_env$remove_frame <- remove_frame + replot_env$set_asp <- set_asp + replot_env$get_asp <- get_asp + replot_env$set_xlim <- set_xlim + replot_env$get_xlim <- get_xlim + replot_env$reset_ylim <- reset_ylim + replot_env$set_ylim <- set_ylim + replot_env$get_ylim <- get_ylim + replot_env$set_pad <- set_pad + return(replot_env) +} # }}} + +str.replot_xts <- function(x, ...) { + print(str(unclass(x))) +} + +# print/plot replot methods {{{ +print.replot_xts <- function(x, ...) plot(x,...) +plot.replot_xts <- function(x, ...) { + plot.new() + #assign(".chob",x,.GlobalEnv) + assign(".xts_chob",x,.plotxtsEnv) + cex <- par(cex=x$Env$cex) + mar <- par(mar=x$Env$mar) + if(.Device=="X11") # only reasonable way to fix X11/quartz issue + par(cex=x$Env$cex * 1.5) + oxpd <- par(xpd=FALSE) + usr <- par("usr") + # plot negative (underlay) actions + last.frame <- x$get_frame() + x$update_frames() + lapply(x$Env$actions, + function(aob) { + if(attr(aob,"frame") < 0) { + x$set_frame(attr(aob,"frame"),attr(aob,"clip")) + env <- attr(aob,"env") + if(is.list(env)) { + # if env is c(env, Env), convert to list + env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE) + } + eval(aob, env) + } + } + ) + # plot positive (overlay) actions + lapply(x$Env$actions, + function(aob) { + if(attr(aob,"frame") > 0) { + x$set_frame(attr(aob,"frame"),attr(aob,"clip")) + env <- attr(aob,"env") + if(is.list(env)) { + env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE) + } + eval(aob, env) + } + } + ) + #for(frames in 1:length(x$get_ylim())) { + #x$set_frame(frames) + #abline(h=x$get_ylim()[[frames]][1], col=x$Env$theme$grid, lwd=1) + #} + x$set_frame(abs(last.frame),clip=FALSE) + do.call("clip",as.list(usr)) + par(xpd=oxpd,cex=cex$cex,mar=mar$mar)#,usr=usr) + invisible(x$Env$actions) +} # }}} + +# scale.ranges {{{ +scale.ranges <- function(frame, asp, ranges) +{ + asp/asp[frame] * abs(diff(ranges[[frame]])) +} # }}} + +`+.replot` <- function(e1, e2) { + e2 <- match.call()$e2 + e2$plot_object <- (substitute(e1)) + eval(e2) +} + +`+.replot` <- function(e1, e2) { + assign(".xts_chob",e1,.plotxtsEnv) + e2 <- eval(e2) + e2 +} + + +##### accessor functions + +re_Chart <- function() current.chob() +chart_asp <- function() current.chob()$get_asp() +chart_ylim <- function() current.chob()$get_ylim() +chart_xlim <- function() current.chob()$get_xlim() + +actions <- function(obj) obj$Env$actions +chart_actions <- function() actions(current.chob()) From noreply at r-forge.r-project.org Thu Jul 10 13:15:09 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 10 Jul 2014 13:15:09 +0200 (CEST) Subject: [Xts-commits] r809 - pkg/xtsExtra/R Message-ID: <20140710111509.39A29184668@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-10 13:15:08 +0200 (Thu, 10 Jul 2014) New Revision: 809 Modified: pkg/xtsExtra/R/plot2.R Log: Modifying some of the functionality of plot2_xts and drawdowns panel Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-09 23:34:55 UTC (rev 808) +++ pkg/xtsExtra/R/plot2.R 2014-07-10 11:15:08 UTC (rev 809) @@ -13,7 +13,7 @@ chart.lines <- function(x, colorset=1:12){ for(i in 1:NCOL(x)) - lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1) + lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1) } # chart_Series {{{ @@ -43,7 +43,7 @@ xtsExtraTheme <- function(){ theme <-list(col=list(bg="#FFFFFF", label.bg="#F0F0F0", - grid="#F0F0F0", + grid="darkgray", #grid="#F0F0F0", grid2="#F5F5F5", ticks="#999999", labels="#333333", @@ -63,6 +63,7 @@ } plot2_xts <- function(x, + panel="", name=deparse(substitute(x)), subset="", clev=0, @@ -117,6 +118,8 @@ set_ylim(ylim) } environment(cs$subset) <- environment(cs$get_asp) + + # Do some checks on x if(is.character(x)) stop("'x' must be a time-series object") @@ -133,8 +136,13 @@ cs$Env$cex <- pars$cex cs$Env$mar <- pars$mar cs$set_asp(3) + + # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other + # transformations (e.g. cumulative returns, correlations, etc.) as the + # main panel cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE))) + cs$set_frame(1,FALSE) cs$Env$clev = min(clev+0.01,1) # (0,1] cs$Env$theme$bbands <- theme$bbands @@ -167,6 +175,7 @@ } ticks } + # need to add if(upper.x.label) to allow for finer control cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]), segments(atbt, #axTicksByTime2(xdata[xsubset]), @@ -178,7 +187,7 @@ par('usr')[3]-0.2*min(strheight(axt)), names(axt),xpd=TRUE,cex=0.9,pos=3)), clip=FALSE,expr=TRUE) - cs$set_frame(-1) + #cs$set_frame(-1) # background of main window #cs$add(expression(rect(par("usr")[1], # par("usr")[3], @@ -255,16 +264,18 @@ cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) assign(".xts_chob", cs, .plotxtsEnv) - # handle TA="add_Vo()" as we would interactively FIXME: allow TA=NULL to work - #if(!is.null(TA) && nchar(TA) > 0) { - # TA <- parse(text=TA, srcfile=NULL) - # for( ta in 1:length(TA)) { - # if(length(TA[ta][[1]][-1]) > 0) { - # cs <- eval(TA[ta]) + # Plot the panels or default to a simple line chart + #if(!is.null(panel) && nchar(panel) > 0) { + # panel <- parse(text=panel, srcfile=NULL) + # for( p in 1:length(panel)) { + # if(length(panel[p][[1]][-1]) > 0) { + # cs <- eval(panel[p]) # } else { - # cs <- eval(TA[ta]) + # cs <- eval(panel[p]) # } # } + #} else { + # cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) #} assign(".xts_chob", cs, .plotxtsEnv) @@ -272,63 +283,44 @@ } #}}} addDrawdowns <- function(geometric=TRUE, ...){ - # added in wilder=TRUE to handle missingness behavior in original TTR::RSI call lenv <- new.env() lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] - x.pos <- 1:NROW(drawdowns) - #theme <- x$Env$theme$rsi - # vertical grid lines - #segments(axTicksByTime2(xdata[xsubset]), - # par("usr")[3], #min(-10,range(na.omit(macd))[1]), - # axTicksByTime2(xdata[xsubset]), - # par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid) - # col=x$Env$theme$grid) chart.lines(drawdowns) } mapply(function(name,value) { assign(name,value,envir=lenv) }, - names(list(geometric=geometric,...)), - list(geometric=geometric,...)) + names(list(geometric=geometric,...)), + list(geometric=geometric,...)) exp <- parse(text=gsub("list","plot_drawdowns", - as.expression(substitute(list(x=current.chob(), - geometric=geometric,...)))), + as.expression(substitute(list(x=current.chob(), + geometric=geometric,...)))), srcfile=NULL) - + plot_object <- current.chob() xsubset <- plot_object$Env$xsubset drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) - print(drawdowns) - print(range(drawdowns)) + lenv$xdata <- drawdowns + lenv$xsubset <- subset + + # add the frame for drawdowns info plot_object$add_frame(ylim=c(0,1),asp=0.2) plot_object$next_frame() - lenv$xdata <- drawdowns #structure(drawdowns,.Dimnames=list(NULL, "drawdowns")) - #text.exp <- expression(text(c(1, - # 1+strwidth(paste("RSI(",n,"):",sep=""))), - # 0.3, - # c(paste("RSI(",n,"):",sep=""), - # round(last(xdata[xsubset]),5)), - # col=c(1,theme$rsi$col$rsi),adj=c(0,0),cex=0.9,offset=0,pos=4)) - #plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE) - #plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) - - #plot_object$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) + text.exp <- expression(text(c(1, 1+strwidth("Drawdowns")), + 0.3, + c("Drawdowns", ""), + col=c(1,"gray"),adj=c(0,0),cex=0.9,offset=0,pos=4)) + plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE) + plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) + + # add frame for the actual drawdowns data plot_object$add_frame(ylim=range(drawdowns),asp=1,fixed=TRUE) plot_object$next_frame() - - # add grid lines - #lenv$grid_lines <- function(xdata,x) { c(RSIdn,RSIup) } - # add grid lines - #exp <- c(expression(segments(1, grid_lines(xdata,xsubset), - # NROW(xdata[xsubset]), grid_lines(xdata,xsubset), col=theme$grid)),exp, - # 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)), - # 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))) + + # need to add gridlines and y-axis labels for this panel + # using axis is easier, but does not have same formatting as other axes + # exp <- c(exp, expression(axis(side = 2, at = pretty(range(xdata))))) plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE) plot_object } From noreply at r-forge.r-project.org Fri Jul 11 01:23:02 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 11 Jul 2014 01:23:02 +0200 (CEST) Subject: [Xts-commits] r810 - pkg/xtsExtra/R Message-ID: <20140710232302.AB1A8186F69@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-11 01:23:01 +0200 (Fri, 11 Jul 2014) New Revision: 810 Modified: pkg/xtsExtra/R/plot2.R Log: improving panel and adding byColumn for small multiples Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-10 11:15:08 UTC (rev 809) +++ pkg/xtsExtra/R/plot2.R 2014-07-10 23:23:01 UTC (rev 810) @@ -64,6 +64,7 @@ plot2_xts <- function(x, panel="", + byColumn=FALSE, name=deparse(substitute(x)), subset="", clev=0, @@ -119,31 +120,10 @@ } environment(cs$subset) <- environment(cs$get_asp) - # Do some checks on x - if(is.character(x)) - stop("'x' must be a time-series object") - - # If we detect an OHLC object, we should call quantmod::chart_Series - #if(is.OHLC(x)) { - # cs$Env$xdata <- OHLC(x) - # if(has.Vo(x)) - # cs$Env$vo <- Vo(x) - #} else - - cs$Env$xdata <- x - #subset <- match(.index(x[subset]), .index(x)) - cs$Env$xsubset <- subset + # add theme and charting parameters to Env + cs$set_asp(3) cs$Env$cex <- pars$cex cs$Env$mar <- pars$mar - cs$set_asp(3) - - # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other - # transformations (e.g. cumulative returns, correlations, etc.) as the - # main panel - cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) - cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE))) - - cs$set_frame(1,FALSE) cs$Env$clev = min(clev+0.01,1) # (0,1] cs$Env$theme$bbands <- theme$bbands cs$Env$theme$shading <- theme$shading @@ -164,6 +144,35 @@ cs$Env$grid.ticks.lwd <- theme$grid.ticks.lwd #cs$Env$type <- type + # Do some checks on x + if(is.character(x)) + stop("'x' must be a time-series object") + + # If we detect an OHLC object, we should call quantmod::chart_Series + #if(is.OHLC(x)) { + # cs$Env$xdata <- OHLC(x) + # if(has.Vo(x)) + # cs$Env$vo <- Vo(x) + #} else + + # Raw returns data passed into function + cs$Env$R <- x + + # Compute xdata based on the first panel + # xdata <- PerformanceAnalytics:::Drawdowns(R) + cs$Env$xdata <- x + #subset <- match(.index(x[subset]), .index(x)) + cs$Env$xsubset <- subset + + + # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other + # transformations (e.g. cumulative returns, correlations, etc.) as the + # main panel? + cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) + cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE))) + + cs$set_frame(1,FALSE) + # axis_ticks function to label lower frequency ranges/grid lines cs$Env$axis_ticks <- function(xdata,xsubset) { ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 + @@ -176,6 +185,7 @@ ticks } + # compute the x-axis ticks # need to add if(upper.x.label) to allow for finer control cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]), segments(atbt, #axTicksByTime2(xdata[xsubset]), @@ -187,12 +197,15 @@ par('usr')[3]-0.2*min(strheight(axt)), names(axt),xpd=TRUE,cex=0.9,pos=3)), clip=FALSE,expr=TRUE) + #cs$set_frame(-1) # background of main window #cs$add(expression(rect(par("usr")[1], # par("usr")[3], # par("usr")[2], # par("usr")[4],border=NA,col=theme$bg)),expr=TRUE) + + # Add frame for the chart "header" to display the name and start/end dates cs$add_frame(0,ylim=c(0,1),asp=0.2) cs$set_frame(1) @@ -206,6 +219,8 @@ labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)), las=1,lwd.ticks=1,mgp=c(3,1.5,0),tcl=-0.4,cex.axis=.9)), expr=TRUE) + + # add name and start/end dates cs$Env$name <- name text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)), expression(text(NROW(xdata[xsubset]),0.5, @@ -214,6 +229,7 @@ cs$add(text.exp, env=cs$Env, expr=TRUE) cs$set_frame(2) + # y-axis labels cs$Env$axis_labels <- function(xdata,xsubset,scale=5) { axTicksByValue(na.omit(xdata[xsubset])) } @@ -261,7 +277,43 @@ # add main series cs$set_frame(2) - cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) + if(isTRUE(byColumn)){ + cs$add(expression(chart.lines(xdata[,1][xsubset])),expr=TRUE) + for(i in 2:NCOL(x)){ + lenv <- new.env() + lenv$xdata <- cs$Env$xdata[,i][subset] + lenv$name <- colnames(cs$Env$xdata)[i] + + cs$add_frame(ylim=c(0,1),asp=0.25) + cs$next_frame() + text.exp <- expression(text(x=c(1,1+strwidth(name)), + y=0.3, + labels=c(name,""), + col=c(1,1),adj=c(0,0),cex=0.9,offset=0,pos=4)) + cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) + + cs$add_frame(ylim=range(cs$Env$xdata[cs$Env$xsubset]),asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$next_frame() + + exp <- expression(chart.lines(xdata[xsubset])) + + 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)), + 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))) + cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) + } + } else { + cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) + } assign(".xts_chob", cs, .plotxtsEnv) # Plot the panels or default to a simple line chart @@ -277,17 +329,18 @@ #} else { # cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) #} + # assign(".xts_chob", cs, .plotxtsEnv) - assign(".xts_chob", cs, .plotxtsEnv) cs } #}}} -addDrawdowns <- function(geometric=TRUE, ...){ +addDrawdowns <- function(geometric=TRUE, col=1, ...){ lenv <- new.env() + lenv$name <- "Drawdowns" lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata - xsubset <- x$Env$xsubset - drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] + #xsubset <- x$Env$xsubset + drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric) chart.lines(drawdowns) } mapply(function(name,value) { assign(name,value,envir=lenv) }, @@ -299,29 +352,151 @@ srcfile=NULL) plot_object <- current.chob() - xsubset <- plot_object$Env$xsubset + xdata <- plot_object$Env$xdata + #xsubset <- plot_object$Env$xsubset + drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) lenv$xdata <- drawdowns - lenv$xsubset <- subset + lenv$col <- col # add the frame for drawdowns info - plot_object$add_frame(ylim=c(0,1),asp=0.2) + plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() - text.exp <- expression(text(c(1, 1+strwidth("Drawdowns")), - 0.3, - c("Drawdowns", ""), - col=c(1,"gray"),adj=c(0,0),cex=0.9,offset=0,pos=4)) - plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE) + text.exp <- expression(text(x=c(1,1+strwidth(name)), + y=0.3, + labels=c(name,""), + 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) # add frame for the actual drawdowns data - plot_object$add_frame(ylim=range(drawdowns),asp=1,fixed=TRUE) + plot_object$add_frame(ylim=range(na.omit(drawdowns)),asp=1,fixed=TRUE) plot_object$next_frame() - # need to add gridlines and y-axis labels for this panel # using axis is easier, but does not have same formatting as other axes # exp <- c(exp, expression(axis(side = 2, at = pretty(range(xdata))))) - plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE) + # 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)), + 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))) + plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) plot_object } +# add_TA <- function(x, order=NULL, on=NA, legend="auto", +# yaxis=list(NULL,NULL), +# col=1, taType=NULL, ...) { +# lenv <- new.env() +# lenv$name <- deparse(substitute(x)) +# lenv$plot_ta <- function(x, ta, on, taType, col=col,...) { +# xdata <- x$Env$xdata +# xsubset <- x$Env$xsubset +# if(all(is.na(on))) { +# 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] +# for(i in 1:NCOL(ta.y)) +# lines(ta.x, as.numeric(ta.y[,i]), col=col,...) +# } +# } +# 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, +# taType=taType,col=col,...)), +# list(x=x,order=order,on=on,legend=legend, +# taType=taType,col=col,...)) +# exp <- parse(text=gsub("list","plot_ta", +# as.expression(substitute(list(x=current.chob(), +# ta=get("x"),on=on, +# taType=taType,col=col,...)))), +# srcfile=NULL) +# plot_object <- current.chob() +# xdata <- plot_object$Env$xdata +# xsubset <- plot_object$Env$xsubset +# if(is.logical(x)) no.update <- TRUE else no.update <- FALSE +# # 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.15) +# plot_object$next_frame() +# text.exp <- expression(text(x=c(1,1+strwidth(name)), +# y=0.3, +# labels=c(name,round(last(xdata[xsubset]),5)), +# 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(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)), +# 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))) +# 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(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))) +# #} +# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) +# } +# } +# plot_object +# } #}}} + + From noreply at r-forge.r-project.org Sun Jul 13 21:06:33 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 13 Jul 2014 21:06:33 +0200 (CEST) Subject: [Xts-commits] r811 - pkg/xtsExtra/R Message-ID: <20140713190633.44CC4186C49@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-13 21:06:32 +0200 (Sun, 13 Jul 2014) New Revision: 811 Modified: pkg/xtsExtra/R/plot2.R Log: Revisions to plot2_xts and adding an add_Lines function Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-10 23:23:01 UTC (rev 810) +++ pkg/xtsExtra/R/plot2.R 2014-07-13 19:06:32 UTC (rev 811) @@ -8,7 +8,7 @@ # chart_pars {{{ chart_pars <- function() { - list(cex=0.6, mar=c(3,1,0,1)) + list(cex=0.6, mar=c(3,2,0,2)) } # }}} chart.lines <- function(x, colorset=1:12){ @@ -121,7 +121,11 @@ environment(cs$subset) <- environment(cs$get_asp) # add theme and charting parameters to Env - cs$set_asp(3) + if(byColumn){ + cs$set_asp(NCOL(x)) + } else { + cs$set_asp(3) + } cs$Env$cex <- pars$cex cs$Env$mar <- pars$mar cs$Env$clev = min(clev+0.01,1) # (0,1] @@ -157,6 +161,7 @@ # Raw returns data passed into function cs$Env$R <- x + cs$Env$column_names <- colnames(R) # Compute xdata based on the first panel # xdata <- PerformanceAnalytics:::Drawdowns(R) @@ -278,13 +283,17 @@ # add main series cs$set_frame(2) if(isTRUE(byColumn)){ + # Add expression for the main plot cs$add(expression(chart.lines(xdata[,1][xsubset])),expr=TRUE) for(i in 2:NCOL(x)){ + # create a local environment lenv <- new.env() lenv$xdata <- cs$Env$xdata[,i][subset] lenv$name <- colnames(cs$Env$xdata)[i] + lenv$ylim <- range(cs$Env$xdata[subset]) - cs$add_frame(ylim=c(0,1),asp=0.25) + # Add a small frame for the time series info + cs$add_frame(ylim=c(0,1),asp=0.2) cs$next_frame() text.exp <- expression(text(x=c(1,1+strwidth(name)), y=0.3, @@ -292,23 +301,37 @@ col=c(1,1),adj=c(0,0),cex=0.9,offset=0,pos=4)) cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) - cs$add_frame(ylim=range(cs$Env$xdata[cs$Env$xsubset]),asp=NCOL(cs$Env$xdata), fixed=TRUE) + # Add the frame for the sub-plots + cs$add_frame(ylim=range(cs$Env$xdata[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) cs$next_frame() exp <- expression(chart.lines(xdata[xsubset])) - 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,10) + 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)), - 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))) + + exp <- c(expression( + # y-axis grid lines + segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), + col=theme$grid)), # add y-axis grid lines + exp, # NOTE 'exp' was defined earlier + # 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,offset=0,pos=4,cex=0.9)), + expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), + noquote(format(y_grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9)), + # x-axis grid lines + expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(atbt, #axTicksByTime2(xdata[xsubset]), + ylim[1], + atbt, #axTicksByTime2(xdata[xsubset]), + ylim[2], col=theme$grid))) cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } } else { @@ -339,7 +362,13 @@ lenv$name <- "Drawdowns" lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata - #xsubset <- x$Env$xsubset + xsubset <- x$Env$xsubset + # Add x-axis grid lines + segments(axTicksByTime2(xdata[xsubset]), + par("usr")[3], + axTicksByTime2(xdata[xsubset]), + par("usr")[4], + col=x$Env$theme$grid) drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric) chart.lines(drawdowns) } @@ -376,8 +405,10 @@ # exp <- c(exp, expression(axis(side = 2, at = pretty(range(xdata))))) # add grid lines, using custom function for MACD gridlines - lenv$grid_lines <- function(xdata,xsubset) { - pretty(range(xdata[xsubset])) + lenv$grid_lines <- function(xdata,xsubset) { + ylim <- range(xdata[xsubset]) + p <- pretty(ylim, 10) + 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 @@ -392,111 +423,113 @@ plot_object } -# add_TA <- function(x, order=NULL, on=NA, legend="auto", -# yaxis=list(NULL,NULL), -# col=1, taType=NULL, ...) { -# lenv <- new.env() -# lenv$name <- deparse(substitute(x)) -# lenv$plot_ta <- function(x, ta, on, taType, col=col,...) { -# xdata <- x$Env$xdata -# xsubset <- x$Env$xsubset -# if(all(is.na(on))) { -# 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] -# for(i in 1:NCOL(ta.y)) -# lines(ta.x, as.numeric(ta.y[,i]), col=col,...) -# } -# } -# 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, -# taType=taType,col=col,...)), -# list(x=x,order=order,on=on,legend=legend, -# taType=taType,col=col,...)) -# exp <- parse(text=gsub("list","plot_ta", -# as.expression(substitute(list(x=current.chob(), -# ta=get("x"),on=on, -# taType=taType,col=col,...)))), -# srcfile=NULL) -# plot_object <- current.chob() -# xdata <- plot_object$Env$xdata -# xsubset <- plot_object$Env$xsubset -# if(is.logical(x)) no.update <- TRUE else no.update <- FALSE -# # 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.15) -# plot_object$next_frame() -# text.exp <- expression(text(x=c(1,1+strwidth(name)), -# y=0.3, -# labels=c(name,round(last(xdata[xsubset]),5)), -# 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(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)), -# 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))) -# 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(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))) -# #} -# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) -# } -# } -# plot_object -# } #}}} +# based on quantmod::add_TA +add_Lines <- function(x, name="", order=NULL, on=NA, legend="auto", + yaxis=list(NULL,NULL), + col=1, taType=NULL, ...) { + lenv <- new.env() + lenv$name <- name + lenv$plot_ta <- function(x, ta, on, taType, col=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] + for(i in 1:NCOL(ta.y)) + lines(ta.x, as.numeric(ta.y[,i]), col=col,...) + } + } + 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, + taType=taType,col=col,...)), + list(x=x,order=order,on=on,legend=legend, + taType=taType,col=col,...)) + exp <- parse(text=gsub("list","plot_ta", + as.expression(substitute(list(x=current.chob(), + ta=get("x"),on=on, + taType=taType,col=col,...)))), + srcfile=NULL) + plot_object <- current.chob() + xdata <- plot_object$Env$xdata + xsubset <- plot_object$Env$xsubset + if(is.logical(x)) no.update <- TRUE else no.update <- FALSE + # 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=c(1,1+strwidth(name)), + y=0.3, + labels=c(name,round(last(xdata[xsubset]),5)), + 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)), + 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))) + 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(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))) + #} + plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) + } + } + plot_object +} #}}} From noreply at r-forge.r-project.org Sun Jul 13 22:52:07 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 13 Jul 2014 22:52:07 +0200 (CEST) Subject: [Xts-commits] r812 - pkg/xtsExtra/R Message-ID: <20140713205207.7DD5B185791@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-13 22:52:07 +0200 (Sun, 13 Jul 2014) New Revision: 812 Modified: pkg/xtsExtra/R/plot2.R Log: Adding a main panel transformation and optional type argument for plots Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-13 19:06:32 UTC (rev 811) +++ pkg/xtsExtra/R/plot2.R 2014-07-13 20:52:07 UTC (rev 812) @@ -11,9 +11,9 @@ list(cex=0.6, mar=c(3,2,0,2)) } # }}} -chart.lines <- function(x, colorset=1:12){ +chart.lines <- function(x, colorset=1:12, type="l"){ for(i in 1:NCOL(x)) - lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1) + lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1, type=type) } # chart_Series {{{ @@ -63,8 +63,10 @@ } plot2_xts <- function(x, - panel="", + mainPanel=NULL, + panels=NULL, byColumn=FALSE, + type="l", name=deparse(substitute(x)), subset="", clev=0, @@ -146,7 +148,7 @@ cs$Env$format.labels <- format.labels cs$Env$ticks.on <- grid.ticks.on cs$Env$grid.ticks.lwd <- theme$grid.ticks.lwd - #cs$Env$type <- type + cs$Env$type <- type # Do some checks on x if(is.character(x)) @@ -160,24 +162,43 @@ #} else # Raw returns data passed into function - cs$Env$R <- x - cs$Env$column_names <- colnames(R) - - # Compute xdata based on the first panel - # xdata <- PerformanceAnalytics:::Drawdowns(R) cs$Env$xdata <- x - #subset <- match(.index(x[subset]), .index(x)) cs$Env$xsubset <- subset + cs$Env$column_names <- colnames(x) + cs$Env$nobs <- NROW(cs$Env$xdata) + # Compute transformation if specified by panel argument + # cs$Env$R <- PerformanceAnalytics:::Drawdowns(x) + # rough prototype for calling a function for the main "panel" + if(!is.null(mainPanel)){ + FUN <- match.fun(mainPanel$name) + args <- mainPanel$args + .formals <- formals(FUN) + .formals <- modify.args(formals=.formals, arglist=args, dots=TRUE) + if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE) + .formals$... <- NULL + R <- try(do.call(FUN, .formals), silent=TRUE) + if(inherits(R, "try-error")) { + message(paste("mainPanel function failed with message", R)) + cs$Env$R <- x + } else { + cs$Env$R <- R + } + } else { + cs$Env$R <- R + } # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other # transformations (e.g. cumulative returns, correlations, etc.) as the # main panel? + # Set xlim based on the raw returns data passed into function cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) - cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE))) - cs$set_frame(1,FALSE) + # Set ylim based on the transformed data + cs$set_ylim(list(structure(range(na.omit(cs$Env$R[subset])),fixed=TRUE))) + + cs$set_frame(1,FALSE) # axis_ticks function to label lower frequency ranges/grid lines cs$Env$axis_ticks <- function(xdata,xsubset) { ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 + @@ -203,13 +224,6 @@ names(axt),xpd=TRUE,cex=0.9,pos=3)), clip=FALSE,expr=TRUE) - #cs$set_frame(-1) - # background of main window - #cs$add(expression(rect(par("usr")[1], - # par("usr")[3], - # par("usr")[2], - # par("usr")[4],border=NA,col=theme$bg)),expr=TRUE) - # Add frame for the chart "header" to display the name and start/end dates cs$add_frame(0,ylim=c(0,1),asp=0.2) cs$set_frame(1) @@ -232,65 +246,43 @@ paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), col=1,adj=c(0,0),pos=2))) cs$add(text.exp, env=cs$Env, expr=TRUE) - cs$set_frame(2) - # y-axis labels - cs$Env$axis_labels <- function(xdata,xsubset,scale=5) { - axTicksByValue(na.omit(xdata[xsubset])) - } - cs$Env$make_pretty_labels <- function(ylim) { - p <- pretty(ylim,10) + cs$set_frame(2) + # define function for y-axis labels + cs$Env$grid_lines <- function(xdata, xsubset) { + ylim <- range(xdata[xsubset]) + p <- pretty(ylim, 10) p[p > ylim[1] & p < ylim[2]] } - #cs$add(assign("five",rnorm(10))) # this gets re-evaled each update, though only to test - #cs$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE) - #cs$add(expression(assign("alabels", pretty(range(xdata[xsubset],na.rm=TRUE)))),expr=TRUE) - #cs$add(expression(assign("alabels", pretty(get_ylim(get_frame())[[2]],10))),expr=TRUE) - cs$add(expression(assign("alabels", make_pretty_labels(get_ylim(get_frame())[[2]]))),expr=TRUE) - # add $1 grid lines if appropriate - #cs$set_frame(-2) + # add y-axis grid lines and labels + exp <- c( + # y-axis grid lines + expression(segments(1, grid_lines(R,xsubset), NROW(xdata[xsubset]), grid_lines(R,xsubset), + col=theme$grid)), + # left y-axis labels + expression(text(1-1/3-max(strwidth(grid_lines(R,xsubset))), grid_lines(R,xsubset), + noquote(format(grid_lines(R,xsubset), justify="right")), + col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE)), + # right y-axis labels + expression(text(NROW(R[xsubset])+1/3, grid_lines(R,xsubset), + noquote(format(grid_lines(R,xsubset), justify="right")), + col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE)) + ) + cs$add(exp, env=cs$Env, expr=TRUE) - # add minor y-grid lines - #cs$add(expression(if(diff(range(xdata[xsubset],na.rm=TRUE)) < 50) - # segments(1,seq(min(xdata[xsubset]%/%1,na.rm=TRUE), - # max(xdata[xsubset]%/%1,na.rm=TRUE),1), - # length(xsubset), - # seq(min(xdata[xsubset]%/%1,na.rm=TRUE), - # max(xdata[xsubset]%/%1,na.rm=TRUE),1), - # col=theme$grid2, lty="dotted")), expr=TRUE) - - cs$set_frame(2) - # add main y-grid lines - cs$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE) - - # left axis labels - if(theme$lylab) { - cs$add(expression(text(1-1/3-max(strwidth(alabels)), - alabels, #axis_labels(xdata,xsubset), - noquote(format(alabels,justify="right")), - col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE) - } - - # right axis labels - if(theme$rylab) { - cs$add(expression(text(NROW(xdata[xsubset])+1/3, - alabels, - noquote(format(alabels,justify="right")), - col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE) - } - # add main series cs$set_frame(2) if(isTRUE(byColumn)){ # Add expression for the main plot - cs$add(expression(chart.lines(xdata[,1][xsubset])),expr=TRUE) + cs$add(expression(chart.lines(R[,1][xsubset], type=type)),expr=TRUE) for(i in 2:NCOL(x)){ # create a local environment lenv <- new.env() - lenv$xdata <- cs$Env$xdata[,i][subset] - lenv$name <- colnames(cs$Env$xdata)[i] - lenv$ylim <- range(cs$Env$xdata[subset]) + lenv$xdata <- cs$Env$R[,i][subset] + lenv$name <- cs$Env$colum_names[i] + lenv$ylim <- range(cs$Env$R[subset]) + lenv$type <- cs$Env$type # Add a small frame for the time series info cs$add_frame(ylim=c(0,1),asp=0.2) @@ -302,10 +294,11 @@ cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) # Add the frame for the sub-plots - cs$add_frame(ylim=range(cs$Env$xdata[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) + # Set the ylim based on the (potentially) transformed data in cs$Env$R + cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) cs$next_frame() - exp <- expression(chart.lines(xdata[xsubset])) + exp <- expression(chart.lines(xdata[xsubset], type=type)) # define function to plot the y-axis grid lines lenv$y_grid_lines <- function(ylim) { @@ -322,10 +315,10 @@ # 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,offset=0,pos=4,cex=0.9)), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9)), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), # x-axis grid lines expression(atbt <- axTicksByTime2(xdata[xsubset]), segments(atbt, #axTicksByTime2(xdata[xsubset]), @@ -335,7 +328,7 @@ cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } } else { - cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) + cs$add(expression(chart.lines(R[xsubset])),expr=TRUE) } assign(".xts_chob", cs, .plotxtsEnv) @@ -415,10 +408,10 @@ # 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)), + 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))) + 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) plot_object } @@ -454,8 +447,7 @@ .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] - for(i in 1:NCOL(ta.y)) - lines(ta.x, as.numeric(ta.y[,i]), col=col,...) + chart.lines(ta.y) } } lenv$xdata <- x @@ -488,9 +480,9 @@ if(is.na(on)) { plot_object$add_frame(ylim=c(0,1),asp=0.2) plot_object$next_frame() - text.exp <- expression(text(x=c(1,1+strwidth(name)), + text.exp <- expression(text(x=1, y=0.3, - labels=c(name,round(last(xdata[xsubset]),5)), + labels=name, 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) @@ -505,16 +497,16 @@ # 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)), + 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))) + 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(xdata[xsubset]) + pretty(range(xdata[xsubset])) } exp <- c(exp, # LHS @@ -524,7 +516,7 @@ # 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))) + 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) } From noreply at r-forge.r-project.org Sun Jul 13 23:08:35 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 13 Jul 2014 23:08:35 +0200 (CEST) Subject: [Xts-commits] r813 - pkg/xtsExtra/R Message-ID: <20140713210835.E3CD81875AC@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-13 23:08:35 +0200 (Sun, 13 Jul 2014) New Revision: 813 Modified: pkg/xtsExtra/R/plot2.R Log: cleaning up some comments and adding support for different line chart types Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-13 20:52:07 UTC (rev 812) +++ pkg/xtsExtra/R/plot2.R 2014-07-13 21:08:35 UTC (rev 813) @@ -12,8 +12,12 @@ } # }}} chart.lines <- function(x, colorset=1:12, type="l"){ + if(type == "h"){ + lines(1:NROW(x),x[,1],lwd=2,col=colorset[1],lend=3,lty=1, type="h") + } else { for(i in 1:NCOL(x)) - lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1, type=type) + lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1, type="l") + } } # chart_Series {{{ @@ -394,17 +398,15 @@ plot_object$add_frame(ylim=range(na.omit(drawdowns)),asp=1,fixed=TRUE) plot_object$next_frame() - # using axis is easier, but does not have same formatting as other axes - # exp <- c(exp, expression(axis(side = 2, at = pretty(range(xdata))))) - # add grid lines, using custom function for MACD gridlines - lenv$grid_lines <- function(xdata,xsubset) { ylim <- range(xdata[xsubset]) p <- pretty(ylim, 10) p[p > ylim[1] & p < ylim[2]] } + # add y-axis gridlines and labels 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 + col=theme$grid)), + exp, # NOTE 'exp' was defined earlier # 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")), @@ -419,10 +421,10 @@ # based on quantmod::add_TA add_Lines <- function(x, name="", order=NULL, on=NA, legend="auto", yaxis=list(NULL,NULL), - col=1, taType=NULL, ...) { + col=1, type="l", ...) { lenv <- new.env() lenv$name <- name - lenv$plot_ta <- function(x, ta, on, taType, col=col,...) { + lenv$plot_ta <- function(x, ta, on, type, col,...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset if(all(is.na(on))) { @@ -447,20 +449,20 @@ .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) + 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, - taType=taType,col=col,...)), + type=type,col=col,...)), list(x=x,order=order,on=on,legend=legend, - taType=taType,col=col,...)) + type=type,col=col,...)) exp <- parse(text=gsub("list","plot_ta", as.expression(substitute(list(x=current.chob(), ta=get("x"),on=on, - taType=taType,col=col,...)))), + type=type,col=col,...)))), srcfile=NULL) plot_object <- current.chob() xdata <- plot_object$Env$xdata From noreply at r-forge.r-project.org Tue Jul 15 00:18:59 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 15 Jul 2014 00:18:59 +0200 (CEST) Subject: [Xts-commits] r814 - in pkg/xtsExtra: R sandbox Message-ID: <20140714221859.C422D184C73@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-15 00:18:59 +0200 (Tue, 15 Jul 2014) New Revision: 814 Added: pkg/xtsExtra/sandbox/paFUN.R Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/R/replot_xts.R pkg/xtsExtra/sandbox/test_plot2.R Log: More functionality for adding panels Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-13 21:08:35 UTC (rev 813) +++ pkg/xtsExtra/R/plot2.R 2014-07-14 22:18:59 UTC (rev 814) @@ -2,7 +2,7 @@ # Environment for our xts chart objects .plotxtsEnv <- new.env() -current.chob <- function() invisible(get(".xts_chob",.plotxtsEnv)) +current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv)) # based on quantmod R/chart_Series.R @@ -13,10 +13,12 @@ chart.lines <- function(x, colorset=1:12, type="l"){ if(type == "h"){ - lines(1:NROW(x),x[,1],lwd=2,col=colorset[1],lend=3,lty=1, type="h") + colors <- ifelse(x[,1] < 0, "darkred", "darkgreen") + lines(1:NROW(x),x[,1],lwd=2,col=colors,lend=1,lty=1,type="h") } else { - for(i in 1:NCOL(x)) - lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=3,lty=1, type="l") + for(i in 1:NCOL(x)){ + lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=1,lty=1,type="l") + } } } @@ -172,7 +174,6 @@ cs$Env$nobs <- NROW(cs$Env$xdata) # Compute transformation if specified by panel argument - # cs$Env$R <- PerformanceAnalytics:::Drawdowns(x) # rough prototype for calling a function for the main "panel" if(!is.null(mainPanel)){ FUN <- match.fun(mainPanel$name) @@ -199,6 +200,8 @@ cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) # Set ylim based on the transformed data + # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or + # which is best. cs$set_ylim(list(structure(range(na.omit(cs$Env$R[subset])),fixed=TRUE))) @@ -278,23 +281,33 @@ # add main series cs$set_frame(2) if(isTRUE(byColumn)){ + # We need to plot the first "panel" here because the plot area is + # set up based on the code above + lenv <- new.env() + lenv$xdata <- cs$Env$R[,1][subset] + lenv$name <- cs$Env$colum_names[1] + #lenv$ymax <- range(cs$Env$R[subset])[2] + lenv$type <- cs$Env$type + exp <- expression(chart.lines(xdata, type=type)) + #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) # Add expression for the main plot - cs$add(expression(chart.lines(R[,1][xsubset], type=type)),expr=TRUE) + cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) + for(i in 2:NCOL(x)){ # create a local environment lenv <- new.env() lenv$xdata <- cs$Env$R[,i][subset] - lenv$name <- cs$Env$colum_names[i] + lenv$name <- cs$Env$column_names[i] lenv$ylim <- range(cs$Env$R[subset]) lenv$type <- cs$Env$type # Add a small frame for the time series info cs$add_frame(ylim=c(0,1),asp=0.2) cs$next_frame() - text.exp <- expression(text(x=c(1,1+strwidth(name)), - y=0.3, - labels=c(name,""), - col=c(1,1),adj=c(0,0),cex=0.9,offset=0,pos=4)) + text.exp <- expression(text(x=1, + y=0.5, + labels=name, + adj=c(0,0),cex=0.9,offset=0,pos=4)) cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) # Add the frame for the sub-plots @@ -311,10 +324,10 @@ p[p > ylim[1] & p < ylim[2]] } - exp <- c(expression( + exp <- c( # y-axis grid lines - segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), - col=theme$grid)), # add y-axis grid lines + expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), + col=theme$grid)), # add y-axis grid lines exp, # NOTE 'exp' was defined earlier # y-axis labels/boxes expression(text(1-1/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim), @@ -332,7 +345,7 @@ cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } } else { - cs$add(expression(chart.lines(R[xsubset])),expr=TRUE) + cs$add(expression(chart.lines(R[xsubset], type=type)),expr=TRUE) } assign(".xts_chob", cs, .plotxtsEnv) @@ -373,11 +386,11 @@ names(list(geometric=geometric,...)), list(geometric=geometric,...)) exp <- parse(text=gsub("list","plot_drawdowns", - as.expression(substitute(list(x=current.chob(), + as.expression(substitute(list(x=current.xts_chob(), geometric=geometric,...)))), srcfile=NULL) - plot_object <- current.chob() + plot_object <- current.xts_chob() xdata <- plot_object$Env$xdata #xsubset <- plot_object$Env$xsubset @@ -419,9 +432,9 @@ } # based on quantmod::add_TA -add_Lines <- function(x, name="", order=NULL, on=NA, legend="auto", - yaxis=list(NULL,NULL), - col=1, type="l", ...) { +addLines <- function(x, name="", order=NULL, on=NA, legend="auto", + yaxis=list(NULL,NULL), + col=1, type="l", ...) { lenv <- new.env() lenv$name <- name lenv$plot_ta <- function(x, ta, on, type, col,...) { @@ -449,6 +462,7 @@ .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] + print(head(ta.y)) chart.lines(ta.y, colorset=col, type=type) } } @@ -460,11 +474,11 @@ 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.chob(), + as.expression(substitute(list(x=current.xts_chob(), ta=get("x"),on=on, type=type,col=col,...)))), srcfile=NULL) - plot_object <- current.chob() + plot_object <- current.xts_chob() xdata <- plot_object$Env$xdata xsubset <- plot_object$Env$xsubset if(is.logical(x)) no.update <- TRUE else no.update <- FALSE @@ -526,4 +540,128 @@ plot_object } #}}} +addReturns <- function(){ + # This just plots the raw returns data + lenv <- new.env() + lenv$name <- "Returns" + lenv$plot_returns <- function(x) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + # Add x-axis grid lines + segments(axTicksByTime2(xdata[xsubset]), + par("usr")[3], + axTicksByTime2(xdata[xsubset]), + par("usr")[4], + col=x$Env$theme$grid) + chart.lines(xdata[xsubset]) + } + #mapply(function(name,value) { assign(name,value,envir=lenv) }, + # names(list(geometric=geometric,...)), + # list(geometric=geometric,...)) + exp <- parse(text=gsub("list","plot_returns", + as.expression(substitute(list(x=current.xts_chob())))), + srcfile=NULL) + + plot_object <- current.xts_chob() + xdata <- plot_object$Env$xdata + #xsubset <- plot_object$Env$xsubset + + lenv$xdata <- xdata + lenv$col <- col + + # 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=name, + 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 data + plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1,fixed=TRUE) + plot_object$next_frame() + + lenv$grid_lines <- function(xdata,xsubset) { + ylim <- range(xdata[xsubset]) + p <- pretty(ylim, 10) + p[p > ylim[1] & p < ylim[2]] + } + # add y-axis gridlines and labels + 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 + # 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=TRUE) + plot_object +} +addRollingPerformance <- function(width=12, FUN="Return.annualized", fill=NA, ...){ + lenv <- new.env() + lenv$name <- paste("Rolling", FUN) + lenv$plot_performance <- function(x, width, FUN, fill, ...) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + # Add x-axis grid lines + segments(axTicksByTime2(xdata[xsubset]), + par("usr")[3], + axTicksByTime2(xdata[xsubset]), + par("usr")[4], + col=x$Env$theme$grid) + rolling_performance <- RollingPerformance(R=xdata, width=width, FUN=FUN, fill=fill, ...=...) + chart.lines(rolling_performance) + } + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(width=width, FUN=FUN, fill=fill, ...)), + list(width=width, FUN=FUN, fill=fill, ...)) + exp <- parse(text=gsub("list","plot_performance", + as.expression(substitute(list(x=current.xts_chob(), + width=width, FUN=FUN, fill=fill, ...)))), + srcfile=NULL) + + plot_object <- current.xts_chob() + xdata <- plot_object$Env$xdata + #xsubset <- plot_object$Env$xsubset + + rolling_performance <- RollingPerformance(R=plot_object$Env$xdata, width=width, FUN=FUN, ...=..., fill=fill) + lenv$xdata <- rolling_performance + lenv$col <- col + + # 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=name, + 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 + plot_object$add_frame(ylim=range(na.omit(rolling_performance)),asp=1,fixed=TRUE) + plot_object$next_frame() + + lenv$grid_lines <- function(xdata,xsubset) { + ylim <- range(na.omit(xdata[xsubset])) + p <- pretty(ylim, 10) + p[p > ylim[1] & p < ylim[2]] + } + # add y-axis gridlines and labels + 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 + # 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=TRUE) + plot_object +} Modified: pkg/xtsExtra/R/replot_xts.R =================================================================== --- pkg/xtsExtra/R/replot_xts.R 2014-07-13 21:08:35 UTC (rev 813) +++ pkg/xtsExtra/R/replot_xts.R 2014-07-14 22:18:59 UTC (rev 814) @@ -275,10 +275,10 @@ ##### accessor functions -re_Chart <- function() current.chob() -chart_asp <- function() current.chob()$get_asp() -chart_ylim <- function() current.chob()$get_ylim() -chart_xlim <- function() current.chob()$get_xlim() +re_Chart <- function() current.xts_chob() +chart_asp <- function() current.xts_chob()$get_asp() +chart_ylim <- function() current.xts_chob()$get_ylim() +chart_xlim <- function() current.xts_chob()$get_xlim() actions <- function(obj) obj$Env$actions -chart_actions <- function() actions(current.chob()) +chart_actions <- function() actions(current.xts_chob()) Added: pkg/xtsExtra/sandbox/paFUN.R =================================================================== --- pkg/xtsExtra/sandbox/paFUN.R (rev 0) +++ pkg/xtsExtra/sandbox/paFUN.R 2014-07-14 22:18:59 UTC (rev 814) @@ -0,0 +1,132 @@ +CumReturns <- + function (R, wealth.index = FALSE, geometric = TRUE, begin = c("first","axis")) + { # @author Peter Carl + + # DESCRIPTION: + # Cumulates the returns given and draws a line graph of the results as + # a cumulative return or a "wealth index". + + # Inputs: + # R: a matrix, data frame, or timeSeries of returns + # wealth.index: if true, shows the "value of $1", starting the cumulation + # of returns at 1 rather than zero + # legend.loc: use this to locate the legend, e.g., "topright" + # colorset: use the name of any of the palattes above + # method: "none" + + # Outputs: + # A timeseries line chart of the cumulative return series + + # FUNCTION: + + # Transform input data to a matrix + begin = begin[1] + x = checkData(R) + + # Get dimensions and labels + columns = ncol(x) + columnnames = colnames(x) + + # Calculate the cumulative return + one = 0 + if(!wealth.index) + one = 1 + + ##find the longest column, calc cum returns and use it for starting values + + if(begin == "first") { + length.column.one = length(x[,1]) + # find the row number of the last NA in the first column + start.row = 1 + start.index = 0 + while(is.na(x[start.row,1])){ + start.row = start.row + 1 + } + x = x[start.row:length.column.one,] + if(geometric) + reference.index = PerformanceAnalytics:::na.skip(x[,1],FUN=function(x) {cumprod(1+x)}) + else + reference.index = PerformanceAnalytics:::na.skip(x[,1],FUN=function(x) {cumsum(x)}) + } + for(column in 1:columns) { + if(begin == "axis") { + start.index = FALSE + } else { + # find the row number of the last NA in the target column + start.row = 1 + while(is.na(x[start.row,column])){ + start.row = start.row + 1 + } + start.index=ifelse(start.row > 1,TRUE,FALSE) + } + if(start.index){ + # we need to "pin" the beginning of the shorter series to the (start date - 1 period) + # value of the reference index while preserving NA's in the shorter series + if(geometric) + z = PerformanceAnalytics:::na.skip(x[,column],FUN = function(x,index=reference.index[(start.row - 1)]) {rbind(index,1+x)}) + else + z = PerformanceAnalytics:::na.skip(x[,column],FUN = function(x,index=reference.index[(start.row - 1)]) {rbind(1+index,1+x)}) + } else { + z = 1+x[,column] + } + column.Return.cumulative = PerformanceAnalytics:::na.skip(z,FUN = function(x, one, geometric) {if(geometric) cumprod(x)-one else (1-one) + cumsum(x-1)},one=one, geometric=geometric) + if(column == 1) + Return.cumulative = column.Return.cumulative + else + Return.cumulative = merge(Return.cumulative,column.Return.cumulative) + } + if(columns == 1) + Return.cumulative = as.xts(Return.cumulative) + colnames(Return.cumulative) = columnnames + + return(Return.cumulative) + } + +RollingPerformance <- function (R, width = 12, FUN = "Return.annualized", ..., fill = NA) +{ # @author Peter Carl + + # DESCRIPTION: + # A wrapper to create a chart of rolling peRformance metrics in a line chart + + # Inputs: + # R: a matrix, data frame, or timeSeries of returns + # FUN: any function that can be evaluated using a single set of returns + # (e.g., rolling beta won't work, but Return.annualizeds will) + + # Outputs: + # A timeseries line chart of the calculated series + + # FUNCTION: + + # Transform input data to a matrix + x = checkData(R) + + # Get dimensions and labels + columns = ncol(x) + columnnames = colnames(x) + + # Separate function args from plot args + dotargs <-list(...) + funargsmatch = pmatch(names(dotargs), names(formals(FUN)), nomatch = 0L) + funargs = dotargs[funargsmatch>0L] + if(is.null(funargs))funargs=list() + funargs$...=NULL + + funargs$width=width + funargs$FUN=FUN + funargs$fill = fill + funargs$align='right' + + # Calculate + for(column in 1:columns) { + # the drop=FALSE flag is essential for when the zoo object only has one column + rollargs<-c(list(data=na.omit(x[,column,drop=FALSE])),funargs) + column.Return.calc <- do.call(rollapply,rollargs) + if(column == 1) + Return.calc = xts(column.Return.calc) + else + Return.calc = merge(Return.calc,column.Return.calc) + } + colnames(Return.calc) = columnnames + Return.calc +} Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-13 21:08:35 UTC (rev 813) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-14 22:18:59 UTC (rev 814) @@ -1,42 +1,72 @@ +library(xtsExtra) +library(PerformanceAnalytics) - data(edhec) -R <- edhec[,1:5] +R <- edhec[,1:2] - chart.TimeSeries(R) - -# The main title gets messed up when adding panels plot2_xts(R) -x <- current.chob() -ls.str(x) -ls.str(x$Env) -addDrawdowns() -addDrawdowns() -x <- current.chob() -ls.str(x) -ls.str(x$Env) +charts.TimeSeries(R) +# charts.TimeSeries messes up par("mar") so I need to call dev.off() +dev.off() +# the titles are gett +plot2_xts(R, byColumn=TRUE) +chart.Bar(R[,1]) +plot2_xts(R[,1], type="h") -chart.TimeSeries(R, auto.grid=FALSE) -plot2_xts(R, auto.grid=FALSE) +charts.Bar(R) +# charts.TimeSeries messes up par("mar") so I need to call dev.off() to reset +dev.off() +plot2_xts(R, byColumn=TRUE, type="h") +# Replicates charts.PerformanceSummary +plot2_xts(R, mainPanel=list(name="CumReturns")) +addReturns() +addDrawdowns() -charts.TimeSeries(R) -plot2_xts(R, byColumn=TRUE) -title("Edhec Returns") +plot2_xts(R) +addRollingPerformance() +addRollingPerformance(FUN="StdDev.annualized") +addRollingPerformance(FUN="SharpeRatio.annualized") -cl <- chartLayout(matrix(1:5), 1, c(2,2,1,1,1)) -plot2_xts(R, byColumn=TRUE, layout=cl) -title("Edhec Returns") -x <- current.chob() +# The main title gets messed up when adding panels +# plot2_xts(R) +# x <- current.chob() +# ls.str(x) +# ls.str(x$Env) +# +# addDrawdowns() +# addDrawdowns() +# x <- current.chob() +# ls.str(x) +# ls.str(x$Env) +# +# +# chart.TimeSeries(R, auto.grid=FALSE) +# plot2_xts(R, auto.grid=FALSE) +# +# +# charts.TimeSeries(R) +# plot2_xts(R, byColumn=TRUE) +# title("Edhec Returns") +# +# cl <- chartLayout(matrix(1:5), 1, c(2,2,1,1,1)) +# plot2_xts(R, byColumn=TRUE, layout=cl) +# title("Edhec Returns") +# +# x <- current.chob() # Get the structure of the environments -ls.str(x) -ls.str(x$Env) +# ls.str(x) +# ls.str(x$Env) +# getSymbols("YHOO", src="yahoo") +# chart_Series(YHOO) +# add_RSI() +# add_MACD() ##### 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 Tue Jul 15 22:03:24 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 15 Jul 2014 22:03:24 +0200 (CEST) Subject: [Xts-commits] r815 - pkg/xtsExtra Message-ID: <20140715200324.4070E1862EF@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-15 22:03:23 +0200 (Tue, 15 Jul 2014) New Revision: 815 Modified: pkg/xtsExtra/.Rbuildignore Log: Adding sandbox folder to Rbuildignore Modified: pkg/xtsExtra/.Rbuildignore =================================================================== --- pkg/xtsExtra/.Rbuildignore 2014-07-14 22:18:59 UTC (rev 814) +++ pkg/xtsExtra/.Rbuildignore 2014-07-15 20:03:23 UTC (rev 815) @@ -20,3 +20,5 @@ man/xtsdf\.Rd ^.*\.Rproj$ ^\.Rproj\.user$ + +sandbox From noreply at r-forge.r-project.org Wed Jul 16 13:44:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 16 Jul 2014 13:44:29 +0200 (CEST) Subject: [Xts-commits] r816 - in pkg/xtsExtra: . R sandbox Message-ID: <20140716114429.452CE185099@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-16 13:44:28 +0200 (Wed, 16 Jul 2014) New Revision: 816 Modified: pkg/xtsExtra/NAMESPACE pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: cleaning up plot2_xts code and adding relevant functions to NAMESPACE Modified: pkg/xtsExtra/NAMESPACE =================================================================== --- pkg/xtsExtra/NAMESPACE 2014-07-15 20:03:23 UTC (rev 815) +++ pkg/xtsExtra/NAMESPACE 2014-07-16 11:44:28 UTC (rev 816) @@ -13,6 +13,16 @@ S3method(plot, xts) S3method(barplot, xts) +export("plot2_xts") +export("chart_pars") +export("xtsExtraTheme") +export("addDrawdowns") +export("addLines") +export("addReturns") +export("addRollingPerformance") +S3method(print, replot_xts) +S3method(plot, replot_xts) + ## Analytics -- All blocked out for now #export("acf") Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-15 20:03:23 UTC (rev 815) +++ pkg/xtsExtra/R/plot2.R 2014-07-16 11:44:28 UTC (rev 816) @@ -280,69 +280,73 @@ # add main series cs$set_frame(2) - if(isTRUE(byColumn)){ - # We need to plot the first "panel" here because the plot area is - # set up based on the code above - lenv <- new.env() - lenv$xdata <- cs$Env$R[,1][subset] - lenv$name <- cs$Env$colum_names[1] - #lenv$ymax <- range(cs$Env$R[subset])[2] - lenv$type <- cs$Env$type - exp <- expression(chart.lines(xdata, type=type)) - #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) - # Add expression for the main plot - cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) - - for(i in 2:NCOL(x)){ - # create a local environment + if((isTRUE(byColumn)) || (byColumn >= 1L)){ + if(is.numeric(byColumn)){ + # split the data up and iterate over each "chunk" of data + } else { + # We need to plot the first "panel" here because the plot area is + # set up based on the code above lenv <- new.env() - lenv$xdata <- cs$Env$R[,i][subset] - lenv$name <- cs$Env$column_names[i] - lenv$ylim <- range(cs$Env$R[subset]) + lenv$xdata <- cs$Env$R[,1][subset] + lenv$name <- cs$Env$colum_names[1] + #lenv$ymax <- range(cs$Env$R[subset])[2] lenv$type <- cs$Env$type + exp <- expression(chart.lines(xdata, type=type)) + #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) + # Add expression for the main plot + cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) - # Add a small frame for the time series info - cs$add_frame(ylim=c(0,1),asp=0.2) - cs$next_frame() - text.exp <- expression(text(x=1, - y=0.5, - labels=name, - adj=c(0,0),cex=0.9,offset=0,pos=4)) - cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) - - # Add the frame for the sub-plots - # Set the ylim based on the (potentially) transformed data in cs$Env$R - cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) - cs$next_frame() - - exp <- expression(chart.lines(xdata[xsubset], type=type)) - - # define function to plot the y-axis grid lines - lenv$y_grid_lines <- function(ylim) { - #pretty(range(xdata[xsubset])) - p <- pretty(ylim,10) - p[p > ylim[1] & p < ylim[2]] + for(i in 2:NCOL(x)){ + # create a local environment + lenv <- new.env() + lenv$xdata <- cs$Env$R[,i][subset] + lenv$name <- cs$Env$column_names[i] + lenv$ylim <- range(cs$Env$R[subset]) + lenv$type <- cs$Env$type + + # Add a small frame for the time series info + cs$add_frame(ylim=c(0,1),asp=0.2) + cs$next_frame() + text.exp <- expression(text(x=1, + y=0.5, + labels=name, + adj=c(0,0),cex=0.9,offset=0,pos=4)) + cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) + + # Add the frame for the sub-plots + # Set the ylim based on the (potentially) transformed data in cs$Env$R + cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$next_frame() + + exp <- expression(chart.lines(xdata[xsubset], type=type)) + + # define function to plot the y-axis grid lines + lenv$y_grid_lines <- function(ylim) { + #pretty(range(xdata[xsubset])) + p <- pretty(ylim,10) + p[p > ylim[1] & p < ylim[2]] + } + + exp <- c( + # y-axis grid lines + expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), + col=theme$grid)), # add y-axis grid lines + exp, # NOTE 'exp' was defined earlier + # 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,offset=0,pos=4,cex=0.9, xpd=TRUE)), + expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), + noquote(format(y_grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), + # x-axis grid lines + expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(atbt, #axTicksByTime2(xdata[xsubset]), + ylim[1], + atbt, #axTicksByTime2(xdata[xsubset]), + ylim[2], col=theme$grid))) + cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } - - exp <- c( - # y-axis grid lines - expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), - col=theme$grid)), # add y-axis grid lines - exp, # NOTE 'exp' was defined earlier - # 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,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), - noquote(format(y_grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - # x-axis grid lines - expression(atbt <- axTicksByTime2(xdata[xsubset]), - segments(atbt, #axTicksByTime2(xdata[xsubset]), - ylim[1], - atbt, #axTicksByTime2(xdata[xsubset]), - ylim[2], col=theme$grid))) - cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } } else { cs$add(expression(chart.lines(R[xsubset], type=type)),expr=TRUE) @@ -462,7 +466,6 @@ .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] - print(head(ta.y)) chart.lines(ta.y, colorset=col, type=type) } } @@ -540,11 +543,11 @@ plot_object } #}}} -addReturns <- function(){ +addReturns <- function(type="l"){ # This just plots the raw returns data lenv <- new.env() lenv$name <- "Returns" - lenv$plot_returns <- function(x) { + lenv$plot_returns <- function(x, type) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset # Add x-axis grid lines @@ -553,21 +556,24 @@ axTicksByTime2(xdata[xsubset]), par("usr")[4], col=x$Env$theme$grid) - chart.lines(xdata[xsubset]) + chart.lines(xdata[xsubset], type=type) } - #mapply(function(name,value) { assign(name,value,envir=lenv) }, - # names(list(geometric=geometric,...)), - # list(geometric=geometric,...)) + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(type=type)), + list(type=type)) exp <- parse(text=gsub("list","plot_returns", - as.expression(substitute(list(x=current.xts_chob())))), + as.expression(substitute(list(x=current.xts_chob(), + type=type)))), srcfile=NULL) plot_object <- current.xts_chob() + xdata <- plot_object$Env$xdata - #xsubset <- plot_object$Env$xsubset lenv$xdata <- xdata + lenv$xsubset <- plot_object$Env$xsubset lenv$col <- col + lenv$type <- type # add the frame for time series info plot_object$add_frame(ylim=c(0,1),asp=0.25) Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-15 20:03:23 UTC (rev 815) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-16 11:44:28 UTC (rev 816) @@ -1,73 +1,48 @@ library(xtsExtra) library(PerformanceAnalytics) +source("sandbox/paFUN.R") - data(edhec) -R <- edhec[,1:2] +R <- edhec[,1:4] -chart.TimeSeries(R) +# basic plot with defaults plot2_xts(R) -charts.TimeSeries(R) -# charts.TimeSeries messes up par("mar") so I need to call dev.off() -dev.off() -# the titles are gett +# assign to a variable and then print it results in a plot +x <- plot2_xts(R) +class(x) +x + +# small multiples, line plot of each column plot2_xts(R, byColumn=TRUE) -chart.Bar(R[,1]) +# bar chart of returns plot2_xts(R[,1], type="h") -charts.Bar(R) -# charts.TimeSeries messes up par("mar") so I need to call dev.off() to reset -dev.off() +# bar chart of returns +# NOTE: only plots the first column of returns data +plot2_xts(R, type="h") + +# small multiples, bar chart of each column plot2_xts(R, byColumn=TRUE, type="h") -# Replicates charts.PerformanceSummary +# Replicate charts.PerformanceSummary plot2_xts(R, mainPanel=list(name="CumReturns")) -addReturns() +addReturns(type="h") addDrawdowns() -plot2_xts(R) +# layout safe +# layout(matrix(1:4, 2, 2)) +# for(i in 1:4) {plot(plot2_xts(R[,i], type="h"))} +# layout(matrix(1)) + +# Rolling performance +plot2_xts(R, mainPanel=list(name="CumReturns")) addRollingPerformance() addRollingPerformance(FUN="StdDev.annualized") addRollingPerformance(FUN="SharpeRatio.annualized") -# The main title gets messed up when adding panels -# plot2_xts(R) -# x <- current.chob() -# ls.str(x) -# ls.str(x$Env) -# -# addDrawdowns() -# addDrawdowns() -# x <- current.chob() -# ls.str(x) -# ls.str(x$Env) -# -# -# chart.TimeSeries(R, auto.grid=FALSE) -# plot2_xts(R, auto.grid=FALSE) -# -# -# charts.TimeSeries(R) -# plot2_xts(R, byColumn=TRUE) -# title("Edhec Returns") -# -# cl <- chartLayout(matrix(1:5), 1, c(2,2,1,1,1)) -# plot2_xts(R, byColumn=TRUE, layout=cl) -# title("Edhec Returns") -# -# x <- current.chob() -# Get the structure of the environments -# ls.str(x) -# ls.str(x$Env) - -# getSymbols("YHOO", src="yahoo") -# chart_Series(YHOO) -# add_RSI() -# add_MACD() - ##### 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? @@ -81,11 +56,5 @@ # 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 for -# frame -# asp -# clip - # http://www.lemnica.com/esotericR/Introducing-Closures/ From noreply at r-forge.r-project.org Thu Jul 17 00:05:27 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Jul 2014 00:05:27 +0200 (CEST) Subject: [Xts-commits] r817 - pkg/xtsExtra/R Message-ID: <20140716220527.EAD4F187323@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-17 00:05:27 +0200 (Thu, 17 Jul 2014) New Revision: 817 Modified: pkg/xtsExtra/R/plot2.R Log: Adding support for small multiples with pages Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-16 11:44:28 UTC (rev 816) +++ pkg/xtsExtra/R/plot2.R 2014-07-16 22:05:27 UTC (rev 817) @@ -78,6 +78,27 @@ clev=0, pars=chart_pars(), theme=xtsExtraTheme(), ...){ + + # Small multiples with multiple pages behavior occurs when byColumn is + # an integer. (i.e. bycolumn=2 means to iterate over the data in a step + # size of 2 and plot 2 panels on each page + # Make recursive calls and return + if(is.numeric(byColumn)){ + byColumn <- min(NCOL(x), byColumn) + idx <- seq.int(1L, NCOL(x), 1L) + chunks <- split(idx, ceiling(seq_along(idx)/byColumn)) + for(i in 1:length(chunks)){ + tmp <- chunks[[i]] + p <- plot2_xts(x=x[,tmp], mainPanel=mainPanel, panels=panels, + byColumn=TRUE, type=type, name=name, subset=subset, + clev=clev, pars=pars, theme=theme, ...=...) + if(i < length(chunks)) + print(p) + } + # NOTE: return here so we don't draw another chart + return(p) + } + cs <- new.replot_xts() #cex <- pars$cex #mar <- pars$mar @@ -190,7 +211,7 @@ cs$Env$R <- R } } else { - cs$Env$R <- R + cs$Env$R <- x } # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other @@ -247,7 +268,8 @@ expr=TRUE) # add name and start/end dates - cs$Env$name <- name + if(isTRUE(byColumn)) cs$Env$name <- cs$Env$column_names[1] else cs$Env$name <- name + text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)), expression(text(NROW(xdata[xsubset]),0.5, paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), @@ -280,73 +302,69 @@ # add main series cs$set_frame(2) - if((isTRUE(byColumn)) || (byColumn >= 1L)){ - if(is.numeric(byColumn)){ - # split the data up and iterate over each "chunk" of data - } else { - # We need to plot the first "panel" here because the plot area is - # set up based on the code above + if(isTRUE(byColumn)){ + # We need to plot the first "panel" here because the plot area is + # set up based on the code above + lenv <- new.env() + lenv$xdata <- cs$Env$R[,1][subset] + lenv$name <- cs$Env$colum_names[1] + #lenv$ymax <- range(cs$Env$R[subset])[2] + lenv$type <- cs$Env$type + exp <- expression(chart.lines(xdata, type=type)) + #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) + # Add expression for the main plot + cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) + + for(i in 2:NCOL(x)){ + # create a local environment lenv <- new.env() - lenv$xdata <- cs$Env$R[,1][subset] - lenv$name <- cs$Env$colum_names[1] - #lenv$ymax <- range(cs$Env$R[subset])[2] + lenv$xdata <- cs$Env$R[,i][subset] + lenv$name <- cs$Env$column_names[i] + lenv$ylim <- range(cs$Env$R[subset]) lenv$type <- cs$Env$type - exp <- expression(chart.lines(xdata, type=type)) - #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) - # Add expression for the main plot - cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) - for(i in 2:NCOL(x)){ - # create a local environment - lenv <- new.env() - lenv$xdata <- cs$Env$R[,i][subset] - lenv$name <- cs$Env$column_names[i] - lenv$ylim <- range(cs$Env$R[subset]) - lenv$type <- cs$Env$type - - # Add a small frame for the time series info - cs$add_frame(ylim=c(0,1),asp=0.2) - cs$next_frame() - text.exp <- expression(text(x=1, - y=0.5, - labels=name, - adj=c(0,0),cex=0.9,offset=0,pos=4)) - cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) - - # Add the frame for the sub-plots - # Set the ylim based on the (potentially) transformed data in cs$Env$R - cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) - cs$next_frame() - - exp <- expression(chart.lines(xdata[xsubset], type=type)) - - # define function to plot the y-axis grid lines - lenv$y_grid_lines <- function(ylim) { - #pretty(range(xdata[xsubset])) - p <- pretty(ylim,10) - p[p > ylim[1] & p < ylim[2]] - } - - exp <- c( - # y-axis grid lines - expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), - col=theme$grid)), # add y-axis grid lines - exp, # NOTE 'exp' was defined earlier - # 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,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), - noquote(format(y_grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - # x-axis grid lines - expression(atbt <- axTicksByTime2(xdata[xsubset]), - segments(atbt, #axTicksByTime2(xdata[xsubset]), - ylim[1], - atbt, #axTicksByTime2(xdata[xsubset]), - ylim[2], col=theme$grid))) - cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) + # Add a small frame for the time series info + cs$add_frame(ylim=c(0,1),asp=0.2) + cs$next_frame() + text.exp <- expression(text(x=1, + y=0.5, + labels=name, + adj=c(0,0),cex=0.9,offset=0,pos=4)) + cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) + + # Add the frame for the sub-plots + # Set the ylim based on the (potentially) transformed data in cs$Env$R + cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$next_frame() + + exp <- expression(chart.lines(xdata[xsubset], type=type)) + + # define function to plot the y-axis grid lines + lenv$y_grid_lines <- function(ylim) { + #pretty(range(xdata[xsubset])) + p <- pretty(ylim,10) + p[p > ylim[1] & p < ylim[2]] } + + exp <- c( + # y-axis grid lines + expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), + col=theme$grid)), # add y-axis grid lines + exp, # NOTE 'exp' was defined earlier + # 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,offset=0,pos=4,cex=0.9, xpd=TRUE)), + expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), + noquote(format(y_grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), + # x-axis grid lines + expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(atbt, #axTicksByTime2(xdata[xsubset]), + ylim[1], + atbt, #axTicksByTime2(xdata[xsubset]), + ylim[2], col=theme$grid))) + cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } } else { cs$add(expression(chart.lines(R[xsubset], type=type)),expr=TRUE) From noreply at r-forge.r-project.org Thu Jul 17 00:46:16 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Jul 2014 00:46:16 +0200 (CEST) Subject: [Xts-commits] r818 - in pkg/xtsExtra: R sandbox Message-ID: <20140716224616.8D3D5185ECD@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-17 00:46:15 +0200 (Thu, 17 Jul 2014) New Revision: 818 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: Adding panels and more examples to test_plot2 Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-16 22:05:27 UTC (rev 817) +++ pkg/xtsExtra/R/plot2.R 2014-07-16 22:46:15 UTC (rev 818) @@ -201,7 +201,7 @@ args <- mainPanel$args .formals <- formals(FUN) .formals <- modify.args(formals=.formals, arglist=args, dots=TRUE) - if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=R, dots=TRUE) + if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=x, dots=TRUE) .formals$... <- NULL R <- try(do.call(FUN, .formals), silent=TRUE) if(inherits(R, "try-error")) { @@ -368,24 +368,22 @@ } } else { cs$add(expression(chart.lines(R[xsubset], type=type)),expr=TRUE) + assign(".xts_chob", cs, .plotxtsEnv) } - assign(".xts_chob", cs, .plotxtsEnv) # Plot the panels or default to a simple line chart - #if(!is.null(panel) && nchar(panel) > 0) { - # panel <- parse(text=panel, srcfile=NULL) - # for( p in 1:length(panel)) { - # if(length(panel[p][[1]][-1]) > 0) { - # cs <- eval(panel[p]) - # } else { - # cs <- eval(panel[p]) - # } - # } - #} else { - # cs$add(expression(chart.lines(xdata[xsubset])),expr=TRUE) - #} - # assign(".xts_chob", cs, .plotxtsEnv) - + if(!is.null(panels) && nchar(panels) > 0) { + panels <- parse(text=panels, srcfile=NULL) + for( p in 1:length(panels)) { + if(length(panels[p][[1]][-1]) > 0) { + cs <- eval(panels[p]) + } else { + cs <- eval(panels[p]) + } + } + } + + assign(".xts_chob", cs, .plotxtsEnv) cs } #}}} Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-16 22:05:27 UTC (rev 817) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-16 22:46:15 UTC (rev 818) @@ -8,6 +8,9 @@ # basic plot with defaults plot2_xts(R) +plot2_xts(R, mainPanel=list(name="CumReturns"), + panels=c("addReturns(type='h')", "addDrawdowns()")) + # assign to a variable and then print it results in a plot x <- plot2_xts(R) class(x) @@ -16,6 +19,12 @@ # small multiples, line plot of each column plot2_xts(R, byColumn=TRUE) +layout(matrix(1:2)) +plot2_xts(R, byColumn=2) +layout(matrix(1)) + +plot2_xts(R[,1]) + # bar chart of returns plot2_xts(R[,1], type="h") @@ -31,10 +40,24 @@ addReturns(type="h") addDrawdowns() +# Replicate charts.Performance Summary in a 2x2 layout +# y-axis range here can be deceiving +layout(matrix(1:4, 2, 2)) +for(i in 1:ncol(R)){ + p <- plot2_xts(R[,i], mainPanel=list(name="CumReturns"), + panels=c("addReturns(type='h')", "addDrawdowns()"), + name=colnames(R)[i]) + print(p) +} +layout(matrix(1)) + +# make chart specifications simple functions that return expressions to +# evaluate just like panels + # layout safe -# layout(matrix(1:4, 2, 2)) -# for(i in 1:4) {plot(plot2_xts(R[,i], type="h"))} -# layout(matrix(1)) +layout(matrix(1:4, 2, 2)) +for(i in 1:4) {plot(plot2_xts(R[,i], type="h"))} +layout(matrix(1)) # Rolling performance plot2_xts(R, mainPanel=list(name="CumReturns")) From noreply at r-forge.r-project.org Thu Jul 17 23:39:33 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 17 Jul 2014 23:39:33 +0200 (CEST) Subject: [Xts-commits] r819 - in pkg/xtsExtra: R sandbox Message-ID: <20140717213933.B8DE1184499@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-17 23:39:32 +0200 (Thu, 17 Jul 2014) New Revision: 819 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: Revisions for consistency of y-axis limits and labels for small multiples with multiple pages. Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-16 22:46:15 UTC (rev 818) +++ pkg/xtsExtra/R/plot2.R 2014-07-17 21:39:32 UTC (rev 819) @@ -11,9 +11,11 @@ list(cex=0.6, mar=c(3,2,0,2)) } # }}} -chart.lines <- function(x, colorset=1:12, type="l"){ +chart.lines <- function(x, type="l", colorset=1:10, up.col=NULL, dn.col=NULL){ + if(is.null(up.col)) up.col <- "green" + if(is.null(dn.col)) dn.col <- "red" if(type == "h"){ - colors <- ifelse(x[,1] < 0, "darkred", "darkgreen") + colors <- ifelse(x[,1] < 0, dn.col, up.col) lines(1:NROW(x),x[,1],lwd=2,col=colors,lend=1,lty=1,type="h") } else { for(i in 1:NCOL(x)){ @@ -55,9 +57,10 @@ labels="#333333", line.col="darkorange", dn.col="red", - up.col=NA, + up.col="green", dn.border="#333333", - up.border="#333333"), + up.border="#333333", + colorset=1:10), shading=1, format.labels=TRUE, coarse.time=TRUE, @@ -77,6 +80,7 @@ subset="", clev=0, pars=chart_pars(), theme=xtsExtraTheme(), + ylim=NULL, ...){ # Small multiples with multiple pages behavior occurs when byColumn is @@ -87,11 +91,23 @@ byColumn <- min(NCOL(x), byColumn) idx <- seq.int(1L, NCOL(x), 1L) chunks <- split(idx, ceiling(seq_along(idx)/byColumn)) + + if(!is.null(panels) && nchar(panels) > 0){ + # we will plot the panels, but not plot the returns by column + byColumn <- FALSE + } else { + # we will plot the returns by column, but not the panels + byColumn <- TRUE + panels <- NULL + mainPanel <- NULL + ylim <- range(na.omit(x[subset])) + } + for(i in 1:length(chunks)){ tmp <- chunks[[i]] p <- plot2_xts(x=x[,tmp], mainPanel=mainPanel, panels=panels, - byColumn=TRUE, type=type, name=name, subset=subset, - clev=clev, pars=pars, theme=theme, ...=...) + byColumn=byColumn, type=type, name=name, subset=subset, + clev=clev, pars=pars, theme=theme, ylim=ylim, ...=...) if(i < length(chunks)) print(p) } @@ -165,6 +181,7 @@ cs$Env$theme$dn.col <- dn.col cs$Env$theme$up.border <- up.border cs$Env$theme$dn.border <- dn.border + cs$Env$theme$colorset <- theme$col$colorset cs$Env$theme$rylab <- theme$rylab cs$Env$theme$lylab <- theme$lylab cs$Env$theme$bg <- theme$col$bg @@ -214,18 +231,20 @@ cs$Env$R <- x } - # xlim and ylim are set based on cs$Env$xdata[subset]. How do we handle other - # transformations (e.g. cumulative returns, correlations, etc.) as the - # main panel? # Set xlim based on the raw returns data passed into function cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) # Set ylim based on the transformed data # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or # which is best. - cs$set_ylim(list(structure(range(na.omit(cs$Env$R[subset])),fixed=TRUE))) + if(is.null(ylim)){ + cs$set_ylim(list(structure(range(na.omit(cs$Env$R[subset])),fixed=TRUE))) + cs$Env$constant_ylim <- range(na.omit(cs$Env$R[subset])) + } else { + cs$set_ylim(list(structure(ylim, fixed=TRUE))) + cs$Env$constant_ylim <- ylim + } - cs$set_frame(1,FALSE) # axis_ticks function to label lower frequency ranges/grid lines cs$Env$axis_ticks <- function(xdata,xsubset) { @@ -268,7 +287,8 @@ expr=TRUE) # add name and start/end dates - if(isTRUE(byColumn)) cs$Env$name <- cs$Env$column_names[1] else cs$Env$name <- name + if((isTRUE(byColumn)) | (byColumn == 1) | (NCOL(x) == 1)) + cs$Env$name <- cs$Env$column_names[1] else cs$Env$name <- name text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)), expression(text(NROW(xdata[xsubset]),0.5, @@ -278,26 +298,36 @@ cs$set_frame(2) # define function for y-axis labels - cs$Env$grid_lines <- function(xdata, xsubset) { - ylim <- range(xdata[xsubset]) - p <- pretty(ylim, 10) + #cs$Env$grid_lines <- function(xdata, xsubset) { + # ylim <- range(xdata[xsubset]) + # p <- pretty(ylim, 5) + # p[p > ylim[1] & p < ylim[2]] + #} + + cs$Env$y_grid_lines <- function(ylim) { + #pretty(range(xdata[xsubset])) + p <- pretty(ylim,5) p[p > ylim[1] & p < ylim[2]] } # add y-axis grid lines and labels - exp <- c( - # y-axis grid lines - expression(segments(1, grid_lines(R,xsubset), NROW(xdata[xsubset]), grid_lines(R,xsubset), - col=theme$grid)), - # left y-axis labels - expression(text(1-1/3-max(strwidth(grid_lines(R,xsubset))), grid_lines(R,xsubset), - noquote(format(grid_lines(R,xsubset), justify="right")), - col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE)), - # right y-axis labels - expression(text(NROW(R[xsubset])+1/3, grid_lines(R,xsubset), - noquote(format(grid_lines(R,xsubset), justify="right")), - col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE)) - ) + exp <- expression(segments(1, y_grid_lines(constant_ylim), NROW(xdata[xsubset]), + y_grid_lines(constant_ylim), col=theme$grid)) + if(theme$lylab){ + exp <- c(exp, + # left y-axis labels + expression(text(1-1/3-max(strwidth(y_grid_lines(constant_ylim))), + y_grid_lines(constant_ylim), + noquote(format(y_grid_lines(constant_ylim), justify="right")), + col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE))) + } + if(theme$rylab){ + exp <- c(exp, + # right y-axis labels + expression(text(NROW(R[xsubset])+1/3, y_grid_lines(constant_ylim), + noquote(format(y_grid_lines(constant_ylim), justify="right")), + col=theme$labels, offset=0, pos=4, cex=0.9, xpd=TRUE))) + } cs$add(exp, env=cs$Env, expr=TRUE) # add main series @@ -310,64 +340,79 @@ lenv$name <- cs$Env$colum_names[1] #lenv$ymax <- range(cs$Env$R[subset])[2] lenv$type <- cs$Env$type - exp <- expression(chart.lines(xdata, type=type)) + exp <- expression(chart.lines(xdata, type=type, colorset=theme$colorset, + up.col=theme$up.col, dn.col=theme$dn.col)) #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) # Add expression for the main plot cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) - for(i in 2:NCOL(x)){ - # create a local environment - lenv <- new.env() - lenv$xdata <- cs$Env$R[,i][subset] - lenv$name <- cs$Env$column_names[i] - lenv$ylim <- range(cs$Env$R[subset]) - lenv$type <- cs$Env$type - - # Add a small frame for the time series info - cs$add_frame(ylim=c(0,1),asp=0.2) - cs$next_frame() - text.exp <- expression(text(x=1, - y=0.5, - labels=name, - adj=c(0,0),cex=0.9,offset=0,pos=4)) - cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) - - # Add the frame for the sub-plots - # Set the ylim based on the (potentially) transformed data in cs$Env$R - cs$add_frame(ylim=range(cs$Env$R[cs$Env$xsubset]), asp=NCOL(cs$Env$xdata), fixed=TRUE) - cs$next_frame() - - exp <- expression(chart.lines(xdata[xsubset], type=type)) - - # define function to plot the y-axis grid lines - lenv$y_grid_lines <- function(ylim) { - #pretty(range(xdata[xsubset])) - p <- pretty(ylim,10) - p[p > ylim[1] & p < ylim[2]] + if(NCOL(cs$Env$xdata) > 1){ + for(i in 2:NCOL(cs$Env$xdata)){ + # create a local environment + lenv <- new.env() + lenv$xdata <- cs$Env$R[,i][subset] + lenv$name <- cs$Env$column_names[i] + lenv$ylim <- cs$Env$constant_ylim + lenv$type <- cs$Env$type + + # Add a small frame for the time series info + cs$add_frame(ylim=c(0,1),asp=0.2) + cs$next_frame() + text.exp <- expression(text(x=1, + y=0.5, + labels=name, + adj=c(0,0),cex=0.9,offset=0,pos=4)) + cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) + + # Add the frame for the sub-plots + # Set the ylim based on the (potentially) transformed data in cs$Env$R + cs$add_frame(ylim=cs$Env$constant_ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$next_frame() + + exp <- expression(chart.lines(xdata[xsubset], type=type, + colorset=theme$colorset, + up.col=theme$up.col, + dn.col=theme$dn.col)) + + # 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)), + # x-axis grid lines + expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(atbt, #axTicksByTime2(xdata[xsubset]), + ylim[1], + atbt, #axTicksByTime2(xdata[xsubset]), + ylim[2], col=theme$grid))) + if(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,offset=0,pos=4,cex=0.9, xpd=TRUE))) + } + if(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,offset=0,pos=4,cex=0.9, xpd=TRUE))) + } + cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) } - - exp <- c( - # y-axis grid lines - expression(segments(1,y_grid_lines(ylim),NROW(xdata[xsubset]), y_grid_lines(ylim), - col=theme$grid)), # add y-axis grid lines - exp, # NOTE 'exp' was defined earlier - # 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,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(NROW(xdata[xsubset])+1/3, y_grid_lines(ylim), - noquote(format(y_grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - # x-axis grid lines - expression(atbt <- axTicksByTime2(xdata[xsubset]), - segments(atbt, #axTicksByTime2(xdata[xsubset]), - ylim[1], - atbt, #axTicksByTime2(xdata[xsubset]), - ylim[2], col=theme$grid))) - cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) - } + } } else { - cs$add(expression(chart.lines(R[xsubset], type=type)),expr=TRUE) + cs$add(expression(chart.lines(R[xsubset], type=type, + colorset=theme$colorset, + up.col=theme$up.col, + dn.col=theme$dn.col)),expr=TRUE) assign(".xts_chob", cs, .plotxtsEnv) } @@ -387,20 +432,21 @@ cs } #}}} -addDrawdowns <- function(geometric=TRUE, col=1, ...){ +addDrawdowns <- function(geometric=TRUE, ylim=NULL, ...){ lenv <- new.env() lenv$name <- "Drawdowns" lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset + colorset <- x$Env$theme$colorset # Add x-axis grid lines segments(axTicksByTime2(xdata[xsubset]), par("usr")[3], axTicksByTime2(xdata[xsubset]), par("usr")[4], col=x$Env$theme$grid) - drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric) - chart.lines(drawdowns) + drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] + chart.lines(drawdowns, type="l", colorset=colorset) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(geometric=geometric,...)), @@ -412,40 +458,41 @@ plot_object <- current.xts_chob() xdata <- plot_object$Env$xdata - #xsubset <- plot_object$Env$xsubset + xsubset <- plot_object$Env$xsubset drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) lenv$xdata <- drawdowns - lenv$col <- col # 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=c(1,1+strwidth(name)), - y=0.3, - labels=c(name,""), - 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=name, + 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 - plot_object$add_frame(ylim=range(na.omit(drawdowns)),asp=1,fixed=TRUE) + if(is.null(ylim)) { + ylim <- range(na.omit(lenv$xdata[xsubset])) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() - lenv$grid_lines <- function(xdata,xsubset) { - ylim <- range(xdata[xsubset]) - p <- pretty(ylim, 10) + lenv$grid_lines <- function(ylim) { + #ylim <- range(xdata[xsubset]) + p <- pretty(ylim, 5) p[p > ylim[1] & p < ylim[2]] } # add y-axis gridlines and labels - exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset), + exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]),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(xdata,xsubset))),grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(1-1/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(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(NROW(xdata[xsubset])+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) plot_object @@ -559,20 +606,23 @@ plot_object } #}}} -addReturns <- function(type="l"){ +addReturns <- function(type="h", name=NULL, ylim=NULL){ # This just plots the raw returns data lenv <- new.env() - lenv$name <- "Returns" + if(is.null(name)) lenv$name <- "Returns" else lenv$name <- name lenv$plot_returns <- function(x, type) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset + colorset <- x$Env$theme$colorset + up.col <- x$Env$theme$up.col + dn.col <- x$Env$theme$dn.col # Add x-axis grid lines segments(axTicksByTime2(xdata[xsubset]), par("usr")[3], axTicksByTime2(xdata[xsubset]), par("usr")[4], col=x$Env$theme$grid) - chart.lines(xdata[xsubset], type=type) + chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(type=type)), @@ -584,52 +634,60 @@ plot_object <- current.xts_chob() + # get the raw returns data xdata <- plot_object$Env$xdata + xsubset <- plot_object$Env$xsubset + # add data to the local environment lenv$xdata <- xdata - lenv$xsubset <- plot_object$Env$xsubset + lenv$xsubset <- xsubset lenv$col <- col lenv$type <- type # 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=name, + text.exp <- expression(text(x=1, y=0.3, labels=name, 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 data - plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1,fixed=TRUE) + if(is.null(ylim)) { + ylim <- range(na.omit(lenv$xdata[xsubset])) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() - lenv$grid_lines <- function(xdata,xsubset) { - ylim <- range(xdata[xsubset]) - p <- pretty(ylim, 10) + lenv$grid_lines <- function(ylim) { + #ylim <- range(xdata[xsubset]) + p <- pretty(ylim, 5) p[p > ylim[1] & p < ylim[2]] } # add y-axis gridlines and labels - exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset), - col=theme$grid)), + exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]), + 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(xdata,xsubset))),grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(1-1/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(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(NROW(xdata[xsubset])+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) plot_object } -addRollingPerformance <- function(width=12, FUN="Return.annualized", fill=NA, ...){ +addRollingPerformance <- function(width=12, FUN="Return.annualized", fill=NA, ylim=NULL, ...){ lenv <- new.env() lenv$name <- paste("Rolling", FUN) lenv$plot_performance <- function(x, width, FUN, fill, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset + colorset <- x$Env$theme$colorset + up.col <- x$Env$theme$up.col + dn.col <- x$Env$theme$dn.col # Add x-axis grid lines segments(axTicksByTime2(xdata[xsubset]), par("usr")[3], @@ -637,7 +695,7 @@ par("usr")[4], col=x$Env$theme$grid) rolling_performance <- RollingPerformance(R=xdata, width=width, FUN=FUN, fill=fill, ...=...) - chart.lines(rolling_performance) + chart.lines(rolling_performance, type="l", colorset=colorset, up.col=up.col, dn.col=dn.col) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(width=width, FUN=FUN, fill=fill, ...)), @@ -649,7 +707,7 @@ plot_object <- current.xts_chob() xdata <- plot_object$Env$xdata - #xsubset <- plot_object$Env$xsubset + xsubset <- plot_object$Env$xsubset rolling_performance <- RollingPerformance(R=plot_object$Env$xdata, width=width, FUN=FUN, ...=..., fill=fill) lenv$xdata <- rolling_performance @@ -658,31 +716,33 @@ # 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=name, + text.exp <- expression(text(x=1, y=0.3, labels=name, 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 - plot_object$add_frame(ylim=range(na.omit(rolling_performance)),asp=1,fixed=TRUE) + if(is.null(ylim)) { + ylim <- range(na.omit(lenv$xdata[xsubset])) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() - lenv$grid_lines <- function(xdata,xsubset) { - ylim <- range(na.omit(xdata[xsubset])) - p <- pretty(ylim, 10) + lenv$grid_lines <- function(ylim) { + #ylim <- range(na.omit(xdata[xsubset])) + p <- pretty(ylim, 5) p[p > ylim[1] & p < ylim[2]] } # add y-axis gridlines and labels - exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset), - col=theme$grid)), + exp <- c(expression(segments(1,grid_lines(ylim),NROW(xdata[xsubset]), + 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(xdata,xsubset))),grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(1-1/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(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset), - noquote(format(grid_lines(xdata,xsubset),justify="right")), + expression(text(NROW(xdata[xsubset])+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) plot_object Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-16 22:46:15 UTC (rev 818) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-17 21:39:32 UTC (rev 819) @@ -8,9 +8,6 @@ # basic plot with defaults plot2_xts(R) -plot2_xts(R, mainPanel=list(name="CumReturns"), - panels=c("addReturns(type='h')", "addDrawdowns()")) - # assign to a variable and then print it results in a plot x <- plot2_xts(R) class(x) @@ -20,7 +17,7 @@ plot2_xts(R, byColumn=TRUE) layout(matrix(1:2)) -plot2_xts(R, byColumn=2) +plot2_xts(R, byColumn=2, type="h") layout(matrix(1)) plot2_xts(R[,1]) @@ -40,6 +37,15 @@ addReturns(type="h") addDrawdowns() + +plot2_xts(R, mainPanel=list(name="CumReturns"), + panels=c("addReturns(type='h')", "addDrawdowns()")) + +layout(matrix(1:4, 2, 2)) +plot2_xts(R, byColumn=1, mainPanel=list(name="CumReturns"), + panels=c("addReturns(type='h')", "addDrawdowns()")) +layout(matrix(1)) + # Replicate charts.Performance Summary in a 2x2 layout # y-axis range here can be deceiving layout(matrix(1:4, 2, 2)) @@ -51,14 +57,17 @@ } layout(matrix(1)) -# make chart specifications simple functions that return expressions to -# evaluate just like panels - -# layout safe +# layout safe: loop over returns layout(matrix(1:4, 2, 2)) for(i in 1:4) {plot(plot2_xts(R[,i], type="h"))} layout(matrix(1)) +# layout safe: easier to specify byColumn=1 +# NOTE: y-axis matches even with multiple pages (i.e. graphics devices) +layout(matrix(1:4, 2, 2)) +plot2_xts(R, byColumn=1, type="h") +layout(matrix(1)) + # Rolling performance plot2_xts(R, mainPanel=list(name="CumReturns")) addRollingPerformance() From noreply at r-forge.r-project.org Fri Jul 18 23:44:54 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 18 Jul 2014 23:44:54 +0200 (CEST) Subject: [Xts-commits] r820 - pkg/xtsExtra/sandbox Message-ID: <20140718214454.CDEF21859EF@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-18 23:44:54 +0200 (Fri, 18 Jul 2014) New Revision: 820 Modified: pkg/xtsExtra/sandbox/test_plot2.R Log: Adding required package to script in sandbox Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-17 21:39:32 UTC (rev 819) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-18 21:44:54 UTC (rev 820) @@ -1,5 +1,6 @@ library(xtsExtra) library(PerformanceAnalytics) +library(quantmod) source("sandbox/paFUN.R") data(edhec) From noreply at r-forge.r-project.org Tue Jul 22 19:35:00 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 22 Jul 2014 19:35:00 +0200 (CEST) Subject: [Xts-commits] r821 - in pkg/xtsExtra: R sandbox Message-ID: <20140722173501.0B12E1872A6@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-22 19:35:00 +0200 (Tue, 22 Jul 2014) New Revision: 821 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: Revisions to use FUN instead of mainPanel Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-18 21:44:54 UTC (rev 820) +++ pkg/xtsExtra/R/plot2.R 2014-07-22 17:35:00 UTC (rev 821) @@ -72,7 +72,7 @@ } plot2_xts <- function(x, - mainPanel=NULL, + FUN=NULL, panels=NULL, byColumn=FALSE, type="l", @@ -99,13 +99,13 @@ # we will plot the returns by column, but not the panels byColumn <- TRUE panels <- NULL - mainPanel <- NULL + FUN <- NULL ylim <- range(na.omit(x[subset])) } for(i in 1:length(chunks)){ tmp <- chunks[[i]] - p <- plot2_xts(x=x[,tmp], mainPanel=mainPanel, panels=panels, + p <- plot2_xts(x=x[,tmp], FUN=FUN, panels=panels, byColumn=byColumn, type=type, name=name, subset=subset, clev=clev, pars=pars, theme=theme, ylim=ylim, ...=...) if(i < length(chunks)) @@ -213,16 +213,15 @@ # Compute transformation if specified by panel argument # rough prototype for calling a function for the main "panel" - if(!is.null(mainPanel)){ - FUN <- match.fun(mainPanel$name) - args <- mainPanel$args - .formals <- formals(FUN) - .formals <- modify.args(formals=.formals, arglist=args, dots=TRUE) + if(!is.null(FUN)){ + fun <- match.fun(FUN) + .formals <- formals(fun) + .formals <- modify.args(formals=.formals, arglist=list(...), dots=TRUE) if("R" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, R=x, dots=TRUE) .formals$... <- NULL - R <- try(do.call(FUN, .formals), silent=TRUE) + R <- try(do.call(fun, .formals), silent=TRUE) if(inherits(R, "try-error")) { - message(paste("mainPanel function failed with message", R)) + message(paste("FUN function failed with message", R)) cs$Env$R <- x } else { cs$Env$R <- R Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-18 21:44:54 UTC (rev 820) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-22 17:35:00 UTC (rev 821) @@ -34,16 +34,16 @@ plot2_xts(R, byColumn=TRUE, type="h") # Replicate charts.PerformanceSummary -plot2_xts(R, mainPanel=list(name="CumReturns")) +plot2_xts(R, FUN="CumReturns") addReturns(type="h") addDrawdowns() -plot2_xts(R, mainPanel=list(name="CumReturns"), +plot2_xts(R, FUN="CumReturns", panels=c("addReturns(type='h')", "addDrawdowns()")) layout(matrix(1:4, 2, 2)) -plot2_xts(R, byColumn=1, mainPanel=list(name="CumReturns"), +plot2_xts(R, byColumn=1, FUN="CumReturns", panels=c("addReturns(type='h')", "addDrawdowns()")) layout(matrix(1)) @@ -51,7 +51,7 @@ # y-axis range here can be deceiving layout(matrix(1:4, 2, 2)) for(i in 1:ncol(R)){ - p <- plot2_xts(R[,i], mainPanel=list(name="CumReturns"), + p <- plot2_xts(R[,i], FUN="CumReturns", panels=c("addReturns(type='h')", "addDrawdowns()"), name=colnames(R)[i]) print(p) @@ -70,7 +70,8 @@ layout(matrix(1)) # Rolling performance -plot2_xts(R, mainPanel=list(name="CumReturns")) +plot2_xts(R, FUN="CumReturns", geometric=FALSE) +plot2_xts(R, FUN="CumReturns", geometric=TRUE, wealth.index=TRUE) addRollingPerformance() addRollingPerformance(FUN="StdDev.annualized") addRollingPerformance(FUN="SharpeRatio.annualized") From noreply at r-forge.r-project.org Tue Jul 22 19:40:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 22 Jul 2014 19:40:01 +0200 (CEST) Subject: [Xts-commits] r822 - pkg/xtsExtra/R Message-ID: <20140722174001.CFA451841F0@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-22 19:40:01 +0200 (Tue, 22 Jul 2014) New Revision: 822 Modified: pkg/xtsExtra/R/plot2.R Log: substitute main for name Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-22 17:35:00 UTC (rev 821) +++ pkg/xtsExtra/R/plot2.R 2014-07-22 17:40:01 UTC (rev 822) @@ -76,7 +76,7 @@ panels=NULL, byColumn=FALSE, type="l", - name=deparse(substitute(x)), + main=deparse(substitute(x)), subset="", clev=0, pars=chart_pars(), theme=xtsExtraTheme(), @@ -106,7 +106,7 @@ for(i in 1:length(chunks)){ tmp <- chunks[[i]] p <- plot2_xts(x=x[,tmp], FUN=FUN, panels=panels, - byColumn=byColumn, type=type, name=name, subset=subset, + byColumn=byColumn, type=type, main=main, subset=subset, clev=clev, pars=pars, theme=theme, ylim=ylim, ...=...) if(i < length(chunks)) print(p) @@ -285,11 +285,11 @@ las=1,lwd.ticks=1,mgp=c(3,1.5,0),tcl=-0.4,cex.axis=.9)), expr=TRUE) - # add name and start/end dates + # add main and start/end dates if((isTRUE(byColumn)) | (byColumn == 1) | (NCOL(x) == 1)) - cs$Env$name <- cs$Env$column_names[1] else cs$Env$name <- name + cs$Env$main <- cs$Env$column_names[1] else cs$Env$main <- main - text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)), + 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, paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), col=1,adj=c(0,0),pos=2))) @@ -336,12 +336,12 @@ # set up based on the code above lenv <- new.env() lenv$xdata <- cs$Env$R[,1][subset] - lenv$name <- cs$Env$colum_names[1] + lenv$main <- cs$Env$colum_names[1] #lenv$ymax <- range(cs$Env$R[subset])[2] lenv$type <- cs$Env$type exp <- expression(chart.lines(xdata, type=type, colorset=theme$colorset, up.col=theme$up.col, dn.col=theme$dn.col)) - #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=name))) + #exp <- c(exp, expression(text(1, ymax, adj=c(0,0), pos=4, cex=0.9, offset=0, labels=main))) # Add expression for the main plot cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) @@ -350,7 +350,7 @@ # create a local environment lenv <- new.env() lenv$xdata <- cs$Env$R[,i][subset] - lenv$name <- cs$Env$column_names[i] + lenv$main <- cs$Env$column_names[i] lenv$ylim <- cs$Env$constant_ylim lenv$type <- cs$Env$type @@ -359,7 +359,7 @@ cs$next_frame() text.exp <- expression(text(x=1, y=0.5, - labels=name, + labels=main, adj=c(0,0),cex=0.9,offset=0,pos=4)) cs$add(text.exp, env=c(lenv,cs$Env), expr=TRUE) @@ -433,7 +433,7 @@ addDrawdowns <- function(geometric=TRUE, ylim=NULL, ...){ lenv <- new.env() - lenv$name <- "Drawdowns" + lenv$main <- "Drawdowns" lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset @@ -465,7 +465,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=name, + 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) @@ -498,11 +498,11 @@ } # based on quantmod::add_TA -addLines <- function(x, name="", order=NULL, on=NA, legend="auto", +addLines <- function(x, main="", order=NULL, on=NA, legend="auto", yaxis=list(NULL,NULL), col=1, type="l", ...) { lenv <- new.env() - lenv$name <- name + lenv$main <- main lenv$plot_ta <- function(x, ta, on, type, col,...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset @@ -563,7 +563,7 @@ plot_object$next_frame() text.exp <- expression(text(x=1, y=0.3, - labels=name, + 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) @@ -605,10 +605,10 @@ plot_object } #}}} -addReturns <- function(type="h", name=NULL, ylim=NULL){ +addReturns <- function(type="h", main=NULL, ylim=NULL){ # This just plots the raw returns data lenv <- new.env() - if(is.null(name)) lenv$name <- "Returns" else lenv$name <- name + if(is.null(main)) lenv$main <- "Returns" else lenv$main <- main lenv$plot_returns <- function(x, type) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset @@ -646,7 +646,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=name, + 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) @@ -680,7 +680,7 @@ addRollingPerformance <- function(width=12, FUN="Return.annualized", fill=NA, ylim=NULL, ...){ lenv <- new.env() - lenv$name <- paste("Rolling", FUN) + lenv$main <- paste("Rolling", FUN) lenv$plot_performance <- function(x, width, FUN, fill, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset @@ -715,7 +715,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=name, + text.exp <- expression(text(x=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) From noreply at r-forge.r-project.org Tue Jul 22 19:48:02 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 22 Jul 2014 19:48:02 +0200 (CEST) Subject: [Xts-commits] r823 - in pkg/xtsExtra: R sandbox Message-ID: <20140722174802.9118C187536@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-22 19:48:02 +0200 (Tue, 22 Jul 2014) New Revision: 823 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: substitute multi.panel for byColumn Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-22 17:40:01 UTC (rev 822) +++ pkg/xtsExtra/R/plot2.R 2014-07-22 17:48:02 UTC (rev 823) @@ -74,7 +74,7 @@ plot2_xts <- function(x, FUN=NULL, panels=NULL, - byColumn=FALSE, + multi.panel=FALSE, type="l", main=deparse(substitute(x)), subset="", @@ -83,21 +83,21 @@ ylim=NULL, ...){ - # Small multiples with multiple pages behavior occurs when byColumn is - # an integer. (i.e. bycolumn=2 means to iterate over the data in a step + # Small multiples with multiple pages behavior occurs when multi.panel is + # an integer. (i.e. multi.panel=2 means to iterate over the data in a step # size of 2 and plot 2 panels on each page # Make recursive calls and return - if(is.numeric(byColumn)){ - byColumn <- min(NCOL(x), byColumn) + if(is.numeric(multi.panel)){ + multi.panel <- min(NCOL(x), multi.panel) idx <- seq.int(1L, NCOL(x), 1L) - chunks <- split(idx, ceiling(seq_along(idx)/byColumn)) + chunks <- split(idx, ceiling(seq_along(idx)/multi.panel)) if(!is.null(panels) && nchar(panels) > 0){ # we will plot the panels, but not plot the returns by column - byColumn <- FALSE + multi.panel <- FALSE } else { # we will plot the returns by column, but not the panels - byColumn <- TRUE + multi.panel <- TRUE panels <- NULL FUN <- NULL ylim <- range(na.omit(x[subset])) @@ -106,7 +106,7 @@ for(i in 1:length(chunks)){ tmp <- chunks[[i]] p <- plot2_xts(x=x[,tmp], FUN=FUN, panels=panels, - byColumn=byColumn, type=type, main=main, subset=subset, + multi.panel=multi.panel, type=type, main=main, subset=subset, clev=clev, pars=pars, theme=theme, ylim=ylim, ...=...) if(i < length(chunks)) print(p) @@ -166,7 +166,7 @@ environment(cs$subset) <- environment(cs$get_asp) # add theme and charting parameters to Env - if(byColumn){ + if(multi.panel){ cs$set_asp(NCOL(x)) } else { cs$set_asp(3) @@ -286,7 +286,7 @@ expr=TRUE) # add main and start/end dates - if((isTRUE(byColumn)) | (byColumn == 1) | (NCOL(x) == 1)) + 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)), @@ -331,7 +331,7 @@ # add main series cs$set_frame(2) - if(isTRUE(byColumn)){ + if(isTRUE(multi.panel)){ # We need to plot the first "panel" here because the plot area is # set up based on the code above lenv <- new.env() Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-22 17:40:01 UTC (rev 822) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-22 17:48:02 UTC (rev 823) @@ -15,10 +15,10 @@ x # small multiples, line plot of each column -plot2_xts(R, byColumn=TRUE) +plot2_xts(R, multi.panel=TRUE) layout(matrix(1:2)) -plot2_xts(R, byColumn=2, type="h") +plot2_xts(R, multi.panel=2, type="h") layout(matrix(1)) plot2_xts(R[,1]) @@ -31,7 +31,7 @@ plot2_xts(R, type="h") # small multiples, bar chart of each column -plot2_xts(R, byColumn=TRUE, type="h") +plot2_xts(R, multi.panel=TRUE, type="h") # Replicate charts.PerformanceSummary plot2_xts(R, FUN="CumReturns") @@ -43,7 +43,7 @@ panels=c("addReturns(type='h')", "addDrawdowns()")) layout(matrix(1:4, 2, 2)) -plot2_xts(R, byColumn=1, FUN="CumReturns", +plot2_xts(R, multi.panel=1, FUN="CumReturns", panels=c("addReturns(type='h')", "addDrawdowns()")) layout(matrix(1)) @@ -63,10 +63,10 @@ for(i in 1:4) {plot(plot2_xts(R[,i], type="h"))} layout(matrix(1)) -# layout safe: easier to specify byColumn=1 +# layout safe: easier to specify multi.panel=1 # NOTE: y-axis matches even with multiple pages (i.e. graphics devices) layout(matrix(1:4, 2, 2)) -plot2_xts(R, byColumn=1, type="h") +plot2_xts(R, multi.panel=1, type="h") layout(matrix(1)) # Rolling performance From noreply at r-forge.r-project.org Sat Jul 26 18:15:56 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 26 Jul 2014 18:15:56 +0200 (CEST) Subject: [Xts-commits] r824 - in pkg/xtsExtra: R sandbox Message-ID: <20140726161556.DF2F7184220@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-26 18:15:55 +0200 (Sat, 26 Jul 2014) New Revision: 824 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/sandbox/test_plot2.R Log: adding argument for easier way to control y-axis with multi panel plots Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-22 17:48:02 UTC (rev 823) +++ pkg/xtsExtra/R/plot2.R 2014-07-26 16:15:55 UTC (rev 824) @@ -81,6 +81,7 @@ clev=0, pars=chart_pars(), theme=xtsExtraTheme(), ylim=NULL, + y.axis.same=TRUE, ...){ # Small multiples with multiple pages behavior occurs when multi.panel is @@ -100,7 +101,11 @@ multi.panel <- TRUE panels <- NULL FUN <- NULL - ylim <- range(na.omit(x[subset])) + if(y.axis.same){ + ylim <- range(na.omit(x[subset])) + } else { + ylim <- NULL + } } for(i in 1:length(chunks)){ @@ -237,9 +242,21 @@ # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or # which is best. if(is.null(ylim)){ - cs$set_ylim(list(structure(range(na.omit(cs$Env$R[subset])),fixed=TRUE))) + if(isTRUE(multi.panel)){ + if(y.axis.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))) + } 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))) + } + } 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$Env$constant_ylim <- range(na.omit(cs$Env$R[subset])) } else { + # use the ylim arg passed in cs$set_ylim(list(structure(ylim, fixed=TRUE))) cs$Env$constant_ylim <- ylim } @@ -351,7 +368,11 @@ lenv <- new.env() lenv$xdata <- cs$Env$R[,i][subset] lenv$main <- cs$Env$column_names[i] - lenv$ylim <- cs$Env$constant_ylim + if(y.axis.same){ + lenv$ylim <- cs$Env$constant_ylim + } else { + lenv$ylim <- range(na.omit(cs$Env$R[,i][subset])) + } lenv$type <- cs$Env$type # Add a small frame for the time series info @@ -365,7 +386,7 @@ # Add the frame for the sub-plots # Set the ylim based on the (potentially) transformed data in cs$Env$R - cs$add_frame(ylim=cs$Env$constant_ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$add_frame(ylim=lenv$ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE) cs$next_frame() exp <- expression(chart.lines(xdata[xsubset], type=type, Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-07-22 17:48:02 UTC (rev 823) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-07-26 16:15:55 UTC (rev 824) @@ -16,6 +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) layout(matrix(1:2)) plot2_xts(R, multi.panel=2, type="h") From noreply at r-forge.r-project.org Thu Jul 31 23:43:04 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 31 Jul 2014 23:43:04 +0200 (CEST) Subject: [Xts-commits] r825 - pkg/xtsExtra/R Message-ID: <20140731214304.7C158184800@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-31 23:43:04 +0200 (Thu, 31 Jul 2014) New Revision: 825 Modified: pkg/xtsExtra/R/plot2.R Log: plot2_xts chart.lines function: reverse line order Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-07-26 16:15:55 UTC (rev 824) +++ pkg/xtsExtra/R/plot2.R 2014-07-31 21:43:04 UTC (rev 825) @@ -18,7 +18,7 @@ colors <- ifelse(x[,1] < 0, dn.col, up.col) lines(1:NROW(x),x[,1],lwd=2,col=colors,lend=1,lty=1,type="h") } else { - for(i in 1:NCOL(x)){ + for(i in NCOL(x):1){ lines(1:NROW(x),x[,i],lwd=2,col=colorset[i],lend=1,lty=1,type="l") } }