From 8fb26c50e5914d2d17fd4c94cb63d19f04bc35a6 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 7 Aug 2016 15:18:56 +0800 Subject: [PATCH 1/4] Refactor dropTA to use panel functionality Since S4 method and chartSeries.chob are deprecated, dropTA, listTA and get.chob functions are refactored to use panel functionality of xts::plot.xts. The way TAs are removed is based on which frame they are added to. --- R/TA.R | 8 +++++--- R/chob.R | 2 +- R/dropTA.R | 35 ++++++++++++++++++++++------------- 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/R/TA.R b/R/TA.R index 00c28461..6ffc451d 100644 --- a/R/TA.R +++ b/R/TA.R @@ -286,9 +286,11 @@ function(type=c('chartSeries','barChart','candleChart')) { }# }}} # listTA {{{ `listTA` <- -function(dev) { - if(missing(dev)) dev <- dev.cur() - sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call) +function(chob) { + if(missing(chob)) chob <- get.chob() + # return function calls of addTA + chob$Env$call_list[-1] + #sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call) } # }}} chartNULL <- function(...) return(invisible(NULL)) diff --git a/R/chob.R b/R/chob.R index e2db7e45..e1a126b2 100644 --- a/R/chob.R +++ b/R/chob.R @@ -27,7 +27,7 @@ function(x,pos) `get.chob` <- function() { - x <- .chob$.chob + x <- xts:::.plotxtsEnv$.xts_chob return(x) #x <- get('.chob',as.environment("package:quantmod")) #attr(x,'.Environment') <- NULL diff --git a/R/dropTA.R b/R/dropTA.R index 7c493d71..05e8fa81 100644 --- a/R/dropTA.R +++ b/R/dropTA.R @@ -61,18 +61,15 @@ function(ta,pos,occ=1,dev) { } `dropTA` <- -function(ta,occ=1,dev,all=FALSE) { +function(ta,occ=1,chob,all=FALSE) { if(all) return(do.call('dropTA', list(1:length(listTA())))) if(missing(ta)) stop("no TA indicator specified") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) - # get the current chob - lchob <- get.chob()[[dev]] + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) sel.ta <- NULL @@ -91,22 +88,34 @@ function(ta,occ=1,dev,all=FALSE) { if(!is.na(which.ta)) { # decrease window count if necessary - if(lchob@passed.args$TA[[which.ta]]@new) - lchob@windows <- lchob@windows - 1 + #if(lchob@passed.args$TA[[which.ta]]@new) + # lchob@windows <- lchob@windows - 1 sel.ta <- c(sel.ta,which.ta) + } else { + stop("nothing to remove") } } if(is.null(sel.ta)) stop("nothing to remove") # remove TA from current list - lchob@passed.args$TA <- lchob@passed.args$TA[-sel.ta] - if(length(lchob@passed.args$TA) < 1) - lchob@passed.args$TA <- list() + ta.list <- ta.list[-sel.ta] + for(li in sel.ta) { + # number of actions of chartSeries object without TA is 9 + frame <- attr(chob$Env$actions[[9 + sel.ta]], "frame") + if(abs(frame)==2) + chob$Env$actions[[9 + sel.ta]] <- NULL + else + chob$remove_frame(frame) + chob$Env$TA[[sel.ta]] <- NULL + ncalls <- length(chob$Env$call_list) + # plot.xts(...) is included in call_list but listTA() is not + chob$Env$call_list[1 + sel.ta] <- NULL + } # redraw chart - do.call("chartSeries.chob",list(lchob)) + chob - write.chob(lchob,lchob@device) + #write.chob(lchob,lchob@device) } From 756da0a27ab4f4c5c1d601b0acee9352fd19343f Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Mon, 8 Aug 2016 17:15:39 +0800 Subject: [PATCH 2/4] Refactor swapTA to use panel funactionalty To reduce memory usage temporary storage is dropped and "replace()" function is applied to re-order TAs and function calls instead. actions and y limits are re-ordered according to the frames. --- R/dropTA.R | 35 +++++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/R/dropTA.R b/R/dropTA.R index 05e8fa81..ece30e06 100644 --- a/R/dropTA.R +++ b/R/dropTA.R @@ -1,13 +1,13 @@ `swapTA` <- -function(ta1,ta2,occ1=1,occ2=1,dev) { +function(ta1,ta2,occ1=1,occ2=1,chob) { if(missing(ta1) | missing(ta2)) stop("two TA indicator required") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) + # default to the current chob if none specified + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) # get the current chob - lchob <- get.chob()[[dev]] + lchob <- chob # make indicator name match original call if(regexpr("^add",ta1) == -1) ta1 <- paste("add",ta1,sep='') @@ -19,14 +19,25 @@ function(ta1,ta2,occ1=1,occ2=1,dev) { which.ta2 <- which(ta2==sapply(ta.list, function(x) deparse(x[[1]])))[occ2] - tmp.ta1 <- lchob@passed.args$TA[[which.ta1]] - tmp.ta2 <- lchob@passed.args$TA[[which.ta2]] - - lchob@passed.args$TA[[which.ta1]] <- tmp.ta2 - lchob@passed.args$TA[[which.ta2]] <- tmp.ta1 + ### swap two TAs without temporary storage + + ta.seq <- seq_along(ta.list) + ta.swap <- replace(ta.seq, c(which.ta1, which.ta2), ta.seq[c(which.ta2, which.ta1)]) + lchob$Env$TA <- lchob$Env$TA[ta.swap] + lchob$Env$call_list[-1] <- lchob$Env$call_list[1 + ta.swap] + # swap frames + frame <- sapply(lchob$Env$actions[9+c(which.ta1, which.ta2)], function(x) attr(x, "frame")) + attr(lchob$Env$actions[[9+which.ta1]], "frame") <- frame[2] + attr(lchob$Env$actions[[9+which.ta2]], "frame") <- frame[1] + # swap actions + lchob$Env$actions[-c(1:9)] <- lchob$Env$actions[9+ta.swap] + # swap y limits + lchob$Env$ylim[frame] <- lchob$Env$ylim[rev(frame)] + + ### End swap - do.call("chartSeries.chob",list(lchob)) - write.chob(lchob,lchob@device) + lchob + #write.chob(lchob,lchob@device) } `moveTA` <- From bdac3b4728d3833872d04752240df3cdd6a38f8b Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Mon, 8 Aug 2016 18:02:09 +0800 Subject: [PATCH 3/4] Refactor moveTA to use panel functionality In addition to the movement of TA, function calls and actions are re-ordered as well. --- R/dropTA.R | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/R/dropTA.R b/R/dropTA.R index ece30e06..9541bd8a 100644 --- a/R/dropTA.R +++ b/R/dropTA.R @@ -41,18 +41,18 @@ function(ta1,ta2,occ1=1,occ2=1,chob) { } `moveTA` <- -function(ta,pos,occ=1,dev) { +function(ta,pos,occ=1,chob) { pos <- pos - 1 if(missing(ta)) stop("no TA indicator specified") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) + # default to the current chob if none specified + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) # get the current chob - lchob <- get.chob()[[dev]] + lchob <- chob # make indicator name match original call if(regexpr("^add",ta) == -1) ta <- paste("add",ta,sep='') @@ -63,12 +63,19 @@ function(ta,pos,occ=1,dev) { if(is.na(which.ta)) stop("no TA") - lchob@passed.args$TA <- append(lchob@passed.args$TA[-which.ta], - lchob@passed.args$TA[which.ta], + lchob$Env$TA <- append(lchob$Env$TA[-which.ta], + lchob$Env$TA[which.ta], after=pos) - - do.call("chartSeries.chob",list(lchob)) - write.chob(lchob,lchob@device) + lchob$Env$call_list <- append(lchob$Env$call_list[-(1+which.ta)], + lchob$Env$call_list[1+which.ta], + after=pos+1) + # move actions + lchob$Env$actions <- append(lchob$Env$actions[-(9+which.ta)], + lchob$Env$actions[9+which.ta], + after=pos+9) + + lchob + #write.chob(lchob,lchob@device) } `dropTA` <- From ce7cad73b9ade7f9da4654e2f84e1621345aea9b Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 20 Aug 2016 16:50:10 +0800 Subject: [PATCH 4/4] Refactor addTA to use panel functionality When "ta" is not characters of functions from TTR (SMA, BBands, ...), shading regime or new series are added if "ta" is logic or an object of xts class, respectively. --- R/TA.R | 124 +++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 98 insertions(+), 26 deletions(-) diff --git a/R/TA.R b/R/TA.R index 6ffc451d..e216f70c 100644 --- a/R/TA.R +++ b/R/TA.R @@ -38,42 +38,114 @@ function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) { plot(do.call(paste('add',ta,sep=''),list(...))) } else stop(paste('no TA method found for',paste('add',ta,sep=''))) } else { - lchob <- get.current.chob() - chobTA <- new("chobTA") - if(any(is.na(on))) { - chobTA@new <- TRUE - } else { - chobTA@new <- FALSE - chobTA@on <- on + lenv <- new.env() + lenv$chartTA <- function(x, ta, order, on, legend, yrange, ...) { + xsubset <- x$Env$xsubset + if(!is.null(order)) ta <- ta[,order] + if(all(is.na(on))) { + xlim <- x$Env$xlim + frame <- x$get_frame() + print(frame) + ylim <- x$get_ylim()[[frame]] + theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + } + 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, ylim[1] ,shade$end+1/3, ylim[2], col=theme$BBands$col$fill,...) + } else { + # we can add points that are not necessarily at the points + # on the main series + subset.range <- paste(start(xdata[xsubset]), + end(xdata[xsubset]),sep="/") + ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]), + .index(xdata[xsubset]), tzone=indexTZ(xdata)),ta)[subset.range] + ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) + ta.y <- ta.adj[,-1] + for(i in 1:NCOL(ta.y)) + lines(ta.x, as.numeric(ta.y[,i]), ...) + } } - nrc <- NROW(lchob@xdata) + if(!is.character(legend) || legend == "auto") + legend <- gsub("^add", "", deparse(match.call())) + # map all passed args (if any) to 'lenv' environment + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(ta=ta,order=order,on=on,legend=legend,yrange=yrange,...)), + list(ta=ta,order=order,on=on,legend=legend,yrange=yrange,...)) + exp <- parse(text=gsub("list","chartTA", + as.expression(substitute(list(x=current.chob(), + ta=get("ta"),order=order, + on=on,legend=legend, + yrange=yrange,...)))), + srcfile=NULL) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f", last(ta)))), + text.col = c(theme$fg, col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(!hasArg(col)) lenv$col <- lchob$Env$theme$BBands$col$ma + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + nrc <- NROW(xdata) ta <- try.xts(ta, error=FALSE) if(is.xts(ta)) { - x <- merge(lchob@xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE)) + x <- merge(xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE)) } else { if(NROW(ta) != nrc) stop('non-xtsible data must match the length of the underlying series') - x <- merge(lchob@xdata, ta, join='left', retside=c(FALSE,TRUE)) + x <- merge(xdata, ta, join='left', retside=c(FALSE,TRUE)) } if(is.logical(ta)) x <- as.logical(x, drop=FALSE) #identical to storage.mode(x)<-"logical" - - chobTA@TA.values <- coredata(x)[lchob@xsubset,] - chobTA@name <- "chartTA" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - yrange=yrange, - colors=lchob@colors, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - isLogical=is.logical(ta), - x.labels=lchob@x.labels, - order=order,legend=legend, - pars=list(list(...)), - time.scale=lchob@time.scale) + + lenv$xdata <- structure(x, .Dimnames=list(NULL, names(x))) + lenv$ta <- lchob$Env$TA$ta <- x + lenv$get_frame <- lchob$get_frame + if(all(is.na(on))) { + if(missing(yrange)) + lchob$add_frame(ylim=range(lenv$ta[xsubset],na.rm=TRUE), asp=1) + else { + lchob$add_frame(ylim=lenv$yrange, asp=1) + } + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + } + else { + for(i in seq_along(on)) { + lchob$set_frame(on[i]+1L) + if(!missing(yrange)) { + frame <- lchob$get_frame() + lchob$Env$ylim[[frame]] <- structure(yrange, fixed=FALSE) + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + } + } # if(is.null(sys.call(-1))) { # TA <- lchob@passed.args$TA # lchob@passed.args$TA <- c(TA,chobTA) @@ -82,7 +154,7 @@ function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) { # #quantmod:::chartSeries.chob(lchob) # invisible(chobTA) # } else { - return(chobTA) + lchob # } } }#}}}