diff --git a/R/addAroon.R b/R/addAroon.R index 8f54022d..b3fcf355 100644 --- a/R/addAroon.R +++ b/R/addAroon.R @@ -8,79 +8,155 @@ `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) { + xsubset <- x$Env$xsubset + 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, ...) + 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( + 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)), + 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, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + 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)) + xsubset <- lchob$Env$xsubset + Aroon <- aroon(HL=xdata,n=n)[,-3] + 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() } 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) { + xsubset <- x$Env$xsubset + AroonOsc <- AroonOsc[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(AroonOsc) - 1) + xlim <- x$Env$xlim + 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, ...) } - 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( + 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))), + text.col = c(theme$fg, theme$Aroon$col$aroonOsc), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (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 } - 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)[,3] + 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(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 { - 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..d69abb1c 100644 --- a/R/addCLV.R +++ b/R/addCLV.R @@ -7,45 +7,72 @@ `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) { + xsubset <- x$Env$xsubset + clv <- clv[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(clv) - 1) + xlim <- x$Env$xlim + 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, ...) } - 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( + 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))), + text.col = c(theme$fg, theme$CLV$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$CLV)) { + lchob$Env$theme$CLV$col <- 5 + } + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + clv <- CLV(HLC=HLC(xdata)) + 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(lenv$clv[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) + 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..7e591652 100644 --- a/R/addCMF.R +++ b/R/addCMF.R @@ -2,41 +2,76 @@ # addCMF {{{ `addCMF` <- function(n=20) { - lchob <- get.current.chob() + lenv <- new.env() + lenv$chartCMF <- function(x, n) { + xsubset <- x$Env$xsubset + cmf <- cmf[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cmf) - 1) + xlim <- x$Env$xlim + 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") - 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( + 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 = "")), + text.col = c(theme$fg, ifelse(last(cmf[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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + 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) + 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(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 } #}}} # chartCMF {{{ `chartCMF` <- diff --git a/R/addCMO.R b/R/addCMO.R index fb0f5a2e..5d91a303 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) + lenv <- new.env() + lenv$chartCMO <- function(x, n) { + xsubset <- x$Env$xsubset + cmo <- cmo[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cmo) - 1) + xlim <- x$Env$xlim + 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) + } + 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( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + 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))) + + 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" + } - chobTA <- new("chobTA") - chobTA@new <- TRUE + 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) - } + 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 } #}}} # chartCMO {{{ `chartCMO` <- diff --git a/R/addChaikin.R b/R/addChaikin.R index 4e836101..026eae3b 100644 --- a/R/addChaikin.R +++ b/R/addChaikin.R @@ -9,87 +9,147 @@ `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) { + xsubset <- x$Env$xsubset + ChaikinAD <- ChaikinAD[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(ChaikinAD) - 1) + xlim <- x$Env$xlim + 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, ...) } - 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( + 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))), + text.col = c(theme$fg, theme$ChAD$col$chaikinAD), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ChAD)) { + lchob$Env$theme$ChAD$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) + 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(lenv$ChaikinAD[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) + 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) { + xsubset <- x$Env$xsubset + ChaikinVol <- ChaikinVol[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(ChaikinVol) - 1) + xlim <- x$Env$xlim + 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, ...) } - 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( + 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(ChaikinVol[xsubset])))), + text.col = c(theme$fg, theme$ChVol$col$chaikinVol), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ChVol)) { + lchob$Env$theme$ChVol$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) + 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(lenv$ChaikinVol[xsubset],na.rm=TRUE),asp=1,fixed=FALSE) + 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..1eeafba0 100644 --- a/R/addEMV.R +++ b/R/addEMV.R @@ -8,45 +8,81 @@ 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 + lenv <- new.env() + lenv$chartEMV <- function(x, volume, n, maType, vol.divisor, ..., on, legend) { + xsubset <- x$Env$xsubset + emv <- emv[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(emv) - 1) + xlim <- x$Env$xlim + 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, ...) } - else { - chobTA@new <- FALSE - chobTA@on <- on + 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 } - 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( + 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]))), + paste("maEMV :", sprintf("%.3f",last(emv$maEMV[xsubset])))), + text.col = c(theme$fg, theme$EMV$col$emv, theme$EMV$col$maEMV), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + emv <- EMV(HL = HLC(xdata)[,-3], volume = volume, n = n, maType = maType, + vol.divisor = vol.divisor) + 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(lenv$emv[xsubset],na.rm=TRUE)*1.05,asp=1,fixed=FALSE) + 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..e3a45d2d 100644 --- a/R/addKST.R +++ b/R/addKST.R @@ -9,46 +9,81 @@ 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) - x <- coredata(Cl(x)) - x <- 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 + lenv <- new.env() + lenv$chartKST <- function(x, n, nROC, nSig, maType, wts, ..., on, legend) { + xsubset <- x$Env$xsubset + kst <- kst[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(kst) - 1) + xlim <- x$Env$xlim + 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, ...) } - else { - chobTA@new <- FALSE - chobTA@on <- on + 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( + 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)), + paste("signal :",format(last(kst[xsubset,2]),nsmall = 3L))), + text.col = c(theme$fg, theme$KST$col$kst, theme$KST$col$signal), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$KST)) { + lchob$Env$theme$KST$col$kst <- 6 + lchob$Env$theme$KST$col$signal <- 7 } - 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) + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- Cl(x) + kst <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType, + wts = wts) + 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(lenv$kst[xsubset], na.rm=TRUE) * 1.05,asp=1,fixed=FALSE) + 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 +} \ No newline at end of file diff --git a/R/addMFI.R b/R/addMFI.R index 923877df..8ebacff4 100644 --- a/R/addMFI.R +++ b/R/addMFI.R @@ -7,45 +7,74 @@ `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 + lenv <- new.env() + lenv$chartMFI <- function(x, n, ..., on, legend) { + xsubset <- lchob$Env$xsubset + mfi <- mfi[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(mfi) - 1) + xlim <- x$Env$xlim + 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, ...) } - else { - chobTA@new <- FALSE - chobTA@on <- on + 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( + 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))), + text.col = c(theme$fg, theme$MFI$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$MFI)) { + lchob$Env$theme$MFI$col <- 8 } - 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) + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + volume <- lchob$Env$vo + x <- HLC(x) + mfi <- MFI(HLC = x, volume = volume, n = n) + 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=range(lenv$mfi[xsubset], na.rm=TRUE),asp=1,fixed=FALSE) + 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..0d7d8533 100644 --- a/R/addOBV.R +++ b/R/addOBV.R @@ -7,43 +7,72 @@ `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 + 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 = theme$OBV$col, lwd = 1, lend = 2, ...) + } - else { - chobTA@new <- FALSE - chobTA@on <- on + 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[xsubset]),nsmall = 3L))), + text.col = c(theme$fg, theme$OBV$col), + xjust = lc$xjust, + yjust = lc$yjust, + 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 + 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() + 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 } - 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) + x <- try.xts(lchob$Env$xdata, error=FALSE) + xsubset <- lchob$Env$xsubset + vo <- lchob$Env$vo + 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) + 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..da7ad1c3 100644 --- a/R/addSMI.R +++ b/R/addSMI.R @@ -3,12 +3,78 @@ `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 + + 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) { + 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( + 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[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 = theme$SMI$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 + 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() + 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 xx <- if(is.OHLC(x)) { cbind(Hi(x),Lo(x),Cl(x)) @@ -20,33 +86,13 @@ 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) - #} + 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) + 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..35f252ac 100644 --- a/R/addTA.R +++ b/R/addTA.R @@ -15,46 +15,81 @@ # 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) { + xsubset <- lchob$Env$xsubset + + mom <- mom[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(mom) - 1) + xlim <- x$Env$xlim + 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') + + } + 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( + 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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$Momentum)) { + lchob$Env$theme$Momentum$col <- "#0033CC" + } - # 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) - } + 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(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 } #}}} # chartMomentum {{{ `chartMomentum` <- @@ -100,41 +135,87 @@ 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) { + xsubset <- x$Env$xsubset + cci <- cci[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(cci) - 1) + xlim <- x$Env$xlim + 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) + cci.below <- ifelse(cci <= -100,cci,-100) + + 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=theme$CCI$col,lwd=1,type='l') + + } + 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 + 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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$CCI)) { + lchob$Env$theme$CCI$col <- 'red' + } - 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) - } + 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 } #}}} # chartCCI {{{ `chartCCI` <- @@ -194,40 +275,86 @@ function(x) { # addADX {{{ `addADX` <- function(n=14, maType="EMA", wilder=TRUE) { + lenv <- new.env() + lenv$chartADX <- function(x, n, maType, wilder) { + xsubset <- x$Env$xsubset + adx <- adx[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(adx) - 1) + xlim <- x$Env$xlim + 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') + # draw DIn + lines(x.pos,adx[,2],col=theme$ADX$col$DIn,lwd=1,type='l') + # draw ADX + lines(x.pos,adx[,4],col=theme$ADX$col$adx,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) + 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) + 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' + } - 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) - } + 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 } #}}} # chartADX {{{ `chartADX` <- @@ -267,40 +394,71 @@ function(x) { # addATR {{{ `addATR` <- function(n=14, maType="EMA", ...) { + lenv <- new.env() + lenv$chartATR <- function(x, n, maType) { + xsubset <- x$Env$xsubset + atr <- atr[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(atr) - 1) + xlim <- x$Env$xlim + 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') + } + 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) + 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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$ATR)) { + lchob$Env$theme$ATR$col <- 'blue' + } - 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) - } + 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 } #}}} # chartATR {{{ `chartATR` <- @@ -334,42 +492,80 @@ 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) { + xsubset <- x$Env$xsubset + + 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 + 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') + # draw Signal + lines(x.pos,trix[,2],col=theme$TRIX$col$signal,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) + 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) + 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' + } - 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) - } + 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 } #}}} # chartTRIX {{{ `chartTRIX` <- @@ -408,13 +604,66 @@ 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) { + xsubset <- x$Env$xsubset + dpo <- dpo[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(dpo) - 1) + xlim <- x$Env$xlim + 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 + 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") + + } + 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) + 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("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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() - 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)) { @@ -422,30 +671,14 @@ function(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) - } + 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=FALSE) + lchob$next_frame() + lchob$replot(exp, env=c(lenv,lchob$Env), expr=TRUE) + lchob } #}}} # chartDPO {{{ `chartDPO` <- @@ -514,41 +747,75 @@ 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) { + xsubset <- x$Env$xsubset + rsi <- rsi[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(rsi) - 1) + xlim <- x$Env$xlim + 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') + + } + 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) + 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("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) + 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 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) - } + 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 } #}}} # chartRSI {{{ `chartRSI` <- @@ -594,42 +861,70 @@ 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) { + xsubset <- x$Env$xsubset + + roc <- roc[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(roc) - 1) + xlim <- x$Env$xlim + 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') + } + 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) + 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) - 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) + 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 } #}}} # chartROC {{{ `chartROC` <- @@ -660,44 +955,180 @@ 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) { + xsubset <- x$Env$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 + 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 + 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') { + 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), + 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 + + lines(x.pos, bb[,4], col=bband.col[4],lwd=1) + + 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), + 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 + lines(x.pos, bbw, col=bband.col[5],lwd=1) + + 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) { + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + 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 + 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) + 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) + + } else + if(draw == 'percent') { + # draw %B in new frame + 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 + + 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) + lchob } #}}} # chartBBands {{{ `chartBBands` <- @@ -806,44 +1237,76 @@ 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))[xsubset] + + 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=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=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') + } + + 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 = 2, + 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() + 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' + } - 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$TA$mae <- mae + lchob$set_frame(sign(on)*(abs(on)+1L)) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartEnvelope {{{ `chartEnvelope` <- @@ -884,41 +1347,35 @@ 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) - - chobTA <- new("chobTA") - chobTA@new <- FALSE + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + + 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$TA$sar <- sar + lchob$set_frame(2) + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + lchob } #}}} # chartSAR {{{ `chartSAR` <- @@ -940,37 +1397,84 @@ function(x) { `addMACD` <- function(fast=12,slow=26,signal=9,type='EMA',histogram=TRUE,col) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + + lenv <- new.env() + lenv$chartMACD <- function(x, fast, slow, signal, type, histogram, col) { + xsubset <- x$Env$xsubset + + macd <- macd[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(macd) - 1) + xlim <- x$Env$xlim + 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) + } - chobTA <- new("chobTA") - chobTA@new <- TRUE + lines(x.pos,macd[,1],col=col[3],lwd=1) + lines(x.pos,macd[,2],col=col[4],lwd=1,lty='dotted') + + } + 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)), + 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( + 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 = ""), + 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, + bty='n', + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() - col <- if(missing(col)) col <- c('#999999','#777777', - '#BBBBBB','#FF0000') + 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) + 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 } #}}} # chartMACD {{{ `chartMACD` <- @@ -1031,69 +1535,90 @@ 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 + y_grid_lines <- x$Env$y_grid_lines + spacing <- theme$spacing + width <- theme$width i <- when - indexClass(x) <- "POSIXct" - POSIXindex <- index(x) + indexClass(xdata) <- "POSIXct" + POSIXindex <- index(xdata) if (missing(i)) - i <- 1:NROW(x) + i <- 1:NROW(xdata) if (timeBased(i)) - i <- as.character(as.POSIXct(i)) + i <- as.character(as.POSIXct(i)) if (is.character(i)) { - i <- strsplit(i, ';')[[1]] - i.tmp <- NULL - for (ii in i) { - if (!identical(grep("::", ii), integer(0))) { - dates <- strsplit(ii, "::")[[1]] - first.time <- ifelse(dates[1] == "", POSIXindex[1], - do.call("firstof", as.list(as.numeric(strsplit(dates[1], - ":|-|/| ")[[1]])))) - last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)], - do.call("lastof", as.list(as.numeric(strsplit(dates[2], - ":|-|/| ")[[1]])))) - } - else { - dates <- ii - first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates, - ":|-|/| ")[[1]]))) - last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates, - ":|-|/| ")[[1]]))) - } - i.tmp <- c(i.tmp, which(POSIXindex <= last.time & - POSIXindex >= first.time)) + i <- strsplit(i, ';')[[1]] + i.tmp <- NULL + for (ii in i) { + if (!identical(grep("::", ii), integer(0))) { + dates <- strsplit(ii, "::")[[1]] + first.time <- ifelse(dates[1] == "", POSIXindex[1], + do.call("firstof", as.list(as.numeric(strsplit(dates[1], + ":|-|/| ")[[1]])))) + last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)], + do.call("lastof", as.list(as.numeric(strsplit(dates[2], + ":|-|/| ")[[1]])))) + } + else { + dates <- ii + first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates, + ":|-|/| ")[[1]]))) + last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates, + ":|-|/| ")[[1]]))) } - i <- i.tmp + i.tmp <- c(i.tmp, which(POSIXindex <= last.time & + POSIXindex >= first.time)) + } + i <- i.tmp } - - xstart <- unique(c(i[1],i[which(diff(i) != 1)+1])) - xend <- unique(c(i[which(diff(i) != 1)-1], rev(i)[1])) - - 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], 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=col,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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + + 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 +1645,63 @@ 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, series, h, v, on, overlay, col) { + xsubset <- x$Env$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_series <- x$Env$y_grid_series + + if(!overlay) { + 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 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_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(series)) { + # draw series given positions specified in x + lines(x.points,series[,1],col=col) + } + if(!is.null(h)) { + # draw horizontal series given positions specified in h + segments(xlim[1],h,xlim[2],h,col=col) + } + if(!is.null(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(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() + + 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` <- @@ -1176,51 +1731,83 @@ 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) { - lchob <- get.current.chob() - xdata <- as.matrix(lchob@xdata) - - chobTA <- new("chobTA") - chobTA@new <- !overlay - + lenv <- new.env() + 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.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.points])) + } + 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 + else + y.points <- y.points[.index(y.points) %in% .index(xdata[xsubset])] * offset + + if(!overlay) { + 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 + 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.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(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) + 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 - 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 + if(!is.null(y)) if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths') - x <- x[xsubset] - if(!is.null(y)) - y <- y[xsubset] - - - 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 +1849,114 @@ 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 + 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.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$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 + + # 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 + spacing <- x$Env$theme$spacing + 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])[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 + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(on==1) { - x <- as.matrix(lchob@xdata) - + 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 { - # 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] + 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 <- EMA(x.tmp,n=n[i],wilder=wilder[1], - ratio=ratio[1]) - ma.tmp <- cbind(ma.tmp,ma) + ratio=ratio[1])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) } - - 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$Env$TA$ema <- ma.tmp + if(overlay) + lchob$set_frame(on+1) + else { + 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 } # }}} # chartEMA {{{ `chartEMA` <- @@ -1369,61 +2004,104 @@ 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 + 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$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 + +# 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 + spacing <- x$Env$theme$spacing + 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 + + 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])[xsubset] + ma.tmp <- cbind(ma.tmp,ma) + + lines(x.pos,ma,col=colors[i],lwd=1,type='l') + } + } + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(on==1) { - x <- as.matrix(lchob@xdata) - + 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 { - # 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] + 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]) + ma <- SMA(x.tmp,n=n[i])[xsubset] ma.tmp <- cbind(ma.tmp,ma) } - - 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) + lchob$Env$TA$sma <- ma.tmp + + 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 +2145,101 @@ 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 + 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$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 + + # 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 + spacing <- x$Env$theme$spacing + 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 <- 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') + } + } + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(on==1) { - x <- as.matrix(lchob@xdata) - + 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 { - # 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] + 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) } - - 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) - } + xsubset <- lchob$Env$xsubset + + 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 { + 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 +2261,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 +2275,108 @@ 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 + 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$TA)) == tolower(name.TA)) + target.TA <- names(x$Env$TA)[which.TA] + xdata <- get(target.TA, pos = x$Env$TA) - # get the appropriate data - from the approp. src + 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 + spacing <- x$Env$theme$spacing + 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])[xsubset] +# 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') + } + } + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(on==1) { - x <- as.matrix(lchob@xdata) - + 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 { - # 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] + 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) } - - 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) + 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 { - 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 } # }}} # chartDEMA {{{ `chartDEMA` <- @@ -1635,56 +2412,116 @@ 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 + 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 <- 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$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 + +# if(is.function(with.col)) { +# x.tmp <- do.call(with.col,list(xdata)) +# } else x.tmp <- xdata[,with.col] + x.tmp <- xdata + } + x.tmp <- cbind(x.tmp, vo) + + if(!has.Vo(x.tmp)) return() + + xsubset <- x$Env$xsubset + spacing <- x$Env$theme$spacing + 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])[xsubset] + # 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') + } + } + 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + vo <- lchob$Env$vo if(on==1) { - x <- as.matrix(lchob@xdata) - + x <- lchob$Env$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)) + 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 + 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) - 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 <- EVWMA(x.tmp[, 1],x.tmp[, 2],n=n[li])[xsubset] + ma.tmp <- cbind(ma.tmp, ma) } - 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) + lchob$Env$TA$evwma <- ma.tmp + if(overlay) { + lchob$set_frame(on+1) } 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 } # }}} # chartEVWMA {{{ `chartEVWMA` <- @@ -1720,59 +2557,112 @@ 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 + 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$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 - # get the appropriate data - from the approp. src +# 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 + spacing <- x$Env$theme$spacing + 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)[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) + + 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, 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() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() if(on==1) { - x <- as.matrix(lchob@xdata) - + 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 { - # 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 - - 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] + 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) } - - 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) - } + xsubset <- lchob$Env$xsubset + + 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 { + 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 +2696,35 @@ 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() + 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) + lchob } # }}} # chartExpiry {{{ `chartExpiry` <- diff --git a/R/addTDI.R b/R/addTDI.R index 07b444ad..35f828ac 100644 --- a/R/addTDI.R +++ b/R/addTDI.R @@ -7,43 +7,76 @@ `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] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" - if (any(is.na(on))) { - chobTA@new <- TRUE + lenv <- new.env() + lenv$chartTDI <- function(x, n, multiple, ..., on, legend) { + xsubset <- x$Env$xsubset + tdi <- tdi[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(tdi) - 1) + xlim <- x$Env$xlim + 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, ...) + } - else { - chobTA@new <- FALSE - chobTA@on <- on + 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( + 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)), + paste("di :",format(last(tdi[xsubset,1]),nsmall = 3L))), + text.col = c(theme$fg, theme$TDI$col$tdi, theme$TDI$col$di), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$TDI)) { + lchob$Env$theme$TDI$col$tdi <- 5 + lchob$Env$theme$TDI$col$di <- 6 } - 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) + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- Cl(x) + tdi <- TDI(price = x, n = n, multiple = multiple) + 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(lenv$tdi[xsubset], na.rm=TRUE)*1.05, asp=1, fixed=FALSE) + 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..6fdeb430 100644 --- a/R/addVo.R +++ b/R/addVo.R @@ -1,83 +1,129 @@ # 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) - 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") + lenv <- new.env() - if(lchob@color.vol & is.OHLC(x)) { + lenv$chartVo <- function(x) { + xdata <- x$Env$xdata + xsubset <- x$Env$xsubset + vo <- x$Env$TA$vo[xsubset] + + spacing <- x$Env$theme$spacing + width <- x$Env$theme$width + + x.pos <- 1 + spacing * (1:NROW(vo) - 1) + xlim <- x$Env$xlim + 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 + + # multi.col <- x$Env$multi.col + color.vol <- x$Env$color.vol + log.scale <- ifelse(x$Env$log.scale,"y","") + + bar.col <- if(color.vol) { + theme$bar.col[xsubset] + } else theme$border.col[xsubset] + + border.col <- theme$border.col[xsubset] + + if(x$Env$theme$thin) { + # plot thin volume bars if appropriate + segments(x.pos,ylim[1],x.pos,vo,col=bar.col) + } else { + rect(x.pos-spacing/3,ylim[1],x.pos+spacing/3,vo, + col=bar.col,border=border.col) + } + } + + exp <- parse(text=gsub("list","chartVo",as.expression(substitute(list(x=current.chob(),...)))), + srcfile=NULL) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste("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", + y.intersp=0.95))) + + 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 + + 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) - - bar.col <- bar.col[lchob@xsubset] - - chobTA <- new("chobTA") - chobTA@new <- TRUE - - chobTA@TA.values <- (Volumes/vol.scale[[1]])[lchob@xsubset] - chobTA@name <- "chartVo" - chobTA@call <- match.call() + # 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(xdata[,1])), + bar.col,lchob$Env$theme$border) - 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$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$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 + 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..4f470b49 100644 --- a/R/addVolatility.R +++ b/R/addVolatility.R @@ -7,43 +7,74 @@ `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) { + xsubset <- x$Env$xsubset + vol <- vol[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(vol) - 1) + xlim <- x$Env$xlim + 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, ...) + } - 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, 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( + 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]))), + text.col = c(theme$fg, theme$Volatility$col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$Vol)) { + lchob$Env$theme$Volatility$col <- 8 } - 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) + x <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + x <- OHLC(x) + vol <- volatility(OHLC = x, n = n, calc = calc, N = N) + 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(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 { - 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..f94f12ec 100644 --- a/R/addWPR.R +++ b/R/addWPR.R @@ -3,12 +3,61 @@ `addWPR` <- function(n=14) { - lchob <- get.current.chob() - - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartWPR <- function(x, n) { + xsubset <- x$Env$xsubset + + wpr <- wpr[xsubset] + spacing <- x$Env$theme$spacing + x.pos <- 1 + spacing * (1:NROW(wpr) - 1) + xlim <- x$Env$xlim + 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') + + } + 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( + 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) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if (is.null(lchob$Env$theme$WPR)) { + lchob$Env$theme$WPR$col <- "#0033CC" + } - 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)) @@ -20,29 +69,13 @@ 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) - } + 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 } #}}} # chartWPR {{{ `chartWPR` <- diff --git a/R/addZigZag.R b/R/addZigZag.R index 7d18ae6d..cd7661cc 100644 --- a/R/addZigZag.R +++ b/R/addZigZag.R @@ -8,44 +8,77 @@ function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE, ..., on = -1, legend = "auto") { - lchob <- get.current.chob() - x <- as.matrix(lchob@xdata) + lenv <- new.env() + lenv$chartZigZag <- function(x, change, percent, retrace, lastExtreme, ..., on, legend) { + xsubset <- x$Env$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, ":"), + 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)) + } + 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 = theme$ZigZag$col, + xjust = lc$xjust, + yjust = 2, + bty = "n", + y.intersp=0.95) + } + 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() + 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)) - x <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace, + zigzag <- 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] - } - else chobTA@TA.values <- x[lchob@xsubset, ] - chobTA@name <- "chartTA" + lenv$xdata <- structure(zigzag, .Dimnames=list(NULL, "zigzag")) + lenv$zigzag <- lchob$Env$TA$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 }