[Xts-commits] r863 - pkg/xtsExtra/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 26 18:28:15 CET 2014
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())
More information about the Xts-commits
mailing list