From 50706f49a9d15ba47f81041776f374d196d4105d Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 20 Jul 2016 00:38:12 +0800 Subject: [PATCH 01/12] Refactor addTA functions to follow skeleton_TA structure As chartSeries is now a wrapper for chart_Series and chartSeries.chob is deprecated, code of add* functions that manipulate chob and chobTA objects breaks. So add* functions are refactored to use skeleton_TA structure to coordinate with chart_Series called by chartSeries. For those add* functions, however, quantmod::chart* functions are untouched. New chart* functions are passed to lenv environment in add* based on skeleton_TA structure. quantmod::chart* functions will be deprecated. --- R/addAroon.R | 184 ++-- R/addCLV.R | 95 +- R/addCMF.R | 97 +- R/addCMO.R | 95 +- R/addChaikin.R | 184 ++-- R/addEMV.R | 102 ++- R/addKST.R | 104 ++- R/addMFI.R | 94 +- R/addOBV.R | 93 +- R/addSMI.R | 110 ++- R/addTA.R | 2208 ++++++++++++++++++++++++++++----------------- R/addTDI.R | 92 +- R/addVo.R | 149 ++- R/addVolatility.R | 91 +- R/addWPR.R | 93 +- R/addZigZag.R | 101 ++- 16 files changed, 2489 insertions(+), 1403 deletions(-) diff --git a/R/addAroon.R b/R/addAroon.R index 8f54022d..c4067b5a 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -8,79 +8,143 @@ `addAroon` <- function (n = 20, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- cbind(Hi(x),Lo(x)) - x <- aroon(HL = x, n = n)[,-3] - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartAroon <- function(x, n, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- cbind(Hi(xdata),Lo(xdata)) + Aroon <- aroon(HL=xdata,n=n)[xsubset,-3] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(Aroon) - 1) + xlim <- x$Env$xlim + ylim <- c(0,100) + theme <- x$Env$theme + + lines(x.pos, Aroon[,1], col = theme$aroon$col$aroonUp, + lwd = 1, lend = 2, ...) + lines(x.pos, Aroon[,2], col = theme$aroon$col$aroonDn, + lwd = 1, lend = 2, ...) } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + if(!is.character(legend) || legend == "auto") + legend <- gsub("^add", "", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, ..., on = on, legend = legend)), + list(n = n, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartAroon", as.expression(substitute(list(x = current.chob(), + n = n, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(Aroon,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste("aroonUp :",format(last(Aroon[,1]),nsmall = 3L)), + paste("aroonDn :",format(last(Aroon[,2]),nsmall = 3L))), + text.col = c(theme$fg, theme$aroon$col$aroonUp, theme$aroon$col$aroonDn), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], 0, xlim[2], 100, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(0, 100)), + xlim[2], y_grid_lines(c(0, 100)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(0, 100)), y_grid_lines(c(0, 100)), + 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], 0, xlim[2], 100, border=theme$labels)), exp) + + lchob <- current.chob() + if (is.null(lchob$Env$theme$aroon$col$arronUp)) { + lchob$Env$theme$aroon$col$aroonUp <- 3 + lchob$Env$theme$aroon$col$aroonDn <- 4 + } + xdata <- lchob$Env$xdata + xdata <- cbind(Hi(xdata),Lo(xdata)) + xsubset <- lchob$Env$xsubset + Aroon <- aroon(HL=xdata,n=n)[xsubset,-3] + lchob$Env$Aroon <- Aroon +# lenv$xdata <- structure(Aroon, .Dimnames = list(NULL, "aroon")) + if(is.na(on)) { + lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) + lchob$next_frame() } else { - chobTA@new <- FALSE - chobTA@on <- on + lchob$set_frame(sign(on)*(abs(on)+1L)) } - chobTA@call <- match.call() - legend.name <- gsub("^add", "", deparse(match.call())) - gpars <- c(list(...), list(col = 3:4))[unique(names(c(list(col = 3:4), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - return(chobTA) + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } `addAroonOsc` <- function (n = 20, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- cbind(Hi(x),Lo(x)) - x <- aroon(HL = x, n = n)[,3] - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartAroonOsc <- function(x, n, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- cbind(Hi(xdata),Lo(xdata)) + AroonOsc <- aroon(HL=xdata,n=n)[xsubset,3] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(AroonOsc) - 1) + xlim <- x$Env$xlim + ylim <- range(AroonOsc,na.rm=TRUE) + theme <- x$Env$theme + + lines(x.pos, AroonOsc, col = theme$aroon$col$aroonOsc, + lwd = 1, lend = 2, ...) } - else { - chobTA@new <- FALSE - chobTA@on <- on + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addAroonOsc", "Aroon Oscillator", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, ..., on = on, legend = legend)), + list(n = n, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartAroonOsc", as.expression(substitute(list(x = current.chob(), + n = n, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(AroonOsc,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(AroonOsc),nsmall = 3L))), + text.col = c(theme$fg, 4), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[2], col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), + xlim[2], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, 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], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) + + lchob <- current.chob() + if (is.null(lchob$Env$theme$aroon$col$aroonOsc)) { + lchob$Env$theme$aroon$col$aroonOsc <- 3 } - chobTA@call <- match.call() - legend.name <- gsub("^addAroonOsc", "Aroon Oscillator ", deparse(match.call())) - gpars <- c(list(...), list(col = 3:4))[unique(names(c(list(col = 3:4), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + xdata <- lchob$Env$xdata + xdata <- cbind(Hi(xdata),Lo(xdata)) + xsubset <- lchob$Env$xsubset + AroonOsc <- aroon(HL=xdata,n=n)[xsubset,3] + lchob$Env$AroonOsc <- AroonOsc + if(is.na(on)) { + lchob$add_frame(ylim=c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05),asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addCLV.R b/R/addCLV.R index 8aa5f68a..8f96bc24 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -7,45 +7,66 @@ `addCLV` <- function (..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- HLC(x) - x <- CLV(HLC = x) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartCLV <- function(x, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + clv <- CLV(HLC=HLC(xdata))[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(clv) - 1) + xlim <- x$Env$xlim + ylim <- range(clv,na.rm=TRUE) + theme <- x$Env$theme + + lines(x.pos, clv, type = "h", col = theme$clv$col, + lwd = 1, lend = 2, ...) } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addCLV", "Close Location Value", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(..., on = on, legend = legend)), + list(..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartCLV", as.expression(substitute(list(x = current.chob(), + ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(clv,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(clv),nsmall = 3L))), + text.col = c(theme$fg, 5), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(clv, na.rm=TRUE)), + xlim[2], y_grid_lines(range(clv, na.rm=TRUE)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(clv, na.rm=TRUE)), y_grid_lines(range(clv, 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], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], border=theme$labels)), exp) + + lchob <- current.chob() + if (is.null(lchob$Env$theme$clv$col)) { + lchob$Env$theme$clv$col <- 5 + } + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + clv <- CLV(HLC=HLC(xdata))[xsubset] + lchob$Env$clv <- clv + if(is.na(on)) { + lchob$add_frame(ylim=range(clv,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$next_frame() } else { - chobTA@new <- FALSE - chobTA@on <- on + lchob$set_frame(sign(on)*abs(on)) } - chobTA@call <- match.call() - legend.name <- gsub("^.*[(]", " Close Location Value (", - deparse(match.call()))#, extended = TRUE) - gpars <- c(list(...), list(col=5, type = "h"))[unique(names(c(list(col=5, type = "h"), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) -# 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) -# chartSeries.chob <- quantmod:::chartSeries.chob -# do.call("chartSeries.chob", list(lchob)) -# invisible(chobTA) -# } -# else { - return(chobTA) -# } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addCMF.R b/R/addCMF.R index 909ff27f..e6168314 100644 --- a/R/addCMF.R +++ b/R/addCMF.R @@ -2,41 +2,72 @@ # addCMF {{{ `addCMF` <- function(n=20) { - lchob <- get.current.chob() + lenv <- new.env() + lenv$chartCMF <- function(x, n) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- cbind(Hi(xdata),Lo(xdata),Cl(xdata)) + vo <- x$Env$vo + cmf <- CMF(xdata,vo,n=n)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cmf) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(cmf), na.rm = TRUE), + max(abs(cmf), na.rm = TRUE))*1.05 + theme <- x$Env$theme - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE - - xx <- if(is.OHLC(x)) { - cbind(Hi(x),Lo(x),Cl(x)) + cmf.positive <- ifelse(cmf >= 0,cmf,0) + cmf.negative <- ifelse(cmf < 0,cmf,0) + + polygon(c(x.pos,rev(x.pos)),cbind(cmf.positive,rep(0,length(cmf))),col=theme$up.col) + polygon(c(x.pos,rev(x.pos)),cbind(cmf.negative,rep(0,length(cmf))),col=theme$dn.col) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n)), list(n = n)) + exp <- parse(text = gsub("list", "chartCMF", as.expression(substitute(list(x = current.chob(), + n = n)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f",last(cmf)), sep = "")), + text.col = c(theme$fg, ifelse(last(cmf) > 0,theme$up.col,theme$dn.col)), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(cmf), na.rm = TRUE)*1.05, xlim[2], max(abs(cmf), 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(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), 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(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), 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(cmf), na.rm = TRUE)*1.05, xlim[2], max(abs(cmf), na.rm = TRUE)*1.05, border=theme$labels), + segments(xlim[1], 0, xlim[2], 0, col = "#999999")), exp) + + lchob <- current.chob() + xdata <- lchob$Env$xdata + xdata <- if(is.OHLC(xdata)) { + cbind(Hi(xdata),Lo(xdata),Cl(xdata)) } else stop("CMF only applicaple to HLC series") - - cmf <- CMF(xx,Vo(x),n=n) - - chobTA@TA.values <- cmf[lchob@xsubset] - chobTA@name <- "chartCMF" - 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) - } + xsubset <- lchob$Env$xsubset + vo <- lchob$Env$vo + + cmf <- CMF(xdata,vo,n=n)[xsubset] + lchob$Env$cmf <- cmf + if(!is.character(legend) || legend == "auto") + lchob$Env$legend <- paste("Chaikin Money Flow (", n, ")", sep="") + lchob$add_frame(ylim=c(-max(abs(cmf), na.rm = TRUE), + max(abs(cmf), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartCMF {{{ `chartCMF` <- diff --git a/R/addCMO.R b/R/addCMO.R index fb0f5a2e..181fe681 100644 --- a/R/addCMO.R +++ b/R/addCMO.R @@ -3,47 +3,80 @@ `addCMO` <- function(n=14) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartCMO <- function(x, n) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xx <- if(has.Cl(xdata)) { + Cl(xdata) + } else if(NCOL(xdata)==1) { + xdata + } else { + xdata[,1] + } + cmo <- CMO(xx,n=n)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cmo) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(cmo), na.rm = TRUE), + max(abs(cmo), na.rm = TRUE))*1.05 + theme <- x$Env$theme + + lines(x.pos, cmo, col = "#0033CC", lwd = 1, lend = 2) + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n)), list(n = n)) + exp <- parse(text = gsub("list", "chartCMO", as.expression(substitute(list(x = current.chob(), + n = n)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f",last(cmo)), sep = "")), + text.col = c(theme$fg, "#0033CC"), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(cmo), na.rm = TRUE)*1.05, xlim[2], max(abs(cmo), 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(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), 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(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), 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(cmo), na.rm = TRUE)*1.05, xlim[2], max(abs(cmo), na.rm = TRUE)*1.05, border=theme$labels), + segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted")), exp) + + lchob <- current.chob() + + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset # needs to accept any arguments for x, not just close xx <- if(has.Cl(x)) { Cl(x) - } else if(is.null(dim(x))) { + } else if(NCOL(x)==1) { x } else { x[,1] } - cmo <- CMO(xx,n=n) - - chobTA@TA.values <- cmo[lchob@xsubset] - chobTA@name <- "chartCMO" - 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) - } + cmo <- CMO(xx,n=n)[xsubset] + lchob$Env$cmo <- cmo + if(!is.character(legend) || legend == "auto") + lchob$Env$legend <- paste("Chande Momentum Oscillator (", n, ") ", sep="") + lchob$add_frame(ylim=c(-max(abs(cmo), na.rm = TRUE), + max(abs(cmo), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartCMO {{{ `chartCMO` <- diff --git a/R/addChaikin.R b/R/addChaikin.R index 4e836101..1ef01b98 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -9,87 +9,135 @@ `addChAD` <- function (..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- chaikinAD(HLC = HLC(x), volume = Vo(x)) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartChAD <- function(x, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + vo <- x$Env$vo + ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(ChaikinAD) - 1) + xlim <- x$Env$xlim + ylim <- range(ChaikinAD,na.rm=TRUE) + theme <- x$Env$theme + + lines(x.pos, ChaikinAD, col = theme$chaikin$col$chaikinad, + lwd = 1, lend = 2, ...) } - else { - chobTA@new <- FALSE - chobTA@on <- on + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addChAD", "Chaikin Acc/Dist", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(..., on = on, legend = legend)), + list(..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartChAD", as.expression(substitute(list(x = current.chob(), + ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(ChaikinAD,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(ChaikinAD),nsmall = 3L))), + text.col = c(theme$fg, theme$chaikin$col$chaikinad), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), + xlim[2], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), y_grid_lines(range(ChaikinAD, 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], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], border=theme$labels)), exp) + + lchob <- current.chob() + if (is.null(lchob$Env$theme$chaikin$col$chaikinad)) { + lchob$Env$theme$chaikin$col$chaikinad <- 3 } - chobTA@call <- match.call() - legend.name <- gsub("^.*[(]", " Chaikin Acc/Dist (", deparse(match.call())) - #extended = TRUE) - gpars <- c(list(...), list(col = 11))[unique(names(c(list(col = 11), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + vo <- lchob$Env$vo + ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo)[xsubset] + lchob$Env$ChaikinAD <- ChaikinAD + if(is.na(on)) { + lchob$add_frame(ylim=range(ChaikinAD,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } `addChVol` <- function (n = 10, maType, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- chaikinVolatility(HL = HLC(x)[,-3], n = n, maType = maType) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartChVol <- function(x, n, maType, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(ChaikinVol) - 1) + xlim <- x$Env$xlim + ylim <- range(ChaikinVol,na.rm=TRUE) + theme <- x$Env$theme + + lines(x.pos, ChaikinVol, col = theme$chaikin$col$chaikinvol, + lwd = 1, lend = 2, ...) } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on + if(missing(maType)) maType <- "SMA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addChVol", "Chaikin Volatility", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, maType = maType, ..., on = on, legend = legend)), + list(n = n, maType = maType, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartChVol", as.expression(substitute(list(x = current.chob(), + n = n, maType = maType, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(ChaikinVol,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(ChaikinVol),nsmall = 3L))), + text.col = c(theme$fg, theme$chaikin$col$chaikinvol), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), + xlim[2], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), y_grid_lines(range(ChaikinVol, 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], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], border=theme$labels)), exp) + lchob <- current.chob() + if (is.null(lchob$Env$theme$chaikin$col$chaikinvol)) { + lchob$Env$theme$chaikin$col$chaikinvol <- "#F5F5F5" } - chobTA@call <- match.call() - legend.name <- gsub("^.*[(]", " Chaikin Volatility (", deparse(match.call()))#, - #extended = TRUE) - gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType)[xsubset] + lchob$Env$ChaikinVol <- ChaikinVol + if(is.na(on)) { + lchob$add_frame(ylim=range(ChaikinVol,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addEMV.R b/R/addEMV.R index 38527b74..ee13d2ed 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -8,45 +8,73 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- EMV(HL = HLC(x)[,-3], volume = Vo(x), n = n, maType = maType, - vol.divisor = vol.divisor) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on + lenv <- new.env() + lenv$chartEMV <- function(x, volume, n, maType, vol.divisor, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + volume <- x$Env$volume + emv <- EMV(HL=HLC(xdata)[,-3], volume = volume, n = n, maType = maType, + on = on, legend = legend)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(emv) - 1) + xlim <- x$Env$xlim + ylim <- range(emv,na.rm=TRUE)*1.05 + theme <- x$Env$theme + + lines(x.pos, emv$emv, col = 6, lwd = 1, lend = 2, ...) + lines(x.pos, emv$maEMV, col = 7, lwd = 1, lend = 2, ...) } - chobTA@call <- match.call() - legend.name <- gsub("^.*[(]", " Ease of Movement (", deparse(match.call()))#, - #extended = TRUE) - gpars <- c(list(...), list(col = 6:7))[unique(names(c(list(col = 6:7), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) - chartSeries.chob <- chartSeries.chob - do.call("chartSeries.chob", list(lchob)) - invisible(chobTA) + if(missing(volume)) volume <- lchob$Env$vo + if(missing(maType)) maType <- "SMA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^.*[(]", "Ease of Movement (", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(volume = volume, n = n, maType = maType, vol.divisor = vol.divisor, ..., + on = on, legend = legend)), + list(volume = volume, n = n, maType = maType, vol.divisor = vol.divisor, ..., + on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartEMV", + as.expression(substitute(list(x = current.chob(), volume = volume, n = n, maType = maType, vol.divisor = vol.divisor, ..., + on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(emv,na.rm=TRUE)*1.05), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste("emv :", sprintf("%.3f",last(emv$emv))), + paste("maEMV :", sprintf("%.3f",last(emv$maEMV)))), + text.col = c(theme$fg, 6, 7), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(emv,na.rm=TRUE)*1.05), + xlim[2], y_grid_lines(range(emv,na.rm=TRUE)*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(emv,na.rm=TRUE)*1.05), y_grid_lines(range(emv,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], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) + + lchob <- current.chob() + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + emv <- EMV(HL = HLC(xdata)[,-3], volume = volume, n = n, maType = maType, + vol.divisor = vol.divisor)[xsubset] + lchob$Env$emv <- emv + lchob$Env$volume <- volume + if(is.na(on)) { + lchob$add_frame(ylim=range(emv,na.rm=TRUE)*1.05,asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*abs(on)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addKST.R b/R/addKST.R index 9e668fb6..cd53d564 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -9,46 +9,74 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, maType, wts = 1:NROW(n), ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartKST <- function(x, n, nROC, nSig, maType, wts, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- xdata[xsubset] + xdata <- coredata(Cl(xdata)) + kst <- KST(price = xdata, n = n, nROC = nROC, nSig = nSig, maType = maType, + wts = wts) + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(kst) - 1) + xlim <- x$Env$xlim + ylim <- range(kst, na.rm=TRUE) * 1.05 + theme <- x$Env$theme + + lines(x.pos, kst[,1], col = 6, lwd = 1, lend = 2, ...) + lines(x.pos, kst[,2], col = 7, lwd = 1, lend = 2, ...) + } + if(missing(maType)) maType <- "SMA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addKST", "Know Sure Thing", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, nROC = nROC, nSig = nSig, + maType = maType, wts = wts, ..., on = on, legend = legend)), + list(n = n, nROC = nROC, nSig = nSig, + maType = maType, wts = wts, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartKST", as.expression(substitute(list(x = current.chob(), + n = n, nROC = nROC, nSig = nSig, + maType = maType, wts = wts, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(kst, na.rm=TRUE) * 1.05), + legend(x = lc$x, y = lc$y, + legend = c(legend, + paste("kst :",format(last(kst[,1]),nsmall = 3L)), + paste("signal :",format(last(kst[,2]),nsmall = 3L))), + text.col = c(theme$fg, 6, 7), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), + xlim[2], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), y_grid_lines(range(kst, 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], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, border=theme$labels)), exp) + + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- x[xsubset] x <- coredata(Cl(x)) - x <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, + kst <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, wts = wts) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + lchob$Env$kst <- kst + if(is.na(on)) { + lchob$add_frame(ylim=range(kst, na.rm=TRUE) * 1.05,asp=1,fixed=TRUE) + lchob$next_frame() } else { - chobTA@new <- FALSE - chobTA@on <- on - } - chobTA@call <- match.call() - legend.name <- gsub("^addKST", "Know Sure Thing ", deparse(match.call())) - gpars <- c(list(...), list(col = 6:7))[unique(names(c(list(col = 6:7), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) - chartSeries.chob <- chartSeries.chob - do.call("chartSeries.chob", list(lchob)) - invisible(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } - else { - return(chobTA) - } -} - + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob +} \ No newline at end of file diff --git a/R/addMFI.R b/R/addMFI.R index 923877df..af3fb61b 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -7,45 +7,67 @@ `addMFI` <- function (n = 14, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - volume <- Vo(x) - x <- HLC(x) - x <- MFI(HLC = x, volume = volume, n = n) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on + lenv <- new.env() + lenv$chartMFI <- function(x, n, ..., on, legend) { + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + volume <- lchob$Env$vo + xdata <- HLC(xdata) + mfi <- MFI(HLC = xdata, volume = volume, n = n)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(mfi) - 1) + xlim <- x$Env$xlim + ylim <- c(0,100) + theme <- x$Env$theme + + lines(x.pos, mfi, col = 8, lwd = 1, lend = 2, ...) } - chobTA@call <- match.call() - legend.name <- gsub("^addMFI", "Money Flow Index ", deparse(match.call())) - gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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(!is.character(legend) || legend == "auto") + legend <- gsub("^addMFI", "Money Flow Index ", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, ..., on = on, legend = legend)), + list(n = n, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartMFI", as.expression(substitute(list(x = current.chob(), + n = n, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, c(0,100)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(mfi),nsmall = 3L))), + text.col = c(theme$fg, 8), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], 0, xlim[2], 100, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(0,100)), + xlim[2], y_grid_lines(c(0,100)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(0,100)), y_grid_lines(c(0,100)), + 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], 0, xlim[2], 100, border=theme$labels)), exp) + + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + volume <- lchob$Env$vo + x <- HLC(x) + mfi <- MFI(HLC = x, volume = volume, n = n)[xsubset] + lchob$Env$mfi <- mfi + if(any(is.na(on))) { + lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addOBV.R b/R/addOBV.R index 6d39ec2b..e72e7c1f 100644 --- a/R/addOBV.R +++ b/R/addOBV.R @@ -7,43 +7,66 @@ `addOBV` <- function (..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- try.xts(lchob@xdata, error=FALSE) - x <- OBV(price = Cl(x), volume = Vo(x)) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on + lenv <- new.env() + lenv$chartOBV <- function(x, ..., on, legend) { + xdata <- try.xts(x$Env$xdata, error=FALSE) + xsubset <- x$Env$xsubset + vo <- x$Env$vo + obv <- OBV(price = Cl(xdata), volume = vo)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(obv) - 1) + xlim <- x$Env$xlim + ylim <- range(obv, na.rm=TRUE) * 1.05 + theme <- x$Env$theme + + lines(x.pos, obv, col = 4, lwd = 1, lend = 2, ...) + } - chobTA@call <- match.call() - legend.name <- gsub("^.*[(]", " On Balance Volume (", deparse(match.call()))#, - #extended = TRUE) - gpars <- c(list(...), list(col=4))[unique(names(c(list(col=4), list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) - chartSeries.chob <- chartSeries.chob - do.call("chartSeries.chob", list(lchob)) - invisible(chobTA) + if(!is.character(legend) || legend == "auto") + legend <- gsub("^.*[(]", " On Balance Volume (", deparse(match.call()))#, + #extended = TRUE) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(..., on = on, legend = legend)), + list(..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartOBV", as.expression(substitute(list(x = current.chob(), + ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(obv, na.rm=TRUE) * 1.05), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(format(last(obv),nsmall = 3L))), + text.col = c(theme$fg, 4), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(obv, na.rm=TRUE)[1] * 1.05, xlim[2], range(obv, na.rm=TRUE)[2] * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(obv, na.rm=TRUE) * 1.05), + xlim[2], y_grid_lines(range(obv, na.rm=TRUE) * 1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(obv, na.rm=TRUE) * 1.05), y_grid_lines(range(obv, 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], range(obv, na.rm=TRUE)[1] * 1.05, xlim[2], range(obv, na.rm=TRUE)[2] * 1.05, border=theme$labels)), exp) + + lchob <- current.chob() + x <- try.xts(lchob$Env$xdata, error=FALSE) + xsubset <- lchob$Env$xsubset + vo <- lchob$Env$vo + obv <- OBV(price = Cl(x), volume = vo)[xsubset] + lchob$Env$obv <- obv + if(is.na(on)) { + lchob$add_frame(ylim=range(obv, na.rm=TRUE) * 1.05 ,asp=1,fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } diff --git a/R/addSMI.R b/R/addSMI.R index 1515dc94..a5a7fe00 100644 --- a/R/addSMI.R +++ b/R/addSMI.R @@ -3,12 +3,76 @@ `addSMI` <- function(n=13,slow=25,fast=2,signal=9,ma.type='EMA') { - lchob <- get.current.chob() + lenv <- new.env() + lenv$chartSMI <- function(x, n, slow, fast, signal, ma.type) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + cbind(Hi(xdata),Lo(xdata),Cl(xdata)) + } else if(is.null(dim(xdata))) { + xdata + } else { + xdata[,1] + } + + smi <- SMI(xx, n=n, nFast=fast, + nSlow=slow, nSig=signal, maType=ma.type)[xsubset] + + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(smi) - 1) + xlim <- x$Env$xlim + ylim <- c(-max(abs(smi[,1]), na.rm = TRUE), + max(abs(smi[,1]), na.rm = TRUE))*1.05 + theme <- x$Env$theme + + COLOR <- "#0033CC" + SIGNAL <- "#BFCFFF" + + lines(x.pos,smi[,1],col=COLOR,lwd=1,type='l') + lines(x.pos,smi[,2],col=SIGNAL,lwd=1,lty='dotted',type='l') + + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n,fast = fast,slow = slow,signal = signal,ma.type = ma.type)), + list(n = n,fast = fast,slow = slow,signal = signal,ma.type = ma.type)) + exp <- parse(text = gsub("list", "chartSMI", as.expression(substitute(list(x = current.chob(), + n = n,fast = fast,slow = slow,signal = signal,ma.type = ma.type)))), srcfile = NULL) + exp <- c(exp, expression( + COLOR <- "#0033CC", + SIGNAL <- "#BFCFFF", + text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, + paste("Stochastic Momentum Index (", + paste(n,fast,slow,signal,sep=','), + "):", sep = ""), col = theme$fg, + pos = 4), + + text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, + paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[,1])), sep = ""), col = COLOR, + pos = 4), + + text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, + paste("\n\n\n\n\nSignal: ", + sprintf("%.3f",last(smi[,2])), sep = ""), col = SIGNAL, + pos = 4))) + exp <- c(expression( + # add inbox color + rect(xlim[1], -max(abs(smi[,1]), na.rm = TRUE)*1.05, xlim[2], max(abs(smi[,1]), 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(smi[,1]), na.rm = TRUE),max(abs(smi[,1]), na.rm = TRUE))*1.05), + xlim[2], y_grid_lines(c(-max(abs(smi[,1]), na.rm = TRUE),max(abs(smi[,1]), 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(smi[,1]), na.rm = TRUE),max(abs(smi[,1]), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(smi[,1]), na.rm = TRUE),max(abs(smi[,1]), 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(smi[,1]), na.rm = TRUE)*1.05, xlim[2], max(abs(smi[,1]), na.rm = TRUE)*1.05, border=theme$labels)), exp) - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + lchob <- current.chob() + + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { cbind(Hi(x),Lo(x),Cl(x)) @@ -19,34 +83,14 @@ } smi <- SMI(xx, n=n, nFast=fast, - nSlow=slow, nSig=signal, maType=ma.type) - -# subset here -# smi <- smi[lchob@sindex] - - chobTA@TA.values <- smi[lchob@xsubset,] - chobTA@name <- "chartSMI" - 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,slow=slow,fast=fast,signal=signal, - ma.type=ma.type) - #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) - #} + nSlow=slow, nSig=signal, maType=ma.type)[xsubset] + lchob$Env$smi <- smi + + lchob$add_frame(ylim=c(-max(abs(smi[,1]), na.rm = TRUE), + max(abs(smi[,1]), na.rm = TRUE))*1.05, asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartSMI {{{ `chartSMI` <- diff --git a/R/addTA.R b/R/addTA.R index e810f5cf..8b12a324 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 + 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() - # needs to accept any arguments for x, not just close + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset - xx <- if(is.OHLC(x)) { - Cl(x) - } else x + 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] - mom <- momentum(xx,n=n) - - 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` <- @@ -100,41 +128,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` <- @@ -194,40 +258,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` <- @@ -267,40 +350,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` <- @@ -334,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` <- @@ -408,44 +520,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` <- @@ -514,41 +656,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` <- @@ -594,42 +758,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` <- @@ -660,44 +839,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` <- @@ -806,44 +1111,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` <- @@ -884,41 +1213,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` <- @@ -940,37 +1261,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` <- @@ -1031,69 +1394,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]])))) } - i <- i.tmp + 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 <- 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])) - - 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) - } + + 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() + + 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` <- @@ -1120,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 - - 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) + 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 + + 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` <- @@ -1180,47 +1590,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` <- @@ -1262,66 +1705,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` <- @@ -1369,61 +1849,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` <- @@ -1467,55 +1964,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` <- @@ -1537,7 +2067,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) @@ -1551,55 +2081,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` <- @@ -1635,56 +2173,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` <- @@ -1720,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` <- @@ -1806,41 +2398,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` <- diff --git a/R/addTDI.R b/R/addTDI.R index 07b444ad..5f6e2293 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -7,43 +7,67 @@ `addTDI` <- function (n = 20, multiple = 2, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- Cl(x) - x <- TDI(price = x, n = n, multiple = multiple) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartTDI <- function(x, n, multiple, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- Cl(xdata) + tdi <- TDI(price = xdata, n = n, multiple = multiple)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(tdi) - 1) + xlim <- x$Env$xlim + ylim <- range(tdi, na.rm=TRUE)*1.05 + theme <- x$Env$theme + + lines(x.pos, tdi[,1], col = 5, lwd = 1, lend = 2, ...) + lines(x.pos, tdi[,2], col = 6, lwd = 1, lend = 2, ...) + } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^addTDI", "Trend Detection Index ", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, multiple = multiple, ..., on = on, legend = legend)), + list(n = n, multiple = multiple, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartTDI", as.expression(substitute(list(x = current.chob(), + n = n, multiple = multiple, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(tdi, na.rm=TRUE)*1.05), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste("tdi :",format(last(tdi[,1]),nsmall = 3L)), + paste("di :",format(last(tdi[,1]),nsmall = 3L))), + text.col = c(theme$fg, 5, 6), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), + xlim[2], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), y_grid_lines(range(tdi, 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], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) + + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- Cl(x) + tdi <- TDI(price = x, n = n, multiple = multiple)[xsubset] + lchob$Env$tdi <- tdi if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on - } - chobTA@call <- match.call() - legend.name <- gsub("^addTDI", "Trend Detection Index ", deparse(match.call())) - gpars <- c(list(...), list(col = 5:6))[unique(names(c(list(col = 5:6), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + lchob$add_frame(ylim=range(tdi, na.rm=TRUE)*1.05, asp=1, fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } diff --git a/R/addVo.R b/R/addVo.R index 8187de3c..410aff2a 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -1,13 +1,81 @@ # addVo {{{ -`addVo` <- function(log.scale=FALSE) { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - if(!lchob@show.vol || !has.Vo(x)) - return(invisible(new('chobTA', new=FALSE, name="chartNULL", call=match.call()))) - - Volumes <- Vo(x) - max.vol <- max(Volumes,na.rm=TRUE) +`addVo` <- function(log.scale=FALSE, ...) { + lenv <- new.env() + + lenv$chartVo <- function(x, ...) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + vo <- x$Env$vo + + spacing <- x$Env$theme$spacing + width <- x$Env$theme$width + + x.range <- x$get_xlim() + x.range <- seq(x.range[1],x.range[2]*spacing) + + # multi.col <- x$Env$multi.col + color.vol <- x$Env$color.vol + log.scale <- ifelse(x$Env$log.scale,"y","") + + vol.scale <- x$Env$vol.scale + + x.pos <- 1 + spacing * (1:length(vo) - 1) + + bar.col <- if(x$Env$color.vol) { + x$Env$theme$bar.col + } else x$Env$theme$border.col + + border.col <- x$Env$theme$border.col + min.vol <- min(vo) + + if(x$Env$theme$thin) { + # plot thin volume bars if appropriate + segments(x.pos,min.vol,x.pos,vo,col=bar.col) + } else { + rect(x.pos-spacing/3,min.vol,x.pos+spacing/3,vo, + col=bar.col,border=border.col) + } + legend.text <- list(list( + legend=c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo)*vol.scale[[1]],big.mark=',')), + text.col=c(x$Env$theme$fg, last(bar.col)) + )) + lc <- xts:::legend.coords("topleft", x$Env$xlim, range(vo)) + legend(x = lc$x, y = lc$y, + legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(x$Env$TA.values)*vol.scale[[1]],big.mark=',')), + text.col = c(x$Env$theme$fg, last(bar.col)), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95) + } + + # map all passed args (if any) to 'lenv' environment + mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(...)), list(...)) + exp <- parse(text=gsub("list","chartVo",as.expression(substitute(list(x=current.chob(),...)))), + srcfile=NULL) + lchob <- current.chob() + xdata <- lchob$Env$vo + xsubset <- lchob$Env$xsubset + x <- lchob$Env$xdata + theme <- lchob$Env$theme + vo <- xdata[xsubset] + lenv$xdata <- xdata + + lenv$grid_lines <- function(xdata,x) { seq(0,1) } + # add inbox color + exp <- c(expression(rect(xlim[1], range(vo)[1], xlim[2], range(vo)[2],col=theme$fill)), + # add grid lines and left-side axis labels + expression(segments(xlim[1], y_grid_lines(range(vo)), xlim[2], + y_grid_lines(range(vo)), col = theme$grid, lwd = grid.ticks.lwd, + lty = 3), + text(xlim[1], y_grid_lines(range(vo)), y_grid_lines(range(TA.values)), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE)), + # add border of plotting area + expression(rect(xlim[1], range(vo)[1], xlim[2], range(vo)[2],border=theme$labels)),exp) + + max.vol <- max(vo,na.rm=TRUE) vol.scale <- list(100, "100s") if (max.vol > 10000) vol.scale <- list(1000, "1000s") @@ -18,66 +86,47 @@ if (max.vol > 1e+07) vol.scale <- list(1e+06, "millions") - if(lchob@color.vol & is.OHLC(x)) { + if(lchob$Env$color.vol) { # calculate colors for bars, if applicable. Opens <- Op(x) Closes <- Cl(x) - if(lchob@multi.col) { + if(lchob$Env$multi.col) { # colored bars - 4 color last.Closes <- as.numeric(Lag(Closes)) last.Closes[1] <- Closes[1] bar.col <- ifelse(Opens < Closes, ifelse(Opens < last.Closes, - lchob@colors$dn.up.col, - lchob@colors$up.up.col), + lchob$Env$theme$dn.up.col, + lchob$Env$theme$up.up.col), ifelse(Opens < last.Closes, - lchob@colors$dn.dn.col, - lchob@colors$up.dn.col)) + lchob$Env$theme$dn.dn.col, + lchob$Env$theme$up.dn.col)) } else { # colored bars - 2 color bar.col <- ifelse(Opens < Closes, - lchob@colors$up.col, - lchob@colors$dn.col) + lchob$Env$theme$up.col, + lchob$Env$theme$dn.col) } # 1 color bars - } else bar.col <- ifelse(!is.null(lchob@colors$Vo.bar.col), - lchob@colors$Vo.bar.col,lchob@colors$border) - border.col <- ifelse(is.null(lchob@colors$border), - bar.col,lchob@colors$border) + } else bar.col <- ifelse(rep(!is.null(lchob$Env$theme$Vo.bar.col), NROW(x)), + lchob$Env$theme$Vo.bar.col,lchob$Env$theme$border) + border.col <- ifelse(rep(is.null(lchob$Env$theme$border),NROW(x)), + bar.col,lchob$Env$theme$border) - bar.col <- bar.col[lchob@xsubset] + bar.col <- bar.col[lchob$Env$xsubset] + + lchob$Env$theme$border.col <- border.col + lchob$Env$theme$bar.col <- bar.col - chobTA <- new("chobTA") - chobTA@new <- TRUE + lchob$Env$vol.scale <- vol.scale + lchob$Env$TA.values <- vo/vol.scale[[1]] - chobTA@TA.values <- (Volumes/vol.scale[[1]])[lchob@xsubset] - chobTA@name <- "chartVo" - chobTA@call <- match.call() + lchob$Env$theme$thin <- ifelse(lchob$Env$type %in% c('bars','matchsticks'),TRUE,FALSE) - 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, - vol.scale=vol.scale, - x.labels=lchob@x.labels, - log.scale=log.scale, - bar.col=bar.col,border.col=border.col, - time.scale=lchob@time.scale) - - chobTA@params$thin <- ifelse(lchob@type %in% c('bars','matchsticks'),TRUE,FALSE) - - 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$add_frame(ylim=range(vo),asp=1) # need to have a value set for ylim + lchob$next_frame() + lchob$replot(exp,env=c(lenv, lchob$Env),expr=TRUE) + lchob } # }}} # chartVo {{{ `chartVo` <- diff --git a/R/addVolatility.R b/R/addVolatility.R index 2fe1f718..75b158bb 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -7,43 +7,66 @@ `addVolatility` <- function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- OHLC(x) - x <- volatility(OHLC = x, n = n, calc = calc, N = N) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartVolatility <- function(x, n, calc, N, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- OHLC(xdata) + vol <- volatility(OHLC = xdata, n = n, calc = calc, N = N)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(vol) - 1) + xlim <- x$Env$xlim + ylim <- c(min(vol, na.rm=TRUE) * 0.95, max(vol, na.rm=TRUE) * 1.05) + theme <- x$Env$theme + + lines(x.pos, vol, col = 8, lwd = 1, lend = 2, ...) + } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^add", "", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n, calc = calc, N = N, ..., on = on, legend = legend)), + list(n = n, calc = calc, N = N, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartVolatility", as.expression(substitute(list(x = current.chob(), + n = n, calc = calc, N = N, ..., on = on, legend = legend)))), srcfile = NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + format(last(vol),nsmall = 3L)), + text.col = c(theme$fg, 8), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], min(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), + xlim[2], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, 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(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, border=theme$labels)), exp) + + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- OHLC(x) + vol <- volatility(OHLC = x, n = n, calc = calc, N = N)[xsubset] + lchob$Env$vol <- vol if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on - } - chobTA@call <- match.call() - legend.name <- gsub("^add", "", deparse(match.call())) - gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8), - list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + lchob$add_frame(ylim=c(min(vol, na.rm=TRUE) * 0.95, + max(vol, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } diff --git a/R/addWPR.R b/R/addWPR.R index f31254e1..0e9c278c 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -3,12 +3,63 @@ `addWPR` <- function(n=14) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartWPR <- function(x, n) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + + xx <- if(is.OHLC(xdata)) { + cbind(Hi(xdata),Lo(xdata),Cl(xdata)) + } else if(is.null(dim(xdata))) { + xdata + } else { + xdata[,1] + } + + + wpr <- WPR(xx,n=n)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(wpr) - 1) + xlim <- x$Env$xlim + ylim <- c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05 + theme <- x$Env$theme + + COLOR <- "#0033CC" + lines(x.pos,wpr,col=COLOR,lwd=1,type='l') + + } + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(n = n)), + list(n = n)) + exp <- parse(text = gsub("list", "chartWPR", as.expression(substitute(list(x = current.chob(), + n = n)))), srcfile = NULL) + exp <- c(exp, expression( + COLOR <- "#0033CC", + text(0, max(abs(wpr), na.rm = TRUE)*.9, + paste("Williams %R (", n,"):", sep = ""), col = theme$fg, + pos = 4), + + text(0, max(abs(wpr), na.rm = TRUE)*.9, + paste("\n\n\n",sprintf("%.3f",last(wpr)), sep = ""), col = COLOR, + pos = 4))) + exp <- c(expression( + # add inbox color + rect(xlim[1], max(abs(wpr), na.rm = TRUE) * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), + xlim[2], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), y_grid_lines(c(-0.1, max(abs(wpr), 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], -0.1 * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, border=theme$labels)), exp) + + lchob <- current.chob() + + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset xx <- if(is.OHLC(x)) { cbind(Hi(x),Lo(x),Cl(x)) @@ -19,30 +70,12 @@ } - wpr <- WPR(xx,n=n) - - chobTA@TA.values <- as.numeric(wpr)[lchob@xsubset] - chobTA@name <- "chartWPR" - 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) - } + wpr <- WPR(xx,n=n)[xsubset] + lchob$Env$wpr <- wpr + lchob$add_frame(ylim=c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05, asp=1, fixed=TRUE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartWPR {{{ `chartWPR` <- diff --git a/R/addZigZag.R b/R/addZigZag.R index 7d18ae6d..b108ed09 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -8,44 +8,75 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, ..., on = -1, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) - x <- cbind(Hi(x),Lo(x)) - x <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, - lastExtreme = lastExtreme) - yrange <- NULL - chobTA <- new("chobTA") - if (NCOL(x) == 1) { - chobTA@TA.values <- x[lchob@xsubset] + lenv <- new.env() + lenv$chartZigZag <- function(x, change, percent, retrace, lastExtreme, ..., on, legend) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + xdata <- cbind(Hi(xdata),Lo(xdata)) + zigzag <- ZigZag(HL = xdata, change = change, percent = percent, retrace = retrace, + lastExtreme = lastExtreme)[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(zigzag) - 1) + xlim <- x$Env$xlim + ylim <- c(min(zigzag, na.rm=TRUE)*0.975, max(zigzag, na.rm=TRUE)*1.05) + theme <- x$Env$theme + + if(any(is.na(on))) { + legend.name <- c(paste(legend, ":"), + paste(format(last(na.omit(zigzag)),nsmall = 3L))) + text.col <- c(x$Env$theme$fg, 4) + # 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) + yjust <- 1 + } else { + ylim <- x$get_ylim()[[2]] + legend.name <- paste(legend, ":", format(last(na.omit(zigzag)),nsmall = 3L)) + text.col <- 4 + yjust <- 1.5 + } + lines(x.pos, zigzag, col = 4, lwd = 4, lend = 2, ...) + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(x = lc$x, y = lc$y, + legend = legend.name, + text.col = text.col, + xjust = lc$xjust, + yjust = yjust, + bty = "n", + y.intersp=0.95) } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" + if(!is.character(legend) || legend == "auto") + legend <- gsub("^add", "", deparse(match.call())) + mapply(function(name, value) { + assign(name, value, envir = lenv) + }, names(list(change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme, ..., on = on, legend = legend)), + list(change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme, ..., on = on, legend = legend)) + exp <- parse(text = gsub("list", "chartZigZag", as.expression(substitute(list(x = current.chob(), + change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme, ..., on = on, legend = legend)))), srcfile = NULL) + lchob <- current.chob() + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- cbind(Hi(x),Lo(x)) + zigzag <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, + lastExtreme = lastExtreme)[xsubset] + lchob$Env$zigzag <- zigzag + if (any(is.na(on))) { - chobTA@new <- TRUE - } - else { - chobTA@new <- FALSE - chobTA@on <- on - } - chobTA@call <- match.call() - legend.name <- gsub("^add", "", deparse(match.call())) - gpars <- c(list(...), list(col = 4, lwd = 3))[unique(names(c(list(col = 4, - lwd = 3), list(...))))] - chobTA@params <- list(xrange = lchob@xrange, yrange = yrange, - 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, - isLogical = is.logical(x), legend = legend, legend.name = legend.name, - pars = list(gpars)) - 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) + lchob$add_frame(ylim=c(min(zigzag, na.rm=TRUE)*0.975, + max(zigzag, na.rm=TRUE)*1.05), asp=1, fixed=TRUE) + lchob$next_frame() } else { - return(chobTA) + lchob$set_frame(sign(on)*(abs(on)+1L)) } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } From e48d821d0b8cb4905f436dd621bdba8e47f0fc39 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Tue, 26 Jul 2016 17:26:14 +0800 Subject: [PATCH 02/12] Fix y limit bug of subset series When subset is specified in chartSeries, addVo() doesn't apply correct subset volume to the chart. To fix this issue, subset setting is applied to chartVo function in chartSeries and pass subset volume to the environment. y-axis limit of the frame is expanded to reserve space from the top. --- R/addVo.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/addVo.R b/R/addVo.R index 410aff2a..931d50aa 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -60,20 +60,21 @@ x <- lchob$Env$xdata theme <- lchob$Env$theme vo <- xdata[xsubset] + lchob$Env$vo <- vo + yrange <- c(range(vo, na.rm=TRUE)[1], range(vo, na.rm=TRUE)[2] * 1.05) lenv$xdata <- xdata - lenv$grid_lines <- function(xdata,x) { seq(0,1) } # add inbox color - exp <- c(expression(rect(xlim[1], range(vo)[1], xlim[2], range(vo)[2],col=theme$fill)), + exp <- c(expression(yrange <- c(range(vo, na.rm=TRUE)[1], range(vo, na.rm=TRUE)[2] * 1.05), rect(xlim[1], yrange[1], xlim[2], yrange[2],col=theme$fill)), # add grid lines and left-side axis labels - expression(segments(xlim[1], y_grid_lines(range(vo)), xlim[2], - y_grid_lines(range(vo)), col = theme$grid, lwd = grid.ticks.lwd, + expression(segments(xlim[1], y_grid_lines(yrange), xlim[2], + y_grid_lines(yrange), col = theme$grid, lwd = grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(vo)), y_grid_lines(range(TA.values)), + text(xlim[1], y_grid_lines(yrange), y_grid_lines(range(TA.values)), col = theme$labels, srt = theme$srt, offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE)), # add border of plotting area - expression(rect(xlim[1], range(vo)[1], xlim[2], range(vo)[2],border=theme$labels)),exp) + expression(rect(xlim[1], yrange[1], xlim[2], yrange[2],border=theme$labels)),exp) max.vol <- max(vo,na.rm=TRUE) vol.scale <- list(100, "100s") @@ -123,7 +124,7 @@ lchob$Env$theme$thin <- ifelse(lchob$Env$type %in% c('bars','matchsticks'),TRUE,FALSE) - lchob$add_frame(ylim=range(vo),asp=1) # need to have a value set for ylim + lchob$add_frame(ylim=yrange, asp=1, fixed=TRUE) # need to have a value set for ylim lchob$next_frame() lchob$replot(exp,env=c(lenv, lchob$Env),expr=TRUE) lchob From b3f5ef0dfed040fac04b80cb3acf775860c794d9 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Tue, 2 Aug 2016 16:57:20 +0800 Subject: [PATCH 03/12] Fix addVo() subsetting bug When reChart is called to draw subset volume, bar colors are wrong and subset functionality fails. The volume chart starts from the first day of the series no matter what subset period is specified. Pull out the panel settings from chartVo and wrap in expression. --- R/addVo.R | 111 ++++++++++++++++++++++++++---------------------------- 1 file changed, 54 insertions(+), 57 deletions(-) diff --git a/R/addVo.R b/R/addVo.R index 931d50aa..6ea6d7e9 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -6,27 +6,30 @@ lenv$chartVo <- function(x, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - vo <- x$Env$vo + vo <- x$Env$vo[xsubset] spacing <- x$Env$theme$spacing width <- x$Env$theme$width - x.range <- x$get_xlim() - x.range <- seq(x.range[1],x.range[2]*spacing) + x.pos <- 1 + spacing * (1:NROW(vo) - 1) + xlim <- x$Env$xlim + ylim <- c(min(vo, na.rm=TRUE), max(vo, na.rm=TRUE) * 1.05) + theme <- x$Env$theme + + vol.scale <- x$Env$vol.scale + TA.values <- x$Env$TA.values + + thin <- theme$thin # multi.col <- x$Env$multi.col color.vol <- x$Env$color.vol log.scale <- ifelse(x$Env$log.scale,"y","") - vol.scale <- x$Env$vol.scale - - x.pos <- 1 + spacing * (1:length(vo) - 1) + bar.col <- if(color.vol) { + theme$bar.col + } else theme$border.col - bar.col <- if(x$Env$color.vol) { - x$Env$theme$bar.col - } else x$Env$theme$border.col - - border.col <- x$Env$theme$border.col + border.col <- theme$border.col min.vol <- min(vo) if(x$Env$theme$thin) { @@ -36,56 +39,40 @@ rect(x.pos-spacing/3,min.vol,x.pos+spacing/3,vo, col=bar.col,border=border.col) } - legend.text <- list(list( - legend=c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo)*vol.scale[[1]],big.mark=',')), - text.col=c(x$Env$theme$fg, last(bar.col)) - )) - lc <- xts:::legend.coords("topleft", x$Env$xlim, range(vo)) - legend(x = lc$x, y = lc$y, - legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(x$Env$TA.values)*vol.scale[[1]],big.mark=',')), - text.col = c(x$Env$theme$fg, last(bar.col)), - xjust = lc$xjust, - yjust = lc$yjust, - bty = "n", - y.intersp=0.95) } # map all passed args (if any) to 'lenv' environment mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(...)), list(...)) exp <- parse(text=gsub("list","chartVo",as.expression(substitute(list(x=current.chob(),...)))), srcfile=NULL) + exp <- c(exp, expression( + lc <- xts:::legend.coords("topleft", xlim, range(vo,na.rm=TRUE)), + legend(x = lc$x, y = lc$y, + legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(TA.values)*vol.scale[[1]],big.mark=',')), + text.col = c(theme$fg, last(theme$bar.col)), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + exp <- c(expression( + # add inbox color + rect(xlim[1], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], col=theme$fill), + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), + xlim[2], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), + text(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), y_grid_lines(range(TA.values, 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], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) + lchob <- current.chob() xdata <- lchob$Env$vo xsubset <- lchob$Env$xsubset x <- lchob$Env$xdata theme <- lchob$Env$theme vo <- xdata[xsubset] - lchob$Env$vo <- vo - yrange <- c(range(vo, na.rm=TRUE)[1], range(vo, na.rm=TRUE)[2] * 1.05) - lenv$xdata <- xdata - - # add inbox color - exp <- c(expression(yrange <- c(range(vo, na.rm=TRUE)[1], range(vo, na.rm=TRUE)[2] * 1.05), rect(xlim[1], yrange[1], xlim[2], yrange[2],col=theme$fill)), - # add grid lines and left-side axis labels - expression(segments(xlim[1], y_grid_lines(yrange), xlim[2], - y_grid_lines(yrange), col = theme$grid, lwd = grid.ticks.lwd, - lty = 3), - text(xlim[1], y_grid_lines(yrange), y_grid_lines(range(TA.values)), - col = theme$labels, srt = theme$srt, - offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE)), - # add border of plotting area - expression(rect(xlim[1], yrange[1], xlim[2], yrange[2],border=theme$labels)),exp) - - max.vol <- max(vo,na.rm=TRUE) - vol.scale <- list(100, "100s") - if (max.vol > 10000) - vol.scale <- list(1000, "1000s") - if (max.vol > 1e+05) - vol.scale <- list(10000, "10,000s") - if (max.vol > 1e+06) - vol.scale <- list(1e+05, "100,000s") - if (max.vol > 1e+07) - vol.scale <- list(1e+06, "millions") if(lchob$Env$color.vol) { # calculate colors for bars, if applicable. @@ -108,23 +95,33 @@ lchob$Env$theme$up.col, lchob$Env$theme$dn.col) } - # 1 color bars - } else bar.col <- ifelse(rep(!is.null(lchob$Env$theme$Vo.bar.col), NROW(x)), + # 1 color bars + } else bar.col <- ifelse(rep(!is.null(lchob$Env$theme$Vo.bar.col), NROW(xdata[,1])), lchob$Env$theme$Vo.bar.col,lchob$Env$theme$border) - border.col <- ifelse(rep(is.null(lchob$Env$theme$border),NROW(x)), + border.col <- ifelse(rep(is.null(lchob$Env$theme$border),NROW(xdata[,1])), bar.col,lchob$Env$theme$border) - + bar.col <- bar.col[lchob$Env$xsubset] lchob$Env$theme$border.col <- border.col lchob$Env$theme$bar.col <- bar.col - + + lchob$Env$theme$thin <- ifelse(lchob$Env$type %in% c('bars','matchsticks'),TRUE,FALSE) + + max.vol <- max(vo,na.rm=TRUE) + vol.scale <- list(100, "100s") + if (max.vol > 10000) + vol.scale <- list(1000, "1000s") + if (max.vol > 1e+05) + vol.scale <- list(10000, "10,000s") + if (max.vol > 1e+06) + vol.scale <- list(1e+05, "100,000s") + if (max.vol > 1e+07) + vol.scale <- list(1e+06, "millions") lchob$Env$vol.scale <- vol.scale lchob$Env$TA.values <- vo/vol.scale[[1]] - - lchob$Env$theme$thin <- ifelse(lchob$Env$type %in% c('bars','matchsticks'),TRUE,FALSE) - lchob$add_frame(ylim=yrange, asp=1, fixed=TRUE) # need to have a value set for ylim + lchob$add_frame(ylim=c(min(vo, na.rm=TRUE), max(vo, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) # need to have a value set for ylim lchob$next_frame() lchob$replot(exp,env=c(lenv, lchob$Env),expr=TRUE) lchob From a4ee734c599a0a334219a74c85efdb5480113b80 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 31 Jul 2016 16:25:51 +0800 Subject: [PATCH 04/12] 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 From b68c0ea4f23154c3e240a549e9fa3334ff755343 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 7 Aug 2016 00:38:03 +0800 Subject: [PATCH 05/12] Pass function calls and indicator values to the environment To coordinate with functions that manipulate TA such as swapTA(), moveTA() and dropTA(), TA values is passed to a new name list "TA" and function calls are passed to call_list. --- R/addAroon.R | 10 +- R/addCLV.R | 5 +- R/addCMF.R | 5 +- R/addCMO.R | 5 +- R/addChaikin.R | 12 +- R/addEMV.R | 13 ++- R/addKST.R | 5 +- R/addMFI.R | 5 +- R/addOBV.R | 5 +- R/addSMI.R | 5 +- R/addTA.R | 280 +++++++++++++++++++++++++++++++++++----------- R/addTDI.R | 5 +- R/addVo.R | 6 +- R/addVolatility.R | 5 +- R/addWPR.R | 5 +- R/addZigZag.R | 4 +- 16 files changed, 289 insertions(+), 86 deletions(-) diff --git a/R/addAroon.R b/R/addAroon.R index c4067b5a..89aecba4 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -45,6 +45,7 @@ function (n = 20, ..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + Aroon <- TA$Aroon, # add inbox color rect(xlim[1], 0, xlim[2], 100, col=theme$fill), # add grid lines and left-side axis labels @@ -58,6 +59,8 @@ function (n = 20, ..., on = NA, legend = "auto") rect(xlim[1], 0, xlim[2], 100, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if (is.null(lchob$Env$theme$aroon$col$arronUp)) { lchob$Env$theme$aroon$col$aroonUp <- 3 lchob$Env$theme$aroon$col$aroonDn <- 4 @@ -66,7 +69,7 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset Aroon <- aroon(HL=xdata,n=n)[xsubset,-3] - lchob$Env$Aroon <- Aroon + lchob$Env$TA$Aroon <- Aroon # lenv$xdata <- structure(Aroon, .Dimnames = list(NULL, "aroon")) if(is.na(on)) { lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) @@ -116,6 +119,7 @@ function (n = 20, ..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + AroonOsc <- TA$AroonOsc, # add inbox color rect(xlim[1], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[2], col=theme$fill), # add grid lines and left-side axis labels @@ -129,6 +133,8 @@ function (n = 20, ..., on = NA, legend = "auto") rect(xlim[1], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if (is.null(lchob$Env$theme$aroon$col$aroonOsc)) { lchob$Env$theme$aroon$col$aroonOsc <- 3 } @@ -136,7 +142,7 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset AroonOsc <- aroon(HL=xdata,n=n)[xsubset,3] - lchob$Env$AroonOsc <- AroonOsc + lchob$Env$TA$AroonOsc <- AroonOsc if(is.na(on)) { lchob$add_frame(ylim=c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05),asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addCLV.R b/R/addCLV.R index 8f96bc24..3740b8ab 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -40,6 +40,7 @@ function (..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + clv <- TA$clv, # add inbox color rect(xlim[1], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], col=theme$fill), # add grid lines and left-side axis labels @@ -53,13 +54,15 @@ function (..., on = NA, legend = "auto") rect(xlim[1], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if (is.null(lchob$Env$theme$clv$col)) { lchob$Env$theme$clv$col <- 5 } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset clv <- CLV(HLC=HLC(xdata))[xsubset] - lchob$Env$clv <- clv + lchob$Env$TA$clv <- clv if(is.na(on)) { lchob$add_frame(ylim=range(clv,na.rm=TRUE),asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addCMF.R b/R/addCMF.R index e6168314..501a58c4 100644 --- a/R/addCMF.R +++ b/R/addCMF.R @@ -38,6 +38,7 @@ bty = "n", y.intersp=0.95))) exp <- c(expression( + cmf <- TA$cmf, # add inbox color rect(xlim[1], -max(abs(cmf), na.rm = TRUE)*1.05, xlim[2], max(abs(cmf), na.rm = TRUE)*1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -52,6 +53,8 @@ segments(xlim[1], 0, xlim[2], 0, col = "#999999")), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() xdata <- lchob$Env$xdata xdata <- if(is.OHLC(xdata)) { cbind(Hi(xdata),Lo(xdata),Cl(xdata)) @@ -60,7 +63,7 @@ vo <- lchob$Env$vo cmf <- CMF(xdata,vo,n=n)[xsubset] - lchob$Env$cmf <- cmf + lchob$Env$TA$cmf <- cmf if(!is.character(legend) || legend == "auto") lchob$Env$legend <- paste("Chaikin Money Flow (", n, ")", sep="") lchob$add_frame(ylim=c(-max(abs(cmf), na.rm = TRUE), diff --git a/R/addCMO.R b/R/addCMO.R index 181fe681..ba37ffe8 100644 --- a/R/addCMO.R +++ b/R/addCMO.R @@ -40,6 +40,7 @@ bty = "n", y.intersp=0.95))) exp <- c(expression( + cmo <- TA$cmo, # add inbox color rect(xlim[1], -max(abs(cmo), na.rm = TRUE)*1.05, xlim[2], max(abs(cmo), na.rm = TRUE)*1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -54,6 +55,8 @@ segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted")), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -69,7 +72,7 @@ } cmo <- CMO(xx,n=n)[xsubset] - lchob$Env$cmo <- cmo + lchob$Env$TA$cmo <- cmo if(!is.character(legend) || legend == "auto") lchob$Env$legend <- paste("Chande Momentum Oscillator (", n, ") ", sep="") lchob$add_frame(ylim=c(-max(abs(cmo), na.rm = TRUE), diff --git a/R/addChaikin.R b/R/addChaikin.R index 1ef01b98..86ebc846 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -43,6 +43,7 @@ function (..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + ChaikinAD <- TA$ChaikinAD, # add inbox color rect(xlim[1], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], col=theme$fill), # add grid lines and left-side axis labels @@ -56,6 +57,8 @@ function (..., on = NA, legend = "auto") rect(xlim[1], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if (is.null(lchob$Env$theme$chaikin$col$chaikinad)) { lchob$Env$theme$chaikin$col$chaikinad <- 3 } @@ -63,7 +66,7 @@ function (..., on = NA, legend = "auto") xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo)[xsubset] - lchob$Env$ChaikinAD <- ChaikinAD + lchob$Env$TA$ChaikinAD <- ChaikinAD if(is.na(on)) { lchob$add_frame(ylim=range(ChaikinAD,na.rm=TRUE),asp=1,fixed=TRUE) lchob$next_frame() @@ -111,7 +114,8 @@ function (n = 10, maType, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( + exp <- c(expression( + ChaikinVol <- TA$ChaikinVol, # add inbox color rect(xlim[1], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], col=theme$fill), # add grid lines and left-side axis labels @@ -124,13 +128,15 @@ function (n = 10, maType, ..., on = NA, legend = "auto") # add border of plotting area rect(xlim[1], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if (is.null(lchob$Env$theme$chaikin$col$chaikinvol)) { lchob$Env$theme$chaikin$col$chaikinvol <- "#F5F5F5" } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType)[xsubset] - lchob$Env$ChaikinVol <- ChaikinVol + lchob$Env$TA$ChaikinVol <- ChaikinVol if(is.na(on)) { lchob$add_frame(ylim=range(ChaikinVol,na.rm=TRUE),asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addEMV.R b/R/addEMV.R index ee13d2ed..fdcb70a3 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -12,9 +12,9 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, lenv$chartEMV <- function(x, volume, n, maType, vol.divisor, ..., on, legend) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - volume <- x$Env$volume + volume <- x$Env$TA$volume emv <- EMV(HL=HLC(xdata)[,-3], volume = volume, n = n, maType = maType, - on = on, legend = legend)[xsubset] + legend = legend)[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(emv) - 1) xlim <- x$Env$xlim @@ -24,6 +24,9 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, lines(x.pos, emv$emv, col = 6, lwd = 1, lend = 2, ...) lines(x.pos, emv$maEMV, col = 7, lwd = 1, lend = 2, ...) } + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(missing(volume)) volume <- lchob$Env$vo if(missing(maType)) maType <- "SMA" if(!is.character(legend) || legend == "auto") @@ -49,6 +52,7 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, bty = "n", y.intersp=0.95))) exp <- c(expression( + emv <- TA$emv, # add inbox color rect(xlim[1], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -61,13 +65,12 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, # add border of plotting area rect(xlim[1], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) - lchob <- current.chob() xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset emv <- EMV(HL = HLC(xdata)[,-3], volume = volume, n = n, maType = maType, vol.divisor = vol.divisor)[xsubset] - lchob$Env$emv <- emv - lchob$Env$volume <- volume + lchob$Env$TA$emv <- emv + lchob$Env$TA$volume <- volume if(is.na(on)) { lchob$add_frame(ylim=range(emv,na.rm=TRUE)*1.05,asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addKST.R b/R/addKST.R index cd53d564..70dbe500 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -50,6 +50,7 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, bty = "n", y.intersp=0.95))) exp <- c(expression( + kst <- TA$kst, # add inbox color rect(xlim[1], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -63,13 +64,15 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, rect(xlim[1], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- x[xsubset] x <- coredata(Cl(x)) kst <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, wts = wts) - lchob$Env$kst <- kst + lchob$Env$TA$kst <- kst if(is.na(on)) { lchob$add_frame(ylim=range(kst, na.rm=TRUE) * 1.05,asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addMFI.R b/R/addMFI.R index af3fb61b..1e7c420d 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -41,6 +41,7 @@ function (n = 14, ..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + mfi <- TA$mfi, # add inbox color rect(xlim[1], 0, xlim[2], 100, col=theme$fill), # add grid lines and left-side axis labels @@ -54,12 +55,14 @@ function (n = 14, ..., on = NA, legend = "auto") rect(xlim[1], 0, xlim[2], 100, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset volume <- lchob$Env$vo x <- HLC(x) mfi <- MFI(HLC = x, volume = volume, n = n)[xsubset] - lchob$Env$mfi <- mfi + lchob$Env$TA$mfi <- mfi if(any(is.na(on))) { lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addOBV.R b/R/addOBV.R index e72e7c1f..7d851e1c 100644 --- a/R/addOBV.R +++ b/R/addOBV.R @@ -42,6 +42,7 @@ function (..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + obv <- TA$obv, # add inbox color rect(xlim[1], range(obv, na.rm=TRUE)[1] * 1.05, xlim[2], range(obv, na.rm=TRUE)[2] * 1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -55,11 +56,13 @@ function (..., on = NA, legend = "auto") rect(xlim[1], range(obv, na.rm=TRUE)[1] * 1.05, xlim[2], range(obv, na.rm=TRUE)[2] * 1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- try.xts(lchob$Env$xdata, error=FALSE) xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo obv <- OBV(price = Cl(x), volume = vo)[xsubset] - lchob$Env$obv <- obv + lchob$Env$TA$obv <- obv if(is.na(on)) { lchob$add_frame(ylim=range(obv, na.rm=TRUE) * 1.05 ,asp=1,fixed=TRUE) lchob$next_frame() diff --git a/R/addSMI.R b/R/addSMI.R index a5a7fe00..448845db 100644 --- a/R/addSMI.R +++ b/R/addSMI.R @@ -57,6 +57,7 @@ sprintf("%.3f",last(smi[,2])), sep = ""), col = SIGNAL, pos = 4))) exp <- c(expression( + smi <- TA$smi, # add inbox color rect(xlim[1], -max(abs(smi[,1]), na.rm = TRUE)*1.05, xlim[2], max(abs(smi[,1]), na.rm = TRUE)*1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -70,6 +71,8 @@ rect(xlim[1], -max(abs(smi[,1]), na.rm = TRUE)*1.05, xlim[2], max(abs(smi[,1]), na.rm = TRUE)*1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -84,7 +87,7 @@ smi <- SMI(xx, n=n, nFast=fast, nSlow=slow, nSig=signal, maType=ma.type)[xsubset] - lchob$Env$smi <- smi + lchob$Env$TA$smi <- smi lchob$add_frame(ylim=c(-max(abs(smi[,1]), na.rm = TRUE), max(abs(smi[,1]), na.rm = TRUE))*1.05, asp=1, fixed=TRUE) diff --git a/R/addTA.R b/R/addTA.R index b671b0cd..e4da8501 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -55,6 +55,7 @@ paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''), col = COLOR, pos = 4))) exp <- c(expression( + mom <- TA$mom, # 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 @@ -69,6 +70,8 @@ segments(xlim[1],0,xlim[2],0,col="#666666",lwd=1,lty='dotted')), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -80,7 +83,7 @@ } else xx <- x[,with.col] mom <- momentum(xx,n=n)[xsubset] - lchob$Env$mom <- mom + lchob$Env$TA$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) @@ -175,6 +178,7 @@ function(x) { paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red', pos = 4))) exp <- c(expression( + cci <- TA$cci, # 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 @@ -190,6 +194,8 @@ function(x) { rect(xlim[1],-100,xlim[2],100,col=theme$bbands$col$fill,border=theme$fg)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -199,7 +205,7 @@ function(x) { } else x cci <- CCI(xx,n=n,maType=maType,c=c)[xsubset] - lchob$Env$cci <- cci + lchob$Env$TA$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() @@ -291,6 +297,7 @@ function(x) { n = n, maType = maType, wilder = wilder)))), srcfile = NULL) exp <- c(expression( + adx <- TA$adx, # 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 @@ -306,6 +313,8 @@ function(x) { segments(xlim[1], 40, xlim[2], 40, col = "#666666", lty = "dotted")), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -313,7 +322,7 @@ function(x) { 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)[xsubset] - lchob$Env$adx <- adx + lchob$Env$TA$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() @@ -379,6 +388,7 @@ function(x) { n = n, maType = maType)))), srcfile = NULL) exp <- c(expression( + atr <- TA$atr, # 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 @@ -392,6 +402,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -399,7 +411,7 @@ function(x) { if(!is.OHLC(x)) stop("only applicable to HLC series") atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...)[xsubset] - lchob$Env$atr <- atr + lchob$Env$TA$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() @@ -467,6 +479,7 @@ function(x) { 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( + trix <- TA$trix, # 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 @@ -480,6 +493,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -489,7 +504,7 @@ function(x) { } else x trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)[xsubset] - lchob$Env$trix <- trix + lchob$Env$TA$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() @@ -574,6 +589,7 @@ function(x) { pos = 4))) exp <- c(expression( + dpo <- TA$dpo, # 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 @@ -588,6 +604,8 @@ function(x) { segments(xlim[1], 0, xlim[2], 0, col = "#999999")), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -599,7 +617,7 @@ function(x) { } else x dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)[xsubset] - lchob$Env$dpo <- dpo + lchob$Env$TA$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() @@ -706,6 +724,7 @@ function(x) { paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC', pos = 4))) exp <- c(expression( + rsi <- TA$rsi, # 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 @@ -719,6 +738,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -728,7 +749,7 @@ function(x) { } else x rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)[xsubset] - lchob$Env$rsi <- rsi + lchob$Env$TA$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) @@ -803,6 +824,7 @@ function(x) { exp <- parse(text = gsub("list", "chartROC", as.expression(substitute(list(x = current.chob(), n = n, type = type, col = col)))), srcfile = NULL) exp <- c(expression( + roc <- TA$roc, # 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 @@ -816,6 +838,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -825,7 +849,7 @@ function(x) { } else x roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE)[xsubset] - lchob$Env$roc <- roc + lchob$Env$TA$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() @@ -989,6 +1013,8 @@ function(x) { # draw <- draw.options[pmatch(draw,draw.options)] lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -998,7 +1024,7 @@ function(x) { } else x bb <- BBands(xx,n=n,maType=maType,sd=sd)[xsubset] - lchob$Env$bb <- bb + lchob$Env$TA$bb <- bb if(draw == 'bands') { # draw Bollinger Bands on price chart lchob$set_frame(-2) @@ -1181,6 +1207,8 @@ function(x) { n = n, p = p, maType = maType, ..., on = on)))), srcfile = NULL) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -1191,7 +1219,7 @@ function(x) { ma <- do.call(maType,list(xx,n=n,...)) mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))[xsubset] - lchob$Env$mae <- mae + lchob$Env$TA$mae <- mae lchob$set_frame(on+1) lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -1251,6 +1279,8 @@ function(x) { exp <- parse(text = gsub("list", "chartSAR", as.expression(substitute(list(x = current.chob(), accel = accel, col = col)))), srcfile = NULL) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -1258,7 +1288,7 @@ function(x) { if(!is.OHLC(x)) stop("SAR requires HL series") sar <- SAR(cbind(Hi(x),Lo(x)),accel=accel)[xsubset] - lchob$Env$sar <- sar + lchob$Env$TA$sar <- sar lchob$set_frame(2) lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -1333,6 +1363,7 @@ function(x) { bty='n', y.intersp=0.95))) exp <- c(expression( + macd <- TA$macd, # 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 @@ -1346,6 +1377,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -1355,7 +1388,7 @@ function(x) { } else x macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)[xsubset] - lchob$Env$macd <- macd + lchob$Env$TA$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() @@ -1493,6 +1526,8 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(overlay) { lchob$set_frame(sign(on)*(abs(on)+1L)) @@ -1534,7 +1569,7 @@ function(x) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset xdata <- cbind(Hi(xdata),Lo(xdata)) - lines <- x$Env$lines[xsubset] + lines <- x$Env$TA$lines[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:nrow(lines) - 1) xlim <- x$Env$xlim @@ -1576,7 +1611,9 @@ function(x) { 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 + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + lchob$Env$TA$lines <- x if(overlay) { lchob$set_frame(sign(on)*(abs(on)+1L)) @@ -1669,6 +1706,8 @@ function(x) { bg = bg, cex = cex, on = on, overlay = overlay)))), srcfile=NULL) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset xdata <- xdata[xsubset] @@ -1747,9 +1786,9 @@ function(x) { } 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -1770,6 +1809,7 @@ function(x) { for(li in 1:length(n)) { ma <- EMA(x.tmp,n=n[li],wilder=wilder[1],ratio=ratio[1])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) if(!overlay) { ylim <- c(min(ma*0.975, na.rm=TRUE), max(ma*1.05, na.rm=TRUE)) # add inbox color @@ -1806,24 +1846,34 @@ function(x) { 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 + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } 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])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$Env$TA$ema <- ma.tmp 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])[xsubset] - 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() @@ -1891,9 +1941,9 @@ function(x) { } 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -1942,6 +1992,31 @@ function(x) { 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } + xsubset <- lchob$Env$xsubset + + ma.tmp <- NULL + for(i in 1:length(n)) { + ma <- SMA(x.tmp,n=n[i])[xsubset] + ma.tmp <- cbind(ma.tmp,ma) + } + lchob$Env$TA$sma <- ma.tmp + if(overlay) { lchob$set_frame(sign(on)*(abs(on)+1L)) } else { @@ -2007,9 +2082,9 @@ function(x) { } 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -2055,23 +2130,36 @@ function(x) { 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 + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } 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(li in 1:length(n)) { + ma <- WMA(x.tmp,n=n[li],wts=wts)[xsubset] + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$Env$TA$wma <- ma.tmp 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 @@ -2124,9 +2212,9 @@ function(x) { } 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -2180,6 +2268,30 @@ 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } + xsubset <- lchob$Env$xsubset + + ma.tmp <- NULL + for(li in 1:length(n)) { + ma <- DEMA(x.tmp,n=n[li])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$Env$TA$dema <- ma.tmp if(overlay) { lchob$set_frame(on+1) } else { @@ -2234,14 +2346,14 @@ function(x) { 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) + 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -2250,6 +2362,7 @@ function(x) { # } else x.tmp <- xdata[,with.col] x.tmp <- xdata } + x.tmp <- cbind(x.tmp, vo) if(!has.Vo(x.tmp)) return() @@ -2298,6 +2411,32 @@ 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + vo <- lchob$Env$vo + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } + xsubset <- lchob$Env$xsubset + x.tmp <- cbind(x.tmp, vo) + + ma.tmp <- NULL + for(li in 1:length(n)) { + ma <- EVWMA(x.tmp[, 1],x.tmp[, 2],n=n[li])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$Env$TA$evwma <- ma.tmp if(overlay) { lchob$set_frame(on+1) } else { @@ -2355,9 +2494,9 @@ function(x) { } 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) + which.TA <- which(tolower(names(x$Env$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) if(missing(with.col)) with.col <- 1 @@ -2414,22 +2553,33 @@ function(x) { 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 + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(on==1) { + x <- lchob$Env$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 { + name.TA <- sub("\\(.*", "", sub(".*chart", "", paste(deparse(lchob$get_actions(on+1)[[1]]), collapse = ""))) + which.TA <- which(tolower(names(lchob$Env$TA)) == tolower(name.TA)) + target.TA <- names(lchob$Env$TA)[which.TA] + x.tmp <- get(target.TA, pos = lchob$Env$TA) + } 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 - + for(li in 1:length(n)) { + ma <- ZLEMA(x.tmp,n=n[li],ratio=ratio) + ma.tmp <- cbind(ma.tmp, ma) + } + lchob$Env$TA$zlema <- ma.tmp 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() @@ -2492,6 +2642,8 @@ function(x) { exp <- parse(text = gsub("list", "chartExpiry", as.expression(substitute(list(x = current.chob(), type=type,lty=lty)))), srcfile = NULL) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() lchob$set_frame(-2) lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) diff --git a/R/addTDI.R b/R/addTDI.R index 5f6e2293..f26f5cb4 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -43,6 +43,7 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + tdi <- TA$tdi, # add inbox color rect(xlim[1], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -56,11 +57,13 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") rect(xlim[1], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- Cl(x) tdi <- TDI(price = x, n = n, multiple = multiple)[xsubset] - lchob$Env$tdi <- tdi + lchob$Env$TA$tdi <- tdi if (any(is.na(on))) { lchob$add_frame(ylim=range(tdi, na.rm=TRUE)*1.05, asp=1, fixed=TRUE) lchob$next_frame() diff --git a/R/addVo.R b/R/addVo.R index 6ea6d7e9..aa1c4744 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -55,6 +55,7 @@ bty = "n", y.intersp=0.95))) exp <- c(expression( + vo <- TA$vo, # add inbox color rect(xlim[1], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], col=theme$fill), # add grid lines and left-side axis labels @@ -67,12 +68,15 @@ # add border of plotting area rect(xlim[1], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) - lchob <- current.chob() + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() xdata <- lchob$Env$vo xsubset <- lchob$Env$xsubset x <- lchob$Env$xdata theme <- lchob$Env$theme vo <- xdata[xsubset] + lchob$Env$TA$vo <- vo if(lchob$Env$color.vol) { # calculate colors for bars, if applicable. diff --git a/R/addVolatility.R b/R/addVolatility.R index 75b158bb..11881bc4 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -41,6 +41,7 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") bty = "n", y.intersp=0.95))) exp <- c(expression( + vol <- TA$vol, # add inbox color rect(xlim[1], min(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -54,11 +55,13 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") rect(xlim[1], min(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- OHLC(x) vol <- volatility(OHLC = x, n = n, calc = calc, N = N)[xsubset] - lchob$Env$vol <- vol + lchob$Env$TA$vol <- vol if (any(is.na(on))) { lchob$add_frame(ylim=c(min(vol, na.rm=TRUE) * 0.95, max(vol, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) diff --git a/R/addWPR.R b/R/addWPR.R index 0e9c278c..80cc9c06 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -44,6 +44,7 @@ paste("\n\n\n",sprintf("%.3f",last(wpr)), sep = ""), col = COLOR, pos = 4))) exp <- c(expression( + wpr <- TA$wpr, # add inbox color rect(xlim[1], max(abs(wpr), na.rm = TRUE) * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, col=theme$fill), # add grid lines and left-side axis labels @@ -57,6 +58,8 @@ rect(xlim[1], -0.1 * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, border=theme$labels)), exp) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -71,7 +74,7 @@ wpr <- WPR(xx,n=n)[xsubset] - lchob$Env$wpr <- wpr + lchob$Env$TA$wpr <- wpr lchob$add_frame(ylim=c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05, asp=1, fixed=TRUE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) diff --git a/R/addZigZag.R b/R/addZigZag.R index b108ed09..371e87d0 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -62,12 +62,14 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, exp <- parse(text = gsub("list", "chartZigZag", as.expression(substitute(list(x = current.chob(), change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme, ..., on = on, legend = legend)))), srcfile = NULL) lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- cbind(Hi(x),Lo(x)) zigzag <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme)[xsubset] - lchob$Env$zigzag <- zigzag + lchob$Env$TA$zigzag <- zigzag if (any(is.na(on))) { lchob$add_frame(ylim=c(min(zigzag, na.rm=TRUE)*0.975, From b93bbb55624521cb5705d0230e7d5a5146367901 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 13 Aug 2016 16:30:47 +0800 Subject: [PATCH 06/12] Fix bar color bug when subsetting Pass subsetted bar.color to the histogram. --- R/addVo.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/R/addVo.R b/R/addVo.R index aa1c4744..f1984837 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -26,10 +26,10 @@ log.scale <- ifelse(x$Env$log.scale,"y","") bar.col <- if(color.vol) { - theme$bar.col - } else theme$border.col + theme$bar.col[xsubset] + } else theme$border.col[xsubset] - border.col <- theme$border.col + border.col <- theme$border.col[xsubset] min.vol <- min(vo) if(x$Env$theme$thin) { @@ -105,8 +105,6 @@ border.col <- ifelse(rep(is.null(lchob$Env$theme$border),NROW(xdata[,1])), bar.col,lchob$Env$theme$border) - bar.col <- bar.col[lchob$Env$xsubset] - lchob$Env$theme$border.col <- border.col lchob$Env$theme$bar.col <- bar.col From cb4fff70af8a02e0e24eb8d194103e429a0eefdd Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 14 Aug 2016 14:13:19 +0800 Subject: [PATCH 07/12] Update last price when subsetting Updating the last price displayed on chart when zoomChart is called to view subset series. --- R/addAroon.R | 10 +++++----- R/addCLV.R | 4 ++-- R/addCMF.R | 6 +++--- R/addCMO.R | 4 ++-- R/addChaikin.R | 8 ++++---- R/addEMV.R | 6 +++--- R/addKST.R | 12 +++++------- R/addMFI.R | 4 ++-- R/addOBV.R | 4 ++-- R/addSMI.R | 6 +++--- R/addTA.R | 47 ++++++++++++++++++++++++----------------------- R/addTDI.R | 6 +++--- R/addVo.R | 17 +++++++---------- R/addVolatility.R | 4 ++-- R/addWPR.R | 4 ++-- R/addZigZag.R | 2 +- 16 files changed, 70 insertions(+), 74 deletions(-) diff --git a/R/addAroon.R b/R/addAroon.R index 89aecba4..f4dcbc77 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -37,8 +37,8 @@ function (n = 20, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(Aroon,na.rm=TRUE)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste("aroonUp :",format(last(Aroon[,1]),nsmall = 3L)), - paste("aroonDn :",format(last(Aroon[,2]),nsmall = 3L))), + paste("aroonUp :",format(last(Aroon[xsubset,1]),nsmall = 3L)), + paste("aroonDn :",format(last(Aroon[xsubset,2]),nsmall = 3L))), text.col = c(theme$fg, theme$aroon$col$aroonUp, theme$aroon$col$aroonDn), xjust = lc$xjust, yjust = lc$yjust, @@ -68,7 +68,7 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- lchob$Env$xdata xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset - Aroon <- aroon(HL=xdata,n=n)[xsubset,-3] + Aroon <- aroon(HL=xdata,n=n)[,-3] lchob$Env$TA$Aroon <- Aroon # lenv$xdata <- structure(Aroon, .Dimnames = list(NULL, "aroon")) if(is.na(on)) { @@ -112,7 +112,7 @@ function (n = 20, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(AroonOsc,na.rm=TRUE)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(AroonOsc),nsmall = 3L))), + paste(format(last(AroonOsc[xsubset]),nsmall = 3L))), text.col = c(theme$fg, 4), xjust = lc$xjust, yjust = lc$yjust, @@ -141,7 +141,7 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- lchob$Env$xdata xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset - AroonOsc <- aroon(HL=xdata,n=n)[xsubset,3] + AroonOsc <- aroon(HL=xdata,n=n)[,3] lchob$Env$TA$AroonOsc <- AroonOsc if(is.na(on)) { lchob$add_frame(ylim=c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05),asp=1,fixed=TRUE) diff --git a/R/addCLV.R b/R/addCLV.R index 3740b8ab..d4dbf347 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -33,7 +33,7 @@ function (..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(clv,na.rm=TRUE)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(clv),nsmall = 3L))), + paste(format(last(clv[xsubset]),nsmall = 3L))), text.col = c(theme$fg, 5), xjust = lc$xjust, yjust = lc$yjust, @@ -61,7 +61,7 @@ function (..., on = NA, legend = "auto") } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - clv <- CLV(HLC=HLC(xdata))[xsubset] + clv <- CLV(HLC=HLC(xdata)) lchob$Env$TA$clv <- clv if(is.na(on)) { lchob$add_frame(ylim=range(clv,na.rm=TRUE),asp=1,fixed=TRUE) diff --git a/R/addCMF.R b/R/addCMF.R index 501a58c4..dcb8ce26 100644 --- a/R/addCMF.R +++ b/R/addCMF.R @@ -31,8 +31,8 @@ lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(sprintf("%.3f",last(cmf)), sep = "")), - text.col = c(theme$fg, ifelse(last(cmf) > 0,theme$up.col,theme$dn.col)), + paste(sprintf("%.3f",last(cmf[xsubset])), sep = "")), + text.col = c(theme$fg, ifelse(last(cmf[xsubset]) > 0,theme$up.col,theme$dn.col)), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -62,7 +62,7 @@ xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo - cmf <- CMF(xdata,vo,n=n)[xsubset] + cmf <- CMF(xdata,vo,n=n) lchob$Env$TA$cmf <- cmf if(!is.character(legend) || legend == "auto") lchob$Env$legend <- paste("Chaikin Money Flow (", n, ")", sep="") diff --git a/R/addCMO.R b/R/addCMO.R index ba37ffe8..5124c769 100644 --- a/R/addCMO.R +++ b/R/addCMO.R @@ -33,7 +33,7 @@ lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(sprintf("%.3f",last(cmo)), sep = "")), + paste(sprintf("%.3f",last(cmo[xsubset])), sep = "")), text.col = c(theme$fg, "#0033CC"), xjust = lc$xjust, yjust = lc$yjust, @@ -71,7 +71,7 @@ x[,1] } - cmo <- CMO(xx,n=n)[xsubset] + cmo <- CMO(xx,n=n) lchob$Env$TA$cmo <- cmo if(!is.character(legend) || legend == "auto") lchob$Env$legend <- paste("Chande Momentum Oscillator (", n, ") ", sep="") diff --git a/R/addChaikin.R b/R/addChaikin.R index 86ebc846..d4d4dba7 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -36,7 +36,7 @@ function (..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(ChaikinAD,na.rm=TRUE)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(ChaikinAD),nsmall = 3L))), + paste(format(last(ChaikinAD[xsubset]),nsmall = 3L))), text.col = c(theme$fg, theme$chaikin$col$chaikinad), xjust = lc$xjust, yjust = lc$yjust, @@ -65,7 +65,7 @@ function (..., on = NA, legend = "auto") xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo - ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo)[xsubset] + ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo) lchob$Env$TA$ChaikinAD <- ChaikinAD if(is.na(on)) { lchob$add_frame(ylim=range(ChaikinAD,na.rm=TRUE),asp=1,fixed=TRUE) @@ -108,7 +108,7 @@ function (n = 10, maType, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(ChaikinVol,na.rm=TRUE)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(ChaikinVol),nsmall = 3L))), + paste(format(last(ChaikinVol[xsubset]),nsmall = 3L))), text.col = c(theme$fg, theme$chaikin$col$chaikinvol), xjust = lc$xjust, yjust = lc$yjust, @@ -135,7 +135,7 @@ function (n = 10, maType, ..., on = NA, legend = "auto") } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType)[xsubset] + ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType) lchob$Env$TA$ChaikinVol <- ChaikinVol if(is.na(on)) { lchob$add_frame(ylim=range(ChaikinVol,na.rm=TRUE),asp=1,fixed=TRUE) diff --git a/R/addEMV.R b/R/addEMV.R index fdcb70a3..1143517a 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -44,8 +44,8 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, lc <- xts:::legend.coords("topleft", xlim, range(emv,na.rm=TRUE)*1.05), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste("emv :", sprintf("%.3f",last(emv$emv))), - paste("maEMV :", sprintf("%.3f",last(emv$maEMV)))), + paste("emv :", sprintf("%.3f",last(emv$emv[xsubset]))), + paste("maEMV :", sprintf("%.3f",last(emv$maEMV[xsubset])))), text.col = c(theme$fg, 6, 7), xjust = lc$xjust, yjust = lc$yjust, @@ -68,7 +68,7 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset emv <- EMV(HL = HLC(xdata)[,-3], volume = volume, n = n, maType = maType, - vol.divisor = vol.divisor)[xsubset] + vol.divisor = vol.divisor) lchob$Env$TA$emv <- emv lchob$Env$TA$volume <- volume if(is.na(on)) { diff --git a/R/addKST.R b/R/addKST.R index 70dbe500..777e4639 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -13,10 +13,9 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, lenv$chartKST <- function(x, n, nROC, nSig, maType, wts, ..., on, legend) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- xdata[xsubset] - xdata <- coredata(Cl(xdata)) + xdata <- Cl(xdata) kst <- KST(price = xdata, n = n, nROC = nROC, nSig = nSig, maType = maType, - wts = wts) + wts = wts)[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(kst) - 1) xlim <- x$Env$xlim @@ -42,8 +41,8 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, lc <- xts:::legend.coords("topleft", xlim, range(kst, na.rm=TRUE) * 1.05), legend(x = lc$x, y = lc$y, legend = c(legend, - paste("kst :",format(last(kst[,1]),nsmall = 3L)), - paste("signal :",format(last(kst[,2]),nsmall = 3L))), + paste("kst :",format(last(kst[xsubset,1]),nsmall = 3L)), + paste("signal :",format(last(kst[xsubset,2]),nsmall = 3L))), text.col = c(theme$fg, 6, 7), xjust = lc$xjust, yjust = lc$yjust, @@ -68,8 +67,7 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - x <- x[xsubset] - x <- coredata(Cl(x)) + x <- Cl(x) kst <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, wts = wts) lchob$Env$TA$kst <- kst diff --git a/R/addMFI.R b/R/addMFI.R index 1e7c420d..48dede21 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -34,7 +34,7 @@ function (n = 14, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, c(0,100)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(mfi),nsmall = 3L))), + paste(format(last(mfi[xsubset]),nsmall = 3L))), text.col = c(theme$fg, 8), xjust = lc$xjust, yjust = lc$yjust, @@ -61,7 +61,7 @@ function (n = 14, ..., on = NA, legend = "auto") xsubset <- lchob$Env$xsubset volume <- lchob$Env$vo x <- HLC(x) - mfi <- MFI(HLC = x, volume = volume, n = n)[xsubset] + mfi <- MFI(HLC = x, volume = volume, n = n) lchob$Env$TA$mfi <- mfi if(any(is.na(on))) { lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) diff --git a/R/addOBV.R b/R/addOBV.R index 7d851e1c..0a489bad 100644 --- a/R/addOBV.R +++ b/R/addOBV.R @@ -35,7 +35,7 @@ function (..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(obv, na.rm=TRUE) * 1.05), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(obv),nsmall = 3L))), + paste(format(last(obv[xsubset]),nsmall = 3L))), text.col = c(theme$fg, 4), xjust = lc$xjust, yjust = lc$yjust, @@ -61,7 +61,7 @@ function (..., on = NA, legend = "auto") x <- try.xts(lchob$Env$xdata, error=FALSE) xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo - obv <- OBV(price = Cl(x), volume = vo)[xsubset] + obv <- OBV(price = Cl(x), volume = vo) lchob$Env$TA$obv <- obv if(is.na(on)) { lchob$add_frame(ylim=range(obv, na.rm=TRUE) * 1.05 ,asp=1,fixed=TRUE) diff --git a/R/addSMI.R b/R/addSMI.R index 448845db..cde11455 100644 --- a/R/addSMI.R +++ b/R/addSMI.R @@ -49,12 +49,12 @@ pos = 4), text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, - paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[,1])), sep = ""), col = COLOR, + paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[xsubset,1])), sep = ""), col = COLOR, pos = 4), text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, paste("\n\n\n\n\nSignal: ", - sprintf("%.3f",last(smi[,2])), sep = ""), col = SIGNAL, + sprintf("%.3f",last(smi[xsubset,2])), sep = ""), col = SIGNAL, pos = 4))) exp <- c(expression( smi <- TA$smi, @@ -86,7 +86,7 @@ } smi <- SMI(xx, n=n, nFast=fast, - nSlow=slow, nSig=signal, maType=ma.type)[xsubset] + nSlow=slow, nSig=signal, maType=ma.type) lchob$Env$TA$smi <- smi lchob$add_frame(ylim=c(-max(abs(smi[,1]), na.rm = TRUE), diff --git a/R/addTA.R b/R/addTA.R index e4da8501..dc916ce1 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -52,7 +52,7 @@ 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=''), + paste("\n\n\n",sprintf("%.2f",last(mom[xsubset])),sep=''), col = COLOR, pos = 4))) exp <- c(expression( mom <- TA$mom, @@ -82,7 +82,7 @@ xx <- do.call(with.col,list(x)) } else xx <- x[,with.col] - mom <- momentum(xx,n=n)[xsubset] + mom <- momentum(xx,n=n) lchob$Env$TA$mom <- mom lchob$add_frame(ylim=c(-max(abs(mom),na.rm=TRUE), @@ -175,7 +175,7 @@ function(x) { 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', + paste("\n\n\n",sprintf("%.2f",last(cci[xsubset])),sep=''), col = 'red', pos = 4))) exp <- c(expression( cci <- TA$cci, @@ -204,7 +204,7 @@ function(x) { cbind(Hi(x),Lo(x),Cl(x)) } else x - cci <- CCI(xx,n=n,maType=maType,c=c)[xsubset] + cci <- CCI(xx,n=n,maType=maType,c=c) lchob$Env$TA$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) @@ -321,7 +321,7 @@ function(x) { 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)[xsubset] + adx <- ADX(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,wilder=wilder) lchob$Env$TA$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) @@ -410,7 +410,7 @@ function(x) { if(!is.OHLC(x)) stop("only applicable to HLC series") - atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...)[xsubset] + atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...) lchob$Env$TA$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) @@ -503,7 +503,7 @@ function(x) { Cl(x) } else x - trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)[xsubset] + trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent) lchob$Env$TA$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) @@ -584,8 +584,8 @@ function(x) { 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), + paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo[xsubset]))), sep = ""), + col = ifelse(last(na.omit(dpo[xsubset])) > 0,theme$up.col,theme$dn.col), pos = 4))) exp <- c(expression( @@ -616,7 +616,7 @@ function(x) { Cl(x) } else x - dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)[xsubset] + dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent) lchob$Env$TA$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) @@ -721,7 +721,7 @@ function(x) { pos = 4), text(0, max(rsi,na.rm=TRUE)*.9, - paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC', + paste("\n\n\n",sprintf("%.3f",last(rsi[xsubset])), sep = ""), col = '#0033CC', pos = 4))) exp <- c(expression( rsi <- TA$rsi, @@ -748,7 +748,7 @@ function(x) { Cl(x) } else x - rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)[xsubset] + rsi <- RSI(xx,n=n,maType=maType,wilder=wilder) lchob$Env$TA$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() @@ -848,7 +848,7 @@ function(x) { Cl(x) } else x - roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE)[xsubset] + roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE) lchob$Env$TA$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) @@ -1355,8 +1355,8 @@ function(x) { 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])))), + paste("MACD:",sprintf("%.3f",last(macd[xsubset,1]))), + paste("Signal:",sprintf("%.3f",last(macd[xsubset,2])))), text.col=c(theme$fg, col[3], col[4]), xjust=lc$xjust, yjust=lc$yjust, @@ -1387,7 +1387,7 @@ function(x) { Cl(x) } else x - macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)[xsubset] + macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type) lchob$Env$TA$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) @@ -1571,7 +1571,6 @@ function(x) { xdata <- cbind(Hi(xdata),Lo(xdata)) lines <- x$Env$TA$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 @@ -1593,6 +1592,7 @@ function(x) { } if(!is.null(lines)) { # draw lines given positions specified in x + x.pos <- 1 + spacing * (1:nrow(lines) - 1) lines(x.pos, lines[,1],col=col) } if(!is.null(h)) { @@ -1652,7 +1652,7 @@ function(x) { } # }}} # addPoints {{{ -`addPoints` <- function(x,y=NULL,type='p',pch=20, +`addPoints` <- function(x,y = NULL,type='p',pch=20, offset=1,col=2,bg=2,cex=1, on=1,overlay=TRUE) { @@ -1710,17 +1710,18 @@ function(x) { lchob$Env$call_list[[ncalls + 1]] <- match.call() xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - xdata <- xdata[xsubset] - if(missing(bg)) bg <- col - - xsubset <- x %in% xsubset + + if(is.xts(x)) { + lchob$Env$x.points <- match(.index(x), .index(xdata)) + lchob$Env$y.points <- x + } else { if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') - lchob$Env$x.points <- x lchob$Env$y.points <- y + } if(overlay) diff --git a/R/addTDI.R b/R/addTDI.R index f26f5cb4..f3787c65 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -35,8 +35,8 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, range(tdi, na.rm=TRUE)*1.05), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste("tdi :",format(last(tdi[,1]),nsmall = 3L)), - paste("di :",format(last(tdi[,1]),nsmall = 3L))), + paste("tdi :",format(last(tdi[xsubset,1]),nsmall = 3L)), + paste("di :",format(last(tdi[xsubset,1]),nsmall = 3L))), text.col = c(theme$fg, 5, 6), xjust = lc$xjust, yjust = lc$yjust, @@ -62,7 +62,7 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- Cl(x) - tdi <- TDI(price = x, n = n, multiple = multiple)[xsubset] + tdi <- TDI(price = x, n = n, multiple = multiple) lchob$Env$TA$tdi <- tdi if (any(is.na(on))) { lchob$add_frame(ylim=range(tdi, na.rm=TRUE)*1.05, asp=1, fixed=TRUE) diff --git a/R/addVo.R b/R/addVo.R index f1984837..083d5974 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -6,7 +6,7 @@ lenv$chartVo <- function(x, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - vo <- x$Env$vo[xsubset] + vo <- x$Env$TA$vo[xsubset] spacing <- x$Env$theme$spacing width <- x$Env$theme$width @@ -16,9 +16,6 @@ ylim <- c(min(vo, na.rm=TRUE), max(vo, na.rm=TRUE) * 1.05) theme <- x$Env$theme - vol.scale <- x$Env$vol.scale - TA.values <- x$Env$TA.values - thin <- theme$thin # multi.col <- x$Env$multi.col @@ -48,7 +45,7 @@ exp <- c(exp, expression( lc <- xts:::legend.coords("topleft", xlim, range(vo,na.rm=TRUE)), legend(x = lc$x, y = lc$y, - legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(TA.values)*vol.scale[[1]],big.mark=',')), + legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo[xsubset])*vol.scale[[1]],big.mark=',')), text.col = c(theme$fg, last(theme$bar.col)), xjust = lc$xjust, yjust = lc$yjust, @@ -62,7 +59,7 @@ segments(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), xlim[2], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), y_grid_lines(range(TA.values, na.rm=TRUE)), + text(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), y_grid_lines(range(vo, 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 @@ -75,8 +72,7 @@ xsubset <- lchob$Env$xsubset x <- lchob$Env$xdata theme <- lchob$Env$theme - vo <- xdata[xsubset] - lchob$Env$TA$vo <- vo + vo <- xdata if(lchob$Env$color.vol) { # calculate colors for bars, if applicable. @@ -121,9 +117,10 @@ if (max.vol > 1e+07) vol.scale <- list(1e+06, "millions") lchob$Env$vol.scale <- vol.scale - lchob$Env$TA.values <- vo/vol.scale[[1]] + lchob$Env$TA$vo <- vo/vol.scale[[1]] - lchob$add_frame(ylim=c(min(vo, na.rm=TRUE), max(vo, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) # need to have a value set for ylim + lchob$add_frame(ylim=c(min(lchob$Env$TA$vo, na.rm=TRUE), + max(lchob$Env$TA$vo, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) # need to have a value set for ylim lchob$next_frame() lchob$replot(exp,env=c(lenv, lchob$Env),expr=TRUE) lchob diff --git a/R/addVolatility.R b/R/addVolatility.R index 11881bc4..53d0de1b 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -34,7 +34,7 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") lc <- xts:::legend.coords("topleft", xlim, c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - format(last(vol),nsmall = 3L)), + sprintf("%.3f",last(vol[xsubset]))), text.col = c(theme$fg, 8), xjust = lc$xjust, yjust = lc$yjust, @@ -60,7 +60,7 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- OHLC(x) - vol <- volatility(OHLC = x, n = n, calc = calc, N = N)[xsubset] + vol <- volatility(OHLC = x, n = n, calc = calc, N = N) lchob$Env$TA$vol <- vol if (any(is.na(on))) { lchob$add_frame(ylim=c(min(vol, na.rm=TRUE) * 0.95, diff --git a/R/addWPR.R b/R/addWPR.R index 80cc9c06..60416ece 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -41,7 +41,7 @@ pos = 4), text(0, max(abs(wpr), na.rm = TRUE)*.9, - paste("\n\n\n",sprintf("%.3f",last(wpr)), sep = ""), col = COLOR, + paste("\n\n\n",sprintf("%.3f",last(wpr[xsubset])), sep = ""), col = COLOR, pos = 4))) exp <- c(expression( wpr <- TA$wpr, @@ -73,7 +73,7 @@ } - wpr <- WPR(xx,n=n)[xsubset] + wpr <- WPR(xx,n=n) lchob$Env$TA$wpr <- wpr lchob$add_frame(ylim=c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05, asp=1, fixed=TRUE) lchob$next_frame() diff --git a/R/addZigZag.R b/R/addZigZag.R index 371e87d0..eb7503ae 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -68,7 +68,7 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, xsubset <- lchob$Env$xsubset x <- cbind(Hi(x),Lo(x)) zigzag <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, - lastExtreme = lastExtreme)[xsubset] + lastExtreme = lastExtreme) lchob$Env$TA$zigzag <- zigzag if (any(is.na(on))) { From e284e3c580a41b865fde99b879f7c6c9df0e6c34 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sun, 14 Aug 2016 17:58:23 +0800 Subject: [PATCH 08/12] Allow custom settings to TA's color Pass color settings to addTA functions except for addSAR, addMACD, addShading, addLines, addPoints and add*MA functions that have their own 'col' argument. Users can call chartTheme(addTA = list(...)) colors and pass chart.theme object to chartSeries to manage desired chart colors. --- R/addAroon.R | 23 ++++++++------ R/addCLV.R | 8 ++--- R/addCMO.R | 7 ++-- R/addChaikin.R | 16 +++++----- R/addEMV.R | 10 ++++-- R/addKST.R | 10 ++++-- R/addMFI.R | 7 ++-- R/addOBV.R | 7 ++-- R/addSMI.R | 21 ++++++------ R/addTA.R | 81 +++++++++++++++++++++++++++++++++-------------- R/addTDI.R | 10 ++++-- R/addVolatility.R | 7 ++-- R/addWPR.R | 9 +++--- R/addZigZag.R | 8 +++-- 14 files changed, 143 insertions(+), 81 deletions(-) diff --git a/R/addAroon.R b/R/addAroon.R index f4dcbc77..4e8c83aa 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -20,9 +20,9 @@ function (n = 20, ..., on = NA, legend = "auto") ylim <- c(0,100) theme <- x$Env$theme - lines(x.pos, Aroon[,1], col = theme$aroon$col$aroonUp, + lines(x.pos, Aroon[,1], col = theme$Aroon$col$aroonUp, lwd = 1, lend = 2, ...) - lines(x.pos, Aroon[,2], col = theme$aroon$col$aroonDn, + lines(x.pos, Aroon[,2], col = theme$Aroon$col$aroonDn, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -39,7 +39,7 @@ function (n = 20, ..., on = NA, legend = "auto") legend = c(paste(legend, ":"), paste("aroonUp :",format(last(Aroon[xsubset,1]),nsmall = 3L)), paste("aroonDn :",format(last(Aroon[xsubset,2]),nsmall = 3L))), - text.col = c(theme$fg, theme$aroon$col$aroonUp, theme$aroon$col$aroonDn), + text.col = c(theme$fg, theme$Aroon$col$aroonUp, theme$Aroon$col$aroonDn), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -61,9 +61,10 @@ function (n = 20, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$aroon$col$arronUp)) { - lchob$Env$theme$aroon$col$aroonUp <- 3 - lchob$Env$theme$aroon$col$aroonDn <- 4 + if (is.null(lchob$Env$theme$Aroon)) { + lchob$Env$theme$Aroon$col$aroonUp <- 3 + lchob$Env$theme$Aroon$col$aroonDn <- 4 + lchob$Env$theme$Aroon$col$aroonOsc <- 3 } xdata <- lchob$Env$xdata xdata <- cbind(Hi(xdata),Lo(xdata)) @@ -97,7 +98,7 @@ function (n = 20, ..., on = NA, legend = "auto") ylim <- range(AroonOsc,na.rm=TRUE) theme <- x$Env$theme - lines(x.pos, AroonOsc, col = theme$aroon$col$aroonOsc, + lines(x.pos, AroonOsc, col = theme$Aroon$col$aroonOsc, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -113,7 +114,7 @@ function (n = 20, ..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(AroonOsc[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, 4), + text.col = c(theme$fg, theme$Aroon$col$aroonOsc), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -135,8 +136,10 @@ function (n = 20, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$aroon$col$aroonOsc)) { - lchob$Env$theme$aroon$col$aroonOsc <- 3 + if (is.null(lchob$Env$theme$Aroon)) { + lchob$Env$theme$Aroon$col$aroonUp <- 3 + lchob$Env$theme$Aroon$col$aroonDn <- 4 + lchob$Env$theme$Aroon$col$aroonOsc <- 3 } xdata <- lchob$Env$xdata xdata <- cbind(Hi(xdata),Lo(xdata)) diff --git a/R/addCLV.R b/R/addCLV.R index d4dbf347..0129c983 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -18,7 +18,7 @@ function (..., on = NA, legend = "auto") ylim <- range(clv,na.rm=TRUE) theme <- x$Env$theme - lines(x.pos, clv, type = "h", col = theme$clv$col, + lines(x.pos, clv, type = "h", col = theme$CLV$col, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -34,7 +34,7 @@ function (..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(clv[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, 5), + text.col = c(theme$fg, theme$CLV$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -56,8 +56,8 @@ function (..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$clv$col)) { - lchob$Env$theme$clv$col <- 5 + if (is.null(lchob$Env$theme$CLV)) { + lchob$Env$theme$CLV$col <- 5 } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addCMO.R b/R/addCMO.R index 5124c769..643aafab 100644 --- a/R/addCMO.R +++ b/R/addCMO.R @@ -22,7 +22,7 @@ max(abs(cmo), na.rm = TRUE))*1.05 theme <- x$Env$theme - lines(x.pos, cmo, col = "#0033CC", lwd = 1, lend = 2) + lines(x.pos, cmo, col = theme$CMO$col, lwd = 1, lend = 2) } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -34,7 +34,7 @@ legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(sprintf("%.3f",last(cmo[xsubset])), sep = "")), - text.col = c(theme$fg, "#0033CC"), + text.col = c(theme$fg, theme$CMO$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -57,6 +57,9 @@ lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$CMO)) { + lchob$Env$theme$CMO$col <- "#0033CC" + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addChaikin.R b/R/addChaikin.R index d4d4dba7..c94f87a9 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -21,7 +21,7 @@ function (..., on = NA, legend = "auto") ylim <- range(ChaikinAD,na.rm=TRUE) theme <- x$Env$theme - lines(x.pos, ChaikinAD, col = theme$chaikin$col$chaikinad, + lines(x.pos, ChaikinAD, col = theme$ChAD$col$chaikinAD, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -37,7 +37,7 @@ function (..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(ChaikinAD[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, theme$chaikin$col$chaikinad), + text.col = c(theme$fg, theme$ChAD$col$chaikinAD), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -59,8 +59,8 @@ function (..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$chaikin$col$chaikinad)) { - lchob$Env$theme$chaikin$col$chaikinad <- 3 + if (is.null(lchob$Env$theme$ChAD)) { + lchob$Env$theme$ChAD$col$chaikinAD <- 3 } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -92,7 +92,7 @@ function (n = 10, maType, ..., on = NA, legend = "auto") ylim <- range(ChaikinVol,na.rm=TRUE) theme <- x$Env$theme - lines(x.pos, ChaikinVol, col = theme$chaikin$col$chaikinvol, + lines(x.pos, ChaikinVol, col = theme$ChVol$col$chaikinVol, lwd = 1, lend = 2, ...) } if(missing(maType)) maType <- "SMA" @@ -109,7 +109,7 @@ function (n = 10, maType, ..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(ChaikinVol[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, theme$chaikin$col$chaikinvol), + text.col = c(theme$fg, theme$ChVol$col$chaikinVol), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -130,8 +130,8 @@ function (n = 10, maType, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$chaikin$col$chaikinvol)) { - lchob$Env$theme$chaikin$col$chaikinvol <- "#F5F5F5" + if (is.null(lchob$Env$theme$ChVol)) { + lchob$Env$theme$ChVol$col$chaikinVol <- "#F5F5F5" } xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addEMV.R b/R/addEMV.R index 1143517a..c0b3e111 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -21,12 +21,16 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, ylim <- range(emv,na.rm=TRUE)*1.05 theme <- x$Env$theme - lines(x.pos, emv$emv, col = 6, lwd = 1, lend = 2, ...) - lines(x.pos, emv$maEMV, col = 7, lwd = 1, lend = 2, ...) + lines(x.pos, emv$emv, col = theme$EMV$col$emv, lwd = 1, lend = 2, ...) + lines(x.pos, emv$maEMV, col = theme$EMV$col$maEMV, lwd = 1, lend = 2, ...) } lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$EMV)) { + lchob$Env$theme$EMV$col$emv <- 6 + lchob$Env$theme$EMV$col$maEMV <- 7 + } if(missing(volume)) volume <- lchob$Env$vo if(missing(maType)) maType <- "SMA" if(!is.character(legend) || legend == "auto") @@ -46,7 +50,7 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, legend = c(paste(legend, ":"), paste("emv :", sprintf("%.3f",last(emv$emv[xsubset]))), paste("maEMV :", sprintf("%.3f",last(emv$maEMV[xsubset])))), - text.col = c(theme$fg, 6, 7), + text.col = c(theme$fg, theme$EMV$col$emv, theme$EMV$col$maEMV), xjust = lc$xjust, yjust = lc$yjust, bty = "n", diff --git a/R/addKST.R b/R/addKST.R index 777e4639..c47421a9 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -22,8 +22,8 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, ylim <- range(kst, na.rm=TRUE) * 1.05 theme <- x$Env$theme - lines(x.pos, kst[,1], col = 6, lwd = 1, lend = 2, ...) - lines(x.pos, kst[,2], col = 7, lwd = 1, lend = 2, ...) + lines(x.pos, kst[,1], col = theme$KST$col$kst, lwd = 1, lend = 2, ...) + lines(x.pos, kst[,2], col = theme$KST$col$signal, lwd = 1, lend = 2, ...) } if(missing(maType)) maType <- "SMA" if(!is.character(legend) || legend == "auto") @@ -43,7 +43,7 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, legend = c(legend, paste("kst :",format(last(kst[xsubset,1]),nsmall = 3L)), paste("signal :",format(last(kst[xsubset,2]),nsmall = 3L))), - text.col = c(theme$fg, 6, 7), + text.col = c(theme$fg, theme$KST$col$kst, theme$KST$col$signal), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -65,6 +65,10 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$KST)) { + lchob$Env$theme$KST$col$kst <- 6 + lchob$Env$theme$KST$col$signal <- 7 + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- Cl(x) diff --git a/R/addMFI.R b/R/addMFI.R index 48dede21..e49544c6 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -20,7 +20,7 @@ function (n = 14, ..., on = NA, legend = "auto") ylim <- c(0,100) theme <- x$Env$theme - lines(x.pos, mfi, col = 8, lwd = 1, lend = 2, ...) + lines(x.pos, mfi, col = theme$MFI$col, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") legend <- gsub("^addMFI", "Money Flow Index ", deparse(match.call())) @@ -35,7 +35,7 @@ function (n = 14, ..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(mfi[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, 8), + text.col = c(theme$fg, theme$MFI$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -57,6 +57,9 @@ function (n = 14, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$MFI)) { + lchob$Env$theme$MFI$col <- 8 + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset volume <- lchob$Env$vo diff --git a/R/addOBV.R b/R/addOBV.R index 0a489bad..0d7d8533 100644 --- a/R/addOBV.R +++ b/R/addOBV.R @@ -19,7 +19,7 @@ function (..., on = NA, legend = "auto") ylim <- range(obv, na.rm=TRUE) * 1.05 theme <- x$Env$theme - lines(x.pos, obv, col = 4, lwd = 1, lend = 2, ...) + lines(x.pos, obv, col = theme$OBV$col, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -36,7 +36,7 @@ function (..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(obv[xsubset]),nsmall = 3L))), - text.col = c(theme$fg, 4), + text.col = c(theme$fg, theme$OBV$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -58,6 +58,9 @@ function (..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$OBV)) { + lchob$Env$theme$OBV$col <- 4 + } x <- try.xts(lchob$Env$xdata, error=FALSE) xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo diff --git a/R/addSMI.R b/R/addSMI.R index cde11455..da7ad1c3 100644 --- a/R/addSMI.R +++ b/R/addSMI.R @@ -26,11 +26,8 @@ max(abs(smi[,1]), na.rm = TRUE))*1.05 theme <- x$Env$theme - COLOR <- "#0033CC" - SIGNAL <- "#BFCFFF" - - lines(x.pos,smi[,1],col=COLOR,lwd=1,type='l') - lines(x.pos,smi[,2],col=SIGNAL,lwd=1,lty='dotted',type='l') + lines(x.pos,smi[,1],col=theme$SMI$col$smi,lwd=1,type='l') + lines(x.pos,smi[,2],col=theme$SMI$col$signal,lwd=1,lty='dotted',type='l') } mapply(function(name, value) { @@ -40,8 +37,6 @@ exp <- parse(text = gsub("list", "chartSMI", as.expression(substitute(list(x = current.chob(), n = n,fast = fast,slow = slow,signal = signal,ma.type = ma.type)))), srcfile = NULL) exp <- c(exp, expression( - COLOR <- "#0033CC", - SIGNAL <- "#BFCFFF", text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, paste("Stochastic Momentum Index (", paste(n,fast,slow,signal,sep=','), @@ -49,13 +44,13 @@ pos = 4), text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, - paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[xsubset,1])), sep = ""), col = COLOR, - pos = 4), + paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[xsubset,1])), sep = ""), + col = theme$SMI$col$smi, pos = 4), text(0, max(abs(smi[,1]), na.rm = TRUE)*.9, paste("\n\n\n\n\nSignal: ", - sprintf("%.3f",last(smi[xsubset,2])), sep = ""), col = SIGNAL, - pos = 4))) + sprintf("%.3f",last(smi[xsubset,2])), sep = ""), + col = theme$SMI$col$signal, pos = 4))) exp <- c(expression( smi <- TA$smi, # add inbox color @@ -73,6 +68,10 @@ lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$SMI)) { + lchob$Env$theme$SMI$col$smi <- "#0033CC" + lchob$Env$theme$SMI$col$signal <- "#BFCFFF" + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addTA.R b/R/addTA.R index dc916ce1..6c2b7d1b 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -35,10 +35,8 @@ ylim <- c(-max(abs(mom),na.rm=TRUE), max(abs(mom),na.rm=TRUE)) * 1.05 theme <- x$Env$theme - - COLOR <- "#0033CC" - lines(x.pos,mom,col=COLOR,lwd=2,type='l') + lines(x.pos,mom,col=theme$Momentum$col,lwd=2,type='l') } mapply(function(name, value) { @@ -47,13 +45,12 @@ 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[xsubset])),sep=''), - col = COLOR, pos = 4))) + col = theme$Momentum$col, pos = 4))) exp <- c(expression( mom <- TA$mom, # add inbox color @@ -72,6 +69,9 @@ lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$Momentum)) { + lchob$Env$theme$Momentum$col <- "#0033CC" + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -154,11 +154,11 @@ function(x) { 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) + polygon(c(x.pos,rev(x.pos)),cbind(cci.above,rep(100,length(cci))),col=theme$CCI$col,border=theme$fg) + polygon(c(x.pos,rev(x.pos)),cbind(cci.below,rep(-100,length(cci))),col=theme$CCI$col,border=theme$fg) # draw CCI - lines(x.pos,cci,col='red',lwd=1,type='l') + lines(x.pos,cci,col=theme$CCI$col,lwd=1,type='l') } mapply(function(name, value) { @@ -175,7 +175,7 @@ function(x) { 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[xsubset])),sep=''), col = 'red', + paste("\n\n\n",sprintf("%.2f",last(cci[xsubset])),sep=''), col = theme$CCI$col, pos = 4))) exp <- c(expression( cci <- TA$cci, @@ -196,6 +196,9 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$CCI)) { + lchob$Env$theme$CCI$col <- 'red' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -283,11 +286,11 @@ function(x) { theme <- x$Env$theme # draw DIp - lines(x.pos,adx[,1],col='green',lwd=1,type='l') + lines(x.pos,adx[,1],col=theme$ADX$col$DIp,lwd=1,type='l') # draw DIn - lines(x.pos,adx[,2],col='red',lwd=1,type='l') + lines(x.pos,adx[,2],col=theme$ADX$col$DIn,lwd=1,type='l') # draw ADX - lines(x.pos,adx[,4],col='blue',lwd=2,type='l') + lines(x.pos,adx[,4],col=theme$ADX$col$adx,lwd=2,type='l') } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -315,6 +318,11 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ADX)) { + lchob$Env$theme$ADX$col$DIp <- 'green' + lchob$Env$theme$ADX$col$DIn <- 'red' + lchob$Env$theme$ADX$col$adx <- 'blue' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -379,7 +387,7 @@ function(x) { max(atr[,2]*1.05, na.rm = TRUE)) theme <- x$Env$theme - lines(x.pos,atr[,2],col='blue',lwd=2,type='l') + lines(x.pos,atr[,2],col=theme$ATR$col,lwd=2,type='l') } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -404,6 +412,9 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ATR)) { + lchob$Env$theme$ATR$col <- 'blue' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -468,9 +479,9 @@ function(x) { theme <- x$Env$theme # draw TRIX - lines(x.pos,trix[,1],col='green',lwd=1,type='l') + lines(x.pos,trix[,1],col=theme$TRIX$col$trix,lwd=1,type='l') # draw Signal - lines(x.pos,trix[,2],col='#999999',lwd=1,type='l') + lines(x.pos,trix[,2],col=theme$TRIX$col$signal,lwd=1,type='l') } mapply(function(name, value) { assign(name, value, envir = lenv) @@ -495,6 +506,10 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$TRIX)) { + lchob$Env$theme$TRIX$col$trix <- 'green' + lchob$Env$theme$TRIX$col$signal <- '#999999' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -705,8 +720,8 @@ function(x) { ylim <- c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05) theme <- x$Env$theme - lines(x.pos,rsi,col='#0033CC',lwd=2,type='l') - lines(x.pos,rsi,col='#BFCFFF',lwd=1,lty='dotted',type='l') + lines(x.pos,rsi,col=theme$RSI$col$rsi,lwd=2,type='l') + lines(x.pos,rsi,col=theme$RSI$col$dot,lwd=1,lty='dotted',type='l') } mapply(function(name, value) { @@ -721,7 +736,7 @@ function(x) { pos = 4), text(0, max(rsi,na.rm=TRUE)*.9, - paste("\n\n\n",sprintf("%.3f",last(rsi[xsubset])), sep = ""), col = '#0033CC', + paste("\n\n\n",sprintf("%.3f",last(rsi[xsubset])), sep = ""), col = theme$RSI$col$rsi, pos = 4))) exp <- c(expression( rsi <- TA$rsi, @@ -740,6 +755,10 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$RSI)) { + lchob$Env$theme$RSI$col$rsi <- '#0033CC' + lchob$Env$theme$RSI$col$dot <- '#BFCFFF' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -839,7 +858,6 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) - lchob$Env$call_list[[ncalls + 1]] <- match.call() x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -1015,6 +1033,15 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$bbands)) { + lchob$Env$theme$bbands$col$fill <- '#282828' + lchob$Env$theme$bbands$col$upper <- 'red' + lchob$Env$theme$bbands$col$lower <- 'red' + lchob$Env$theme$bbands$col$ma <- '#D5D5D5' + lchob$Env$theme$bbands$lty$upper <- 'dashed' + lchob$Env$theme$bbands$lty$lower <- 'dashed' + lchob$Env$theme$bbands$lty$ma <- 'dotted' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset @@ -1176,14 +1203,15 @@ function(x) { 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[,1],col=theme$Envelope$col$ma,lwd=1,lty=theme$Envelope$lty$ma) + lines(x.pos,mae[,3],col=theme$Envelope$col$ma,lwd=1,lty=theme$Envelope$lty$ma) #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') + polygon(c(xx,rev(xx)), c(as.numeric(mae[,1]),rev(as.numeric(mae[,3]))), + col=theme$Envelope$col$fill,border=NA) + lines(x.pos,mae[,1],col=theme$Envelope$col$ma,lwd=1,lty=theme$Envelope$lty$ma) + lines(x.pos,mae[,3],col=theme$Envelope$col$ma,lwd=1,lty=theme$Envelope$lty$ma) #lines(x.pos,mae[,2],col='grey',lwd=1,lty='dotted') } @@ -1209,6 +1237,11 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$Envelope)) { + lchob$Env$theme$Envelope$col$ma <- 'blue' + lchob$Env$theme$Envelope$col$fill <- '#282828' + lchob$Env$theme$Envelope$lty$ma <- 'dotted' + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addTDI.R b/R/addTDI.R index f3787c65..1130db95 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -19,8 +19,8 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") ylim <- range(tdi, na.rm=TRUE)*1.05 theme <- x$Env$theme - lines(x.pos, tdi[,1], col = 5, lwd = 1, lend = 2, ...) - lines(x.pos, tdi[,2], col = 6, lwd = 1, lend = 2, ...) + lines(x.pos, tdi[,1], col = theme$TDI$col$tdi, lwd = 1, lend = 2, ...) + lines(x.pos, tdi[,2], col = theme$TDI$col$di, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -37,7 +37,7 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") legend = c(paste(legend, ":"), paste("tdi :",format(last(tdi[xsubset,1]),nsmall = 3L)), paste("di :",format(last(tdi[xsubset,1]),nsmall = 3L))), - text.col = c(theme$fg, 5, 6), + text.col = c(theme$fg, theme$TDI$col$tdi, theme$TDI$col$di), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -59,6 +59,10 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$TDI)) { + lchob$Env$theme$TDI$col$tdi <- 5 + lchob$Env$theme$TDI$col$di <- 6 + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- Cl(x) diff --git a/R/addVolatility.R b/R/addVolatility.R index 53d0de1b..f1b1f4d0 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -19,7 +19,7 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") ylim <- c(min(vol, na.rm=TRUE) * 0.95, max(vol, na.rm=TRUE) * 1.05) theme <- x$Env$theme - lines(x.pos, vol, col = 8, lwd = 1, lend = 2, ...) + lines(x.pos, vol, col = theme$Volatility$col, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -35,7 +35,7 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), sprintf("%.3f",last(vol[xsubset]))), - text.col = c(theme$fg, 8), + text.col = c(theme$fg, theme$Volatility$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", @@ -57,6 +57,9 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$Vol)) { + lchob$Env$theme$Volatility$col <- 8 + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- OHLC(x) diff --git a/R/addWPR.R b/R/addWPR.R index 60416ece..b1927a01 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -24,8 +24,7 @@ ylim <- c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05 theme <- x$Env$theme - COLOR <- "#0033CC" - lines(x.pos,wpr,col=COLOR,lwd=1,type='l') + lines(x.pos,wpr,col=theme$WPR$col,lwd=1,type='l') } mapply(function(name, value) { @@ -35,13 +34,12 @@ exp <- parse(text = gsub("list", "chartWPR", as.expression(substitute(list(x = current.chob(), n = n)))), srcfile = NULL) exp <- c(exp, expression( - COLOR <- "#0033CC", text(0, max(abs(wpr), na.rm = TRUE)*.9, paste("Williams %R (", n,"):", sep = ""), col = theme$fg, pos = 4), text(0, max(abs(wpr), na.rm = TRUE)*.9, - paste("\n\n\n",sprintf("%.3f",last(wpr[xsubset])), sep = ""), col = COLOR, + paste("\n\n\n",sprintf("%.3f",last(wpr[xsubset])), sep = ""), col = theme$WPR$col, pos = 4))) exp <- c(expression( wpr <- TA$wpr, @@ -60,6 +58,9 @@ lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$WPR)) { + lchob$Env$theme$WPR$col <- "#0033CC" + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset diff --git a/R/addZigZag.R b/R/addZigZag.R index eb7503ae..f18045c5 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -40,14 +40,13 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, } else { ylim <- x$get_ylim()[[2]] legend.name <- paste(legend, ":", format(last(na.omit(zigzag)),nsmall = 3L)) - text.col <- 4 yjust <- 1.5 } - lines(x.pos, zigzag, col = 4, lwd = 4, lend = 2, ...) + lines(x.pos, zigzag, col = theme$ZigZag$col, lwd = 4, lend = 2, ...) lc <- xts:::legend.coords("topleft", xlim, ylim) legend(x = lc$x, y = lc$y, legend = legend.name, - text.col = text.col, + text.col = theme$ZigZag$col, xjust = lc$xjust, yjust = yjust, bty = "n", @@ -64,6 +63,9 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ZigZag)) { + lchob$Env$theme$ZigZag$col <- 4 + } x <- lchob$Env$xdata xsubset <- lchob$Env$xsubset x <- cbind(Hi(x),Lo(x)) From 853c33532336438207b65fa5bb22637b31eb5c56 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Wed, 17 Aug 2016 15:51:34 +0800 Subject: [PATCH 09/12] Update bug of unchanged y limit value for addTA functions This commit is mainly for updating bug and cleaning up code for addTA functions. Originally, addTA functions' frame was set to be fixed so y limit value was unchanged when zoomChart was called to zoom up the indicators. The issue is not apparent in small data (~1000) and indicators that have upper and lower limits such as RSI and Aroon. But as the data grows bigger, TA's range will be larger. When zoomChart is called to view a shorter period, say, a month, y limit will be much greater than the value of the subset series, which makes the chart diffcult to read. Remove duplicated calculation for TA in lenv$chartTA. Move the expression of adding border and grid lines to lenv$chartTA. Add well-calculated TA to lenv to avoid duplicated calculation and use lenv$TA to create the y limit for new frame. Set TA's frame to be nonfixed. Divide BBands settings into col and lty. For addVo, minimum volume used to draw bars is replaced by the lower y limit. For addPoints, xts object is now allowed to be specified to x. Fix the bug that points' location will change when zoomChart is called. --- R/addAroon.R | 81 +++--- R/addCLV.R | 41 +-- R/addCMF.R | 49 ++-- R/addCMO.R | 58 ++-- R/addChaikin.R | 86 +++--- R/addEMV.R | 43 +-- R/addKST.R | 46 ++-- R/addMFI.R | 45 ++-- R/addTA.R | 670 +++++++++++++++++++++++++--------------------- R/addTDI.R | 42 +-- R/addVo.R | 46 ++-- R/addVolatility.R | 44 +-- R/addWPR.R | 64 +++-- R/addZigZag.R | 12 +- 14 files changed, 691 insertions(+), 636 deletions(-) diff --git a/R/addAroon.R b/R/addAroon.R index 4e8c83aa..b3fcf355 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -10,15 +10,26 @@ function (n = 20, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartAroon <- function(x, n, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- cbind(Hi(xdata),Lo(xdata)) - Aroon <- aroon(HL=xdata,n=n)[xsubset,-3] + Aroon <- Aroon[xsubset,-3] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(Aroon) - 1) xlim <- x$Env$xlim ylim <- c(0,100) theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, Aroon[,1], col = theme$Aroon$col$aroonUp, lwd = 1, lend = 2, ...) @@ -34,7 +45,8 @@ function (n = 20, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartAroon", as.expression(substitute(list(x = current.chob(), n = n, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(Aroon,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste("aroonUp :",format(last(Aroon[xsubset,1]),nsmall = 3L)), @@ -44,19 +56,6 @@ function (n = 20, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - Aroon <- TA$Aroon, - # add inbox color - rect(xlim[1], 0, xlim[2], 100, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(0, 100)), - xlim[2], y_grid_lines(c(0, 100)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(0, 100)), y_grid_lines(c(0, 100)), - 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], 0, xlim[2], 100, border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -70,8 +69,9 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset Aroon <- aroon(HL=xdata,n=n)[,-3] - lchob$Env$TA$Aroon <- Aroon -# lenv$xdata <- structure(Aroon, .Dimnames = list(NULL, "aroon")) + lenv$xdata <- structure(Aroon, .Dimnames = list(NULL, c("aroonUp", "aroonDn"))) + lenv$Aroon <- lchob$Env$TA$Aroon <- Aroon + lenv$get_frame <- lchob$get_frame if(is.na(on)) { lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) lchob$next_frame() @@ -88,15 +88,27 @@ function (n = 20, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartAroonOsc <- function(x, n, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- cbind(Hi(xdata),Lo(xdata)) - AroonOsc <- aroon(HL=xdata,n=n)[xsubset,3] + AroonOsc <- AroonOsc[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(AroonOsc) - 1) xlim <- x$Env$xlim - ylim <- range(AroonOsc,na.rm=TRUE) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, AroonOsc, col = theme$Aroon$col$aroonOsc, lwd = 1, lend = 2, ...) @@ -110,7 +122,8 @@ function (n = 20, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartAroonOsc", as.expression(substitute(list(x = current.chob(), n = n, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(AroonOsc,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(AroonOsc[xsubset]),nsmall = 3L))), @@ -119,19 +132,6 @@ function (n = 20, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - AroonOsc <- TA$AroonOsc, - # add inbox color - rect(xlim[1], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc)*1.05)[2], col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), - xlim[2], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)), y_grid_lines(c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, 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], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[1], xlim[2], c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -145,9 +145,12 @@ function (n = 20, ..., on = NA, legend = "auto") xdata <- cbind(Hi(xdata),Lo(xdata)) xsubset <- lchob$Env$xsubset AroonOsc <- aroon(HL=xdata,n=n)[,3] - lchob$Env$TA$AroonOsc <- AroonOsc + lenv$xdata <- structure(AroonOsc, .Dimnames = list(NULL, "aroonOsc")) + lenv$AroonOsc <- lchob$Env$TA$AroonOsc <- AroonOsc + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=c(min(AroonOsc,na.rm=TRUE)*0.95, max(AroonOsc, na.rm=TRUE)*1.05),asp=1,fixed=TRUE) + lchob$add_frame(ylim=c(min(lenv$AroonOsc[xsubset],na.rm=TRUE)*0.95, + max(lenv$AroonOsc[xsubset], na.rm=TRUE)*1.05),asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addCLV.R b/R/addCLV.R index 0129c983..d69abb1c 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -9,14 +9,27 @@ function (..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartCLV <- function(x, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - clv <- CLV(HLC=HLC(xdata))[xsubset] + clv <- clv[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(clv) - 1) xlim <- x$Env$xlim - ylim <- range(clv,na.rm=TRUE) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, clv, type = "h", col = theme$CLV$col, lwd = 1, lend = 2, ...) @@ -30,7 +43,8 @@ function (..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartCLV", as.expression(substitute(list(x = current.chob(), ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(clv,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(clv[xsubset]),nsmall = 3L))), @@ -39,19 +53,6 @@ function (..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - clv <- TA$clv, - # add inbox color - rect(xlim[1], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(clv, na.rm=TRUE)), - xlim[2], y_grid_lines(range(clv, na.rm=TRUE)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(clv, na.rm=TRUE)), y_grid_lines(range(clv, 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], range(clv, na.rm=TRUE)[1], xlim[2], range(clv, na.rm=TRUE)[2], border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -62,9 +63,11 @@ function (..., on = NA, legend = "auto") xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset clv <- CLV(HLC=HLC(xdata)) - lchob$Env$TA$clv <- clv + lenv$xdata <- structure(clv, .Dimnames = list(NULL, "clv")) + lenv$clv <- lchob$Env$TA$clv <- clv + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=range(clv,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$clv[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addCMF.R b/R/addCMF.R index dcb8ce26..7e591652 100644 --- a/R/addCMF.R +++ b/R/addCMF.R @@ -4,17 +4,29 @@ lenv <- new.env() lenv$chartCMF <- function(x, n) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- cbind(Hi(xdata),Lo(xdata),Cl(xdata)) - vo <- x$Env$vo - cmf <- CMF(xdata,vo,n=n)[xsubset] + cmf <- cmf[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(cmf) - 1) xlim <- x$Env$xlim - ylim <- c(-max(abs(cmf), na.rm = TRUE), - max(abs(cmf), na.rm = TRUE))*1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] + ylim[1] <- ifelse(ylim[1] > 0, 0, ylim[1]) theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + segments(xlim[1], 0, xlim[2], 0, col = "#999999") cmf.positive <- ifelse(cmf >= 0,cmf,0) cmf.negative <- ifelse(cmf < 0,cmf,0) @@ -28,7 +40,8 @@ exp <- parse(text = gsub("list", "chartCMF", as.expression(substitute(list(x = current.chob(), n = n)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(sprintf("%.3f",last(cmf[xsubset])), sep = "")), @@ -37,20 +50,6 @@ yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - cmf <- TA$cmf, - # add inbox color - rect(xlim[1], -max(abs(cmf), na.rm = TRUE)*1.05, xlim[2], max(abs(cmf), 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(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), - xlim[2], y_grid_lines(c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), 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(cmf), na.rm = TRUE),max(abs(cmf), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(cmf), na.rm = TRUE),max(abs(cmf), 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(cmf), na.rm = TRUE)*1.05, xlim[2], max(abs(cmf), na.rm = TRUE)*1.05, border=theme$labels), - segments(xlim[1], 0, xlim[2], 0, col = "#999999")), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -63,11 +62,13 @@ vo <- lchob$Env$vo cmf <- CMF(xdata,vo,n=n) - lchob$Env$TA$cmf <- cmf + lenv$xdata <- structure(cmf, .Dimnames=list(NULL, "cmf")) + lenv$cmf <- lchob$Env$TA$cmf <- cmf + lenv$get_frame <- lchob$get_frame if(!is.character(legend) || legend == "auto") lchob$Env$legend <- paste("Chaikin Money Flow (", n, ")", sep="") - lchob$add_frame(ylim=c(-max(abs(cmf), na.rm = TRUE), - max(abs(cmf), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) + lchob$add_frame(ylim=c(-max(abs(lenv$cmf[xsubset]), na.rm = TRUE), + max(abs(lenv$cmf[xsubset]), na.rm = TRUE))*1.05,asp=1,fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob diff --git a/R/addCMO.R b/R/addCMO.R index 643aafab..5d91a303 100644 --- a/R/addCMO.R +++ b/R/addCMO.R @@ -5,22 +5,29 @@ lenv <- new.env() lenv$chartCMO <- function(x, n) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xx <- if(has.Cl(xdata)) { - Cl(xdata) - } else if(NCOL(xdata)==1) { - xdata - } else { - xdata[,1] - } - cmo <- CMO(xx,n=n)[xsubset] + cmo <- cmo[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(cmo) - 1) xlim <- x$Env$xlim - ylim <- c(-max(abs(cmo), na.rm = TRUE), - max(abs(cmo), na.rm = TRUE))*1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] + ylim[1] <- ifelse(ylim[1] > 0, 0, ylim[1]) theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted") lines(x.pos, cmo, col = theme$CMO$col, lwd = 1, lend = 2) } @@ -30,29 +37,16 @@ exp <- parse(text = gsub("list", "chartCMO", as.expression(substitute(list(x = current.chob(), n = n)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, - legend = c(paste(legend, ":"), + legend = c(paste("Chande Momentum Oscillator (", n, ") :"), paste(sprintf("%.3f",last(cmo[xsubset])), sep = "")), text.col = c(theme$fg, theme$CMO$col), xjust = lc$xjust, yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - cmo <- TA$cmo, - # add inbox color - rect(xlim[1], -max(abs(cmo), na.rm = TRUE)*1.05, xlim[2], max(abs(cmo), 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(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), - xlim[2], y_grid_lines(c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), 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(cmo), na.rm = TRUE),max(abs(cmo), na.rm = TRUE))*1.05), y_grid_lines(c(-max(abs(cmo), na.rm = TRUE),max(abs(cmo), 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(cmo), na.rm = TRUE)*1.05, xlim[2], max(abs(cmo), na.rm = TRUE)*1.05, border=theme$labels), - segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted")), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -75,11 +69,11 @@ } cmo <- CMO(xx,n=n) - lchob$Env$TA$cmo <- cmo - if(!is.character(legend) || legend == "auto") - lchob$Env$legend <- paste("Chande Momentum Oscillator (", n, ") ", sep="") - lchob$add_frame(ylim=c(-max(abs(cmo), na.rm = TRUE), - max(abs(cmo), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) + lenv$xdata <- structure(cmo, .Dimnames=list(NULL, "cmo")) + lenv$cmo <- lchob$Env$TA$cmo <- cmo + lenv$get_frame <- lchob$get_frame + lchob$add_frame(ylim=c(-max(abs(lenv$cmo[xsubset]), na.rm = TRUE), + max(abs(lenv$cmo[xsubset]), na.rm = TRUE))*1.05,asp=1,fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob diff --git a/R/addChaikin.R b/R/addChaikin.R index c94f87a9..026eae3b 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -11,16 +11,28 @@ function (..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartChAD <- function(x, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - vo <- x$Env$vo - ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo)[xsubset] + ChaikinAD <- ChaikinAD[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(ChaikinAD) - 1) xlim <- x$Env$xlim - ylim <- range(ChaikinAD,na.rm=TRUE) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + lines(x.pos, ChaikinAD, col = theme$ChAD$col$chaikinAD, lwd = 1, lend = 2, ...) } @@ -33,7 +45,8 @@ function (..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartChAD", as.expression(substitute(list(x = current.chob(), ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(ChaikinAD,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(ChaikinAD[xsubset]),nsmall = 3L))), @@ -42,19 +55,6 @@ function (..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - ChaikinAD <- TA$ChaikinAD, - # add inbox color - rect(xlim[1], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), - xlim[2], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(ChaikinAD, na.rm=TRUE)), y_grid_lines(range(ChaikinAD, 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], range(ChaikinAD, na.rm=TRUE)[1], xlim[2], range(ChaikinAD, na.rm=TRUE)[2], border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -66,9 +66,11 @@ function (..., on = NA, legend = "auto") xsubset <- lchob$Env$xsubset vo <- lchob$Env$vo ChaikinAD <- chaikinAD(HLC = HLC(xdata), volume = vo) - lchob$Env$TA$ChaikinAD <- ChaikinAD + lenv$xdata <- structure(ChaikinAD, .Dimnames=list(NULL, "ChaikinAD")) + lenv$ChaikinAD <- lchob$Env$TA$ChaikinAD <- ChaikinAD + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=range(ChaikinAD,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$ChaikinAD[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) lchob$next_frame() } else { @@ -83,14 +85,27 @@ function (n = 10, maType, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartChVol <- function(x, n, maType, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType)[xsubset] + ChaikinVol <- ChaikinVol[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(ChaikinVol) - 1) xlim <- x$Env$xlim - ylim <- range(ChaikinVol,na.rm=TRUE) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, ChaikinVol, col = theme$ChVol$col$chaikinVol, lwd = 1, lend = 2, ...) @@ -105,28 +120,17 @@ function (n = 10, maType, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartChVol", as.expression(substitute(list(x = current.chob(), n = n, maType = maType, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(ChaikinVol,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), - paste(format(last(ChaikinVol[xsubset]),nsmall = 3L))), + paste(sprintf("%.3f", last(ChaikinVol[xsubset])))), text.col = c(theme$fg, theme$ChVol$col$chaikinVol), xjust = lc$xjust, yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - ChaikinVol <- TA$ChaikinVol, - # add inbox color - rect(xlim[1], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), - xlim[2], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(ChaikinVol, na.rm=TRUE)), y_grid_lines(range(ChaikinVol, 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], range(ChaikinVol, na.rm=TRUE)[1], xlim[2], range(ChaikinVol, na.rm=TRUE)[2], border=theme$labels)), exp) + lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() @@ -136,9 +140,11 @@ function (n = 10, maType, ..., on = NA, legend = "auto") xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset ChaikinVol <- chaikinVolatility(HL = HLC(xdata)[,-3], n = n, maType = maType) - lchob$Env$TA$ChaikinVol <- ChaikinVol + lenv$xdata <- structure(ChaikinVol, .Dimnames=list(NULL, "ChaikinVol")) + lenv$ChaikinVol <- lchob$Env$TA$ChaikinVol <- ChaikinVol + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=range(ChaikinVol,na.rm=TRUE),asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$ChaikinVol[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addEMV.R b/R/addEMV.R index c0b3e111..1eeafba0 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -10,16 +10,27 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, { lenv <- new.env() lenv$chartEMV <- function(x, volume, n, maType, vol.divisor, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - volume <- x$Env$TA$volume - emv <- EMV(HL=HLC(xdata)[,-3], volume = volume, n = n, maType = maType, - legend = legend)[xsubset] + emv <- emv[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(emv) - 1) xlim <- x$Env$xlim - ylim <- range(emv,na.rm=TRUE)*1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, emv$emv, col = theme$EMV$col$emv, lwd = 1, lend = 2, ...) lines(x.pos, emv$maEMV, col = theme$EMV$col$maEMV, lwd = 1, lend = 2, ...) @@ -45,7 +56,8 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, as.expression(substitute(list(x = current.chob(), volume = volume, n = n, maType = maType, vol.divisor = vol.divisor, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(emv,na.rm=TRUE)*1.05), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste("emv :", sprintf("%.3f",last(emv$emv[xsubset]))), @@ -55,28 +67,17 @@ function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA, yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - emv <- TA$emv, - # add inbox color - rect(xlim[1], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(emv,na.rm=TRUE)*1.05), - xlim[2], y_grid_lines(range(emv,na.rm=TRUE)*1.05), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(emv,na.rm=TRUE)*1.05), y_grid_lines(range(emv,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], range(emv,na.rm=TRUE)[1]*1.05, xlim[2], range(emv,na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset emv <- EMV(HL = HLC(xdata)[,-3], volume = volume, n = n, maType = maType, vol.divisor = vol.divisor) - lchob$Env$TA$emv <- emv + lenv$xdata <- structure(emv, .Dimnames=list(NULL, c("emv", "maEMV"))) + lenv$emv <- lchob$Env$TA$emv <- emv lchob$Env$TA$volume <- volume + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=range(emv,na.rm=TRUE)*1.05,asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$emv[xsubset],na.rm=TRUE)*1.05,asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addKST.R b/R/addKST.R index c47421a9..e3a45d2d 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -11,17 +11,29 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, { lenv <- new.env() lenv$chartKST <- function(x, n, nROC, nSig, maType, wts, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- Cl(xdata) - kst <- KST(price = xdata, n = n, nROC = nROC, nSig = nSig, maType = maType, - wts = wts)[xsubset] + kst <- kst[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(kst) - 1) xlim <- x$Env$xlim - ylim <- range(kst, na.rm=TRUE) * 1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme - + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + + lines(x.pos, kst[,1], col = theme$KST$col$kst, lwd = 1, lend = 2, ...) lines(x.pos, kst[,2], col = theme$KST$col$signal, lwd = 1, lend = 2, ...) } @@ -38,7 +50,8 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, n = n, nROC = nROC, nSig = nSig, maType = maType, wts = wts, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(kst, na.rm=TRUE) * 1.05), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(legend, paste("kst :",format(last(kst[xsubset,1]),nsmall = 3L)), @@ -48,19 +61,6 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - kst <- TA$kst, - # add inbox color - rect(xlim[1], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), - xlim[2], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(kst, na.rm=TRUE) * 1.05), y_grid_lines(range(kst, 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], range(kst, na.rm=TRUE)[1] * 1.05, xlim[2], range(kst, na.rm=TRUE)[2] * 1.05, border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -74,9 +74,11 @@ function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9, x <- Cl(x) kst <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, wts = wts) - lchob$Env$TA$kst <- kst + lenv$xdata <- structure(kst, .Dimnames=list(NULL, c("kst", "signal"))) + lenv$kst <- lchob$Env$TA$kst <- kst + lenv$get_frame <- lchob$get_frame if(is.na(on)) { - lchob$add_frame(ylim=range(kst, na.rm=TRUE) * 1.05,asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$kst[xsubset], na.rm=TRUE) * 1.05,asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addMFI.R b/R/addMFI.R index e49544c6..8ebacff4 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -9,17 +9,28 @@ function (n = 14, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartMFI <- function(x, n, ..., on, legend) { - xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - volume <- lchob$Env$vo - xdata <- HLC(xdata) - mfi <- MFI(HLC = xdata, volume = volume, n = n)[xsubset] + mfi <- mfi[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(mfi) - 1) xlim <- x$Env$xlim - ylim <- c(0,100) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme - + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + lines(x.pos, mfi, col = theme$MFI$col, lwd = 1, lend = 2, ...) } if(!is.character(legend) || legend == "auto") @@ -31,7 +42,8 @@ function (n = 14, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartMFI", as.expression(substitute(list(x = current.chob(), n = n, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, c(0,100)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste(format(last(mfi[xsubset]),nsmall = 3L))), @@ -40,19 +52,6 @@ function (n = 14, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - mfi <- TA$mfi, - # add inbox color - rect(xlim[1], 0, xlim[2], 100, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(0,100)), - xlim[2], y_grid_lines(c(0,100)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(0,100)), y_grid_lines(c(0,100)), - 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], 0, xlim[2], 100, border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -65,9 +64,11 @@ function (n = 14, ..., on = NA, legend = "auto") volume <- lchob$Env$vo x <- HLC(x) mfi <- MFI(HLC = x, volume = volume, n = n) - lchob$Env$TA$mfi <- mfi + lenv$xdata <- structure(mfi, .Dimnames=list(NULL, "mfi")) + lenv$mfi <- lchob$Env$TA$mfi <- mfi + lenv$get_frame <- lchob$get_frame if(any(is.na(on))) { - lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) + lchob$add_frame(ylim=range(lenv$mfi[xsubset], na.rm=TRUE),asp=1,fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addTA.R b/R/addTA.R index 6c2b7d1b..76e76779 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -20,21 +20,29 @@ 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] + mom <- mom[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 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + segments(xlim[1],0,xlim[2],0,col="#666666",lwd=1,lty='dotted') lines(x.pos,mom,col=theme$Momentum$col,lwd=2,type='l') @@ -45,26 +53,16 @@ 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( - 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[xsubset])),sep=''), - col = theme$Momentum$col, pos = 4))) - exp <- c(expression( - mom <- TA$mom, - # 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) + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("Momentum (", n, "):"), + paste(sprintf("%.2f",last(mom[xsubset])),sep='')), + text.col = c(theme$fg, theme$Momentum$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -83,10 +81,12 @@ } else xx <- x[,with.col] mom <- momentum(xx,n=n) - lchob$Env$TA$mom <- mom + lenv$xdata <- structure(mom, .Dimnames=list(NULL, "mom")) + lenv$mom <- lchob$Env$TA$mom <- mom + lenv$get_frame <- lchob$get_frame - lchob$add_frame(ylim=c(-max(abs(mom),na.rm=TRUE), - max(abs(mom),na.rm=TRUE)) * 1.05, asp=1, fixed=TRUE) + lchob$add_frame(ylim=c(-max(abs(lenv$mom[xsubset]),na.rm=TRUE), + max(abs(lenv$mom[xsubset]),na.rm=TRUE)) * 1.05, asp=1, fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -137,18 +137,29 @@ function(x) { 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] + cci <- cci[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 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + # 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) @@ -171,27 +182,16 @@ function(x) { 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[xsubset])),sep=''), col = theme$CCI$col, - pos = 4))) - exp <- c(expression( - cci <- TA$cci, - # 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) + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("Commodity Channel Index (", n, ",", c,"):",sep=''), + paste(sprintf("%.2f",last(cci[xsubset])),sep='')), + text.col = c(theme$fg, theme$CCI$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -208,9 +208,11 @@ function(x) { } else x cci <- CCI(xx,n=n,maType=maType,c=c) - lchob$Env$TA$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) + lenv$xdata <- structure(cci, .Dimnames=list(NULL, "cci")) + lenv$cci <- lchob$Env$TA$cci <- cci + lenv$get_frame <- lchob$get_frame + lchob$add_frame(ylim=c(-max(abs(lenv$cci[xsubset]), na.rm = TRUE), + max(abs(lenv$cci[xsubset]), na.rm = TRUE))*1.05,asp=1,fixed=TRUE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob @@ -275,15 +277,29 @@ function(x) { 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] + adx <- adx[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)) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + 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=theme$ADX$col$DIp,lwd=1,type='l') @@ -298,22 +314,22 @@ function(x) { 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) - - exp <- c(expression( - adx <- TA$adx, - # 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) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste("DIp : ", sprintf("%.3f",last(adx[xsubset,1]))), + paste("DIn : ", sprintf("%.3f",last(adx[xsubset,2]))), + paste("ADX : ", sprintf("%.3f",last(adx[xsubset,4])))), + text.col = c(theme$fg, + theme$ADX$col$DIp, + theme$ADX$col$DIn, + theme$ADX$col$adx), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -330,9 +346,12 @@ function(x) { 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) - lchob$Env$TA$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) + lenv$xdata <- structure(adx, .Dimnames=list(NULL, c("DIp", "DIn", "DX", "ADX"))) + lenv$adx <- lchob$Env$TA$adx <- adx + lenv$get_frame <- lchob$get_frame + lenv$legend <- gsub("^addADX", "Directional Movement Index ", deparse(match.call())) + lchob$add_frame(ylim=c(min(lenv$adx[xsubset]*0.975, na.rm = TRUE), + max(lenv$adx[xsubset]*1.05, na.rm = TRUE)),asp=1,fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob @@ -377,15 +396,27 @@ function(x) { 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] + atr <- atr[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)) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos,atr[,2],col=theme$ATR$col,lwd=2,type='l') } @@ -394,20 +425,17 @@ function(x) { }, 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) - - exp <- c(expression( - atr <- TA$atr, - # 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) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f", last(atr[xsubset,2])))), + text.col = c(theme$fg, theme$ATR$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -422,9 +450,12 @@ function(x) { if(!is.OHLC(x)) stop("only applicable to HLC series") atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...) - lchob$Env$TA$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) + lenv$xdata <- structure(atr[,2], .Dimnames=list(NULL, "atr")) + lenv$atr <- lchob$Env$TA$atr <- atr + lenv$get_frame <- lchob$get_frame + lenv$legend <- gsub("^addATR", "Average True Range ", deparse(match.call())) + lchob$add_frame(ylim=c(min(lenv$atr[xsubset,2]*0.975, na.rm = TRUE), + max(lenv$atr[xsubset,2]*1.05, na.rm = TRUE)),asp=1,fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob @@ -463,20 +494,28 @@ function(x) { 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)) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) # draw TRIX lines(x.pos,trix[,1],col=theme$TRIX$col$trix,lwd=1,type='l') @@ -489,19 +528,18 @@ 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( - trix <- TA$trix, - # 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) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste("TRIX :",sprintf("%.3f",last(trix[xsubset,1]))), + paste("signal :",sprintf("%.3f",last(trix[xsubset,2]),nsmall = 3L))), + text.col = c(theme$fg, theme$TRIX$col$trix, theme$TRIX$col$signal), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -519,9 +557,12 @@ function(x) { } else x trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent) - lchob$Env$TA$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) + lenv$xdata <- structure(trix, .Dimnames=list(NULL, c("TRIX", "signal"))) + lenv$trix <- lchob$Env$TA$trix <- trix + lenv$get_frame <- lchob$get_frame + lenv$legend <- gsub("^addTRIX", "Triple Exponential Moving Average ", deparse(match.call())) + lchob$add_frame(ylim=c(min(lenv$trix[xsubset,1]*.975,na.rm=TRUE), + max(lenv$trix[xsubset,1]*1.05,na.rm=TRUE)), asp=1, fixed=TRUE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -565,18 +606,28 @@ function(x) { 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] + dpo <- dpo[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 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + segments(xlim[1], 0, xlim[2], 0, col = "#999999") dpo.tmp <- dpo dpo.tmp[is.na(dpo)] <- 0 @@ -594,29 +645,17 @@ function(x) { 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[xsubset]))), sep = ""), - col = ifelse(last(na.omit(dpo[xsubset])) > 0,theme$up.col,theme$dn.col), - pos = 4))) - - exp <- c(expression( - dpo <- TA$dpo, - # 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) + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("De-trended Price Oscillator (", n,"):", sep = ""), + paste(sprintf("%.3f", last(na.omit(dpo[xsubset]))))), + text.col = c(theme$fg, ifelse(last(na.omit(dpo[xsubset])>0), + theme$up.col, theme$dn.col)), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -632,9 +671,11 @@ function(x) { } else x dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent) - lchob$Env$TA$dpo <- dpo + lenv$xdata <- structure(dpo, .Dimnames=list(NULL, "dpo")) + lenv$dpo <- lchob$Env$TA$dpo <- dpo + lenv$get_frame <- lchob$get_frame lchob$add_frame(ylim=c(-max(abs(dpo), na.rm = TRUE), - max(abs(dpo), na.rm = TRUE)) * 1.05,asp=1,fixed=TRUE) + max(abs(dpo), na.rm = TRUE)) * 1.05,asp=1,fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob @@ -708,17 +749,27 @@ function(x) { 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] + rsi <- rsi[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) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos,rsi,col=theme$RSI$col$rsi,lwd=2,type='l') lines(x.pos,rsi,col=theme$RSI$col$dot,lwd=1,lty='dotted',type='l') @@ -731,26 +782,16 @@ function(x) { 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[xsubset])), sep = ""), col = theme$RSI$col$rsi, - pos = 4))) - exp <- c(expression( - rsi <- TA$rsi, - # 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) + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("Relative Strength Index (", n,"):", sep = ""), + paste(sprintf("%.3f",last(rsi[xsubset])), sep = "")), + text.col = c(theme$fg, theme$RSI$col$rsi), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -768,8 +809,10 @@ function(x) { } else x rsi <- RSI(xx,n=n,maType=maType,wilder=wilder) - lchob$Env$TA$rsi <- rsi - lchob$add_frame(ylim=c(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05),asp=1,fixed=TRUE) + lenv$xdata <- structure(rsi, .Dimnames=list(NULL, "rsi")) + lenv$rsi <- lchob$Env$TA$rsi <- rsi + lenv$get_frame <- lchob$get_frame + lchob$add_frame(ylim=c(0,100),asp=1,fixed=TRUE) lchob$next_frame() lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) lchob @@ -820,20 +863,28 @@ function(x) { 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] + roc <- roc[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 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos,roc,col=col,lwd=2,type='l') } @@ -842,19 +893,17 @@ 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( - roc <- TA$roc, - # 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) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f", last(roc[xsubset])))), + text.col = c(theme$fg, col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -867,9 +916,12 @@ function(x) { } else x roc <- ROC(xx,n=n,type=type[1],na.pad=TRUE) - lchob$Env$TA$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) + lenv$xdata <- structure(roc, .Dimnames=list(NULL, "roc")) + lenv$roc <- lchob$Env$TA$roc <- roc + lenv$get_frame <- lchob$get_frame + lenv$legend <- gsub("^add", "", deparse(match.call())) + lchob$add_frame(ylim=c(-max(abs(lenv$roc[xsubset]), na.rm = TRUE), + max(abs(lenv$roc[xsubset]), na.rm = TRUE))*1.05, asp=1, fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -907,22 +959,18 @@ function(x) { 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] + bb <- bb[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) + y_grid_lines <- x$Env$y_grid_lines + 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 @@ -949,7 +997,6 @@ function(x) { 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 (", @@ -964,7 +1011,8 @@ function(x) { } else if(draw == 'percent') { - + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] 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), @@ -977,21 +1025,24 @@ function(x) { 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]) + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(lc$x,lc$y, + legend=c(paste("Bollinger %b (", + paste(n,sd,sep=","), "): ", + sep=""), + paste(sprintf("%.3f",last(bb[,4])), sep = "")), + text.col = c(theme$fg, bband.col[4]), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95) } else { - + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] 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), @@ -1005,20 +1056,19 @@ function(x) { # 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]) + lc <- xts:::legend.coords("topleft", xlim, ylim) + legend(lc$x,lc$y, + legend=c(paste("Bollinger Band Width (", + paste(n,sd,sep=","), "): ", + sep=""), + paste(sprintf("%.3f",last(bbw)), sep = "")), + text.col = c(theme$fg, bband.col[5]), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95) } } mapply(function(name, value) { @@ -1033,14 +1083,16 @@ function(x) { lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - if (is.null(lchob$Env$theme$bbands)) { - lchob$Env$theme$bbands$col$fill <- '#282828' - lchob$Env$theme$bbands$col$upper <- 'red' - lchob$Env$theme$bbands$col$lower <- 'red' - lchob$Env$theme$bbands$col$ma <- '#D5D5D5' - lchob$Env$theme$bbands$lty$upper <- 'dashed' - lchob$Env$theme$bbands$lty$lower <- 'dashed' - lchob$Env$theme$bbands$lty$ma <- 'dotted' + if (is.null(lchob$Env$theme$BBands$col)) { + lchob$Env$theme$BBands$col$fill <- '#282828' + lchob$Env$theme$BBands$col$upper <- 'red' + lchob$Env$theme$BBands$col$lower <- 'red' + lchob$Env$theme$BBands$col$ma <- '#D5D5D5' + } + if (is.null(lchob$Env$theme$BBands$lty)) { + lchob$Env$theme$BBands$lty$upper <- 'dashed' + lchob$Env$theme$BBands$lty$lower <- 'dashed' + lchob$Env$theme$BBands$lty$ma <- 'dotted' } x <- lchob$Env$xdata @@ -1050,8 +1102,10 @@ function(x) { cbind(Hi(x),Lo(x),Cl(x)) } else x - bb <- BBands(xx,n=n,maType=maType,sd=sd)[xsubset] - lchob$Env$TA$bb <- bb + bb <- BBands(xx,n=n,maType=maType,sd=sd) + lenv$xdata <- structure(cbind(bb, (bb[,3] - bb[,1]) / bb[,2]), + .Dimnames=list(NULL, c("dn", "mavg", "up", "pctB", "bbw"))) + lenv$bb <- lchob$Env$TA$bb <- bb if(draw == 'bands') { # draw Bollinger Bands on price chart lchob$set_frame(-2) @@ -1059,21 +1113,18 @@ function(x) { } 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$add_frame(ylim=c(min(lenv$bb[xsubset,4], na.rm = TRUE) * .9, + max(abs(lenv$bb[xsubset,4]), na.rm = TRUE) * 1.05),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] + lenv$bbw <- lchob$Env$TA$bbbw <- bbw - 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$add_frame(ylim=c(min(lenv$bbw[xsubset], na.rm = TRUE) * .9, + max(abs(lenv$bbw[xsubset]), na.rm = TRUE) * 1.05),asp=1,fixed=TRUE) lchob$next_frame() } lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) @@ -1223,7 +1274,7 @@ function(x) { sprintf("%.3f",last(mae[,1])), sep = ""), text.col = "blue", xjust = lc$xjust, - yjust = 1.5, + yjust = 2, bty = "n", y.intersp=0.95) } @@ -1253,7 +1304,7 @@ function(x) { ma <- do.call(maType,list(xx,n=n,...)) mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))[xsubset] lchob$Env$TA$mae <- mae - lchob$set_frame(on+1) + lchob$set_frame(sign(on)*(abs(on)+1L)) lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob } #}}} @@ -1349,33 +1400,41 @@ function(x) { 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] + macd <- macd[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 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + if(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') } - col <- if(missing(col)) col <- c('#999999','#777777', - '#BBBBBB','#FF0000') + if(missing(col)) col <- c('#999999','#777777', + '#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)), @@ -1383,8 +1442,8 @@ function(x) { 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), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(lc$x, lc$y, legend=c(paste("Moving Average Convergence Divergence (", paste(fast,slow,signal,sep=','),"):", sep = ""), @@ -1395,19 +1454,6 @@ function(x) { yjust=lc$yjust, bty='n', y.intersp=0.95))) - exp <- c(expression( - macd <- TA$macd, - # 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() ncalls <- length(lchob$Env$call_list) @@ -1421,9 +1467,11 @@ function(x) { } else x macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type) - lchob$Env$TA$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) + lenv$xdata <- structure(cbind(macd, macd[,1]-macd[,2]), .Dimnames=list(NULL, c("macd", "signal", "histogram"))) + lenv$macd <- lchob$Env$TA$macd <- macd + lenv$get_frame <- lchob$get_frame + lchob$add_frame(ylim=c(-max(abs(lenv$macd[xsubset]),na.rm=TRUE), + max(abs(lenv$macd[xsubset]),na.rm=TRUE))*1.05, asp=1, fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob @@ -1693,11 +1741,15 @@ function(x) { lenv$chartPoints <- function(x, type, pch, offset, col, bg, cex, on, overlay) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - x.points <- x$Env$x.points - xsubset <- x.points %in% xsubset - y.points <- x$Env$y.points + if(is.xts(x$Env$x.points)) { + y.points <- x$Env$x.points[.index(x$Env$x.points) %in% .index(xdata[xsubset])] + x.points <- which(.index(xdata[xsubset]) %in% .index(x$Env$x.points)) + } + else { + x.points <- which(.index(xdata[xsubset]) %in% .index(xdata[x$Env$x.points])) + y.points <- x$Env$y.points + } spacing <- x$Env$theme$spacing - # if OHLC and above - get Hi, else Lo # if univariate - get value y.data <- if(is.OHLC(xdata)) { @@ -1727,7 +1779,7 @@ function(x) { segments(xlim[1], 0, xlim[2], 0, col = "#666666", lty = "dotted") } - points(x=x.points[xsubset], y=y.points[xsubset], type=type,pch=pch,col=col,bg=bg,cex=cex) + points(x=x.points, 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, @@ -1743,18 +1795,12 @@ function(x) { lchob$Env$call_list[[ncalls + 1]] <- match.call() xdata <- lchob$Env$xdata xsubset <- lchob$Env$xsubset - - - if(missing(bg)) bg <- col - if(is.xts(x)) { - lchob$Env$x.points <- match(.index(x), .index(xdata)) - lchob$Env$y.points <- x - } else { + if(!is.null(y)) if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') - lchob$Env$x.points <- x - lchob$Env$y.points <- y - } + + lchob$Env$x.points <- x + lchob$Env$y.points <- y if(overlay) diff --git a/R/addTDI.R b/R/addTDI.R index 1130db95..35f828ac 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -9,15 +9,27 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartTDI <- function(x, n, multiple, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- Cl(xdata) - tdi <- TDI(price = xdata, n = n, multiple = multiple)[xsubset] + tdi <- tdi[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(tdi) - 1) xlim <- x$Env$xlim - ylim <- range(tdi, na.rm=TRUE)*1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos, tdi[,1], col = theme$TDI$col$tdi, lwd = 1, lend = 2, ...) lines(x.pos, tdi[,2], col = theme$TDI$col$di, lwd = 1, lend = 2, ...) @@ -32,7 +44,8 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartTDI", as.expression(substitute(list(x = current.chob(), n = n, multiple = multiple, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(tdi, na.rm=TRUE)*1.05), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), paste("tdi :",format(last(tdi[xsubset,1]),nsmall = 3L)), @@ -42,19 +55,6 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - tdi <- TA$tdi, - # add inbox color - rect(xlim[1], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), - xlim[2], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(range(tdi, na.rm=TRUE)*1.05), y_grid_lines(range(tdi, 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], range(tdi, na.rm=TRUE)[1]*1.05, xlim[2], range(tdi, na.rm=TRUE)[2]*1.05, border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -67,9 +67,11 @@ function (n = 20, multiple = 2, ..., on = NA, legend = "auto") xsubset <- lchob$Env$xsubset x <- Cl(x) tdi <- TDI(price = x, n = n, multiple = multiple) - lchob$Env$TA$tdi <- tdi + lenv$xdata <- structure(tdi, .Dimnames=list(NULL, c("tdi", "di"))) + lenv$tdi <- lchob$Env$TA$tdi <- tdi + lenv$get_frame <- lchob$get_frame if (any(is.na(on))) { - lchob$add_frame(ylim=range(tdi, na.rm=TRUE)*1.05, asp=1, fixed=TRUE) + lchob$add_frame(ylim=range(lenv$tdi[xsubset], na.rm=TRUE)*1.05, asp=1, fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addVo.R b/R/addVo.R index 083d5974..0be63734 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -1,9 +1,9 @@ # addVo {{{ -`addVo` <- function(log.scale=FALSE, ...) { +`addVo` <- function(log.scale=FALSE) { lenv <- new.env() - lenv$chartVo <- function(x, ...) { + lenv$chartVo <- function(x) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset vo <- x$Env$TA$vo[xsubset] @@ -13,8 +13,22 @@ x.pos <- 1 + spacing * (1:NROW(vo) - 1) xlim <- x$Env$xlim - ylim <- c(min(vo, na.rm=TRUE), max(vo, na.rm=TRUE) * 1.05) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) thin <- theme$thin @@ -27,43 +41,28 @@ } else theme$border.col[xsubset] border.col <- theme$border.col[xsubset] - min.vol <- min(vo) if(x$Env$theme$thin) { # plot thin volume bars if appropriate - segments(x.pos,min.vol,x.pos,vo,col=bar.col) + segments(x.pos,ylim[1],x.pos,vo,col=bar.col) } else { - rect(x.pos-spacing/3,min.vol,x.pos+spacing/3,vo, + rect(x.pos-spacing/3,ylim[1],x.pos+spacing/3,vo, col=bar.col,border=border.col) } } - # map all passed args (if any) to 'lenv' environment - mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(...)), list(...)) exp <- parse(text=gsub("list","chartVo",as.expression(substitute(list(x=current.chob(),...)))), srcfile=NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, range(vo,na.rm=TRUE)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, - legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo[xsubset])*vol.scale[[1]],big.mark=',')), + legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo[xsubset]),big.mark=',')), text.col = c(theme$fg, last(theme$bar.col)), xjust = lc$xjust, yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - vo <- TA$vo, - # add inbox color - rect(xlim[1], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), - xlim[2], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)), y_grid_lines(range(vo, 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], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[1], xlim[2], c(min(vo,na.rm=TRUE), max(vo,na.rm=TRUE)*1.05)[2], border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -118,6 +117,7 @@ vol.scale <- list(1e+06, "millions") lchob$Env$vol.scale <- vol.scale lchob$Env$TA$vo <- vo/vol.scale[[1]] + lenv$get_frame <- lchob$get_frame lchob$add_frame(ylim=c(min(lchob$Env$TA$vo, na.rm=TRUE), max(lchob$Env$TA$vo, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) # need to have a value set for ylim diff --git a/R/addVolatility.R b/R/addVolatility.R index f1b1f4d0..4f470b49 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -9,16 +9,28 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") { lenv <- new.env() lenv$chartVolatility <- function(x, n, calc, N, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- OHLC(xdata) - vol <- volatility(OHLC = xdata, n = n, calc = calc, N = N)[xsubset] + vol <- vol[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(vol) - 1) xlim <- x$Env$xlim - ylim <- c(min(vol, na.rm=TRUE) * 0.95, max(vol, na.rm=TRUE) * 1.05) + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + lines(x.pos, vol, col = theme$Volatility$col, lwd = 1, lend = 2, ...) } @@ -31,7 +43,8 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") exp <- parse(text = gsub("list", "chartVolatility", as.expression(substitute(list(x = current.chob(), n = n, calc = calc, N = N, ..., on = on, legend = legend)))), srcfile = NULL) exp <- c(exp, expression( - lc <- xts:::legend.coords("topleft", xlim, c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, legend = c(paste(legend, ":"), sprintf("%.3f",last(vol[xsubset]))), @@ -40,19 +53,6 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") yjust = lc$yjust, bty = "n", y.intersp=0.95))) - exp <- c(expression( - vol <- TA$vol, - # add inbox color - rect(xlim[1], min(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), - xlim[2], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, na.rm=TRUE) * 1.05)), y_grid_lines(c(min(vol, na.rm=TRUE) * 0.95,max(vol, 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(vol, na.rm=TRUE) * 0.95, xlim[2], max(vol, na.rm=TRUE) * 1.05, border=theme$labels)), exp) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -64,10 +64,12 @@ function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto") xsubset <- lchob$Env$xsubset x <- OHLC(x) vol <- volatility(OHLC = x, n = n, calc = calc, N = N) - lchob$Env$TA$vol <- vol + lenv$xdata <- structure(vol, .Dimnames=list(NULL, "vol")) + lenv$vol <- lchob$Env$TA$vol <- vol + lenv$get_frame <- lchob$get_frame if (any(is.na(on))) { - lchob$add_frame(ylim=c(min(vol, na.rm=TRUE) * 0.95, - max(vol, na.rm=TRUE) * 1.05), asp=1, fixed=TRUE) + lchob$add_frame(ylim=c(min(lenv$vol[xsubset], na.rm=TRUE) * 0.95, + max(lenv$vol[xsubset], na.rm=TRUE) * 1.05), asp=1, fixed=FALSE) lchob$next_frame() } else { diff --git a/R/addWPR.R b/R/addWPR.R index b1927a01..f94f12ec 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -5,24 +5,28 @@ lenv <- new.env() lenv$chartWPR <- function(x, n) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xx <- if(is.OHLC(xdata)) { - cbind(Hi(xdata),Lo(xdata),Cl(xdata)) - } else if(is.null(dim(xdata))) { - xdata - } else { - xdata[,1] - } - - - wpr <- WPR(xx,n=n)[xsubset] + wpr <- wpr[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(wpr) - 1) xlim <- x$Env$xlim - ylim <- c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05 + frame <- x$get_frame() + ylim <- x$get_ylim()[[frame]] theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) lines(x.pos,wpr,col=theme$WPR$col,lwd=1,type='l') @@ -34,26 +38,16 @@ exp <- parse(text = gsub("list", "chartWPR", as.expression(substitute(list(x = current.chob(), n = n)))), srcfile = NULL) exp <- c(exp, expression( - text(0, max(abs(wpr), na.rm = TRUE)*.9, - paste("Williams %R (", n,"):", sep = ""), col = theme$fg, - pos = 4), - - text(0, max(abs(wpr), na.rm = TRUE)*.9, - paste("\n\n\n",sprintf("%.3f",last(wpr[xsubset])), sep = ""), col = theme$WPR$col, - pos = 4))) - exp <- c(expression( - wpr <- TA$wpr, - # add inbox color - rect(xlim[1], max(abs(wpr), na.rm = TRUE) * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, col=theme$fill), - # add grid lines and left-side axis labels - segments(xlim[1], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), - xlim[2], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), - col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3), - text(xlim[1], y_grid_lines(c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05), y_grid_lines(c(-0.1, max(abs(wpr), 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], -0.1 * 1.05, xlim[2], max(abs(wpr), na.rm = TRUE) * 1.05, border=theme$labels)), exp) + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("Williams %R (", n,"):", sep = ""), + paste(sprintf("%.3f",last(wpr[xsubset])), sep = "")), + text.col = c(theme$fg, theme$WPR$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) @@ -75,8 +69,10 @@ wpr <- WPR(xx,n=n) - lchob$Env$TA$wpr <- wpr - lchob$add_frame(ylim=c(-0.1, max(abs(wpr), na.rm = TRUE)) * 1.05, asp=1, fixed=TRUE) + lenv$xdata <- structure(wpr, .Dimnames=list(NULL, "wpr")) + lenv$wpr <- lchob$Env$TA$wpr <- wpr + lenv$get_frame <- lchob$get_frame + lchob$add_frame(ylim=c(-0.1, max(abs(lenv$wpr[xsubset]), na.rm = TRUE)) * 1.05, asp=1, fixed=FALSE) lchob$next_frame() lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) lchob diff --git a/R/addZigZag.R b/R/addZigZag.R index f18045c5..cd7661cc 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -10,16 +10,14 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, { lenv <- new.env() lenv$chartZigZag <- function(x, change, percent, retrace, lastExtreme, ..., on, legend) { - xdata <- x$Env$xdata xsubset <- x$Env$xsubset - xdata <- cbind(Hi(xdata),Lo(xdata)) - zigzag <- ZigZag(HL = xdata, change = change, percent = percent, retrace = retrace, - lastExtreme = lastExtreme)[xsubset] + zigzag <- zigzag[xsubset] spacing <- x$Env$theme$spacing x.pos <- 1 + spacing * (1:NROW(zigzag) - 1) xlim <- x$Env$xlim ylim <- c(min(zigzag, na.rm=TRUE)*0.975, max(zigzag, na.rm=TRUE)*1.05) theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines if(any(is.na(on))) { legend.name <- c(paste(legend, ":"), @@ -40,7 +38,6 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, } else { ylim <- x$get_ylim()[[2]] legend.name <- paste(legend, ":", format(last(na.omit(zigzag)),nsmall = 3L)) - yjust <- 1.5 } lines(x.pos, zigzag, col = theme$ZigZag$col, lwd = 4, lend = 2, ...) lc <- xts:::legend.coords("topleft", xlim, ylim) @@ -48,7 +45,7 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, legend = legend.name, text.col = theme$ZigZag$col, xjust = lc$xjust, - yjust = yjust, + yjust = 2, bty = "n", y.intersp=0.95) } @@ -71,7 +68,8 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, x <- cbind(Hi(x),Lo(x)) zigzag <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, lastExtreme = lastExtreme) - lchob$Env$TA$zigzag <- zigzag + lenv$xdata <- structure(zigzag, .Dimnames=list(NULL, "zigzag")) + lenv$zigzag <- lchob$Env$TA$zigzag <- zigzag if (any(is.na(on))) { lchob$add_frame(ylim=c(min(zigzag, na.rm=TRUE)*0.975, From 76395a8a7578202279dc7ae93e6d0056d01e9402 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Thu, 18 Aug 2016 21:53:34 +0800 Subject: [PATCH 10/12] Update bugs for addPoints and addLines Originally, argument "x" is mixed up with the x representing current chart passed to chartPoints and chartLines, which makes points and lines change with "x" continuously whenever new addPoints() and addLines() are called. New arguments are specified to chartPoints and chartLines to distinguish from x representing the current chart. --- R/addTA.R | 65 ++++++++++++++++++++++++++----------------------------- 1 file changed, 31 insertions(+), 34 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index 76e76779..dbe797ed 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1646,55 +1646,53 @@ function(x) { if(missing(v)) v <- NULL lenv <- new.env() - lenv$chartLines <- function(x, h, v, on, overlay, col) { - xdata <- x$Env$xdata + lenv$chartLines <- function(x, series, h, v, on, overlay, col) { xsubset <- x$Env$xsubset - xdata <- cbind(Hi(xdata),Lo(xdata)) - lines <- x$Env$TA$lines[xsubset] + series <- series[which(.index(series) %in% .index(x$Env$xdata[xsubset]))] + x.points <- which(.index(x$Env$xdata[xsubset]) %in% .index(series)) spacing <- x$Env$theme$spacing xlim <- x$Env$xlim ylim <- x$get_ylim()[[abs(on)+1L]] theme <- x$Env$theme - y_grid_lines <- x$Env$y_grid_lines + y_grid_series <- x$Env$y_grid_series if(!overlay) { - ylim <- range(lines[,1], na.rm=TRUE) * 1.05 + ylim <- range(series[,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), + # add grid series and left-side axis labels + segments(xlim[1], y_grid_series(ylim), + xlim[2], y_grid_series(ylim), col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) - text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + text(xlim[1], y_grid_series(ylim), y_grid_series(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 - x.pos <- 1 + spacing * (1:nrow(lines) - 1) - lines(x.pos, lines[,1],col=col) + if(!is.null(series)) { + # draw series given positions specified in x + lines(x.points,series[,1],col=col) } if(!is.null(h)) { - # draw horizontal lines given positions specified in h + # draw horizontal series 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 + # draw vertical series 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)) + }, names(list(x = x, h = h, v = v, on = on, overlay = overlay, col = col)), + list(x = x, h = h, v = v, on = on, overlay = overlay, col = col)) exp <- parse(text = gsub("list", "chartLines", as.expression(substitute(list(x = current.chob(), + series = get("x"), h = h, v = v, on = on, overlay = overlay, col = col)))), srcfile = NULL) lchob <- current.chob() ncalls <- length(lchob$Env$call_list) lchob$Env$call_list[[ncalls + 1]] <- match.call() - lchob$Env$TA$lines <- x if(overlay) { lchob$set_frame(sign(on)*(abs(on)+1L)) @@ -1738,16 +1736,15 @@ function(x) { on=1,overlay=TRUE) { lenv <- new.env() - lenv$chartPoints <- function(x, type, pch, offset, col, bg, cex, on, overlay) { + lenv$chartPoints <- function(x, x.points, y.points, type, pch, offset, col, bg, cex, on, overlay) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset - if(is.xts(x$Env$x.points)) { - y.points <- x$Env$x.points[.index(x$Env$x.points) %in% .index(xdata[xsubset])] - x.points <- which(.index(xdata[xsubset]) %in% .index(x$Env$x.points)) + if(is.xts(x.points)) { + y.points <- x.points[.index(x.points) %in% .index(xdata[xsubset])] + x.points <- which(.index(xdata[xsubset]) %in% .index(x.points)) } else { - x.points <- which(.index(xdata[xsubset]) %in% .index(xdata[x$Env$x.points])) - y.points <- x$Env$y.points + x.points <- which(.index(xdata[xsubset]) %in% .index(xdata[x.points])) } spacing <- x$Env$theme$spacing # if OHLC and above - get Hi, else Lo @@ -1758,7 +1755,10 @@ function(x) { } else Lo(xdata) } else xdata - if(is.null(y.points)) y.points <- y.data[x.points] * offset + if(is.null(y.points)) + y.points <- y.data[x.points] * offset + else + y.points <- y.points[.index(y.points) %in% .index(xdata[xsubset])] * offset if(!overlay) { xlim <- x$Env$xlim @@ -1782,11 +1782,12 @@ function(x) { points(x=x.points, 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)) + names(list(x = x, y = y, type = type, pch = pch, offset = offset, + col = col, bg = bg, cex = cex, on = on, overlay = overlay)), + list(x = x, y = y, 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(), + x.points=get("x"), y.points=get("y"), type = type, pch = pch, offset = offset, col = col, bg = bg, cex = cex, on = on, overlay = overlay)))), srcfile=NULL) @@ -1798,10 +1799,6 @@ function(x) { if(!is.null(y)) if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') - - lchob$Env$x.points <- x - lchob$Env$y.points <- y - if(overlay) lchob$set_frame(on+1) From 1eed85fb2a9d99d52262f535b3433622d67691a1 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Fri, 19 Aug 2016 15:40:54 +0800 Subject: [PATCH 11/12] Update bug for addShading function Apply "col" setting to shading regime. --- R/addTA.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/addTA.R b/R/addTA.R index dbe797ed..35f252ac 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -1593,12 +1593,12 @@ function(x) { 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(xlim[1], ylim[1], xlim[2], ylim[2], col=col, 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) + col=col,border=NA) } mapply(function(name, value) { assign(name, value, envir = lenv) From 1559d583e2aca595b88e183f2b445a7193791293 Mon Sep 17 00:00:00 2001 From: Eric Hung Date: Sat, 20 Aug 2016 12:27:39 +0800 Subject: [PATCH 12/12] Update bugs for addVo Match the laegend color of last volume in subset period with the last bar color. Update the legend volume to be in millions. --- R/addVo.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/addVo.R b/R/addVo.R index 0be63734..6fdeb430 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -57,8 +57,8 @@ frame <- get_frame(), lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), legend(x = lc$x, y = lc$y, - legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(vo[xsubset]),big.mark=',')), - text.col = c(theme$fg, last(theme$bar.col)), + legend = c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(TA$vo[xsubset]),big.mark=',')), + text.col = c(theme$fg, last(theme$bar.col[xsubset])), xjust = lc$xjust, yjust = lc$yjust, bty = "n",