From noreply at r-forge.r-project.org Sat Dec 20 20:35:39 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 20 Dec 2014 20:35:39 +0100 (CET) Subject: [Xts-commits] r862 - in pkg/xtsExtra: . R sandbox Message-ID: <20141220193539.B902B1877C2@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-20 20:35:39 +0100 (Sat, 20 Dec 2014) New Revision: 862 Modified: pkg/xtsExtra/NAMESPACE pkg/xtsExtra/R/plot2.R pkg/xtsExtra/R/replot_xts.R pkg/xtsExtra/sandbox/paFUN.R Log: cleaning up plotting functions in preparation for port to xts Modified: pkg/xtsExtra/NAMESPACE =================================================================== --- pkg/xtsExtra/NAMESPACE 2014-11-11 20:39:20 UTC (rev 861) +++ pkg/xtsExtra/NAMESPACE 2014-12-20 19:35:39 UTC (rev 862) @@ -19,11 +19,11 @@ export("addLines") export("addLegend") -export("chart_pars") -export("xtsExtraTheme") -export("addDrawdowns") -export("addReturns") -export("addRollingPerformance") +#export("chart_pars") +#export("xtsExtraTheme") +#export("addDrawdowns") +#export("addReturns") +#export("addRollingPerformance") S3method(print, replot_xts) S3method(plot, replot_xts) Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-11-11 20:39:20 UTC (rev 861) +++ pkg/xtsExtra/R/plot2.R 2014-12-20 19:35:39 UTC (rev 862) @@ -1,16 +1,9 @@ -# Environment for our xts chart objects +# Environment for our xts chart objects (xts_chob) .plotxtsEnv <- new.env() current.xts_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,2,0,2)) -} # }}} - chart.lines <- function(x, type="l", lty=1, @@ -118,65 +111,31 @@ } } -# function from Peter Carl to add labels to the plot window -# add_label <- function(xfrac, yfrac, label, pos=4, ylog, ...) { -# u <- par("usr") -# x <- u[1] + xfrac * (u[2] - u[1]) -# y <- u[4] - yfrac * (u[4] - u[3]) -# if(ylog){ -# text(x, 10^y, label, pos = pos, ...) -# } else { -# text(x, y, label, pos = pos, ...) -# } + +# xtsExtraTheme <- function(){ +# theme <-list(col=list(bg="#FFFFFF", +# label.bg="#F0F0F0", +# grid="darkgray", #grid="#F0F0F0", +# grid2="#F5F5F5", +# ticks="#999999", +# labels="#333333", +# line.col="darkorange", +# dn.col="red", +# up.col="green", +# dn.border="#333333", +# up.border="#333333", +# colorset=1:10), +# shading=1, +# format.labels=TRUE, +# coarse.time=TRUE, +# rylab=TRUE, +# lylab=TRUE, +# grid.ticks.lwd=1, +# grid.ticks.on="months") +# theme # } -# 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="darkgray", #grid="#F0F0F0", - grid2="#F5F5F5", - ticks="#999999", - labels="#333333", - line.col="darkorange", - dn.col="red", - up.col="green", - dn.border="#333333", - up.border="#333333", - colorset=1:10), - shading=1, - format.labels=TRUE, - coarse.time=TRUE, - rylab=TRUE, - lylab=TRUE, - grid.ticks.lwd=1, - grid.ticks.on="months") - theme -} - +# based on quantmod::chart_Series #' Time series Plotting #' #' Plotting for xts objects. @@ -345,14 +304,6 @@ } 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(grid.ticks.on)) { xs <- x[subset] major.grid <- c(years=nyears(xs), @@ -405,13 +356,9 @@ cs$Env$cex <- cex cs$Env$mar <- mar cs$Env$clev = min(clev+0.01,1) # (0,1] - #cs$Env$theme$bbands <- theme$bbands cs$Env$theme$shading <- 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$colorset <- colorset cs$Env$theme$rylab <- yaxis.right cs$Env$theme$lylab <- yaxis.left @@ -422,8 +369,6 @@ cs$Env$theme$srt <- srt cs$Env$theme$xaxis.las <- xaxis.las cs$Env$theme$cex.axis <- cex.axis - #cs$Env$theme$label.bg <- label.bg - #cs$Env$theme$coarse.time <- coarse.time cs$Env$format.labels <- format.labels cs$Env$grid.ticks.on <- grid.ticks.on cs$Env$grid.ticks.lwd <- grid.ticks.lwd @@ -441,11 +386,6 @@ 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$xdata <- x @@ -737,84 +677,8 @@ } } } - assign(".xts_chob", cs, .plotxtsEnv) cs -} #}}} - -addDrawdowns <- function(geometric=TRUE, ylim=NULL, ...){ - lenv <- new.env() - lenv$main <- "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 - atbt <- axTicksByTime2(xdata[xsubset]) - segments(x$Env$xycoords$x[atbt], - par("usr")[3], - x$Env$xycoords$x[atbt], - par("usr")[4], - col=x$Env$theme$grid) - 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,...)), - list(geometric=geometric,...)) - exp <- parse(text=gsub("list","plot_drawdowns", - as.expression(substitute(list(x=current.xts_chob(), - geometric=geometric,...)))), - srcfile=NULL) - - plot_object <- current.xts_chob() - ncalls <- length(plot_object$Env$call_list) - plot_object$Env$call_list[[ncalls+1]] <- match.call() - - xdata <- plot_object$Env$xdata - xsubset <- plot_object$Env$xsubset - - drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) - lenv$xdata <- drawdowns - - # 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=xlim[1], y=0.3, labels=main, - col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) - plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) - - # add frame for the actual drawdowns data - if(is.null(ylim)) { - ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) - lenv$ylim <- ylim - } - plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) - plot_object$next_frame() - - 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(xlim[1], - grid_lines(ylim), - xlim[2], - grid_lines(ylim), - col=theme$grid)), - exp, # NOTE 'exp' was defined earlier - # add axis labels/boxes - expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(xlim[2]+xstep*2/3, - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) - plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) - plot_object } #' Add a time series to an existing xts plot @@ -1108,297 +972,6 @@ plot_object } - -# # Needed for finding aligned dates for event lines and period areas -# rownames = as.Date(time(y)) -# rownames = format(strptime(rownames,format = date.format.in), date.format) -# # Add event.lines before drawing the data -# # This only labels the dates it finds -# if(!is.null(event.lines)) { -# event.ind = NULL -# for(event in 1:length(event.lines)){ -# event.ind = c(event.ind, grep(event.lines[event], rownames)) -# } -# number.event.labels = ((length(event.labels)-length(event.ind) + 1):length(event.labels)) -# -# abline(v = event.ind, col = event.color, lty = 2) -# if(!is.null(event.labels)) { -# text(x=event.ind,y=ylim[2], label = event.labels[number.event.labels], offset = .2, pos = 2, cex = cex.labels, srt=90, col = event.color) -# } -# } - - - -# based on quantmod::add_TA -# addLines <- function(x, main="", order=NULL, on=NA, legend="auto", -# yaxis=list(NULL,NULL), -# col=1, type="l", ...) { -# lenv <- new.env() -# lenv$main <- main -# lenv$plot_ta <- function(x, ta, on, type, col,...) { -# xdata <- x$Env$xdata -# xsubset <- x$Env$xsubset -# if(all(is.na(on))) { -# # x-axis grid lines based on Env$xdata and Env$xsubset -# segments(axTicksByTime2(xdata[xsubset]), -# par("usr")[3], -# axTicksByTime2(xdata[xsubset]), -# par("usr")[4], -# col=x$Env$theme$grid) -# } -# if(is.logical(ta)) { -# ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset] -# shade <- shading(as.logical(ta,drop=FALSE)) -# if(length(shade$start) > 0) # all FALSE cause zero-length results -# rect(shade$start-1/3, par("usr")[3] ,shade$end+1/3, par("usr")[4], col=col,...) -# } else { -# # we can add points that are not necessarily at the points -# # on the main series -# subset.range <- paste(start(x$Env$xdata[x$Env$xsubset]), -# end(x$Env$xdata[x$Env$xsubset]),sep="/") -# ta.adj <- merge(n=.xts(1:NROW(x$Env$xdata[x$Env$xsubset]), -# .index(x$Env$xdata[x$Env$xsubset]), tzone=indexTZ(x$Env$xdata)),ta)[subset.range] -# ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) -# ta.y <- ta.adj[,-1] -# chart.lines(ta.y, colorset=col, type=type) -# } -# } -# lenv$xdata <- x -# # map all passed args (if any) to 'lenv' environment -# mapply(function(name,value) { assign(name,value,envir=lenv) }, -# names(list(x=x,order=order,on=on,legend=legend, -# type=type,col=col,...)), -# list(x=x,order=order,on=on,legend=legend, -# type=type,col=col,...)) -# exp <- parse(text=gsub("list","plot_ta", -# as.expression(substitute(list(x=current.xts_chob(), -# ta=get("x"),on=on, -# type=type,col=col,...)))), -# srcfile=NULL) -# plot_object <- current.xts_chob() -# ncalls <- length(plot_object$Env$call_list) -# plot_object$Env$call_list[[ncalls+1]] <- match.call() -# xdata <- plot_object$Env$xdata -# xsubset <- plot_object$Env$xsubset -# # if(is.logical(x)) no.update <- TRUE else no.update <- FALSE -# no.update <- TRUE -# # this merge isn't going to work if x isn't in xdata range. Something like: -# # na.approx(merge(n=.xts(1:NROW(xdata),.index(xdata)),ta)[,1]) -# # should allow for any time not in the original to be merged in. -# # probably need to subset xdata _before_ merging, else subset will be wrong -# # -# #tav <- merge(x, xdata, join="right",retside=c(TRUE,FALSE)) -# #lenv$xdata <- tav -# #tav <- tav[xsubset] -# lenv$col <- col -# lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE)) -# -# if(is.na(on)) { -# plot_object$add_frame(ylim=c(0,1),asp=0.2) -# plot_object$next_frame() -# text.exp <- expression(text(x=1, -# y=0.3, -# labels=main, -# col=c(1,col),adj=c(0,0),cex=0.9,offset=0,pos=4)) -# plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) -# -# plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1) # need to have a value set for ylim -# plot_object$next_frame() -# # add grid lines, using custom function for MACD gridlines -# lenv$grid_lines <- function(xdata,xsubset) { -# pretty(range(xdata[xsubset])) -# } -# exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset), -# col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd -# # add axis labels/boxes -# expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset), -# noquote(format(grid_lines(xdata,xsubset),justify="right")), -# col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE)), -# expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset), -# noquote(format(grid_lines(xdata,xsubset),justify="right")), -# col=theme$labels,offset=0,pos=4,cex=0.9,xpd=TRUE))) -# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) -# } else { -# for(i in 1:length(on)) { -# plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? -# lenv$grid_lines <- function(xdata,xsubset) { -# pretty(range(xdata[xsubset])) -# } -# exp <- c(exp, -# # LHS -# #expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset), -# # noquote(format(grid_lines(xdata,xsubset),justify="right")), -# # col=theme$labels,offset=0,pos=4,cex=0.9)), -# # RHS -# expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset), -# noquote(format(grid_lines(xdata,xsubset),justify="right")), -# col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) -# #} -# plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) -# } -# } -# plot_object -# } #}}} - -addReturns <- function(type="h", main=NULL, ylim=NULL){ - # This just plots the raw returns data - lenv <- new.env() - 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 - colorset <- x$Env$theme$colorset - up.col <- x$Env$theme$up.col - dn.col <- x$Env$theme$dn.col - # Add x-axis grid lines - atbt <- axTicksByTime2(xdata[xsubset]) - segments(x$Env$xycoords$x[atbt], - par("usr")[3], - x$Env$xycoords$x[atbt], - par("usr")[4], - col=x$Env$theme$grid) - chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col) - } - 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(), - type=type)))), - srcfile=NULL) - - plot_object <- current.xts_chob() - ncalls <- length(plot_object$Env$call_list) - plot_object$Env$call_list[[ncalls+1]] <- match.call() - - # get the raw returns data - xdata <- plot_object$Env$xdata - xsubset <- plot_object$Env$xsubset - - if(type == "h" & NCOL(xdata) > 1) - warning("only the univariate series will be plotted") - - # add data to the local environment - lenv$xdata <- xdata - lenv$xsubset <- xsubset - 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=xlim[1], y=0.3, labels=main, - col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) - plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) - - # add frame for the actual data - if(is.null(ylim)) { - ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) - lenv$ylim <- ylim - } - plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) - plot_object$next_frame() - - 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(xlim[1], - grid_lines(ylim), - xlim[2], - grid_lines(ylim),col=theme$grid)), - exp, # NOTE 'exp' was defined earlier - # add axis labels/boxes - expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(xlim[2]+xstep*2/3, - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) - 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, ylim=NULL, ...){ - lenv <- new.env() - lenv$main <- 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], - 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, 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, ...)), - 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() - ncalls <- length(plot_object$Env$call_list) - plot_object$Env$call_list[[ncalls+1]] <- match.call() - - xdata <- plot_object$Env$xdata - xsubset <- plot_object$Env$xsubset - - 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=xlim[1], y=0.3, labels=main, - adj=c(0,0),cex=0.9,offset=0,pos=4)) - plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) - - # add frame for the actual drawdowns data - if(is.null(ylim)) { - ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) - lenv$ylim <- ylim - } - plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) - plot_object$next_frame() - - 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(xlim[1], - grid_lines(ylim), - xlim[2], - grid_lines(ylim),col=theme$grid)), - exp, # NOTE 'exp' was defined earlier - # add axis labels/boxes - expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), - expression(text(xlim[2]+xstep*2/3, - grid_lines(ylim), - noquote(format(grid_lines(ylim),justify="right")), - col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) - plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) - plot_object -} - #' Add Legend #' #' @param legend.loc legend.loc places a legend into one of nine locations on Modified: pkg/xtsExtra/R/replot_xts.R =================================================================== --- pkg/xtsExtra/R/replot_xts.R 2014-11-11 20:39:20 UTC (rev 861) +++ pkg/xtsExtra/R/replot_xts.R 2014-12-20 19:35:39 UTC (rev 862) @@ -2,7 +2,6 @@ # 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() @@ -197,17 +196,15 @@ 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) @@ -252,25 +249,24 @@ 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 -} +# `+.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 Modified: pkg/xtsExtra/sandbox/paFUN.R =================================================================== --- pkg/xtsExtra/sandbox/paFUN.R 2014-11-11 20:39:20 UTC (rev 861) +++ pkg/xtsExtra/sandbox/paFUN.R 2014-12-20 19:35:39 UTC (rev 862) @@ -1,3 +1,240 @@ +# prototypes for functions that will likely make their way into PerformanceAnalytics +addDrawdowns <- function(geometric=TRUE, ylim=NULL, ...){ + lenv <- new.env() + lenv$main <- "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 + atbt <- axTicksByTime2(xdata[xsubset]) + segments(x$Env$xycoords$x[atbt], + par("usr")[3], + x$Env$xycoords$x[atbt], + par("usr")[4], + col=x$Env$theme$grid) + 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,...)), + list(geometric=geometric,...)) + exp <- parse(text=gsub("list","plot_drawdowns", + as.expression(substitute(list(x=current.xts_chob(), + geometric=geometric,...)))), + srcfile=NULL) + + plot_object <- current.xts_chob() + ncalls <- length(plot_object$Env$call_list) + plot_object$Env$call_list[[ncalls+1]] <- match.call() + + xdata <- plot_object$Env$xdata + xsubset <- plot_object$Env$xsubset + + drawdowns <- PerformanceAnalytics:::Drawdowns(plot_object$Env$xdata, geometric=geometric) + lenv$xdata <- drawdowns + + # 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=xlim[1], y=0.3, labels=main, + col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) + plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) + + # add frame for the actual drawdowns data + if(is.null(ylim)) { + ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) + plot_object$next_frame() + + 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(xlim[1], + grid_lines(ylim), + xlim[2], + grid_lines(ylim), + col=theme$grid)), + exp, # NOTE 'exp' was defined earlier + # add axis labels/boxes + expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), + grid_lines(ylim), + noquote(format(grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), + expression(text(xlim[2]+xstep*2/3, + grid_lines(ylim), + noquote(format(grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) + plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) + plot_object +} + +addReturns <- function(type="h", main=NULL, ylim=NULL){ + # This just plots the raw returns data + lenv <- new.env() + 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 + colorset <- x$Env$theme$colorset + up.col <- x$Env$theme$up.col + dn.col <- x$Env$theme$dn.col + # Add x-axis grid lines + atbt <- axTicksByTime2(xdata[xsubset]) + segments(x$Env$xycoords$x[atbt], + par("usr")[3], + x$Env$xycoords$x[atbt], + par("usr")[4], + col=x$Env$theme$grid) + chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col) + } + 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(), + type=type)))), + srcfile=NULL) + + plot_object <- current.xts_chob() + ncalls <- length(plot_object$Env$call_list) + plot_object$Env$call_list[[ncalls+1]] <- match.call() + + # get the raw returns data + xdata <- plot_object$Env$xdata + xsubset <- plot_object$Env$xsubset + + if(type == "h" & NCOL(xdata) > 1) + warning("only the univariate series will be plotted") + + # add data to the local environment + lenv$xdata <- xdata + lenv$xsubset <- xsubset + 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=xlim[1], y=0.3, labels=main, + col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) + plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) + + # add frame for the actual data + if(is.null(ylim)) { + ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) + plot_object$next_frame() + + 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(xlim[1], + grid_lines(ylim), + xlim[2], + grid_lines(ylim),col=theme$grid)), + exp, # NOTE 'exp' was defined earlier + # add axis labels/boxes + expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), + grid_lines(ylim), + noquote(format(grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), + expression(text(xlim[2]+xstep*2/3, + grid_lines(ylim), + noquote(format(grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE))) + 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, ylim=NULL, ...){ + lenv <- new.env() + lenv$main <- 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], + 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, 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, ...)), + 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() + ncalls <- length(plot_object$Env$call_list) + plot_object$Env$call_list[[ncalls+1]] <- match.call() + + xdata <- plot_object$Env$xdata + xsubset <- plot_object$Env$xsubset + + 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=xlim[1], y=0.3, labels=main, + adj=c(0,0),cex=0.9,offset=0,pos=4)) + plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE) + + # add frame for the actual drawdowns data + if(is.null(ylim)) { + ylim <- range(lenv$xdata[xsubset], na.rm=TRUE) + lenv$ylim <- ylim + } + plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) + plot_object$next_frame() + + 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(xlim[1], + grid_lines(ylim), + xlim[2], + grid_lines(ylim),col=theme$grid)), + exp, # NOTE 'exp' was defined earlier + # add axis labels/boxes + expression(text(xlim[1]-xstep*2/3-max(strwidth(grid_lines(ylim))), + grid_lines(ylim), + noquote(format(grid_lines(ylim),justify="right")), + col=theme$labels,offset=0,pos=4,cex=0.9, xpd=TRUE)), + expression(text(xlim[2]+xstep*2/3, + grid_lines(ylim), [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/xts -r 862 From noreply at r-forge.r-project.org Fri Dec 26 18:28:15 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 26 Dec 2014 18:28:15 +0100 (CET) Subject: [Xts-commits] r863 - pkg/xtsExtra/R Message-ID: <20141226172815.DF93D1877A7@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-26 18:28:15 +0100 (Fri, 26 Dec 2014) New Revision: 863 Modified: pkg/xtsExtra/R/plot2.R Log: consolidating plotting functions into single file Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-12-20 19:35:39 UTC (rev 862) +++ pkg/xtsExtra/R/plot2.R 2014-12-26 17:28:15 UTC (rev 863) @@ -2,6 +2,66 @@ # Environment for our xts chart objects (xts_chob) .plotxtsEnv <- new.env() +axTicksByTime2 <- function (x, ticks.on = "auto", k = 1, labels = TRUE, + format.labels = TRUE, ends = TRUE, + gt = 2, lt = 25){ + if (timeBased(x)) + x <- xts(rep(1, length(x)), x) + #tick.opts <- c("years", "months", "days", "hours", + # "minutes", "seconds") + tick.opts <- c("years", "months", "weeks", "days") + tick.k.opts <- c(1,1,1,1) + if (ticks.on %in% tick.opts) { + cl <- ticks.on[1] + ck <- k + } + else { + tick.opts <- paste(tick.opts, tick.k.opts) + is <- structure(rep(0, length(tick.opts)), .Names = tick.opts) + for (i in 1:length(tick.opts)) { + y <- strsplit(tick.opts[i], " ")[[1]] + ep <- endpoints(x, y[1], as.numeric(y[2])) + if(i>1 && is[i-1] == length(ep)-1) + break + is[i] <- length(ep) - 1 + if (is[i] > lt) + break + } + nms <- rev(names(is)[which(is > gt & is < lt)])[1] + cl <- strsplit(nms, " ")[[1]][1] + ck <- as.numeric(strsplit(nms, " ")[[1]][2]) + } + if (is.na(cl) || is.na(ck) || is.null(cl)) { + return(c(1,NROW(x))) + #ep <- NULL + } + else ep <- endpoints(x, cl, ck) + if (ends) + ep <- ep + c(rep(1, length(ep) - 1), 0) + if (labels) { + if (is.logical(format.labels) || is.character(format.labels)) { + unix <- ifelse(.Platform$OS.type == "unix", TRUE, + FALSE) + #time.scale <- periodicity(x)$scale + #fmt <- ifelse(unix, "%n%b%n%Y", "%b %Y") + fmt <- switch(cl, + "years"="%Y", + "months"="%b", + "days"="%d", + "weeks"="W%W", + "hours"="%H:%M", + "minutes"="%H:%M:%S", + "seconds"="%H:%M:%S") + if(ndays(x) > 1 && cl %in% c("hours","minutes","seconds")) { + fmt <- paste("%b-%d",fmt) + } + names(ep) <- format(index(x)[ep], fmt) + } + else names(ep) <- as.character(index(x)[ep]) + } + ep +} + current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv)) chart.lines <- function(x, @@ -56,56 +116,56 @@ yjust <- 1 lx <- chob.xlim[1] ly <- yrange[2] - }, + }, left = { xjust <- 0 yjust <- 0.5 lx <- chob.xlim[1] ly <- sum(yrange) / 2 - }, + }, bottomleft = { xjust <- 0 yjust <- 0 lx <- chob.xlim[1] ly <- yrange[1] - }, + }, top = { xjust <- 0.5 yjust <- 1 lx <- (chob.xlim[1] + chob.xlim[2]) / 2 ly <- yrange[2] - }, + }, center = { xjust <- 0.5 yjust <- 0.5 lx <- (chob.xlim[1] + chob.xlim[2]) / 2 ly <- sum(yrange) / 2 - }, + }, bottom = { xjust <- 0.5 yjust <- 0 lx <- (chob.xlim[1] + chob.xlim[2]) / 2 ly <- yrange[1] - }, + }, topright = { xjust <- 1 yjust <- 1 lx <- chob.xlim[2] ly <- yrange[2] - }, + }, right = { xjust <- 1 yjust <- 0.5 lx <- chob.xlim[2] ly <- sum(yrange) / 2 - }, + }, bottomright = { xjust <- 1 yjust <- 0 lx <- chob.xlim[2] ly <- yrange[1] } - ) + ) legend(x=lx, y=ly, legend=colnames(x), xjust=xjust, yjust=yjust, fill=colorset[1:NCOL(x)], bty="n") } @@ -184,40 +244,40 @@ #' center. Default NULL does not draw a legend. #' @author Ross Bennett plot.xts <- function(x, - y=NULL, - ..., - subset="", - FUN=NULL, - panels=NULL, - multi.panel=FALSE, - colorset=1:12, - up.col="green", - dn.col="red", - type="l", - lty=1, - lwd=2, - lend=1, - main=deparse(substitute(x)), - clev=0, - cex=0.6, - cex.axis=0.9, - mar=c(3,2,0,2), - srt=0, - xaxis.las=0, - ylim=NULL, - yaxis.same=TRUE, - yaxis.left=TRUE, - yaxis.right=TRUE, - grid.ticks.on="months", - grid.ticks.lwd=1, - grid.ticks.lty=1, - grid.col="darkgray", - labels.col="#333333", - format.labels=TRUE, - shading=1, - bg.col="#FFFFFF", - grid2="#F5F5F5", - legend.loc=NULL){ + y=NULL, + ..., + subset="", + FUN=NULL, + panels=NULL, + multi.panel=FALSE, + colorset=1:12, + up.col="green", + dn.col="red", + type="l", + lty=1, + lwd=2, + lend=1, + main=deparse(substitute(x)), + clev=0, + cex=0.6, + cex.axis=0.9, + mar=c(3,2,0,2), + srt=0, + xaxis.las=0, + ylim=NULL, + yaxis.same=TRUE, + yaxis.left=TRUE, + yaxis.right=TRUE, + grid.ticks.on="months", + grid.ticks.lwd=1, + grid.ticks.lty=1, + grid.col="darkgray", + labels.col="#333333", + format.labels=TRUE, + shading=1, + bg.col="#FFFFFF", + grid2="#F5F5F5", + legend.loc=NULL){ # 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 @@ -253,7 +313,7 @@ ylim <- range(R[subset], na.rm=TRUE) } } else { - # set the ylim based on the data passed into the x argument + # set the ylim based on the data passed into the x argument ylim <- range(x[subset], na.rm=TRUE) } } @@ -262,40 +322,40 @@ for(i in 1:length(chunks)){ tmp <- chunks[[i]] p <- plot.xts(x=x[,tmp], - y=y, - ...=..., - subset=subset, - FUN=FUN, - panels=panels, - multi.panel=multi.panel, - colorset=colorset, - up.col=up.col, - dn.col=dn.col, - type=type, - lty=lty, - lwd=lwd, - lend=lend, - main=main, - clev=clev, - cex=cex, - cex.axis=cex.axis, - mar=mar, - srt=srt, - xaxis.las=xaxis.las, - ylim=ylim, - yaxis.same=yaxis.same, - yaxis.left=yaxis.left, - yaxis.right=yaxis.right, - grid.ticks.on=grid.ticks.on, - grid.ticks.lwd=grid.ticks.lwd, - grid.ticks.lty=grid.ticks.lty, - grid.col=grid.col, - labels.col=labels.col, - format.labels=format.labels, - shading=shading, - bg.col=bg.col, - grid2=grid2, - legend.loc=legend.loc) + y=y, + ...=..., + subset=subset, + FUN=FUN, + panels=panels, + multi.panel=multi.panel, + colorset=colorset, + up.col=up.col, + dn.col=dn.col, + type=type, + lty=lty, + lwd=lwd, + lend=lend, + main=main, + clev=clev, + cex=cex, + cex.axis=cex.axis, + mar=mar, + srt=srt, + xaxis.las=xaxis.las, + ylim=ylim, + yaxis.same=yaxis.same, + yaxis.left=yaxis.left, + yaxis.right=yaxis.right, + grid.ticks.on=grid.ticks.on, + grid.ticks.lwd=grid.ticks.lwd, + grid.ticks.lty=grid.ticks.lty, + grid.col=grid.col, + labels.col=labels.col, + format.labels=format.labels, + shading=shading, + bg.col=bg.col, + grid2=grid2, + legend.loc=legend.loc) if(i < length(chunks)) print(p) } @@ -650,7 +710,7 @@ adj=c(0,0),cex=1,offset=0,pos=4)) cs$add(text.exp,env=c(lenv, cs$Env),expr=TRUE) } - } + } } else { if(type == "h" & NCOL(x) > 1) warning("only the univariate series will be plotted") @@ -900,7 +960,7 @@ lenv$xdata <- xdata ylim <- range(xdata[xsubset], na.rm=TRUE) lenv$ylim <- ylim - + # add the frame for drawdowns info plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() @@ -964,7 +1024,7 @@ col=col, ...)))), srcfile=NULL) - + plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update) } @@ -1087,3 +1147,284 @@ plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) plot_object } + + +# 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 + +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.replot_xts <- function(x, ...) plot(x,...) +plot.replot_xts <- function(x, ...) { + plot.new() + 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 <- 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.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.xts_chob()) From noreply at r-forge.r-project.org Fri Dec 26 18:30:36 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 26 Dec 2014 18:30:36 +0100 (CET) Subject: [Xts-commits] r864 - pkg/xtsExtra/sandbox Message-ID: <20141226173036.6730E18787B@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-26 18:30:36 +0100 (Fri, 26 Dec 2014) New Revision: 864 Modified: pkg/xtsExtra/sandbox/paFUN.R pkg/xtsExtra/sandbox/test_plot2.R Log: fixing test script and function examples Modified: pkg/xtsExtra/sandbox/paFUN.R =================================================================== --- pkg/xtsExtra/sandbox/paFUN.R 2014-12-26 17:28:15 UTC (rev 863) +++ pkg/xtsExtra/sandbox/paFUN.R 2014-12-26 17:30:36 UTC (rev 864) @@ -7,24 +7,24 @@ xsubset <- x$Env$xsubset colorset <- x$Env$theme$colorset # Add x-axis grid lines - atbt <- axTicksByTime2(xdata[xsubset]) + atbt <- xtsExtra:::axTicksByTime2(xdata[xsubset]) segments(x$Env$xycoords$x[atbt], par("usr")[3], x$Env$xycoords$x[atbt], par("usr")[4], col=x$Env$theme$grid) drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] - chart.lines(drawdowns, type="l", colorset=colorset) + xtsExtra:::chart.lines(drawdowns, type="l", colorset=colorset) } 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.xts_chob(), + as.expression(substitute(list(x=xtsExtra:::current.xts_chob(), geometric=geometric,...)))), srcfile=NULL) - plot_object <- current.xts_chob() + plot_object <- xtsExtra:::current.xts_chob() ncalls <- length(plot_object$Env$call_list) plot_object$Env$call_list[[ncalls+1]] <- match.call() @@ -85,23 +85,23 @@ up.col <- x$Env$theme$up.col dn.col <- x$Env$theme$dn.col # Add x-axis grid lines - atbt <- axTicksByTime2(xdata[xsubset]) + atbt <- xtsExtra:::axTicksByTime2(xdata[xsubset]) segments(x$Env$xycoords$x[atbt], par("usr")[3], x$Env$xycoords$x[atbt], par("usr")[4], col=x$Env$theme$grid) - chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col) + xtsExtra:::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)), list(type=type)) exp <- parse(text=gsub("list","plot_returns", - as.expression(substitute(list(x=current.xts_chob(), + as.expression(substitute(list(x=xtsExtra:::current.xts_chob(), type=type)))), srcfile=NULL) - plot_object <- current.xts_chob() + plot_object <- xtsExtra:::current.xts_chob() ncalls <- length(plot_object$Env$call_list) plot_object$Env$call_list[[ncalls+1]] <- match.call() @@ -167,23 +167,23 @@ up.col <- x$Env$theme$up.col dn.col <- x$Env$theme$dn.col # Add x-axis grid lines - segments(axTicksByTime2(xdata[xsubset]), + segments(xtsExtra:::axTicksByTime2(xdata[xsubset]), par("usr")[3], - axTicksByTime2(xdata[xsubset]), + xtsExtra:::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, type="l", colorset=colorset, up.col=up.col, dn.col=dn.col) + xtsExtra:::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, ...)), list(width=width, FUN=FUN, fill=fill, ...)) exp <- parse(text=gsub("list","plot_performance", - as.expression(substitute(list(x=current.xts_chob(), + as.expression(substitute(list(x=xtsExtra:::current.xts_chob(), width=width, FUN=FUN, fill=fill, ...)))), srcfile=NULL) - plot_object <- current.xts_chob() + plot_object <- xtsExtra:::current.xts_chob() ncalls <- length(plot_object$Env$call_list) plot_object$Env$call_list[[ncalls+1]] <- match.call() Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-12-26 17:28:15 UTC (rev 863) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-12-26 17:30:36 UTC (rev 864) @@ -1,6 +1,6 @@ library(xtsExtra) library(PerformanceAnalytics) -library(quantmod) +# library(quantmod) source("sandbox/paFUN.R") data(edhec) @@ -137,21 +137,21 @@ addSeries(tmp3, on=1, type="p", pch=2) -stock.str='AAPL' -initDate="2011-01-01" -endDate="2012-12-31" -getSymbols(stock.str,from=initDate,to=endDate, src="yahoo") -plot(Ad(AAPL)) -addSeries(Ad(AAPL)["2012-05-28/"]-10, on=1, col = "red") -xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1) -xtsExtra::addLines(c("2011-03-04", "2012-01-10", "2012-07-28"), on=1) -xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28")) +# stock.str='AAPL' +# initDate="2011-01-01" +# endDate="2012-12-31" +# quantmod::getSymbols(stock.str,from=initDate,to=endDate, src="yahoo") +# plot(Ad(AAPL)) +# addSeries(Ad(AAPL)["2012-05-28/"]-10, on=1, col = "red") +# xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28"), on=1) +# xtsExtra::addLines(c("2011-03-04", "2012-01-10", "2012-07-28"), on=1) +# xtsExtra::addLines(c("2011-11-04", "2012-11-10", "2012-05-28")) +# +# aapl <- Ad(AAPL) +# plot(aapl) +# aapl["2011-07/2012-07"] <- NA +# plot(aapl) -aapl <- Ad(AAPL) -plot(aapl) -aapl["2011-07/2012-07"] <- NA -plot(aapl) - # png("~/Documents/foo.png") # plot(R, FUN="CumReturns") # addDrawdowns() From noreply at r-forge.r-project.org Fri Dec 26 19:01:35 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 26 Dec 2014 19:01:35 +0100 (CET) Subject: [Xts-commits] r865 - in pkg/xtsExtra: R man sandbox Message-ID: <20141226180135.2E78F18797C@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-26 19:01:34 +0100 (Fri, 26 Dec 2014) New Revision: 865 Modified: pkg/xtsExtra/R/plot2.R pkg/xtsExtra/man/addLegend.Rd pkg/xtsExtra/man/plot.xts.Rd pkg/xtsExtra/sandbox/paFUN.R pkg/xtsExtra/sandbox/test_plot2.R Log: refactoring to replace the 'colorset' argument with 'col' for consistency with par Modified: pkg/xtsExtra/R/plot2.R =================================================================== --- pkg/xtsExtra/R/plot2.R 2014-12-26 17:30:36 UTC (rev 864) +++ pkg/xtsExtra/R/plot2.R 2014-12-26 18:01:34 UTC (rev 865) @@ -69,7 +69,7 @@ lty=1, lwd=2, lend=1, - colorset=1:10, + col=1:10, up.col=NULL, dn.col=NULL, legend.loc=NULL, @@ -86,9 +86,9 @@ if(length(lty) == 1) lty <- rep(lty, NCOL(x)) if(length(lwd) == 1) lwd <- rep(lwd, NCOL(x)) for(i in NCOL(x):1){ - # lines(1:NROW(x), x[,i], type=type, lend=lend, col=colorset[i], lty=lty[i], lwd=lwd[i], pch=pch) + # lines(1:NROW(x), x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch) # non-equally spaced x-axis - lines(xx$Env$xycoords$x, x[,i], type=type, lend=lend, col=colorset[i], lty=lty[i], lwd=lwd[i], pch=pch) + lines(xx$Env$xycoords$x, x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch) } } else if(type == "bar"){ # This does not work correctly @@ -103,8 +103,8 @@ negatives[row,column] = min(0, x[row,column]) } } - barplot.default(t(positives), add=TRUE, col=colorset, axisnames=FALSE, axes=FALSE) - barplot.default(t(negatives), add=TRUE, col=colorset, axisnames=FALSE, axes=FALSE) + barplot.default(t(positives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE) + barplot.default(t(negatives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE) } if(!is.null(legend.loc)){ yrange <- range(x, na.rm=TRUE) @@ -167,7 +167,7 @@ } ) legend(x=lx, y=ly, legend=colnames(x), xjust=xjust, yjust=yjust, - fill=colorset[1:NCOL(x)], bty="n") + fill=col[1:NCOL(x)], bty="n") } } @@ -212,7 +212,7 @@ #' separate panel. For example, if \code{multi.panel = 2}, then the data #' will be plotted in groups of 2 columns and each group is plotted in a #' separate panel. -#' @param colorset color palette to use, set by default to rational choices +#' @param col color palette to use, set by default to rational choices #' @param up.col color for positive bars if \code{type="h"} #' @param dn.col color for positive bars if \code{type="h"} #' @param type the type of plot to be drawn, same as in \code{\link{plot}} @@ -250,7 +250,7 @@ FUN=NULL, panels=NULL, multi.panel=FALSE, - colorset=1:12, + col=1:12, up.col="green", dn.col="red", type="l", @@ -328,7 +328,7 @@ FUN=FUN, panels=panels, multi.panel=multi.panel, - colorset=colorset, + col=col, up.col=up.col, dn.col=dn.col, type=type, @@ -419,7 +419,11 @@ cs$Env$theme$shading <- shading cs$Env$theme$up.col <- up.col cs$Env$theme$dn.col <- dn.col - cs$Env$theme$colorset <- colorset + if (hasArg(colorset)){ + cs$Env$theme$col <- match.call(expand.dots=TRUE)$colorset + } else { + cs$Env$theme$col <- col + } cs$Env$theme$rylab <- yaxis.right cs$Env$theme$lylab <- yaxis.left cs$Env$theme$bg <- bg.col @@ -616,7 +620,7 @@ lty=lty, lwd=lwd, lend=lend, - colorset=theme$colorset, + col=theme$col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)) @@ -660,7 +664,7 @@ lty=lty, lwd=lwd, lend=lend, - colorset=theme$colorset, + col=theme$col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)) @@ -719,7 +723,7 @@ lty=lty, lwd=lwd, lend=lend, - colorset=theme$colorset, + col=theme$col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)),expr=TRUE) @@ -759,11 +763,7 @@ lenv$plot_lines <- function(x, ta, on, type, col, lty, lwd, pch, ...){ xdata <- x$Env$xdata xsubset <- x$Env$xsubset - if(is.null(col)){ - colorset <- x$Env$theme$colorset - } else { - colorset <- col - } + if(is.null(col)) col <- x$Env$theme$col if(all(is.na(on))){ # Add x-axis grid lines atbt <- axTicksByTime2(xdata[xsubset]) @@ -782,7 +782,7 @@ tzone=indexTZ(xdata)),ta)[subset.range] ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) ta.y <- ta.adj[,-1] - chart.lines(ta.y, type=type, colorset=colorset, lty=lty, lwd=lwd, pch=pch) + chart.lines(ta.y, type=type, col=col, lty=lty, lwd=lwd, pch=pch) } # map all passed args (if any) to 'lenv' environment mapply(function(name,value) { assign(name,value,envir=lenv) }, @@ -906,7 +906,7 @@ lenv$plot_event_lines <- function(x, event.dates, event.labels, date.format, on, lty, lwd, col, ...){ xdata <- x$Env$xdata xsubset <- x$Env$xsubset - colorset <- x$Env$theme$colorset + col <- x$Env$theme$col if(all(is.na(on))){ # Add x-axis grid lines atbt <- axTicksByTime2(xdata[xsubset]) @@ -1039,12 +1039,12 @@ #' right, or center. #' @param legend.names character vector of names for the legend. If \code{NULL}, #' the column names of the current plot object are used. -#' @param colorset fill colorset for the legend. If \code{NULL}, +#' @param col fill colors for the legend. If \code{NULL}, #' the colorset of the current plot object data is used. #' @param ncol number of columns for the legend #' @param \dots any other passthrough parameters. Not currently used. #' @author Ross Bennett -addLegend <- function(legend.loc="center", legend.names=NULL, colorset=NULL, ncol=1, ...){ +addLegend <- function(legend.loc="center", legend.names=NULL, col=NULL, ncol=1, ...){ lenv <- new.env() lenv$main <- "" @@ -1129,10 +1129,10 @@ lenv$ly <- ly lenv$xjust <- xjust lenv$yjust <- yjust - if(!is.null(colorset)){ - lenv$colorset <- colorset[1:nc] + if(!is.null(col)){ + lenv$col <- col[1:nc] } else { - lenv$colorset <- plot_object$Env$theme$colorset[1:nc] + lenv$col <- plot_object$Env$theme$col[1:nc] } if(!is.null(legend.names)){ lenv$names <- legend.names @@ -1142,7 +1142,7 @@ lenv$nc <- ncol # add expression for legend exp <- expression(legend(x=lx, y=ly, legend=names, xjust=xjust, yjust=yjust, - fill=colorset, ncol=nc, bty="n")) + fill=col, ncol=nc, bty="n")) plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=TRUE) plot_object Modified: pkg/xtsExtra/man/addLegend.Rd =================================================================== --- pkg/xtsExtra/man/addLegend.Rd 2014-12-26 17:30:36 UTC (rev 864) +++ pkg/xtsExtra/man/addLegend.Rd 2014-12-26 18:01:34 UTC (rev 865) @@ -3,13 +3,20 @@ \alias{addLegend} \title{Add Legend} \usage{ -addLegend(legend.loc = "center", ncol = 1, ...) +addLegend(legend.loc = "center", legend.names = NULL, col = NULL, + ncol = 1, ...) } \arguments{ \item{legend.loc}{legend.loc places a legend into one of nine locations on the chart: bottomright, bottom, bottomleft, left, topleft, top, topright, right, or center.} +\item{legend.names}{character vector of names for the legend. If \code{NULL}, +the column names of the current plot object are used.} + +\item{col}{fill colors for the legend. If \code{NULL}, +the colorset of the current plot object data is used.} + \item{ncol}{number of columns for the legend} \item{\dots}{any other passthrough parameters. Not currently used.} Modified: pkg/xtsExtra/man/plot.xts.Rd =================================================================== --- pkg/xtsExtra/man/plot.xts.Rd 2014-12-26 17:30:36 UTC (rev 864) +++ pkg/xtsExtra/man/plot.xts.Rd 2014-12-26 18:01:34 UTC (rev 865) @@ -4,7 +4,7 @@ \title{Time series Plotting} \usage{ \method{plot}{xts}(x, y = NULL, ..., subset = "", FUN = NULL, - panels = NULL, multi.panel = FALSE, colorset = 1:12, up.col = "green", + panels = NULL, multi.panel = FALSE, col = 1:12, up.col = "green", dn.col = "red", type = "l", lty = 1, lwd = 2, lend = 1, main = deparse(substitute(x)), clev = 0, cex = 0.6, cex.axis = 0.9, mar = c(3, 2, 0, 2), srt = 0, xaxis.las = 0, ylim = NULL, @@ -32,7 +32,7 @@ will be plotted in groups of 2 columns and each group is plotted in a separate panel.} -\item{colorset}{color palette to use, set by default to rational choices} +\item{col}{color palette to use, set by default to rational choices} \item{up.col}{color for positive bars if \code{type="h"}} Modified: pkg/xtsExtra/sandbox/paFUN.R =================================================================== --- pkg/xtsExtra/sandbox/paFUN.R 2014-12-26 17:30:36 UTC (rev 864) +++ pkg/xtsExtra/sandbox/paFUN.R 2014-12-26 18:01:34 UTC (rev 865) @@ -5,7 +5,7 @@ lenv$plot_drawdowns <- function(x, geometric, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - colorset <- x$Env$theme$colorset + col <- x$Env$theme$col # Add x-axis grid lines atbt <- xtsExtra:::axTicksByTime2(xdata[xsubset]) segments(x$Env$xycoords$x[atbt], @@ -14,7 +14,7 @@ par("usr")[4], col=x$Env$theme$grid) drawdowns <- PerformanceAnalytics:::Drawdowns(xdata, geometric)[xsubset] - xtsExtra:::chart.lines(drawdowns, type="l", colorset=colorset) + xtsExtra:::chart.lines(drawdowns, type="l", col=col) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(geometric=geometric,...)), @@ -81,7 +81,7 @@ lenv$plot_returns <- function(x, type) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - colorset <- x$Env$theme$colorset + col <- x$Env$theme$col up.col <- x$Env$theme$up.col dn.col <- x$Env$theme$dn.col # Add x-axis grid lines @@ -91,7 +91,7 @@ x$Env$xycoords$x[atbt], par("usr")[4], col=x$Env$theme$grid) - xtsExtra:::chart.lines(xdata[xsubset], type=type, colorset=colorset, up.col=up.col, dn.col=dn.col) + xtsExtra:::chart.lines(xdata[xsubset], type=type, col=col, up.col=up.col, dn.col=dn.col) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(type=type)), @@ -163,7 +163,7 @@ lenv$plot_performance <- function(x, width, FUN, fill, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - colorset <- x$Env$theme$colorset + col <- x$Env$theme$col up.col <- x$Env$theme$up.col dn.col <- x$Env$theme$dn.col # Add x-axis grid lines @@ -173,7 +173,7 @@ par("usr")[4], col=x$Env$theme$grid) rolling_performance <- RollingPerformance(R=xdata, width=width, FUN=FUN, fill=fill, ...=...) - xtsExtra:::chart.lines(rolling_performance, type="l", colorset=colorset, up.col=up.col, dn.col=dn.col) + xtsExtra:::chart.lines(rolling_performance, type="l", col=col, 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, ...)), Modified: pkg/xtsExtra/sandbox/test_plot2.R =================================================================== --- pkg/xtsExtra/sandbox/test_plot2.R 2014-12-26 17:30:36 UTC (rev 864) +++ pkg/xtsExtra/sandbox/test_plot2.R 2014-12-26 18:01:34 UTC (rev 865) @@ -90,7 +90,7 @@ plot(R, FUN="CumReturns") plot(R, FUN="CumReturns", lty=1:4) plot(R, FUN="CumReturns", lty=1:4, lwd=c(3, 1, 1, 1)) -plot(R, FUN="CumReturns", lwd=c(3, 2, 2, 2), colorset=c(1, rep("gray", 3))) +plot(R, FUN="CumReturns", lwd=c(3, 2, 2, 2), col=c(1, rep("gray", 3))) plot(R, yaxis.left=TRUE, yaxis.right=FALSE) plot(R, grid.ticks.lwd=1, grid.ticks.lty="solid", grid.col="black") @@ -102,7 +102,7 @@ } plot(R, FUN=foo) addLegend(ncol = 4) -addLegend(legend.names = c("foo", "bar"), colorset = c(1,2), ncol=2) +addLegend(legend.names = c("foo", "bar"), col = c(1,2), ncol=2) plot(R, FUN=foo, legend.loc="topleft") plot(R, FUN=foo, legend.loc="left") From noreply at r-forge.r-project.org Tue Dec 30 04:32:31 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 30 Dec 2014 04:32:31 +0100 (CET) Subject: [Xts-commits] r866 - pkg/xts/R Message-ID: <20141230033231.CDDD3187B67@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-30 04:32:31 +0100 (Tue, 30 Dec 2014) New Revision: 866 Added: pkg/xts/R/modify.args.R Modified: pkg/xts/R/plot.R pkg/xts/R/zzz.R Log: porting functions/files from xtsExtra to xts for plot.xts Added: pkg/xts/R/modify.args.R =================================================================== --- pkg/xts/R/modify.args.R (rev 0) +++ pkg/xts/R/modify.args.R 2014-12-30 03:32:31 UTC (rev 866) @@ -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 $ +# +############################################################################### Modified: pkg/xts/R/plot.R =================================================================== --- pkg/xts/R/plot.R 2014-12-26 18:01:34 UTC (rev 865) +++ pkg/xts/R/plot.R 2014-12-30 03:32:31 UTC (rev 866) @@ -1,108 +1,1430 @@ -# -# xts: eXtensible time-series -# -# Copyright (C) 2008 Jeffrey A. Ryan jeff.a.ryan @ gmail.com -# -# Contributions from Joshua M. Ulrich -# -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . +# Environment for our xts chart objects (xts_chob) +# .plotxtsEnv <- new.env() -`plot.xts` <- function(x, y=NULL, - type='l', auto.grid=TRUE, - major.ticks='auto', minor.ticks=TRUE, - major.format=TRUE, - bar.col='grey', candle.col='white', - ann=TRUE, axes=TRUE, - ...) { - series.title <- deparse(substitute(x)) +axTicksByTime2 <- function (x, ticks.on = "auto", k = 1, labels = TRUE, + format.labels = TRUE, ends = TRUE, + gt = 2, lt = 25){ + if (timeBased(x)) + x <- xts(rep(1, length(x)), x) + #tick.opts <- c("years", "months", "days", "hours", + # "minutes", "seconds") + tick.opts <- c("years", "months", "weeks", "days") + tick.k.opts <- c(1,1,1,1) + if (ticks.on %in% tick.opts) { + cl <- ticks.on[1] + ck <- k + } + else { + tick.opts <- paste(tick.opts, tick.k.opts) + is <- structure(rep(0, length(tick.opts)), .Names = tick.opts) + for (i in 1:length(tick.opts)) { + y <- strsplit(tick.opts[i], " ")[[1]] + ep <- endpoints(x, y[1], as.numeric(y[2])) + if(i>1 && is[i-1] == length(ep)-1) + break + is[i] <- length(ep) - 1 + if (is[i] > lt) + break + } + nms <- rev(names(is)[which(is > gt & is < lt)])[1] + cl <- strsplit(nms, " ")[[1]][1] + ck <- as.numeric(strsplit(nms, " ")[[1]][2]) + } + if (is.na(cl) || is.na(ck) || is.null(cl)) { + return(c(1,NROW(x))) + #ep <- NULL + } + else ep <- endpoints(x, cl, ck) + if (ends) + ep <- ep + c(rep(1, length(ep) - 1), 0) + if (labels) { + if (is.logical(format.labels) || is.character(format.labels)) { + unix <- ifelse(.Platform$OS.type == "unix", TRUE, + FALSE) + #time.scale <- periodicity(x)$scale + #fmt <- ifelse(unix, "%n%b%n%Y", "%b %Y") + fmt <- switch(cl, + "years"="%Y", + "months"="%b", + "days"="%d", + "weeks"="W%W", + "hours"="%H:%M", + "minutes"="%H:%M:%S", + "seconds"="%H:%M:%S") + if(ndays(x) > 1 && cl %in% c("hours","minutes","seconds")) { + fmt <- paste("%b-%d",fmt) + } + names(ep) <- format(index(x)[ep], fmt) + } + else names(ep) <- as.character(index(x)[ep]) + } + ep +} - #time.scale <- periodicity(x)$scale - ep <- axTicksByTime(x,major.ticks, format.labels=major.format) +current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv)) - otype <- type +chart.lines <- function(x, + type="l", + lty=1, + lwd=2, + lend=1, + col=1:10, + up.col=NULL, + dn.col=NULL, + legend.loc=NULL, + pch=1){ + if(is.null(up.col)) up.col <- "green" + if(is.null(dn.col)) dn.col <- "red" + xx <- current.xts_chob() + if(type == "h"){ + colors <- ifelse(x[,1] < 0, dn.col, up.col) + # lines(1:NROW(x),x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h") + # non-equally spaced x-axis + lines(xx$Env$xycoords$x,x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h") + } else if(type == "l" || type == "p") { + if(length(lty) == 1) lty <- rep(lty, NCOL(x)) + if(length(lwd) == 1) lwd <- rep(lwd, NCOL(x)) + for(i in NCOL(x):1){ + # lines(1:NROW(x), x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch) + # non-equally spaced x-axis + lines(xx$Env$xycoords$x, x[,i], type=type, lend=lend, col=col[i], lty=lty[i], lwd=lwd[i], pch=pch) + } + } else if(type == "bar"){ + # This does not work correctly + # The geometry of the x-axis and y-axis is way off with stacked bar plot and + # the x-axis is off for unstacked bar plot + # We may need a separate function to do this correctly because of the + # different geometry/dimensions with stacked and unstacked barplots + positives = negatives = x + for(column in 1:NCOL(x)){ + for(row in 1:NROW(x)){ + positives[row,column] = max(0, x[row,column]) + negatives[row,column] = min(0, x[row,column]) + } + } + barplot.default(t(positives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE) + barplot.default(t(negatives), add=TRUE, col=col, axisnames=FALSE, axes=FALSE) + } + if(!is.null(legend.loc)){ + yrange <- range(x, na.rm=TRUE) + # nobs <- NROW(x) + chob.xlim <- xx$Env$xlim + switch(legend.loc, + topleft = { + xjust <- 0 + yjust <- 1 + lx <- chob.xlim[1] + ly <- yrange[2] + }, + left = { + xjust <- 0 + yjust <- 0.5 + lx <- chob.xlim[1] + ly <- sum(yrange) / 2 + }, + bottomleft = { + xjust <- 0 + yjust <- 0 + lx <- chob.xlim[1] + ly <- yrange[1] + }, + top = { + xjust <- 0.5 + yjust <- 1 + lx <- (chob.xlim[1] + chob.xlim[2]) / 2 + ly <- yrange[2] + }, + center = { + xjust <- 0.5 + yjust <- 0.5 + lx <- (chob.xlim[1] + chob.xlim[2]) / 2 + ly <- sum(yrange) / 2 + }, + bottom = { + xjust <- 0.5 + yjust <- 0 + lx <- (chob.xlim[1] + chob.xlim[2]) / 2 + ly <- yrange[1] + }, + topright = { + xjust <- 1 + yjust <- 1 + lx <- chob.xlim[2] + ly <- yrange[2] + }, + right = { + xjust <- 1 + yjust <- 0.5 + lx <- chob.xlim[2] + ly <- sum(yrange) / 2 + }, + bottomright = { + xjust <- 1 + yjust <- 0 + lx <- chob.xlim[2] + ly <- yrange[1] + } + ) + legend(x=lx, y=ly, legend=colnames(x), xjust=xjust, yjust=yjust, + fill=col[1:NCOL(x)], bty="n") + } +} - if(is.OHLC(x) && type %in% c('candles','bars')) { - x <- x[,has.OHLC(x, TRUE)] - xycoords <- list(x=.index(x), y=seq(min(x),max(x),length.out=NROW(x))) - type <- "n" + +# xtsExtraTheme <- function(){ +# theme <-list(col=list(bg="#FFFFFF", +# label.bg="#F0F0F0", +# grid="darkgray", #grid="#F0F0F0", +# grid2="#F5F5F5", +# ticks="#999999", +# labels="#333333", +# line.col="darkorange", +# dn.col="red", +# up.col="green", +# dn.border="#333333", +# up.border="#333333", +# colorset=1:10), +# shading=1, +# format.labels=TRUE, +# coarse.time=TRUE, +# rylab=TRUE, +# lylab=TRUE, +# grid.ticks.lwd=1, +# grid.ticks.on="months") +# theme +# } + +# based on quantmod::chart_Series +#' Time series Plotting +#' +#' Plotting for xts objects. +#' TODO: description, details, and examples +#' +#' @param x xts object +#' @param y NULL, not used +#' @param \dots any passthrough parameters to FUN +#' @param subset character vector of length one of the subset range using subsetting as in \code{\link{xts}} +#' @param FUN function to apply to \code{x} and plot +#' @param panels character vector of expressions to plot as panels +#' @param multi.panel TRUE/FALSE or an integer less than or equal to the number +#' of columns in the data set. If TRUE, each column of the data is plotted in a +#' separate panel. For example, if \code{multi.panel = 2}, then the data +#' will be plotted in groups of 2 columns and each group is plotted in a +#' separate panel. +#' @param col color palette to use, set by default to rational choices +#' @param up.col color for positive bars if \code{type="h"} +#' @param dn.col color for positive bars if \code{type="h"} +#' @param type the type of plot to be drawn, same as in \code{\link{plot}} +#' @param lty set the line type, same as in plot +#' @param lwd set the line width, same as in plot +#' @param lend set the line end style, same as in plot +#' @param main main title +#' @param clev level for shading, not currently used +#' @param cex not currently used +#' @param cex.axis +#' @param mar set the margins, same as in par +#' @param srt rotation for the y axis labels +#' @param xaxis.las rotation for the x axis labels +#' @param ylim the range of the y axis +#' @param yaxis.same TRUE/FALSE. If TRUE, the y axis is drawn with the same ylim for multiple panels +#' @param yaxis.left if TRUE, draws the y axis on the left +#' @param yaxis.right if TRUE, draws the y axis on the right +#' @param grid.ticks.on period to draw the grid ticks on +#' @param grid.ticks.lwd line width of the grid +#' @param grid.ticks.lty line type of the grid +#' @param grid.col color of the grid +#' @param labels.col color of the axis labels +#' @param format.labels not currently used +#' @param shading not currently used +#' @param bg.col not currently used +#' @param grid2 color for secondary x axis grid +#' @param legend.loc places a legend into one of nine locations on the chart: +#' bottomright, bottom, bottomleft, left, topleft, top, topright, right, or +#' center. Default NULL does not draw a legend. +#' @author Ross Bennett +plot.xts <- function(x, + y=NULL, + ..., + subset="", + FUN=NULL, + panels=NULL, + multi.panel=FALSE, + col=1:12, + up.col="green", + dn.col="red", + type="l", + lty=1, + lwd=2, + lend=1, + main=deparse(substitute(x)), + clev=0, + cex=0.6, + cex.axis=0.9, + mar=c(3,2,0,2), + srt=0, + xaxis.las=0, + ylim=NULL, + yaxis.same=TRUE, + yaxis.left=TRUE, + yaxis.right=TRUE, + grid.ticks.on="months", + grid.ticks.lwd=1, + grid.ticks.lty=1, + grid.col="darkgray", + labels.col="#333333", + format.labels=TRUE, + shading=1, + bg.col="#FFFFFF", + grid2="#F5F5F5", + legend.loc=NULL){ + + # 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(multi.panel)){ + multi.panel <- min(NCOL(x), multi.panel) + idx <- seq.int(1L, NCOL(x), 1L) + 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 + multi.panel <- FALSE + } else { + # we will plot the returns by column, but not the panels + multi.panel <- TRUE + panels <- NULL + + if(yaxis.same){ + # If we want the same y-axis and a FUN is specified, we need to + # apply the transformation first to compute the range for the y-axis + if(!is.null(FUN) && nchar(FUN) > 0){ + 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) + if(inherits(R, "try-error")) { + message(paste("FUN function failed with message", R)) + ylim <- range(x[subset], na.rm=TRUE) + } else { + ylim <- range(R[subset], na.rm=TRUE) + } + } else { + # set the ylim based on the data passed into the x argument + ylim <- range(x[subset], na.rm=TRUE) + } + } + } + + for(i in 1:length(chunks)){ + tmp <- chunks[[i]] + p <- plot.xts(x=x[,tmp], + y=y, + ...=..., + subset=subset, + FUN=FUN, + panels=panels, + multi.panel=multi.panel, + col=col, + up.col=up.col, + dn.col=dn.col, + type=type, + lty=lty, + lwd=lwd, + lend=lend, + main=main, + clev=clev, + cex=cex, + cex.axis=cex.axis, + mar=mar, + srt=srt, + xaxis.las=xaxis.las, + ylim=ylim, + yaxis.same=yaxis.same, + yaxis.left=yaxis.left, + yaxis.right=yaxis.right, + grid.ticks.on=grid.ticks.on, + grid.ticks.lwd=grid.ticks.lwd, + grid.ticks.lty=grid.ticks.lty, + grid.col=grid.col, + labels.col=labels.col, + format.labels=format.labels, + shading=shading, + bg.col=bg.col, + grid2=grid2, + legend.loc=legend.loc) + if(i < length(chunks)) + print(p) + } + # NOTE: return here so we don't draw another chart + return(p) + } + + cs <- new.replot_xts() + if(is.null(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 + + # 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) + } + Env$xsubset <<- x + # set_xlim(c(1,NROW(Env$xdata[Env$xsubset]))) + # non equally spaced x-axis + set_xlim(range(Env$xycoords$x, na.rm=TRUE)) + ylim <- get_ylim() + for(y in seq(2,length(ylim),by=2)) { + if(!attr(ylim[[y]],'fixed')) + 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(lenv$xdata[Env$xsubset], na.rm=TRUE)[1],na.rm=TRUE) + max.tmp <- max(ylim[[frame]][2],range(lenv$xdata[Env$xsubset], na.rm=TRUE)[2],na.rm=TRUE) + ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed) + } + }) + # 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) + + # add theme and charting parameters to Env + if(multi.panel){ + cs$set_asp(NCOL(x)) } else { - if(NCOL(x) > 1) warning('only the univariate series will be plotted') - if(is.null(y)) - xycoords <- xy.coords(.index(x), x[,1]) + cs$set_asp(3) } + cs$Env$cex <- cex + cs$Env$mar <- mar + cs$Env$clev = min(clev+0.01,1) # (0,1] + cs$Env$theme$shading <- shading + cs$Env$theme$up.col <- up.col + cs$Env$theme$dn.col <- dn.col + if (hasArg(colorset)){ + cs$Env$theme$col <- match.call(expand.dots=TRUE)$colorset + } else { + cs$Env$theme$col <- col + } + cs$Env$theme$rylab <- yaxis.right + cs$Env$theme$lylab <- yaxis.left + cs$Env$theme$bg <- bg.col + cs$Env$theme$grid <- grid.col + cs$Env$theme$grid2 <- grid2 + cs$Env$theme$labels <- labels.col + cs$Env$theme$srt <- srt + cs$Env$theme$xaxis.las <- xaxis.las + cs$Env$theme$cex.axis <- cex.axis + cs$Env$format.labels <- format.labels + cs$Env$grid.ticks.on <- grid.ticks.on + cs$Env$grid.ticks.lwd <- grid.ticks.lwd + cs$Env$grid.ticks.lty <- grid.ticks.lty + cs$Env$type <- type + cs$Env$lty <- lty + cs$Env$lwd <- lwd + cs$Env$lend <- lend + cs$Env$legend.loc <- legend.loc + cs$Env$call_list <- list() + cs$Env$call_list[[1]] <- match.call() + + # 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 + + # Raw returns data passed into function + cs$Env$xdata <- x + cs$Env$xsubset <- subset + cs$Env$column_names <- colnames(x) + cs$Env$nobs <- NROW(cs$Env$xdata) + cs$Env$main <- main + + # non equally spaced x-axis + xycoords <- xy.coords(.index(cs$Env$xdata[cs$Env$xsubset]), + cs$Env$xdata[cs$Env$xsubset][,1]) + cs$Env$xycoords <- xycoords + cs$Env$xlim <- range(xycoords$x, na.rm=TRUE) + cs$Env$xstep <- diff(xycoords$x[1:2]) + + # Compute transformation if specified by panel argument + # rough prototype for calling a function for the main "panel" + 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) + if("x" %in% names(.formals)) .formals <- modify.args(formals=.formals, arglist=NULL, x=x, dots=TRUE) + .formals$... <- NULL + R <- try(do.call(fun, .formals), silent=TRUE) + if(inherits(R, "try-error")) { + message(paste("FUN function failed with message", R)) + cs$Env$R <- x + } else { + cs$Env$R <- R + } + } else { + cs$Env$R <- x + } + + # Set xlim based on the raw returns data passed into function + # cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) + # non equally spaced x-axis + cs$set_xlim(cs$Env$xlim) + + + # Set ylim based on the transformed data + # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or + # which is best. + if(is.null(ylim)){ + if(isTRUE(multi.panel)){ + if(yaxis.same){ + # set the ylim for the first panel based on all the data + cs$set_ylim(list(structure(range(cs$Env$R[subset], na.rm=TRUE),fixed=TRUE))) + } else { + # set the ylim for the first panel based on the first column + cs$set_ylim(list(structure(range(cs$Env$R[,1][subset], na.rm=TRUE),fixed=TRUE))) + } + } else { + # set the ylim based on all the data if this is not a multi.panel plot + cs$set_ylim(list(structure(range(cs$Env$R[subset], na.rm=TRUE),fixed=TRUE))) + } + cs$Env$constant_ylim <- range(cs$Env$R[subset], na.rm=TRUE) + } else { + # use the ylim arg passed in + cs$set_ylim(list(structure(ylim, fixed=TRUE))) + 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) { + # ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 + + # last(axTicksByTime2(xdata[xsubset],labels=TRUE),-1) + # if(min(diff(ticks)) < max(strwidth(names(ticks)))) { + # ticks <- unname(ticks) + # } + # ticks + #} + + # compute the x-axis ticks + cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]), + get_ylim()[[2]][1], + xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]), + get_ylim()[[2]][2], + col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)), + clip=FALSE,expr=TRUE) + + # Add frame for the chart "header" to display the name and start/end dates + cs$add_frame(0,ylim=c(0,1),asp=0.5) + cs$set_frame(1) + + # add observation level ticks on x-axis if < 400 obs. + cs$add(expression(if(NROW(xdata[xsubset])<400) + {axis(1,at=xycoords$x,labels=FALSE,col=theme$grid2,tcl=0.3)}),expr=TRUE) + + # add "month" or "month.abb" + cs$add(expression(axt <- axTicksByTime(xdata[xsubset],format.labels=format.labels), + axis(1, + at=xycoords$x[axt], #axTicksByTime(xdata[xsubset]), + labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)), + las=theme$xaxis.las, lwd.ticks=1, mgp=c(3,1.5,0), + tcl=-0.4, cex.axis=theme$cex.axis)), + expr=TRUE) + + # add main and start/end dates + #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(xlim[1],0.5,main,font=2,col='#444444',offset=0,cex=1.1,pos=4)), + expression(text(xlim[2],0.5, + paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), + col=1,adj=c(0,0),pos=2))) + cs$add(text.exp, env=cs$Env, expr=TRUE) + + cs$set_frame(2) + # define function for y-axis labels + #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 <- expression(segments(xlim[1], + y_grid_lines(get_ylim()[[2]]), + xlim[2], + y_grid_lines(get_ylim()[[2]]), + col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)) + if(yaxis.left){ + exp <- c(exp, + # left y-axis labels + expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(get_ylim()[[2]]))), + y_grid_lines(get_ylim()[[2]]), + noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")), + col=theme$labels, srt=theme$srt, offset=0, pos=4, + cex=theme$cex.axis, xpd=TRUE))) + } + if(yaxis.right){ + exp <- c(exp, + # right y-axis labels + expression(text(xlim[2]+xstep*2/3, + y_grid_lines(get_ylim()[[2]]), + noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")), + col=theme$labels, srt=theme$srt, offset=0, pos=4, + cex=theme$cex.axis, xpd=TRUE))) + } + cs$add(exp, env=cs$Env, expr=TRUE) + + # add main series + cs$set_frame(2) + 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() + lenv$xdata <- cs$Env$R[,1][subset] + lenv$label <- colnames(cs$Env$R[,1]) + lenv$type <- cs$Env$type + if(yaxis.same){ + lenv$ylim <- cs$Env$constant_ylim + } else { + lenv$ylim <- range(cs$Env$R[,1][subset], na.rm=TRUE) + } + exp <- expression(chart.lines(xdata, + type=type, + lty=lty, + lwd=lwd, + lend=lend, + col=theme$col, + up.col=theme$up.col, + dn.col=theme$dn.col, + legend.loc=legend.loc)) + # Add expression for the main plot + cs$add(exp, env=c(lenv,cs$Env), expr=TRUE) + text.exp <- expression(text(x=xycoords$x[2], + y=ylim[2]*0.9, + labels=label, + adj=c(0,0),cex=1,offset=0,pos=4)) + cs$add(text.exp,env=c(lenv, cs$Env),expr=TRUE) + + 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$label <- cs$Env$column_names[i] + if(yaxis.same){ + lenv$ylim <- cs$Env$constant_ylim + } else { + lenv$ylim <- range(cs$Env$R[,i][subset], na.rm=TRUE) + } + lenv$type <- cs$Env$type + + # Add a small frame + cs$add_frame(ylim=c(0,1),asp=0.25) + cs$next_frame() + text.exp <- expression(text(x=xlim[1], + y=0.5, + labels="", + 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=lenv$ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE) + cs$next_frame() + + exp <- expression(chart.lines(xdata[xsubset], + type=type, + lty=lty, + lwd=lwd, + lend=lend, + col=theme$col, + up.col=theme$up.col, + dn.col=theme$dn.col, + legend.loc=legend.loc)) + + # define function to plot the y-axis grid lines + lenv$y_grid_lines <- function(ylim) { + #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(xlim[1], + y_grid_lines(ylim), + xlim[2], + y_grid_lines(ylim), + col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)), + # x-axis grid lines + expression(atbt <- axTicksByTime2(xdata[xsubset]), + segments(xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]), + ylim[1], + xycoords$x[atbt], #axTicksByTime2(xdata[xsubset]), + ylim[2], + col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty))) + if(yaxis.left){ + exp <- c(exp, + # y-axis labels/boxes + expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(ylim))), + y_grid_lines(ylim), + noquote(format(y_grid_lines(ylim),justify="right")), + col=theme$labels, srt=theme$srt, offset=0, + pos=4, cex=theme$cex.axis, xpd=TRUE))) + } + if(yaxis.right){ + exp <- c(exp, + expression(text(xlim[2]+xstep*2/3, y_grid_lines(ylim), + noquote(format(y_grid_lines(ylim),justify="right")), + col=theme$labels, srt=theme$srt, offset=0, + pos=4, cex=theme$cex.axis, xpd=TRUE))) + } + cs$add(exp,env=c(lenv, cs$Env),expr=TRUE,no.update=TRUE) + text.exp <- expression(text(x=xycoords$x[2], + y=ylim[2]*0.9, + labels=label, + adj=c(0,0),cex=1,offset=0,pos=4)) + cs$add(text.exp,env=c(lenv, cs$Env),expr=TRUE) + } + } + } else { + if(type == "h" & NCOL(x) > 1) + warning("only the univariate series will be plotted") + cs$add(expression(chart.lines(R[xsubset], + type=type, + lty=lty, + lwd=lwd, + lend=lend, + col=theme$col, + up.col=theme$up.col, + dn.col=theme$dn.col, + legend.loc=legend.loc)),expr=TRUE) + assign(".xts_chob", cs, .plotxtsEnv) + } + + # Plot the panels or default to a simple line chart + 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 +} - plot(xycoords$x, xycoords$y, type=type, axes=FALSE, ann=FALSE, ...) +#' Add a time series to an existing xts plot +#' +#' @param x an xts object to plot. +#' @param main main title for a new panel if drawn. +#' @param on panel number to draw on. A new panel will be drawn if \code{on=NA}. [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/xts -r 866 From noreply at r-forge.r-project.org Tue Dec 30 04:36:30 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 30 Dec 2014 04:36:30 +0100 (CET) Subject: [Xts-commits] r867 - in pkg/xts: . man Message-ID: <20141230033630.9071D187B6E@r-forge.r-project.org> Author: rossbennett34 Date: 2014-12-30 04:36:30 +0100 (Tue, 30 Dec 2014) New Revision: 867 Added: pkg/xts/man/addLegend.Rd pkg/xts/man/addLines.Rd pkg/xts/man/addPoints.Rd pkg/xts/man/addSeries.Rd Modified: pkg/xts/NAMESPACE pkg/xts/man/plot.xts.Rd Log: * moving man files from xtsExtra to xts for plot.xts and add* functions * updating NAMESPACE with appropriate functions and methods for new version of plot.xts Modified: pkg/xts/NAMESPACE =================================================================== --- pkg/xts/NAMESPACE 2014-12-30 03:32:31 UTC (rev 866) +++ pkg/xts/NAMESPACE 2014-12-30 03:36:30 UTC (rev 867) @@ -120,11 +120,18 @@ export(axTicksByTime) export(plot.xts) -#export(lines.xts) +export(addLegend) +export(addLines) +export(addPoints) +export(addSeries) S3method(plot,xts) -S3method(lines,xts) -S3method(points,xts) +S3method(print, replot_xts) +S3method(plot, replot_xts) +#export(lines.xts) +#S3method(lines,xts) +#S3method(points,xts) + #export(Lag.xts, Next.xts) #, Diff.xts) export(lag.xts) Added: pkg/xts/man/addLegend.Rd =================================================================== --- pkg/xts/man/addLegend.Rd (rev 0) +++ pkg/xts/man/addLegend.Rd 2014-12-30 03:36:30 UTC (rev 867) @@ -0,0 +1,30 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{addLegend} +\alias{addLegend} +\title{Add Legend} +\usage{ +addLegend(legend.loc = "center", legend.names = NULL, col = NULL, + ncol = 1, ...) +} +\arguments{ +\item{legend.loc}{legend.loc places a legend into one of nine locations on +the chart: bottomright, bottom, bottomleft, left, topleft, top, topright, +right, or center.} + +\item{legend.names}{character vector of names for the legend. If \code{NULL}, +the column names of the current plot object are used.} + +\item{col}{fill colors for the legend. If \code{NULL}, +the colorset of the current plot object data is used.} + +\item{ncol}{number of columns for the legend} + +\item{\dots}{any other passthrough parameters. Not currently used.} +} +\description{ +Add Legend +} +\author{ +Ross Bennett +} + Added: pkg/xts/man/addLines.Rd =================================================================== --- pkg/xts/man/addLines.Rd (rev 0) +++ pkg/xts/man/addLines.Rd 2014-12-30 03:36:30 UTC (rev 867) @@ -0,0 +1,40 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{addLines} +\alias{addLines} +\title{Add vertical lines to an existing xts plot} +\usage{ +addLines(event.dates, event.labels = NULL, date.format = "\%Y-\%m-\%d", + main = "", on = NA, lty = 1, lwd = 1, col = 1, ...) +} +\arguments{ +\item{event.dates}{character vector of dates. Vertical lines will be drawn +to indicate that an event happened during that time period. \code{event.lines} should +be a vector of dates (e.g., \code{c("09/03","05/06"))} formatted the same as +\code{date.format}. This function matches the re-formatted row names (dates) with +the events.list, so to get a match the formatting needs to be correct.} + +\item{event.labels}{character vector of event labels corresponding to +\code{event.dates}. This will apply text labels (e.g., +\code{c("This Event", "That Event")} to the vertical lines drawn.} + +\item{date.format}{format for the dates in \code{event.lines}.} + +\item{main}{main title for a new panel if drawn.} + +\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} + +\item{lty}{set the line type, same as in \code{\link{plot}}.} + +\item{lwd}{set the line width, same as in \code{\link{plot}}.} + +\item{col}{color palette to use, set by default to rational choices.} + +\item{\dots}{any other passthrough parameters. Not currently used.} +} +\description{ +Add vertical lines to an existing xts plot +} +\author{ +Ross Bennett +} + Added: pkg/xts/man/addPoints.Rd =================================================================== --- pkg/xts/man/addPoints.Rd (rev 0) +++ pkg/xts/man/addPoints.Rd 2014-12-30 03:36:30 UTC (rev 867) @@ -0,0 +1,27 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{addPoints} +\alias{addPoints} +\title{Add time series of points to an existing xts plot} +\usage{ +addPoints(x, main = "", on = NA, col = NULL, pch = 0, ...) +} +\arguments{ +\item{x}{an xts object to plot.} + +\item{main}{main title for a new panel if drawn.} + +\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} + +\item{col}{color palette to use, set by default to rational choices.} + +\item{pch}{the type of plot to be drawn, same as in \code{\link{plot}}.} + +\item{\dots}{any other passthrough parameters. Not currently used.} +} +\description{ +Add time series of points to an existing xts plot +} +\author{ +Ross Bennett +} + Added: pkg/xts/man/addSeries.Rd =================================================================== --- pkg/xts/man/addSeries.Rd (rev 0) +++ pkg/xts/man/addSeries.Rd 2014-12-30 03:36:30 UTC (rev 867) @@ -0,0 +1,34 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{addSeries} +\alias{addSeries} +\title{Add a time series to an existing xts plot} +\usage{ +addSeries(x, main = "", on = NA, type = "l", col = NULL, lty = 1, + lwd = 1, pch = 0, ...) +} +\arguments{ +\item{x}{an xts object to plot.} + +\item{main}{main title for a new panel if drawn.} + +\item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} + +\item{type}{the type of plot to be drawn, same as in \code{\link{plot}}.} + +\item{col}{color palette to use, set by default to rational choices.} + +\item{lty}{set the line type, same as in \code{\link{plot}}.} + +\item{lwd}{set the line width, same as in \code{\link{plot}}.} + +\item{pch}{the type of plot to be drawn, same as in \code{\link{plot}}.} + +\item{\dots}{any other passthrough parameters. Not currently used.} +} +\description{ +Add a time series to an existing xts plot +} +\author{ +Ross Bennett +} + Modified: pkg/xts/man/plot.xts.Rd =================================================================== --- pkg/xts/man/plot.xts.Rd 2014-12-30 03:32:31 UTC (rev 866) +++ pkg/xts/man/plot.xts.Rd 2014-12-30 03:36:30 UTC (rev 867) @@ -1,51 +1,100 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand \name{plot.xts} \alias{plot.xts} -\title{ Plotting xts Objects } -\description{ -Plotting methods for xts objects. -} +\title{Time series Plotting} \usage{ -\method{plot}{xts}(x, y = NULL, - type = "l", - auto.grid = TRUE, - major.ticks = "auto", - minor.ticks = TRUE, - major.format = TRUE, - bar.col = "grey", - candle.col = "white", - ann = TRUE, axes = TRUE, ...) +\method{plot}{xts}(x, y = NULL, ..., subset = "", FUN = NULL, + panels = NULL, multi.panel = FALSE, col = 1:12, up.col = "green", + dn.col = "red", type = "l", lty = 1, lwd = 2, lend = 1, + main = deparse(substitute(x)), clev = 0, cex = 0.6, cex.axis = 0.9, + mar = c(3, 2, 0, 2), srt = 0, xaxis.las = 0, ylim = NULL, + yaxis.same = TRUE, yaxis.left = TRUE, yaxis.right = TRUE, + grid.ticks.on = "months", grid.ticks.lwd = 1, grid.ticks.lty = 1, + grid.col = "darkgray", labels.col = "#333333", format.labels = TRUE, + shading = 1, bg.col = "#FFFFFF", grid2 = "#F5F5F5", legend.loc = NULL) } \arguments{ - \item{x}{ an \code{xts} object } - \item{y}{ an \code{xts} object or NULL } - \item{type}{ type of plot to produce } - \item{auto.grid}{ should grid lines be drawn } - \item{major.ticks}{ should major tickmarks be drawn and labeled } - \item{minor.ticks}{ should minor tickmarks be drawn } - \item{major.format}{ passed along to axTicksByTime. See also } - \item{bar.col}{ the color of the bars when type is \sQuote{bars} or \sQuote{candles} } - \item{candle.col}{ the color of the candles when type is \sQuote{candles} } - \item{ann}{ passed \sQuote{par} graphical parameter } - \item{axes}{passed \sQuote{par} graphical parameter } - \item{\dots}{ additional graphical arguments } -} -\details{ -Mainly used to draw time-series plots with sensible x-axis labels, it -can also plot basic OHLC series using \code{type='candles'} or \code{type='bars'}. +\item{x}{xts object} -Better financial plots can be found in the \pkg{quantmod} package, though -these are generally incompatible with standard R graphics tools. +\item{y}{NULL, not used} + +\item{\dots}{any passthrough parameters to FUN} + +\item{subset}{character vector of length one of the subset range using subsetting as in \code{\link{xts}}} + +\item{FUN}{function to apply to \code{x} and plot} + +\item{panels}{character vector of expressions to plot as panels} + +\item{multi.panel}{TRUE/FALSE or an integer less than or equal to the number +of columns in the data set. If TRUE, each column of the data is plotted in a +separate panel. For example, if \code{multi.panel = 2}, then the data +will be plotted in groups of 2 columns and each group is plotted in a +separate panel.} + +\item{col}{color palette to use, set by default to rational choices} + +\item{up.col}{color for positive bars if \code{type="h"}} + +\item{dn.col}{color for positive bars if \code{type="h"}} + +\item{type}{the type of plot to be drawn, same as in \code{\link{plot}}} + +\item{lty}{set the line type, same as in plot} + +\item{lwd}{set the line width, same as in plot} + +\item{lend}{set the line end style, same as in plot} + +\item{main}{main title} + +\item{clev}{level for shading, not currently used} + +\item{cex}{not currently used} + +\item{cex.axis}{cex of the axis} + +\item{mar}{set the margins, same as in par} + +\item{srt}{rotation for the y axis labels} + +\item{xaxis.las}{rotation for the x axis labels} + +\item{ylim}{the range of the y axis} + +\item{yaxis.same}{TRUE/FALSE. If TRUE, the y axis is drawn with the same ylim for multiple panels} + +\item{yaxis.left}{if TRUE, draws the y axis on the left} + +\item{yaxis.right}{if TRUE, draws the y axis on the right} + +\item{grid.ticks.on}{period to draw the grid ticks on} + +\item{grid.ticks.lwd}{line width of the grid} + +\item{grid.ticks.lty}{line type of the grid} + +\item{grid.col}{color of the grid} + +\item{labels.col}{color of the axis labels} + +\item{format.labels}{not currently used} + +\item{shading}{not currently used} + +\item{bg.col}{not currently used} + +\item{grid2}{color for secondary x axis grid} + +\item{legend.loc}{places a legend into one of nine locations on the chart: +bottomright, bottom, bottomleft, left, topleft, top, topright, right, or +center. Default NULL does not draw a legend.} } -\value{ -Plots an xts object to the current device. +\description{ +Plotting for xts objects. +TODO: description, details, and examples } -\author{ Jeffrey A. Ryan } -\examples{ -data(sample_matrix) -plot(sample_matrix) -plot(as.xts(sample_matrix)) -plot(as.xts(sample_matrix), type='candles') +\author{ +Ross Bennett } -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory. -\keyword{ hplot } +