From efc75e054bcedcb6f71b36aade8474e224b0fbcd Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 20 Jul 2016 18:36:02 +0800 Subject: [PATCH 01/23] Refactor addADX to follow skeleton_TA structure Refactor addADX to use skeleton_TA structure. New chartADX is given to create Directional Movement Index indicator based on skeleton_TA structure. --- R/addTA.R | 79 ++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index e810f5cf..f75ec15a 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -194,40 +194,59 @@ function(x) { # addADX {{{ `addADX` <- function(n=14, maType="EMA", wilder=TRUE) { + lenv <- new.env() + lenv$chartADX <- function(x, n, maType, wilder) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + adx <- ADX(cbind(Hi(xdata), Lo(xdata), Cl(xdata)), n=n, maType=maType, wilder=wilder)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(adx) - 1) + xlim <- x$Env$xlim + ylim <- c(min(adx*0.975, na.rm = TRUE), + max(adx*1.05, na.rm = TRUE)) + theme <- x$Env$theme + # 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) + segments(xlim[1], 20, xlim[2], 20, col = "#666666", lty = "dotted") + segments(xlim[1], 40, xlim[2], 40, col = "#666666", lty = "dotted") + + # draw DIp + lines(x.pos,adx[,1],col='green',lwd=1,type='l') + # draw DIn + lines(x.pos,adx[,2],col='red',lwd=1,type='l') + # draw ADX + lines(x.pos,adx[,4],col='blue',lwd=2,type='l') + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType, wilder = wilder)), + list(n = n, maType = maType, wilder = wilder)) + exp <- parse(text = gsub("list", "chartADX", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType, wilder = wilder)))), srcfile = NULL) + + lchob <- current.chob() - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset if(!is.OHLC(x)) stop("only applicable to HLC series") - adx <- ADX(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,wilder=wilder) - - chobTA@TA.values <- adx[lchob@xsubset,] - chobTA@name <- "chartADX" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,maType=maType,wilder=wilder) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + adx <- ADX(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,wilder=wilder)[xsubset] + lchob$Env$adx <- adx + lchob$add_frame(ylim=c(min(adx*0.975, na.rm = TRUE), + max(adx*1.05, na.rm = TRUE)),asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartADX {{{ `chartADX` <- From a5654d7018bdcb5bda4d6ef7d54329341a249174 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 20 Jul 2016 18:46:37 +0800 Subject: [PATCH 02/23] Refactor addATR to follow skeleton_TA structure Refactor addATR to use skeleton_TA structure. New chartATR is given to create Average True Range indicator based on skeleton_TA structure. --- R/addTA.R | 71 ++++++++++++++++++++++++++++++++----------------------- 1 file changed, 41 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index f75ec15a..f3d4a04e 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -286,40 +286,51 @@ function(x) { # addATR {{{ `addATR` <- function(n=14, maType="EMA", ...) { + lenv <- new.env() + lenv$chartATR <- function(x, n, maType) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + atr <- ATR(cbind(Hi(xdata), Lo(xdata), Cl(xdata)), n=n, maType=maType)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(atr) - 1) + xlim <- x$Env$xlim + ylim <- c(min(atr[,2]*0.975, na.rm = TRUE), + max(atr[,2]*1.05, na.rm = TRUE)) + theme <- x$Env$theme + # 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) + + lines(x.pos,atr[,2],col='blue',lwd=2,type='l') + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType)), list(n = n, maType = maType)) + exp <- parse(text = gsub("list", "chartATR", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType)))), srcfile = NULL) + + lchob <- current.chob() - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset if(!is.OHLC(x)) stop("only applicable to HLC series") - atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...) - - chobTA@TA.values <- atr[lchob@xsubset,] - chobTA@name <- "chartATR" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,maType=maType) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...)[xsubset] + lchob$Env$atr <- atr + lchob$add_frame(ylim=c(min(atr[,2]*0.975, na.rm = TRUE), + max(atr[,2]*1.05, na.rm = TRUE)),asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartATR {{{ `chartATR` <- From 21a28f673b0aa54af61e9a2b83b90515d508dbfa Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Thu, 21 Jul 2016 15:44:57 +0800 Subject: [PATCH 03/23] Refactor addBBands to follow skeleton_TA structure Refactor addBBands to use skeleton_TA structure. New chartBBands function is given to create Bollinger Bands indicator based on skeleton_TA structure. --- R/addTA.R | 188 +++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 157 insertions(+), 31 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index f3d4a04e..9080a2ba 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -690,44 +690,170 @@ function(x) { `addBBands` <- function(n=20,sd=2,maType='SMA',draw='bands',on=-1) { - draw.options <- c('bands','percent','width') - draw <- draw.options[pmatch(draw,draw.options)] - - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - if(draw=='bands') { - chobTA@new <- FALSE - } else { - chobTA@new <- TRUE - on <- NULL + draw.options <- c("bands", "percent", "width") + draw <- draw.options[pmatch(draw, draw.options)] + lenv <- new.env() + lenv$chartBBands <- function(x, n, sd, maType, draw, on) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + cbind(Hi(xdata),Lo(xdata),Cl(xdata)) + } else xdata + + bb <- BBands(xx,n=n,maType=maType,sd=sd)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(bb) - 1) + xlim <- x$Env$xlim + theme <- x$Env$theme + bband.col <- ifelse(!is.null(theme$bbands$col), + theme$bbands$col$upper,'red') + bband.fill <- ifelse(!is.null(theme$bbands$col$fill), + theme$bbands$col$fill,theme$bg) + + # bband col vector + # lower.band, middle.band, upper.band, %b, bb.width + if(length(bband.col) == 1) # no user specified + bband.col <- c(bband.col,'grey',rep(bband.col,3)) + + if(draw == 'bands') { + # draw Bollinger Bands on price chart + if(on[1] > 0) { + lines(x.pos, + bb[,1],col=bband.col[1],lwd=1,lty='dashed') + lines(x.pos, + bb[,3],col=bband.col[3],lwd=1,lty='dashed') + lines(x.pos, + bb[,2],col=bband.col[2],lwd=1,lty='dotted') + } else { + + polygon(c(x.pos,rev(x.pos)), + c(as.numeric(bb[,1]),as.numeric(rev(bb[,3]))),col=bband.fill,border=NA) + lines(x.pos, + bb[,1],col=bband.col[1],lwd=1,lty='dashed') + lines(x.pos, + bb[,3],col=bband.col[3],lwd=1,lty='dashed') + lines(x.pos, + bb[,2],col=bband.col[2],lwd=1,lty='dotted') + } + + lc <- xts:::legend.coords("topleft", xlim, lchob$get_ylim()[[2]]) + legend(lc$x,lc$y, + legend=paste("Bollinger Bands (", + paste(n,sd,sep=","),") [Upper/Lower]: ", + sprintf("%.3f",last(bb[,3])),"/", + sprintf("%.3f",last(bb[,1])), sep = ""), + text.col = bband.col[3], + xjust = lc$xjust, + yjust = 1.5, + bty = "n", + y.intersp=0.95) + + } else + if(draw == 'percent') { + + 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) + + # draw %B in new frame + y.range <- seq(min(bb[,4], na.rm = TRUE) * .9, + max(abs(bb[,4]), na.rm = TRUE) * 1.05, + length.out = length(x.pos)) + + lines(x.pos, bb[,4], col=bband.col[4],lwd=1) + + text(0,last(y.range) * .9, paste("Bollinger %b (", + paste(n,sd,sep=","), "): ", + sep=""), pos=4, col=theme$fg) + text(0,last(y.range) * .9, paste("\n\n\n", + sprintf("%.3f",last(bb[,4])), sep = ""), + pos=4, col=bband.col[4]) + + } else { + + 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) + + # draw width in new frame + # (high band - low band) / middle band + bbw <- (bb[,3] - bb[,1]) / bb[,2] + + y.range <- seq(min(bbw, na.rm = TRUE) * .9, + max(abs(bbw), na.rm = TRUE) * 1.05, + length.out = length(x.pos)) + + lines(x.pos, bbw, col=bband.col[5],lwd=1) + + text(0,last(y.range) * .9, paste("Bollinger Band Width (", + paste(n,sd,sep=","), "): ", + sep=""), pos=4, col=theme$fg) + text(0,last(y.range) * .9, paste("\n\n\n", + sprintf("%.3f",last(bbw)), sep = ""), + pos=4, col=bband.col[5]) + } } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, sd = sd, maType = maType, draw = draw, on = on)), + list(n = n, sd = sd, maType = maType, draw = draw, on = on)) + exp <- parse(text = gsub("list", "chartBBands", as.expression(substitute(list(x = current.chob(), + n = n, sd = sd, maType = maType, draw = draw, on = on)))), srcfile = NULL) +# draw.options <- c('bands','percent','width') +# draw <- draw.options[pmatch(draw,draw.options)] + lchob <- current.chob() + + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { cbind(Hi(x),Lo(x),Cl(x)) } else x - bb <- BBands(xx,n=n,maType=maType,sd=sd) - - chobTA@TA.values <- bb[lchob@xsubset,] - chobTA@name <- "chartBBands" - chobTA@call <- match.call() - chobTA@on <- on - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,ma=maType,sd=sd, - draw=draw) - return(chobTA) + bb <- BBands(xx,n=n,maType=maType,sd=sd)[xsubset] + lchob$Env$bb <- bb + if(draw == 'bands') { + # draw Bollinger Bands on price chart + lchob$set_frame(-2) + + } else + if(draw == 'percent') { + # draw %B in new frame + ylim <- c(min(bb[,4], na.rm = TRUE) * .9, + max(abs(bb[,4]), na.rm = TRUE) * 1.05) + + lchob$add_frame(ylim=c(ylim[1], ylim[2]),asp=1,fixed=TRUE) + lchob$next_frame() + + } else { + # draw width in new frame + # (high band - low band) / middle band + bbw <- (bb[,3] - bb[,1]) / bb[,2] + + ylim <- c(min(bbw, na.rm = TRUE) * .9, + max(abs(bbw), na.rm = TRUE) * 1.05) + + lchob$add_frame(ylim=c(ylim[1], ylim[2]),asp=1,fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartBBands {{{ `chartBBands` <- From 5b8d4d942b19f33bf1017aefb755be0e64fd5d33 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Fri, 22 Jul 2016 17:59:50 +0800 Subject: [PATCH 04/23] Refactor addCCI to follow skeleton_TA structure Refactor addCCI to use skeleton_TA structure. New chartCCI function is given to create Commodity Channel Index indicator based on skeleton_TA structure. --- R/addTA.R | 94 ++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 65 insertions(+), 29 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 9080a2ba..159a72cd 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -100,41 +100,77 @@ function(x) { `addCCI` <- function(n=20, maType="SMA", c=0.015) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartCCI <- function(x, n, maType, c) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xx <- if(is.OHLC(xdata)) { + cbind(Hi(xdata),Lo(xdata),Cl(xdata)) + } else xdata + cci <- CCI(xx,n=n,maType=maType,c=c)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cci) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(cci),na.rm=TRUE), + max(abs(cci),na.rm=TRUE))*1.05 + theme <- x$Env$theme + # 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) + + # draw shading in -100:100 y-range + rect(xlim[1],-100,xlim[2],100,col=theme$bbands$col$fill,border=theme$fg) + + # fill upper and lower areas + cci.above <- ifelse(cci >= 100,cci, 100) + cci.below <- ifelse(cci <= -100,cci,-100) + + polygon(c(x.pos,rev(x.pos)),cbind(cci.above,rep(100,length(cci))),col="red",border=theme$fg) + polygon(c(x.pos,rev(x.pos)),cbind(cci.below,rep(-100,length(cci))),col="red",border=theme$fg) + + # draw CCI + lines(x.pos,cci,col='red',lwd=1,type='l') + + # draw dotted guide line at 0 + segments(xlim[1],0,xlim[2],0,col='#666666',lwd=1,lty='dotted') + + # add indicator name and last value + text(0, ylim[2]*.9, + paste("Commodity Channel Index (", n, ",", + c,"):",sep=''),col=theme$fg,pos=4) + text(0, ylim[2]*.9, + paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red', + pos = 4) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType, c = c)), list(n = n, maType = maType, c = c)) + exp <- parse(text = gsub("list", "chartCCI", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType, c = c)))), srcfile = NULL) + lchob <- current.chob() - chobTA <- new("chobTA") - chobTA@new <- TRUE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { cbind(Hi(x),Lo(x),Cl(x)) } else x - cci <- CCI(xx,n=n,maType=maType,c=c) - - chobTA@TA.values <- cci[lchob@xsubset] - chobTA@name <- "chartCCI" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,maType=maType,c=c) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + cci <- CCI(xx,n=n,maType=maType,c=c)[xsubset] + lchob$Env$cci <- cci + lchob$add_frame(ylim=c(-max(abs(cci), na.rm = TRUE), + max(abs(cci), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartCCI {{{ `chartCCI` <- From f413eda3eff947f01e81f10e025d14fa1c96c16d Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 23 Jul 2016 14:19:07 +0800 Subject: [PATCH 05/23] Refactor addDEMA to follow skeleton_TA structure Refactor addDEMA to use skeleton_TA structure. New chart EMV function is given to create various Moving Averages of a series based on skeleton_TA structure. --- R/addTA.R | 102 +++++++++++++++++++++++++++++------------------------- 1 file changed, 55 insertions(+), 47 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 159a72cd..7fc58135 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1743,55 +1743,63 @@ function(x) { `addDEMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='pink') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - x <- as.matrix(target.TA@TA.values) - - if(missing(with.col)) with.col <- 1 + lenv <- new.env() + lenv$chartDEMA <- function(x, n, on, with.col, overlay, col) { + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- x$Env$xdata + + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(xdata)) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] + if(missing(with.col)) with.col <- 1 + +# if(is.function(with.col)) { +# x.tmp <- do.call(with.col,list(xdata)) +# } else x.tmp <- xdata[,with.col] + x.tmp <- xdata + } + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + if(length(n) < length(col)) { + colors <- 3:10 + } else colors <- col + + for(li in 1:length(n)) { + ma <- DEMA(x.tmp,n=n[li]) +# if(x@new) { +# par(new=TRUE) +# plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)), +# type='n',axes=FALSE,ann=FALSE) +# title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep='')) +# axis(2) +# box(col=x@params$colors$fg.col) +# } + lines(x.pos,ma,col=colors[li],lwd=1,type='l') + } } - - chobTA@TA.values <- x.tmp[lchob@xsubset] - chobTA@name <- "chartDEMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartDEMA", as.expression(substitute(list(x = current.chob(), + n = n, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + lchob$set_frame(on+1) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartDEMA {{{ `chartDEMA` <- From 5348b98ce1ae55379834ab410398db6d6b616c0f Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 23 Jul 2016 15:03:56 +0800 Subject: [PATCH 06/23] Refactor addDPO to follow skeleton_TA structure Refactor addDPO to use skeleton_TA structure. New chartDPO function is given inside addDPO to create Detrended Price Oscillator indicator based on skeleton_TA structure. --- R/addTA.R | 90 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 7fc58135..7bb36f6b 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -474,44 +474,74 @@ function(x) { `addDPO` <- function(n=10, maType="EMA", shift=n/2+1, percent=FALSE) { - lchob <- get.current.chob() + lenv <- new.env() + lenv$chartDPO <- function(x, n, maType, shift, percent) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(dpo) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(dpo), na.rm = TRUE), + max(abs(dpo), na.rm = TRUE))*1.05 + theme <- x$Env$theme + # 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) + segments(xlim[1], 0, xlim[2], 0, col = "#999999") + + dpo.tmp <- dpo + dpo.tmp[is.na(dpo)] <- 0 + dpo.positive <- ifelse(dpo.tmp >= 0,dpo.tmp,0) + dpo.negative <- ifelse(dpo.tmp < 0,dpo.tmp,0) + + polygon(c(x.pos,rev(x.pos)),cbind(dpo.positive,rep(0,length(dpo))),col=theme$up.col, border="#999999") + polygon(c(x.pos,rev(x.pos)),cbind(dpo.negative,rep(0,length(dpo))),col=theme$dn.col, border="#999999") + + text(0, ylim[2]*.9, + paste("De-trended Price Oscillator (", n,"):", sep = ""), + col = theme$fg, pos = 4) + + text(0, ylim[2]*.9, + paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo))), sep = ""), + col = ifelse(last(na.omit(dpo)) > 0,theme$up.col,theme$dn.col), + pos = 4) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType, shift = shift, percent = percent)), + list(n = n, maType = maType, shift = shift, percent = percent)) + exp <- parse(text = gsub("list", "chartDPO", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType, shift = shift, percent = percent)))), srcfile = NULL) + lchob <- current.chob() - x <- as.matrix(lchob@xdata) + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset - chobTA <- new("chobTA") - chobTA@new <- TRUE - # should really allow for _any_ series to be used, like MA (FIXME) xx <- if(is.OHLC(x)) { Cl(x) } else x - dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent) - - chobTA@TA.values <- dpo[lchob@xsubset] - - chobTA@name <- "chartDPO" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,maType=maType,shift=shift,percent=percent) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)[xsubset] + lchob$Env$dpo <- dpo + lchob$add_frame(ylim=c(-max(abs(dpo), na.rm = TRUE), + max(abs(dpo), na.rm = TRUE)) * 1.05,asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartDPO {{{ `chartDPO` <- From 7e7a1f68e90a25947c29d9fdf7495d904ea93a73 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 24 Jul 2016 17:05:31 +0800 Subject: [PATCH 07/23] Refactor addEnvelope to follow skeleton_TA structure Refactor addEnvelope to use skeleton_TA structure. New chartEnvelope function is given to create technical indicators to the chart based on skeleton_TA structure. --- R/addTA.R | 86 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 55 insertions(+), 31 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 7bb36f6b..4b128fdf 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1028,44 +1028,68 @@ function(x) { `addEnvelope` <- function(n=20,p=2.5,maType='SMA',...,on=1) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartEnvelope <- function(x, n, p, maType, ..., on) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + + ma <- do.call(maType,list(xx,n=n,...)) + mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100)) + + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(mae) - 1) + xlim <- x$Env$xlim + theme <- x$Env$theme + if(on[1] > 0) { + lines(x.pos,mae[,1],col='blue',lwd=1,lty='dotted') + lines(x.pos,mae[,3],col='blue',lwd=1,lty='dotted') + #lines(x.pos,mae[,2],col='grey',lwd=1,lty='dotted') + } else { + xx <- x.pos + polygon(c(xx,rev(xx)), c(as.numeric(mae[,1]),rev(as.numeric(mae[,3]))),col='#282828',border=NA) + lines(x.pos,mae[,1],col='blue',lwd=1,lty='dotted') + lines(x.pos,mae[,3],col='blue',lwd=1,lty='dotted') + #lines(x.pos,mae[,2],col='grey',lwd=1,lty='dotted') + } + + lc <- xts:::legend.coords("topleft", xlim, lchob$get_ylim()[[2]]) + legend(lc$x,lc$y, + legend=paste("Moving Ave. Envelope (", + paste(n,p,sep=","),") [Upper/Lower]: ", + sprintf("%.3f",last(mae[,3])),"/", + sprintf("%.3f",last(mae[,1])), sep = ""), + text.col = "blue", + xjust = lc$xjust, + yjust = 1.5, + bty = "n", + y.intersp=0.95) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, p = p, maType = maType, ..., on = on)), + list(n = n, p = p, maType = maType, ..., on = on)) + exp <- parse(text = gsub("list", "chartEnvelope", as.expression(substitute(list(x = current.chob(), + n = n, p = p, maType = maType, ..., on = on)))), srcfile = NULL) + + lchob <- current.chob() - chobTA <- new("chobTA") - chobTA@new <- FALSE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { Cl(x) } else x ma <- do.call(maType,list(xx,n=n,...)) - mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100)) - - chobTA@TA.values <- mae[lchob@xsubset,] - - chobTA@name <- "chartEnvelope" - chobTA@call <- match.call() - chobTA@on <- on - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,p=p,maType=maType) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))[xsubset] + lchob$Env$mae <- mae + lchob$set_frame(on+1) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartEnvelope {{{ `chartEnvelope` <- From 1d44bcac45b85bd02418845d50f172e6a22d372f Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 24 Jul 2016 17:54:37 +0800 Subject: [PATCH 08/23] Refactor addEVWMA to follow skeleton_TA structure Refactor addEVWMA to use skeleton_TA structure. New chartEVWMA is given to create various weighted moving averages of a series based on skeleton_TA structure. --- R/addTA.R | 110 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 61 insertions(+), 49 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 4b128fdf..e9bf2b06 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1889,56 +1889,68 @@ function(x) { `addEVWMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='yellow') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- cbind(do.call(with.col,list(x)),Vo(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - x <- as.matrix(target.TA@TA.values) - - if(missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] + lenv <- new.env() + lenv$chartEVWMA <- function(x, n, on, with.col, overlay, col) { + + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- x$Env$xdata + vo <- x$Env$vo + + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- cbind(do.call(with.col,list(xdata)),vo) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) + + if(missing(with.col)) with.col <- 1 + +# if(is.function(with.col)) { +# x.tmp <- do.call(with.col,list(xdata)) +# } else x.tmp <- xdata[,with.col] + x.tmp <- xdata + } + + if(!has.Vo(x.tmp)) return() + + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + if(length(n) < length(col)) { + colors <- 3:10 + } else colors <- col + + for(li in 1:length(n)) { + ma <- EVWMA(x.tmp[, 1],x.tmp[, 2],n=n[li]) + # if(x@new) { + # par(new=TRUE) + # plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)), + # type='n',axes=FALSE,ann=FALSE) + # title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep='')) + # axis(2) + # box(col=x@params$colors$fg.col) + # } + lines(x.pos,ma,col=colors[li],lwd=1,type='l') + } } - if(!has.Vo(x)) return() - - chobTA@TA.values <- cbind(x.tmp,Vo(x))[lchob@xsubset,] # Price + Volume - chobTA@name <- "chartEVWMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartEVWMA", as.expression(substitute(list(x = current.chob(), + n = n, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + lchob$set_frame(on+1) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartEVWMA {{{ `chartEVWMA` <- From 7dff00988d2de86118a7ef64de21a0d106150460 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 24 Jul 2016 20:21:50 +0800 Subject: [PATCH 09/23] Refactor addExpiry to follow skeleton_TA structure Refactor addExpiry to use skeleton_TA structure. New chartExpiry function is given to add options or futures expiration vertical bars to price chart. --- R/addTA.R | 62 ++++++++++++++++++++++++------------------------------- 1 file changed, 27 insertions(+), 35 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index e9bf2b06..66e96879 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -2072,41 +2072,33 @@ function(x) { # addExpiry {{{ `addExpiry` <- function(type='options',lty='dotted') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- FALSE - - # get the appropriate data - from the approp. src - #if(from.fig==1) { - x <- lchob@xdata - - if(type=='options') { - index.of.exp <- options.expiry(x) - } else index.of.exp <- futures.expiry(x) - - chobTA@TA.values <- index.of.exp[index.of.exp %in% lchob@xsubset] # single numeric vector - chobTA@name <- "chartExpiry" - chobTA@call <- match.call() - chobTA@on <- 1 - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,lty=lty) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + lenv <- new.env() + lenv$chartExpiry <- function(x, type, lty) { + + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- xdata[xsubset] + spacing <- x$Env$theme$spacing + theme <- x$Env$theme + + if(type=='options') { + index.of.exp <- options.expiry(xdata) + } else index.of.exp <- futures.expiry(xdata) + + for(ex in 1:length(index.of.exp)) { + abline(v=index.of.exp[ex]*spacing, lty=lty,col=theme$Expiry) + } + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(type=type,lty=lty)), list(type=type,lty=lty)) + exp <- parse(text = gsub("list", "chartExpiry", as.expression(substitute(list(x = current.chob(), + type=type,lty=lty)))), srcfile = NULL) + lchob <- current.chob() + + lchob$set_frame(-2) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartExpiry {{{ `chartExpiry` <- From cba122dc6a286d1b82ff6ea857b24974ee4ea544 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Mon, 25 Jul 2016 15:17:37 +0800 Subject: [PATCH 10/23] Refactor addMACD to follow skeleton_TA structure Refactor addMACD to use skeleton_TA structure. New chartMACD function is given to create MACD indicator in a new frame based on skeleton_TA structure. --- R/addTA.R | 92 ++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 67 insertions(+), 25 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 66e96879..5866fadd 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1186,37 +1186,79 @@ function(x) { `addMACD` <- function(fast=12,slow=26,signal=9,type='EMA',histogram=TRUE,col) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE - + + lenv <- new.env() + lenv$chartMACD <- function(x, fast, slow, signal, type, histogram, col) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + + macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(macd) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(macd),na.rm=TRUE), + max(abs(macd),na.rm=TRUE))*1.05 + theme <- x$Env$theme + # 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(histogram) { + cols <- ifelse((macd[,1]-macd[,2]) > 0, col[1],col[2]) + rect(x.pos - spacing/5,0,x.pos + spacing/5, macd[,1]-macd[,2], + col=cols,border=cols) + } + + lines(x.pos,macd[,1],col=col[3],lwd=1) + lines(x.pos,macd[,2],col=col[4],lwd=1,lty='dotted') + + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(lc$x, lc$y, + legend=c(paste("Moving Average Convergence Divergence (", + paste(fast,slow,signal,sep=','),"):", sep = ""), + paste("MACD:",sprintf("%.3f",last(macd[,1]))), + paste("Signal:",sprintf("%.3f",last(macd[,2])))), + text.col=c(theme$fg, col[3], col[4]), + xjust=lc$xjust, + yjust=lc$yjust, + bty='n', + y.intersp=0.95) + } col <- if(missing(col)) col <- c('#999999','#777777', - '#BBBBBB','#FF0000') + '#BBBBBB','#FF0000') + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(fast = fast,slow = slow,signal = signal,type = type,histogram = histogram,col = col)), + list(fast = fast,slow = slow,signal = signal,type = type,histogram = histogram,col = col)) + exp <- parse(text = gsub("list", "chartMACD", as.expression(substitute(list(x = current.chob(), + fast = fast,slow = slow,signal = signal,type = type,histogram = histogram,col = col)))), srcfile = NULL) + lchob <- current.chob() + + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { Cl(x) } else x - macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type) - - chobTA@TA.values <- macd[lchob@xsubset,] - - chobTA@name <- "chartMACD" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - fast=fast,slow=slow,signal=signal, - col=col,histo=histogram - ) - return(chobTA) + macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)[xsubset] + lchob$Env$macd <- macd + lchob$add_frame(ylim=c(-max(abs(macd),na.rm=TRUE), + max(abs(macd),na.rm=TRUE))*1.05, asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartMACD {{{ `chartMACD` <- From 8dc75031ff499ba06f8e4c99b68f226e2a79e087 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Mon, 25 Jul 2016 16:37:52 +0800 Subject: [PATCH 11/23] Refactor addMomentum to follow skeleton_TA structure Refactor addMomentum to use skeleton_TA structure. New chartMomentum function is given to create Momentum indicator based on skeleton_TA. Add 'with.col' argument to accept any arguments for x, not just Cl, which is required in the original code. --- R/addTA.R | 98 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 35 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 5866fadd..eb5c541e 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -15,46 +15,74 @@ # CLV,CMD,OBV,KST,TDI,WHF,Aroon,ChAD,ChVol,WilliamsAD, # Points, Stoch, SD, ...??? # addMomentum {{{ -`addMomentum` <- function(n=1) { +`addMomentum` <- function(n=1, with.col=Cl) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE - - # needs to accept any arguments for x, not just close + lenv <- new.env() + lenv$chartMomentum <- function(x, n, with.col) { + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + if(is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + xx <- do.call(with.col,list(xdata)) + } else xx <- xdata[,with.col] + + mom <- momentum(xx,n=n)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(mom) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(mom),na.rm=TRUE), + max(abs(mom),na.rm=TRUE)) * 1.05 + theme <- x$Env$theme + # 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) + + COLOR <- "#0033CC" + + segments(xlim[1],0,xlim[2],0,col="#666666",lwd=1,lty='dotted') + + lines(x.pos,mom,col=COLOR,lwd=2,type='l') + + text(0, ylim[2]*.9, + paste("Momentum (", n, "):"),col=theme$fg, pos=4) + + text(0, ylim[2]*.9, + paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''), + col = COLOR, pos = 4) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, with.col = with.col)), list(n = n, with.col = with.col)) + exp <- parse(text = gsub("list", "chartMomentum", as.expression(substitute(list(x = current.chob(), + n = n, with.col = with.col)))), srcfile = NULL) + lchob <- current.chob() - xx <- if(is.OHLC(x)) { - Cl(x) - } else x + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset - mom <- momentum(xx,n=n) + if(is.OHLC(x) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + xx <- do.call(with.col,list(x)) + } else xx <- x[,with.col] - chobTA@TA.values <- mom[lchob@xsubset] - chobTA@name <- "chartMomentum" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mom <- momentum(xx,n=n)[xsubset] + + lchob$add_frame(ylim=c(-max(abs(mom),na.rm=TRUE), + max(abs(mom),na.rm=TRUE)) * 1.05, asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartMomentum {{{ `chartMomentum` <- From cd1bd959ce0d8a02ff5a1675c452103ea05bfa0a Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Tue, 26 Jul 2016 18:20:44 +0800 Subject: [PATCH 12/23] Refactor addPoints to follow skeleton_TA structure Refactor addPoints to use skeleton_TA structure. New chartPoints function is given to add points to the time series chart based on skeleton_TA structure. --- R/addTA.R | 93 +++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 63 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index eb5c541e..605fe8fb 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1496,47 +1496,80 @@ function(x) { offset=1,col=2,bg=2,cex=1, on=1,overlay=TRUE) { - lchob <- get.current.chob() - xdata <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartPoints <- function(x, type, pch, offset, col, bg, cex, on, overlay) { + xdata <- x$Env$xdata + x.points <- which(x$Env$xsubset %in% x$Env$x) + y.points <- x$Env$y + spacing <- x$Env$theme$spacing + + # if OHLC and above - get Hi, else Lo + # if univariate - get value + y.data <- if(is.OHLC(xdata)) { + if(offset > 1) { + Hi(xdata) + } else Lo(xdata) + } else xdata + + if(is.null(y.points)) y.points <- y.data[x.points] * offset + + if(!overlay) { + x.pos <- 1 + spacing * (1:NROW(x.points) - 1) + xlim <- x$Env$xlim + ylim <- x$get_ylim()[[2]] + theme <- x$Env$theme + # 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) + segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted") + } + + points(x=x.pos, y=y.points, type=type,pch=pch,col=col,bg=bg,cex=cex) + } + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(type = type, pch = pch, offset = offset, col = col, + bg = bg, cex = cex, on = on, overlay = overlay)), + list(type = type, pch = pch, offset = offset, col = col, + bg = bg, cex = cex, on = on, overlay = overlay)) + exp <- parse(text=gsub("list","chartPoints",as.expression(substitute(list(x=current.chob(), + type = type, pch = pch, offset = offset, col = col, + bg = bg, cex = cex, on = on, overlay = overlay)))), + srcfile=NULL) + lchob <- current.chob() + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + xdata <- xdata[xsubset] - chobTA <- new("chobTA") - chobTA@new <- !overlay - chobTA@TA.values <- xdata[lchob@xsubset,] - chobTA@name <- "chartPoints" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - if(missing(bg)) bg <- col - xsubset <- x %in% lchob@xsubset + xsubset <- x %in% xsubset if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') x <- x[xsubset] if(!is.null(y)) y <- y[xsubset] + + lchob$Env$x <- x + lchob$Env$y <- y - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - subset=lchob@xsubset, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - x=x,y=y,type=type,offset=offset, - pch=pch,col=col,bg=bg,cex=cex) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + if(overlay) + lchob$set_frame(on+1) + else { + lchob$add_frame(ylim=lchob$get_ylim()[[2]], asp=1, fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartPoints {{{ `chartPoints` <- From 3f8daac9b18226211b6529e740cf6ec90e9b28ca Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Tue, 26 Jul 2016 18:56:15 +0800 Subject: [PATCH 13/23] Refactor addROC to follow skeleton_TA structure Refactor addROC to use skeleton_TA structure. New chartROC is given to add rate of price series to the price chart based on skeleton_TA structure. --- R/addTA.R | 75 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 605fe8fb..1035b268 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -718,42 +718,57 @@ function(x) { `addROC` <- function(n=1,type=c('discrete','continuous'),col='red') { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartROC <- function(x, n, type, col) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + + roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(roc) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(roc), na.rm = TRUE), + max(abs(roc), na.rm = TRUE))*1.05 + theme <- x$Env$theme + # 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) + + lines(x.pos,roc,col=col,lwd=2,type='l') + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, type = type, col = col)), list(n = n, type = type, col = col)) + exp <- parse(text = gsub("list", "chartROC", as.expression(substitute(list(x = current.chob(), + n = n, type = type, col = col)))), srcfile = NULL) + lchob <- current.chob() - chobTA <- new("chobTA") - chobTA@new <- TRUE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { Cl(x) } else x - type <- match.arg(type) - - roc <- ROC(xx,n=n,type=type,na.pad=TRUE) - - chobTA@TA.values <- roc[lchob@xsubset] - chobTA@name <- "chartROC" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,type=type,col=col) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE)[xsubset] + lchob$Env$roc <- roc + lchob$add_frame(ylim=c(-max(abs(roc), na.rm = TRUE), + max(abs(roc), na.rm = TRUE))*1.05, asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartROC {{{ `chartROC` <- From c8740e305425788c7de98c54dbf3eec38fc677ac Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Tue, 26 Jul 2016 19:07:44 +0800 Subject: [PATCH 14/23] Refactor addRSI to follow skeleton_TA structure New chartRSI is given to create Relative Strength Index indicator based on skeleton_TA structure. --- R/addTA.R | 80 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 29 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 1035b268..e68e5fe1 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -638,41 +638,63 @@ function(x) { `addRSI` <- function(n=14,maType='EMA',wilder=TRUE) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartRSI <- function(x, n, maType, wilder) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(rsi) - 1) + xlim <- x$Env$xlim + ylim <- c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05) + theme <- x$Env$theme + # 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) + + lines(x.pos,rsi,col='#0033CC',lwd=2,type='l') + lines(x.pos,rsi,col='#BFCFFF',lwd=1,lty='dotted',type='l') + + text(0, ylim[2]*.9, + paste("Relative Strength Index (", n,"):", sep = ""), col = theme$fg, + pos = 4) + + text(0, ylim[2]*.9, + paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC', + pos = 4) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType, wilder = wilder)), + list(n = n, maType = maType, wilder = wilder)) + exp <- parse(text = gsub("list", "chartRSI", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType, wilder = wilder)))), srcfile = NULL) + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { Cl(x) } else x - rsi <- RSI(xx,n=n,maType=maType,wilder=wilder) - chobTA@TA.values <- rsi[lchob@xsubset] - chobTA@name <- "chartRSI" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n, wilder=wilder,maType=maType) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)[xsubset] + lchob$Env$rsi <- rsi + lchob$add_frame(ylim=c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05),asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartRSI {{{ `chartRSI` <- From 6754ae3b8c25e77a705260df6ccca35f0be849fd Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 27 Jul 2016 16:55:14 +0800 Subject: [PATCH 15/23] Refactor addSAR to follow skeleton_TA structure New chartSAR function is given to create Stop-And-Reverse indicator based on skeleton_TA structure. --- R/addTA.R | 52 ++++++++++++++++++++++------------------------------ 1 file changed, 22 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index e68e5fe1..22d0e3cf 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1195,41 +1195,33 @@ function(x) { `addSAR` <- function(accel=c(0.02,0.2),col='blue') { - lchob <- get.current.chob() + lenv <- new.env() + lenv$chartSAR <- function(x, accel, col) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + sar <- SAR(cbind(Hi(xdata),Lo(xdata)),accel=accel)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(sar) - 1) - x <- as.matrix(lchob@xdata) + points(x.pos,sar,col=col,cex=1) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(accel = accel, col = col)), list(accel = accel, col = col)) + exp <- parse(text = gsub("list", "chartSAR", as.expression(substitute(list(x = current.chob(), + accel = accel, col = col)))), srcfile = NULL) + lchob <- current.chob() - chobTA <- new("chobTA") - chobTA@new <- FALSE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset if(!is.OHLC(x)) stop("SAR requires HL series") - sar <- SAR(cbind(Hi(x),Lo(x)),accel=accel) - - chobTA@TA.values <- sar[lchob@xsubset] - - chobTA@name <- "chartSAR" - chobTA@call <- match.call() - chobTA@on <- 1 - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - accel=accel,col=col) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + sar <- SAR(cbind(Hi(x),Lo(x)),accel=accel)[xsubset] + lchob$Env$sar <- sar + lchob$set_frame(2) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartSAR {{{ `chartSAR` <- From 053b4afecea6de87431fce7de5672d7eb3aa09e8 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 27 Jul 2016 17:44:15 +0800 Subject: [PATCH 16/23] Refactor addShading to follow skeleton_TA structure New chartShading function is given to add shading area to the price series. --- R/addTA.R | 130 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 74 insertions(+), 56 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 22d0e3cf..5317bb8d 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1376,69 +1376,87 @@ function(x) { # addShading {{{ `addShading` <- function(when,on=-1,overlay=TRUE,col='blue') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - x <- lchob@xdata + lenv <- new.env() + lenv$chartShading <- function(x, when, on, overlay, col) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- xdata[xsubset] + xlim <- x$Env$xlim + ylim <- x$get_ylim()[[abs(on)+1L]] + theme <- x$Env$theme + spacing <- theme$spacing + width <- theme$width i <- when - indexClass(x) <- "POSIXct" - POSIXindex <- index(x) + indexClass(xdata) <- "POSIXct" + POSIXindex <- index(xdata) if (missing(i)) - i <- 1:NROW(x) + i <- 1:NROW(xdata) if (timeBased(i)) - i <- as.character(as.POSIXct(i)) + i <- as.character(as.POSIXct(i)) if (is.character(i)) { - i <- strsplit(i, ';')[[1]] - i.tmp <- NULL - for (ii in i) { - if (!identical(grep("::", ii), integer(0))) { - dates <- strsplit(ii, "::")[[1]] - first.time <- ifelse(dates[1] == "", POSIXindex[1], - do.call("firstof", as.list(as.numeric(strsplit(dates[1], - ":|-|/| ")[[1]])))) - last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)], - do.call("lastof", as.list(as.numeric(strsplit(dates[2], - ":|-|/| ")[[1]])))) - } - else { - dates <- ii - first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates, - ":|-|/| ")[[1]]))) - last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates, - ":|-|/| ")[[1]]))) - } - i.tmp <- c(i.tmp, which(POSIXindex <= last.time & - POSIXindex >= first.time)) + i <- strsplit(i, ';')[[1]] + i.tmp <- NULL + for (ii in i) { + if (!identical(grep("::", ii), integer(0))) { + dates <- strsplit(ii, "::")[[1]] + first.time <- ifelse(dates[1] == "", POSIXindex[1], + do.call("firstof", as.list(as.numeric(strsplit(dates[1], + ":|-|/| ")[[1]])))) + last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)], + do.call("lastof", as.list(as.numeric(strsplit(dates[2], + ":|-|/| ")[[1]])))) + } + else { + dates <- ii + first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates, + ":|-|/| ")[[1]]))) + last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates, + ":|-|/| ")[[1]]))) } - i <- i.tmp + i.tmp <- c(i.tmp, which(POSIXindex <= last.time & + POSIXindex >= first.time)) + } + i <- i.tmp } + + xstart <- unique(c(i[1],i[which(diff(i) != 1)+1])) + xend <- unique(c(i[which(diff(i) != 1)-1], rev(i)[1])) + + if(!overlay) { + # 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) + } + + rect(((xstart-1)*spacing+1)-width/2, rep(ylim[1],length(xstart)), + ((xend-1)*spacing+1)+width/2, rep(ylim[2],length(xend)), + col=c(theme$bbands$col$fill),border=NA) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(when = when, on = on, overlay = overlay, col = col)), + list(when = when, on = on, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartShading", as.expression(substitute(list(x = current.chob(), + when = when, on = on, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() - xstart <- unique(c(i[1],i[which(diff(i) != 1)+1])) - xend <- unique(c(i[which(diff(i) != 1)-1], rev(i)[1])) - - chobTA@TA.values <- x - chobTA@name <- "chartShading" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - yrange=lchob@yrange, - colors=lchob@colors, - spacing=lchob@spacing, - width=lchob@width, - xsubset=lchob@xsubset, - time.scale=lchob@time.scale, - xstart=xstart,xend=xend - ) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + if(overlay) { + lchob$set_frame(sign(on)*(abs(on)+1L)) + } else { + lchob$add_frame(ylim=c(lchob$get_ylim()[[abs(on)+1L]][1], + lchob$get_ylim()[[abs(on)+1L]][2]), asp=1, fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartShading {{{ `chartShading` <- From 495d1ca2d334150f97b0a7452580af197084caba Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 27 Jul 2016 18:11:16 +0800 Subject: [PATCH 17/23] Refactor addSMA to follow skeleton_TA structure New chartSMA function is given to create moving average indicator based on skeleton_TA structure. --- R/addTA.R | 123 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 70 insertions(+), 53 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 5317bb8d..bd73e175 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1765,61 +1765,78 @@ function(x) { `addSMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='brown') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - - x <- as.matrix(target.TA@TA.values) - - if(missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } - ma.tmp <- NULL - for(i in 1:length(n)) { - ma <- SMA(x.tmp,n=n[i]) - ma.tmp <- cbind(ma.tmp,ma) + lenv <- new.env() + lenv$chartSMA <- function(x, n, on, with.col, overlay, col) { + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- x$Env$xdata + + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(xdata)) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) + + if(missing(with.col)) with.col <- 1 + +# if(is.function(with.col)) { +# x.tmp <- do.call(with.col,list(x)) +# } else x.tmp <- x[,with.col] + x.tmp <- xdata + } + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + ylim <- x$get_ylim()[[abs(on)+1L]] + if(length(n) != length(col)) { + colors <- c(4:10,3) + } else colors <- col + + if(!overlay) { + # 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) + } + + ma.tmp <- NULL + for(i in 1:length(n)) { + ma <- SMA(x.tmp,n=n[i]) + ma.tmp <- cbind(ma.tmp,ma) + + lines(x.pos,ma,col=colors[i],lwd=1,type='l') + } } - - chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp)) # single numeric vector - chobTA@name <- "chartSMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartSMA", as.expression(substitute(list(x = current.chob(), + n = n, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + if(overlay) { + lchob$set_frame(sign(on)*(abs(on)+1L)) } else { - return(chobTA) - } + lchob$add_frame(ylim=lchob$get_ylim()[[abs(on)+1L]], asp=1, fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartSMA {{{ `chartSMA` <- From 11b036904aa1c35a33fdf429d3f9cee4b466ab95 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 27 Jul 2016 19:59:59 +0800 Subject: [PATCH 18/23] Refactor addTRIX to follow skeleton_TA structure New chartTRIX function is given to create the TRIX indicator based on skeleton_TA structure. --- R/addTA.R | 78 ++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 48 insertions(+), 30 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index bd73e175..90837bc0 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -428,42 +428,60 @@ function(x) { `addTRIX` <- function(n=20, signal=9, maType="EMA", percent=TRUE) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartTRIX <- function(x, n, signal, maType, percent) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + Cl(xdata) + } else xdata + + trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(trix) - 1) + xlim <- x$Env$xlim + ylim <- c(min(trix[,1]*.975,na.rm=TRUE), + max(trix[,1]*1.05,na.rm=TRUE)) + theme <- x$Env$theme + # 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) + + # draw TRIX + lines(x.pos,trix[,1],col='green',lwd=1,type='l') + # draw Signal + lines(x.pos,trix[,2],col='#999999',lwd=1,type='l') + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, signal = signal, maType = maType, percent = TRUE)), + list(n = n, signal = signal, maType = maType, percent = TRUE)) + exp <- parse(text = gsub("list", "chartTRIX", as.expression(substitute(list(x = current.chob(), + n = n, signal = signal, maType = maType, percent = TRUE)))), srcfile = NULL) + lchob <- current.chob() - chobTA <- new("chobTA") - chobTA@new <- TRUE + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { Cl(x) } else x - trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent) - - chobTA@TA.values <- trix[lchob@xsubset,] - - chobTA@name <- "chartTRIX" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - n=n,signal=signal,maType=maType,percent=percent) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)[xsubset] + lchob$add_frame(ylim=c(min(trix[,1]*.975,na.rm=TRUE), + max(trix[,1]*1.05,na.rm=TRUE)), asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartTRIX {{{ `chartTRIX` <- From 66b20fd49b3d00ba5ca8fff2de308d6f8a29578f Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Thu, 28 Jul 2016 17:12:16 +0800 Subject: [PATCH 19/23] Refactor addWMA to follow skeleton_TA structure New addWMA function is given to create Weighted Moving Average indicator based on skeleton_TA structure. --- R/addTA.R | 131 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 82 insertions(+), 49 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 90837bc0..17a603ab 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1898,55 +1898,88 @@ function(x) { `addWMA` <- function(n=10,wts=1:n,on=1,with.col=Cl,overlay=TRUE,col='green') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - x <- as.matrix(target.TA@TA.values) - - if(missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] + lenv <- new.env() + lenv$chartWMA <- function(x, n, wts, on, with.col, overlay, col) { + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- lchob$Env$xdata + + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(xdata)) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) + + if(missing(with.col)) with.col <- 1 + + # if(is.function(with.col)) { + # x.tmp <- do.call(with.col,list(x)) + # } else x.tmp <- x[,with.col] + # } + x.tmp <- xdata + } + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + theme <- x$Env$theme + if(length(n) < length(col)) { + colors <- 3:10 + } else colors <- col + + for(li in 1:length(n)) { + ma <- WMA(x.tmp,n=n[li],wts=wts)[xsubset] + if(!overlay) { + ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) + # 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) + } + lines(x.pos,ma,col=colors[li],lwd=1,type='l') + } } - - chobTA@TA.values <- x.tmp[lchob@xsubset] - chobTA@name <- "chartWMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n,wts=wts) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, wts = wts, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, wts = wts, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartWMA", as.expression(substitute(list(x = current.chob(), + n = n, wts = wts, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + if(!is.OHLC(x) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(x)) + } else x.tmp <- x[,with.col] + + if(overlay) + lchob$set_frame(on+1) + else { + for(li in 1:length(n)) { + ma <- WMA(x.tmp,n=n[li],wts=wts)[xsubset] + lchob$add_frame(ylim=c(min(ma*0.975, na.rm=TRUE), + max(ma*1.05, na.rm=TRUE)), asp=1, fixed=TRUE) + lchob$next_frame() + } + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartWMA {{{ `chartWMA` <- @@ -1968,7 +2001,7 @@ function(x) { ma <- WMA(x@TA.values,n=x@params$n[li],wts=x@params$wts) if(x@new) { par(new=TRUE) - plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)), + plot(x.range,seq(min(ma*.975, na.rm=TRUE),max(ma*1.05, na.rm=TRUE),length.out=length(x.range)), type='n',axes=FALSE,ann=FALSE) title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep='')) axis(2) From 7834f4ce79ee1ecb8c1006ddd8edc3172f819ed8 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Fri, 29 Jul 2016 20:45:59 +0800 Subject: [PATCH 20/23] Refactor addEMA to follow skeleton_TA structure New chartEMA function is given to add Exponential Moving Average indicator to the price chart based on skeleton_TA structure. --- R/addTA.R | 149 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 93 insertions(+), 56 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 17a603ab..82eaaa75 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1676,66 +1676,103 @@ function(x) { `addEMA` <- function(n=10,wilder=FALSE,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='blue') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - - x <- as.matrix(target.TA@TA.values) - - if(missing(with.col)) with.col <- 1 + lenv <- new.env() + lenv$chartEMA <- function(x, n, wilder, ratio, on, with.col, overlay, col) { + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- x$Env$xdata - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(xdata)) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) + + if(missing(with.col)) with.col <- 1 + + # if(is.function(with.col)) { + # x.tmp <- do.call(with.col,list(x)) + # } else x.tmp <- x[,with.col] + x.tmp <- xdata + } + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + theme <- x$Env$theme + if(length(n) != length(col)) { + colors <- 3:10 + } else colors <- col + + for(li in 1:length(n)) { + ma <- EMA(x.tmp,n=n[li],wilder=wilder[1],ratio=ratio[1]) + if(!overlay) { + ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) + # 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) + + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(x = lc$x, y = lc$y, + legend = paste("EMA (", + paste(n[li],sep=","),"): ", + sprintf("%.3f",last(ma)), + sep = ""), + text.col = colors[li], + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95) + } + lines(x.pos,ma,col=colors[li],lwd=1,type='l') + } } - + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, wilder = wilder, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, wilder = wilder, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartEMA", as.expression(substitute(list(x = current.chob(), + n = n, wilder = wilder, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + if(!is.OHLC(x) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(x)) + } else x.tmp <- x[,with.col] + ma.tmp <- NULL - - for(i in 1:length(n)) { - ma <- EMA(x.tmp,n=n[i],wilder=wilder[1], - ratio=ratio[1]) - ma.tmp <- cbind(ma.tmp,ma) + + if(overlay) + lchob$set_frame(on+1) + else { + for(i in 1:length(n)) { + ma <- EMA(x.tmp,n=n[i],wilder=wilder[1], + ratio=ratio[1]) + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$add_frame(ylim=c(min(ma.tmp*0.975, na.rm=TRUE), + max(ma.tmp*1.05, na.rm=TRUE)), asp=1, fixed=TRUE) + lchob$next_frame() } - - chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp)) - - chobTA@name <- "chartEMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n,wilder=wilder,ratio=ratio) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartEMA {{{ `chartEMA` <- From 790b4a69d050c7bf5c9ce9aebe0114d2339fbbbd Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 30 Jul 2016 14:47:03 +0800 Subject: [PATCH 21/23] Refactor addLines to follow skeleton_TA structure New chartLines function is given to add lines to the ith panel when overlay=TRUE or chart on a new frame based on skeleton_TA structure. --- R/addTA.R | 79 +++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 25 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 82eaaa75..5e8c614f 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1501,33 +1501,62 @@ function(x) { if(missing(h)) h <- NULL if(missing(v)) v <- NULL - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay + lenv <- new.env() + lenv$chartLines <- function(x, h, v, on, overlay, col) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- cbind(Hi(xdata),Lo(xdata)) + lines <- x$Env$lines + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:nrow(lines) - 1) + xlim <- x$Env$xlim + ylim <- x$get_ylim()[[abs(on)+1L]] + theme <- x$Env$theme + + if(!overlay) { + ylim <- range(lines[,1], na.rm=TRUE) * 1.05 + # 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.null(lines)) { + # draw lines given positions specified in x + lines(x.pos, lines[,1],col=col) + } + if(!is.null(h)) { + # draw horizontal lines given positions specified in h + segments(xlim[1],h,xlim[2],h,col=col) + } + if(!is.null(v)) { + # draw vertical lines given positions specified in v + segments((v-1)*spacing+1,ylim[1],(v-1)*spacing+1,ylim[2],col=col) + } + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(h = h, v = v, on = on, overlay = overlay, col = col)), + list(h = h, v = v, on = on, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartLines", as.expression(substitute(list(x = current.chob(), + h = h, v = v, on = on, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + lchob$Env$lines <- x - chobTA@TA.values <- NULL # single numeric vector - chobTA@name <- "chartLines" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,h=h,x=x,v=v) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) + if(overlay) { + lchob$set_frame(sign(on)*(abs(on)+1L)) } else { - return(chobTA) - } + lchob$add_frame(ylim=range(x, na.rm=TRUE) * 1.05, aps=1, fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartLines {{{ `chartLines` <- From acd1fc8c7fafb0078ff11d668d55b459aa00ec22 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 30 Jul 2016 15:04:20 +0800 Subject: [PATCH 22/23] Refactor addZLEMA to follow skeleton_TA structure New chartZLEMA function is given to add various moving averages indicator to the ith panel when overlay=TRUE or create a new frame based on skeleton_TA structure. --- R/addTA.R | 142 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 92 insertions(+), 50 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 5e8c614f..8b12a324 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -2270,59 +2270,101 @@ function(x) { `addZLEMA` <- function(n=10,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='red') { - lchob <- get.current.chob() - chobTA <- new("chobTA") - chobTA@new <- !overlay - - # get the appropriate data - from the approp. src - if(on==1) { - x <- as.matrix(lchob@xdata) - - if(!is.OHLC(x) && missing(with.col)) with.col <- 1 - - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] - } else { - # get values from TA... - which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new)) - target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]] - - if(missing(with.col)) with.col <- 1 + lenv <- new.env() + lenv$chartZLEMA <- function(x, n, ratio, on, with.col, overlay, col) { + # get the appropriate data - from the approp. src + if(on==1) { + xdata <- lchob$Env$xdata + + if(!is.OHLC(xdata) && missing(with.col)) with.col <- 1 + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(xdata)) + } else x.tmp <- xdata[,with.col] + } else { + # get values from TA... + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(x$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(x$Env)) == tolower(name.TA)) + target.TA <- names(x$Env)[which.TA] + xdata <- get(target.TA, envir = x$Env) + + if(missing(with.col)) with.col <- 1 - x <- as.matrix(target.TA@TA.values) - if(missing(with.col)) { - warning('missing "with.col" argument') - invisible(return()) +# if(is.function(with.col)) { +# x.tmp <- do.call(with.col,list(x)) +# } else x.tmp <- x[,with.col] + x.tmp <- xdata + } + xsubset <- x$Env$xsubset + x.tmp <- x.tmp[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + xlim <- x$Env$xlim + theme <- x$Env$theme + if(length(n) != length(col)) { + colors <- 3:10 + } else colors <- col + + for(li in 1:length(n)) { + ma <- ZLEMA(x.tmp,n=n[li],ratio=ratio) + if(!overlay) { + ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) + # 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) + + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(x = lc$x, y = lc$y, + legend = paste("EMA (", + paste(n[li],sep=","),"): ", + sprintf("%.3f",last(ma)), + sep = ""), + text.col = colors[li], + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95) + } + lines(x.pos,ma,col=colors[li],lwd=1,type='l') } - if(is.function(with.col)) { - x.tmp <- do.call(with.col,list(x)) - } else x.tmp <- x[,with.col] } - - chobTA@TA.values <- x.tmp[lchob@xsubset] - chobTA@name <- "chartZLEMA" - chobTA@call <- match.call() - chobTA@on <- on # used for deciding when to draw... - chobTA@params <- list(xrange=lchob@xrange, - colors=lchob@colors, - color.vol=lchob@color.vol, - multi.col=lchob@multi.col, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - x.labels=lchob@x.labels, - time.scale=lchob@time.scale, - col=col,n=n,ratio=ratio) - if(is.null(sys.call(-1))) { - TA <- lchob@passed.args$TA - lchob@passed.args$TA <- c(TA,chobTA) - lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0) - do.call('chartSeries.chob',list(lchob)) - invisible(chobTA) - } else { - return(chobTA) - } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)), + list(n = n, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)) + exp <- parse(text = gsub("list", "chartZLEMA", as.expression(substitute(list(x = current.chob(), + n = n, ratio = ratio, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + + if(is.function(with.col)) { + x.tmp <- do.call(with.col,list(x)) + } else x.tmp <- x[,with.col] + + ma.tmp <- NULL + + if(overlay) + lchob$set_frame(on+1) + else { + for(li in 1:length(n)) { + ma <- ZLEMA(x.tmp,n=n[li],ratio=ratio) + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$add_frame(ylim=c(min(ma.tmp*0.975, na.rm=TRUE), + max(ma.tmp*1.05, na.rm=TRUE)), asp=1, fixed=TRUE) + lchob$next_frame() + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } # }}} # chartZLEMA {{{ `chartZLEMA` <- From 1f3a4268baaa0893e3af685976fe402f3cf5b9e5 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 31 Jul 2016 16:25:51 +0800 Subject: [PATCH 23/23] Fix not find "y_grid_lines" function and subsetting bug Function y_grid_lines is not exported and is in plot_object$Env. chart* functions called in add* are passed to "lenv" environment so y_grid_lines cannot be found. y_grid_lines function is defined in chart* by y_grid_lines <- plot_object$Env$y_grid_lines. For add*MA functions, x.tmp should not be passed by x.tmp[xsubset] because when zoomChart is called, series used to calculate moving averages will change with the subset period if we pass x.tmp[xsubset] to x.tmp. Moving avrage indicators are passed to ma by ma <- *MA(x.tmp, ...)[xsubset] so x.tmp should always be the initial series and should not change with the subset period. --- R/addTA.R | 435 +++++++++++++++++++++++++++++++----------------------- 1 file changed, 253 insertions(+), 182 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 8b12a324..b671b0cd 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -35,36 +35,39 @@ ylim <- c(-max(abs(mom),na.rm=TRUE), max(abs(mom),na.rm=TRUE)) * 1.05 theme <- x$Env$theme - # 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) - + COLOR <- "#0033CC" - segments(xlim[1],0,xlim[2],0,col="#666666",lwd=1,lty='dotted') - lines(x.pos,mom,col=COLOR,lwd=2,type='l') - text(0, ylim[2]*.9, - paste("Momentum (", n, "):"),col=theme$fg, pos=4) - - text(0, ylim[2]*.9, - paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''), - col = COLOR, pos = 4) } mapply(function(name, value) { assign(name, value, envir = lenv) }, names(list(n = n, with.col = with.col)), list(n = n, with.col = with.col)) exp <- parse(text = gsub("list", "chartMomentum", as.expression(substitute(list(x = current.chob(), n = n, with.col = with.col)))), srcfile = NULL) + exp <- c(exp, expression( + COLOR <- "#0033CC", + text(0, max(abs(mom),na.rm=TRUE) *.9, + paste("Momentum (", n, "):"),col=theme$fg, pos=4), + + text(0, max(abs(mom),na.rm=TRUE) *.9, + paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''), + col = COLOR, pos = 4))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(mom),na.rm=TRUE) * 1.05, xlim[2], max(abs(mom),na.rm=TRUE) * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE)) * 1.05), + xlim[2], y_grid_lines(c(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE)) * 1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE)) * 1.05), y_grid_lines(c(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE)) * 1.05), + 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], -max(abs(mom),na.rm=TRUE) * 1.05, xlim[2], max(abs(mom),na.rm=TRUE) * 1.05, border=theme$labels), + segments(xlim[1],0,xlim[2],0,col="#666666",lwd=1,lty='dotted')), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -77,6 +80,7 @@ } else xx <- x[,with.col] mom <- momentum(xx,n=n)[xsubset] + lchob$Env$mom <- mom lchob$add_frame(ylim=c(-max(abs(mom),na.rm=TRUE), max(abs(mom),na.rm=TRUE)) * 1.05, asp=1, fixed=TRUE) @@ -142,20 +146,6 @@ function(x) { ylim <- c(-max(abs(cci),na.rm=TRUE), max(abs(cci),na.rm=TRUE))*1.05 theme <- x$Env$theme - # 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) - - # draw shading in -100:100 y-range - rect(xlim[1],-100,xlim[2],100,col=theme$bbands$col$fill,border=theme$fg) # fill upper and lower areas cci.above <- ifelse(cci >= 100,cci, 100) @@ -167,22 +157,38 @@ function(x) { # draw CCI lines(x.pos,cci,col='red',lwd=1,type='l') - # draw dotted guide line at 0 - segments(xlim[1],0,xlim[2],0,col='#666666',lwd=1,lty='dotted') - - # add indicator name and last value - text(0, ylim[2]*.9, - paste("Commodity Channel Index (", n, ",", - c,"):",sep=''),col=theme$fg,pos=4) - text(0, ylim[2]*.9, - paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red', - pos = 4) } mapply(function(name, value) { assign(name, value, envir = lenv) }, names(list(n = n, maType = maType, c = c)), list(n = n, maType = maType, c = c)) exp <- parse(text = gsub("list", "chartCCI", as.expression(substitute(list(x = current.chob(), n = n, maType = maType, c = c)))), srcfile = NULL) + exp <- c(exp, expression( + # draw dotted guide line at 0 + segments(xlim[1],0,xlim[2],0,col='#666666',lwd=1,lty='dotted'), + + # add indicator name and last value + text(0, max(abs(cci),na.rm=TRUE)*.9, + paste("Commodity Channel Index (", n, ",", + c,"):",sep=''),col=theme$fg,pos=4), + text(0, max(abs(cci),na.rm=TRUE)*.9, + paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red', + pos = 4))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(cci),na.rm=TRUE)*1.05, xlim[2], max(abs(cci),na.rm=TRUE)*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-max(abs(cci),na.rm=TRUE),max(abs(cci),na.rm=TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(cci),na.rm=TRUE),max(abs(cci),na.rm=TRUE))*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-max(abs(cci),na.rm=TRUE),max(abs(cci),na.rm=TRUE))*1.05), y_grid_lines(c(-max(abs(cci),na.rm=TRUE),max(abs(cci),na.rm=TRUE))*1.05), + 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], -max(abs(cci),na.rm=TRUE)*1.05, xlim[2], max(abs(cci),na.rm=TRUE)*1.05, border=theme$labels), + # draw shading in -100:100 y-range + rect(xlim[1],-100,xlim[2],100,col=theme$bbands$col$fill,border=theme$fg)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -269,19 +275,6 @@ function(x) { ylim <- c(min(adx*0.975, na.rm = TRUE), max(adx*1.05, na.rm = TRUE)) theme <- x$Env$theme - # 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) - segments(xlim[1], 20, xlim[2], 20, col = "#666666", lty = "dotted") - segments(xlim[1], 40, xlim[2], 40, col = "#666666", lty = "dotted") # draw DIp lines(x.pos,adx[,1],col='green',lwd=1,type='l') @@ -297,6 +290,21 @@ function(x) { exp <- parse(text = gsub("list", "chartADX", as.expression(substitute(list(x = current.chob(), n = n, maType = maType, wilder = wilder)))), srcfile = NULL) + exp <- c(expression( + # add inbox color + rect(xlim[1], min(adx*0.975, na.rm = TRUE), xlim[2], max(adx*1.05, na.rm = TRUE), col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(adx*0.975, na.rm = TRUE),max(adx*1.05, na.rm = TRUE))), + xlim[2], y_grid_lines(c(min(adx*0.975, na.rm = TRUE),max(adx*1.05, na.rm = TRUE))), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(adx*0.975, na.rm = TRUE),max(adx*1.05, na.rm = TRUE))), y_grid_lines(c(min(adx*0.975, na.rm = TRUE),max(adx*1.05, na.rm = TRUE))), + 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], min(adx*0.975, na.rm = TRUE), xlim[2], max(adx*1.05, na.rm = TRUE), border=theme$labels), + segments(xlim[1], 20, xlim[2], 20, col = "#666666", lty = "dotted"), + segments(xlim[1], 40, xlim[2], 40, col = "#666666", lty = "dotted")), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -361,17 +369,6 @@ function(x) { ylim <- c(min(atr[,2]*0.975, na.rm = TRUE), max(atr[,2]*1.05, na.rm = TRUE)) theme <- x$Env$theme - # 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) lines(x.pos,atr[,2],col='blue',lwd=2,type='l') } @@ -381,6 +378,19 @@ function(x) { exp <- parse(text = gsub("list", "chartATR", as.expression(substitute(list(x = current.chob(), n = n, maType = maType)))), srcfile = NULL) + exp <- c(expression( + # add inbox color + rect(xlim[1], min(atr[,2]*0.975, na.rm = TRUE), xlim[2], max(atr[,2]*1.05, na.rm = TRUE), col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(atr[,2]*0.975, na.rm = TRUE),max(atr[,2]*1.05, na.rm = TRUE))), + xlim[2], y_grid_lines(c(min(atr[,2]*0.975, na.rm = TRUE),max(atr[,2]*1.05, na.rm = TRUE))), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(atr[,2]*0.975, na.rm = TRUE),max(atr[,2]*1.05, na.rm = TRUE))), y_grid_lines(c(min(atr[,2]*0.975, na.rm = TRUE),max(atr[,2]*1.05, na.rm = TRUE))), + 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], min(atr[,2]*0.975, na.rm = TRUE), xlim[2], max(atr[,2]*1.05, na.rm = TRUE), border=theme$labels)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -444,17 +454,6 @@ function(x) { ylim <- c(min(trix[,1]*.975,na.rm=TRUE), max(trix[,1]*1.05,na.rm=TRUE)) theme <- x$Env$theme - # 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) # draw TRIX lines(x.pos,trix[,1],col='green',lwd=1,type='l') @@ -467,6 +466,19 @@ function(x) { list(n = n, signal = signal, maType = maType, percent = TRUE)) exp <- parse(text = gsub("list", "chartTRIX", as.expression(substitute(list(x = current.chob(), n = n, signal = signal, maType = maType, percent = TRUE)))), srcfile = NULL) + exp <- c(expression( + # add inbox color + rect(xlim[1], min(trix[,1]*.975,na.rm=TRUE), xlim[2], max(trix[,1]*1.05,na.rm=TRUE), col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(trix[,1]*.975,na.rm=TRUE),max(trix[,1]*1.05,na.rm=TRUE))), + xlim[2], y_grid_lines(c(min(trix[,1]*.975,na.rm=TRUE),max(trix[,1]*1.05,na.rm=TRUE))), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(trix[,1]*.975,na.rm=TRUE),max(trix[,1]*1.05,na.rm=TRUE))), y_grid_lines(c(min(trix[,1]*.975,na.rm=TRUE),max(trix[,1]*1.05,na.rm=TRUE))), + 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], min(trix[,1]*.975,na.rm=TRUE), xlim[2], max(trix[,1]*1.05,na.rm=TRUE), border=theme$labels)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -477,6 +489,7 @@ function(x) { } else x trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)[xsubset] + lchob$Env$trix <- trix lchob$add_frame(ylim=c(min(trix[,1]*.975,na.rm=TRUE), max(trix[,1]*1.05,na.rm=TRUE)), asp=1, fixed=TRUE) lchob$next_frame() @@ -534,18 +547,6 @@ function(x) { ylim <- c(-max(abs(dpo), na.rm = TRUE), max(abs(dpo), na.rm = TRUE))*1.05 theme <- x$Env$theme - # 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) - segments(xlim[1], 0, xlim[2], 0, col = "#999999") dpo.tmp <- dpo dpo.tmp[is.na(dpo)] <- 0 @@ -555,14 +556,6 @@ function(x) { polygon(c(x.pos,rev(x.pos)),cbind(dpo.positive,rep(0,length(dpo))),col=theme$up.col, border="#999999") polygon(c(x.pos,rev(x.pos)),cbind(dpo.negative,rep(0,length(dpo))),col=theme$dn.col, border="#999999") - text(0, ylim[2]*.9, - paste("De-trended Price Oscillator (", n,"):", sep = ""), - col = theme$fg, pos = 4) - - text(0, ylim[2]*.9, - paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo))), sep = ""), - col = ifelse(last(na.omit(dpo)) > 0,theme$up.col,theme$dn.col), - pos = 4) } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -570,6 +563,30 @@ function(x) { list(n = n, maType = maType, shift = shift, percent = percent)) exp <- parse(text = gsub("list", "chartDPO", as.expression(substitute(list(x = current.chob(), n = n, maType = maType, shift = shift, percent = percent)))), srcfile = NULL) + exp <- c(exp, expression( + text(0, max(abs(dpo), na.rm = TRUE)*.9, + paste("De-trended Price Oscillator (", n,"):", sep = ""), + col = theme$fg, pos = 4), + + text(0, max(abs(dpo), na.rm = TRUE)*.9, + paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo))), sep = ""), + col = ifelse(last(na.omit(dpo)) > 0,theme$up.col,theme$dn.col), + pos = 4))) + + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(dpo), na.rm = TRUE) * 1.05, xlim[2], max(abs(dpo), na.rm = TRUE) * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-max(abs(dpo), na.rm = TRUE),max(abs(dpo), na.rm = TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(dpo), na.rm = TRUE),max(abs(dpo), na.rm = TRUE))*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-max(abs(dpo), na.rm = TRUE),max(abs(dpo), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(dpo), na.rm = TRUE),max(abs(dpo), na.rm = TRUE))*1.05), + 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], -max(abs(dpo), na.rm = TRUE) * 1.05, xlim[2], max(abs(dpo), na.rm = TRUE) * 1.05, border=theme$labels), + segments(xlim[1], 0, xlim[2], 0, col = "#999999")), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -669,28 +686,10 @@ function(x) { xlim <- x$Env$xlim ylim <- c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05) theme <- x$Env$theme - # 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) lines(x.pos,rsi,col='#0033CC',lwd=2,type='l') lines(x.pos,rsi,col='#BFCFFF',lwd=1,lty='dotted',type='l') - text(0, ylim[2]*.9, - paste("Relative Strength Index (", n,"):", sep = ""), col = theme$fg, - pos = 4) - - text(0, ylim[2]*.9, - paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC', - pos = 4) } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -698,6 +697,27 @@ function(x) { list(n = n, maType = maType, wilder = wilder)) exp <- parse(text = gsub("list", "chartRSI", as.expression(substitute(list(x = current.chob(), n = n, maType = maType, wilder = wilder)))), srcfile = NULL) + exp <- c(exp, expression( + text(0, max(rsi,na.rm=TRUE)*.9, + paste("Relative Strength Index (", n,"):", sep = ""), col = theme$fg, + pos = 4), + + text(0, max(rsi,na.rm=TRUE)*.9, + paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC', + pos = 4))) + exp <- c(expression( + # add inbox color + rect(xlim[1], min(rsi,na.rm=TRUE)*.975, xlim[2], max(rsi,na.rm=TRUE)*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05)), + xlim[2], y_grid_lines(c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05)), y_grid_lines(c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05)), + 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], min(rsi,na.rm=TRUE)*.975, xlim[2], max(rsi,na.rm=TRUE)*1.05, border=theme$labels)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -774,18 +794,7 @@ function(x) { ylim <- c(-max(abs(roc), na.rm = TRUE), max(abs(roc), na.rm = TRUE))*1.05 theme <- x$Env$theme - # 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) - + lines(x.pos,roc,col=col,lwd=2,type='l') } mapply(function(name, value) { @@ -793,6 +802,19 @@ function(x) { }, names(list(n = n, type = type, col = col)), list(n = n, type = type, col = col)) exp <- parse(text = gsub("list", "chartROC", as.expression(substitute(list(x = current.chob(), n = n, type = type, col = col)))), srcfile = NULL) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(roc), na.rm = TRUE)*1.05, xlim[2], max(abs(roc), na.rm = TRUE)*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-max(abs(roc), na.rm = TRUE),max(abs(roc), na.rm = TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(roc), na.rm = TRUE),max(abs(roc), na.rm = TRUE))*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-max(abs(roc), na.rm = TRUE),max(abs(roc), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(roc), na.rm = TRUE),max(abs(roc), na.rm = TRUE))*1.05), + 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], -max(abs(roc), na.rm = TRUE)*1.05, xlim[2], max(abs(roc), na.rm = TRUE)*1.05, border=theme$labels)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -1121,7 +1143,7 @@ function(x) { } else xdata ma <- do.call(maType,list(xx,n=n,...)) - mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100)) + mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(mae) - 1) @@ -1278,17 +1300,7 @@ function(x) { ylim <- c(-max(abs(macd),na.rm=TRUE), max(abs(macd),na.rm=TRUE))*1.05 theme <- x$Env$theme - # 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(histogram) { cols <- ifelse((macd[,1]-macd[,2]) > 0, col[1],col[2]) rect(x.pos - spacing/5,0,x.pos + spacing/5, macd[,1]-macd[,2], @@ -1298,17 +1310,6 @@ function(x) { lines(x.pos,macd[,1],col=col[3],lwd=1) lines(x.pos,macd[,2],col=col[4],lwd=1,lty='dotted') - lc <- xts:::legend.coords("topleft", xlim, ylim) - legend(lc$x, lc$y, - legend=c(paste("Moving Average Convergence Divergence (", - paste(fast,slow,signal,sep=','),"):", sep = ""), - paste("MACD:",sprintf("%.3f",last(macd[,1]))), - paste("Signal:",sprintf("%.3f",last(macd[,2])))), - text.col=c(theme$fg, col[3], col[4]), - xjust=lc$xjust, - yjust=lc$yjust, - bty='n', - y.intersp=0.95) } col <- if(missing(col)) col <- c('#999999','#777777', '#BBBBBB','#FF0000') @@ -1318,6 +1319,32 @@ function(x) { list(fast = fast,slow = slow,signal = signal,type = type,histogram = histogram,col = col)) exp <- parse(text = gsub("list", "chartMACD", as.expression(substitute(list(x = current.chob(), fast = fast,slow = slow,signal = signal,type = type,histogram = histogram,col = col)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(macd),na.rm=TRUE), + max(abs(macd),na.rm=TRUE))*1.05), + legend(lc$x, lc$y, + legend=c(paste("Moving Average Convergence Divergence (", + paste(fast,slow,signal,sep=','),"):", sep = ""), + paste("MACD:",sprintf("%.3f",last(macd[,1]))), + paste("Signal:",sprintf("%.3f",last(macd[,2])))), + text.col=c(theme$fg, col[3], col[4]), + xjust=lc$xjust, + yjust=lc$yjust, + bty='n', + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(macd),na.rm=TRUE)*1.05, xlim[2], max(abs(macd),na.rm=TRUE)*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE))*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE))*1.05), y_grid_lines(c(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE))*1.05), + 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], -max(abs(macd),na.rm=TRUE)*1.05, xlim[2], max(abs(macd),na.rm=TRUE)*1.05, border=theme$labels)), exp) + lchob <- current.chob() x <- lchob$Env$xdata @@ -1402,6 +1429,7 @@ function(x) { xlim <- x$Env$xlim ylim <- x$get_ylim()[[abs(on)+1L]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines spacing <- theme$spacing width <- theme$width i <- when @@ -1506,12 +1534,13 @@ function(x) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset xdata <- cbind(Hi(xdata),Lo(xdata)) - lines <- x$Env$lines + lines <- x$Env$lines[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:nrow(lines) - 1) xlim <- x$Env$xlim ylim <- x$get_ylim()[[abs(on)+1L]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(!overlay) { ylim <- range(lines[,1], na.rm=TRUE) * 1.05 @@ -1593,8 +1622,10 @@ function(x) { lenv <- new.env() lenv$chartPoints <- function(x, type, pch, offset, col, bg, cex, on, overlay) { xdata <- x$Env$xdata - x.points <- which(x$Env$xsubset %in% x$Env$x) - y.points <- x$Env$y + xsubset <- x$Env$xsubset + x.points <- x$Env$x.points + xsubset <- x.points %in% xsubset + y.points <- x$Env$y.points spacing <- x$Env$theme$spacing # if OHLC and above - get Hi, else Lo @@ -1608,10 +1639,10 @@ function(x) { if(is.null(y.points)) y.points <- y.data[x.points] * offset if(!overlay) { - x.pos <- 1 + spacing * (1:NROW(x.points) - 1) xlim <- x$Env$xlim ylim <- x$get_ylim()[[2]] 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 @@ -1626,7 +1657,7 @@ function(x) { segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted") } - points(x=x.pos, y=y.points, type=type,pch=pch,col=col,bg=bg,cex=cex) + points(x=x.points[xsubset], y=y.points[xsubset], type=type,pch=pch,col=col,bg=bg,cex=cex) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(type = type, pch = pch, offset = offset, col = col, @@ -1648,12 +1679,9 @@ function(x) { xsubset <- x %in% xsubset if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') - x <- x[xsubset] - if(!is.null(y)) - y <- y[xsubset] - lchob$Env$x <- x - lchob$Env$y <- y + lchob$Env$x.points <- x + lchob$Env$y.points <- y if(overlay) @@ -1731,17 +1759,17 @@ function(x) { x.tmp <- xdata } xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) != length(col)) { colors <- 3:10 } else colors <- col for(li in 1:length(n)) { - ma <- EMA(x.tmp,n=n[li],wilder=wilder[1],ratio=ratio[1]) + ma <- EMA(x.tmp,n=n[li],wilder=wilder[1],ratio=ratio[1])[xsubset] if(!overlay) { ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) # add inbox color @@ -1793,7 +1821,7 @@ function(x) { else { for(i in 1:length(n)) { ma <- EMA(x.tmp,n=n[i],wilder=wilder[1], - ratio=ratio[1]) + ratio=ratio[1])[xsubset] ma.tmp <- cbind(ma.tmp, ma) } lchob$add_frame(ylim=c(min(ma.tmp*0.975, na.rm=TRUE), @@ -1875,11 +1903,12 @@ function(x) { x.tmp <- xdata } xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim ylim <- x$get_ylim()[[abs(on)+1L]] + theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) != length(col)) { colors <- c(4:10,3) } else colors <- col @@ -1900,7 +1929,7 @@ function(x) { ma.tmp <- NULL for(i in 1:length(n)) { - ma <- SMA(x.tmp,n=n[i]) + ma <- SMA(x.tmp,n=n[i])[xsubset] ma.tmp <- cbind(ma.tmp,ma) lines(x.pos,ma,col=colors[i],lwd=1,type='l') @@ -1991,11 +2020,11 @@ function(x) { x.tmp <- xdata } xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) < length(col)) { colors <- 3:10 } else colors <- col @@ -2107,16 +2136,32 @@ function(x) { x.tmp <- xdata } xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim + ylim <- x$get_ylim()[[abs(on)+1L]] + theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) < length(col)) { colors <- 3:10 } else colors <- col + if(!overlay) { + # 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) + } + for(li in 1:length(n)) { - ma <- DEMA(x.tmp,n=n[li]) + ma <- DEMA(x.tmp,n=n[li])[xsubset] # if(x@new) { # par(new=TRUE) # plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)), @@ -2135,7 +2180,12 @@ function(x) { exp <- parse(text = gsub("list", "chartDEMA", as.expression(substitute(list(x = current.chob(), n = n, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) lchob <- current.chob() - lchob$set_frame(on+1) + if(overlay) { + lchob$set_frame(on+1) + } else { + lchob$add_frame(ylim=lchob$get_ylim()[[abs(on)+1L]], asp=1, fixed=TRUE) + lchob$next_frame() + } lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob } # }}} @@ -2204,16 +2254,32 @@ function(x) { if(!has.Vo(x.tmp)) return() xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim + ylim <- x$get_ylim()[[abs(on)+1L]] + theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) < length(col)) { colors <- 3:10 } else colors <- col + if(!overlay) { + # 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) + } + for(li in 1:length(n)) { - ma <- EVWMA(x.tmp[, 1],x.tmp[, 2],n=n[li]) + ma <- EVWMA(x.tmp[, 1],x.tmp[, 2],n=n[li])[xsubset] # if(x@new) { # par(new=TRUE) # plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)), @@ -2232,7 +2298,12 @@ function(x) { exp <- parse(text = gsub("list", "chartEVWMA", as.expression(substitute(list(x = current.chob(), n = n, on = on, with.col = with.col, overlay = overlay, col = col)))), srcfile = NULL) lchob <- current.chob() - lchob$set_frame(on+1) + if(overlay) { + lchob$set_frame(on+1) + } else { + lchob$add_frame(ylim=lchob$get_ylim()[[abs(on)+1L]], asp=1, fixed=TRUE) + lchob$next_frame() + } lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob } # }}} @@ -2296,17 +2367,17 @@ function(x) { x.tmp <- xdata } xsubset <- x$Env$xsubset - x.tmp <- x.tmp[xsubset] spacing <- x$Env$theme$spacing - x.pos <- 1 + spacing * (1:NROW(x.tmp) - 1) + x.pos <- 1 + spacing * (1:NROW(x.tmp[xsubset]) - 1) xlim <- x$Env$xlim theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(length(n) != length(col)) { colors <- 3:10 } else colors <- col for(li in 1:length(n)) { - ma <- ZLEMA(x.tmp,n=n[li],ratio=ratio) + ma <- ZLEMA(x.tmp,n=n[li],ratio=ratio)[xsubset] if(!overlay) { ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) # add inbox color