diff --git a/R/TA.R b/R/TA.R index 00c28461..e216f70c 100644 --- a/R/TA.R +++ b/R/TA.R @@ -38,42 +38,114 @@ function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) { plot(do.call(paste('add',ta,sep=''),list(...))) } else stop(paste('no TA method found for',paste('add',ta,sep=''))) } else { - lchob <- get.current.chob() - chobTA <- new("chobTA") - if(any(is.na(on))) { - chobTA@new <- TRUE - } else { - chobTA@new <- FALSE - chobTA@on <- on + lenv <- new.env() + lenv$chartTA <- function(x, ta, order, on, legend, yrange, ...) { + xsubset <- x$Env$xsubset + if(!is.null(order)) ta <- ta[,order] + if(all(is.na(on))) { + xlim <- x$Env$xlim + frame <- x$get_frame() + print(frame) + ylim <- x$get_ylim()[[frame]] + theme <- x$Env$theme + y_grid_lines <- x$Env$y_grid_lines + + # add inbox color + rect(xlim[1], ylim[1], xlim[2], ylim[2], col=theme$fill) + # add grid lines and left-side axis labels + segments(xlim[1], y_grid_lines(ylim), + xlim[2], y_grid_lines(ylim), + col = theme$grid, lwd = x$Env$grid.ticks.lwd, lty = 3) + text(xlim[1], y_grid_lines(ylim), y_grid_lines(ylim), + col = theme$labels, srt = theme$srt, + offset = 0.5, pos = 2, cex = theme$cex.axis, xpd = TRUE) + # add border of plotting area + rect(xlim[1], ylim[1], xlim[2], ylim[2], border=theme$labels) + } + if(is.logical(ta)) { + ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset] + shade <- shading(as.logical(ta,drop=FALSE)) + if(length(shade$start) > 0) # all FALSE cause zero-length results + rect(shade$start-1/3, ylim[1] ,shade$end+1/3, ylim[2], col=theme$BBands$col$fill,...) + } else { + # we can add points that are not necessarily at the points + # on the main series + subset.range <- paste(start(xdata[xsubset]), + end(xdata[xsubset]),sep="/") + ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]), + .index(xdata[xsubset]), tzone=indexTZ(xdata)),ta)[subset.range] + ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) + ta.y <- ta.adj[,-1] + for(i in 1:NCOL(ta.y)) + lines(ta.x, as.numeric(ta.y[,i]), ...) + } } - nrc <- NROW(lchob@xdata) + if(!is.character(legend) || legend == "auto") + legend <- gsub("^add", "", deparse(match.call())) + # map all passed args (if any) to 'lenv' environment + mapply(function(name,value) { assign(name,value,envir=lenv) }, + names(list(ta=ta,order=order,on=on,legend=legend,yrange=yrange,...)), + list(ta=ta,order=order,on=on,legend=legend,yrange=yrange,...)) + exp <- parse(text=gsub("list","chartTA", + as.expression(substitute(list(x=current.chob(), + ta=get("ta"),order=order, + on=on,legend=legend, + yrange=yrange,...)))), + srcfile=NULL) + exp <- c(exp, expression( + frame <- get_frame(), + lc <- xts:::legend.coords("topleft", xlim, ylim[[frame]]), + legend(x = lc$x, y = lc$y, + legend = c(paste(legend, ":"), + paste(sprintf("%.3f", last(ta)))), + text.col = c(theme$fg, col), + xjust = lc$xjust, + yjust = lc$yjust, + bty = "n", + y.intersp=0.95))) + + lchob <- current.chob() + ncalls <- length(lchob$Env$call_list) + lchob$Env$call_list[[ncalls + 1]] <- match.call() + if(!hasArg(col)) lenv$col <- lchob$Env$theme$BBands$col$ma + xdata <- lchob$Env$xdata + xsubset <- lchob$Env$xsubset + nrc <- NROW(xdata) ta <- try.xts(ta, error=FALSE) if(is.xts(ta)) { - x <- merge(lchob@xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE)) + x <- merge(xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE)) } else { if(NROW(ta) != nrc) stop('non-xtsible data must match the length of the underlying series') - x <- merge(lchob@xdata, ta, join='left', retside=c(FALSE,TRUE)) + x <- merge(xdata, ta, join='left', retside=c(FALSE,TRUE)) } if(is.logical(ta)) x <- as.logical(x, drop=FALSE) #identical to storage.mode(x)<-"logical" - - chobTA@TA.values <- coredata(x)[lchob@xsubset,] - chobTA@name <- "chartTA" - chobTA@call <- match.call() - chobTA@params <- list(xrange=lchob@xrange, - yrange=yrange, - colors=lchob@colors, - spacing=lchob@spacing, - width=lchob@width, - bp=lchob@bp, - isLogical=is.logical(ta), - x.labels=lchob@x.labels, - order=order,legend=legend, - pars=list(list(...)), - time.scale=lchob@time.scale) + + lenv$xdata <- structure(x, .Dimnames=list(NULL, names(x))) + lenv$ta <- lchob$Env$TA$ta <- x + lenv$get_frame <- lchob$get_frame + if(all(is.na(on))) { + if(missing(yrange)) + lchob$add_frame(ylim=range(lenv$ta[xsubset],na.rm=TRUE), asp=1) + else { + lchob$add_frame(ylim=lenv$yrange, asp=1) + } + lchob$next_frame() + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + } + else { + for(i in seq_along(on)) { + lchob$set_frame(on[i]+1L) + if(!missing(yrange)) { + frame <- lchob$get_frame() + lchob$Env$ylim[[frame]] <- structure(yrange, fixed=FALSE) + } + lchob$replot(exp, env=c(lenv, lchob$Env), expr=TRUE) + } + } # if(is.null(sys.call(-1))) { # TA <- lchob@passed.args$TA # lchob@passed.args$TA <- c(TA,chobTA) @@ -82,7 +154,7 @@ function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) { # #quantmod:::chartSeries.chob(lchob) # invisible(chobTA) # } else { - return(chobTA) + lchob # } } }#}}} @@ -286,9 +358,11 @@ function(type=c('chartSeries','barChart','candleChart')) { }# }}} # listTA {{{ `listTA` <- -function(dev) { - if(missing(dev)) dev <- dev.cur() - sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call) +function(chob) { + if(missing(chob)) chob <- get.chob() + # return function calls of addTA + chob$Env$call_list[-1] + #sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call) } # }}} chartNULL <- function(...) return(invisible(NULL)) diff --git a/R/chob.R b/R/chob.R index e2db7e45..e1a126b2 100644 --- a/R/chob.R +++ b/R/chob.R @@ -27,7 +27,7 @@ function(x,pos) `get.chob` <- function() { - x <- .chob$.chob + x <- xts:::.plotxtsEnv$.xts_chob return(x) #x <- get('.chob',as.environment("package:quantmod")) #attr(x,'.Environment') <- NULL diff --git a/R/dropTA.R b/R/dropTA.R index 7c493d71..9541bd8a 100644 --- a/R/dropTA.R +++ b/R/dropTA.R @@ -1,13 +1,13 @@ `swapTA` <- -function(ta1,ta2,occ1=1,occ2=1,dev) { +function(ta1,ta2,occ1=1,occ2=1,chob) { if(missing(ta1) | missing(ta2)) stop("two TA indicator required") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) + # default to the current chob if none specified + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) # get the current chob - lchob <- get.chob()[[dev]] + lchob <- chob # make indicator name match original call if(regexpr("^add",ta1) == -1) ta1 <- paste("add",ta1,sep='') @@ -19,29 +19,40 @@ function(ta1,ta2,occ1=1,occ2=1,dev) { which.ta2 <- which(ta2==sapply(ta.list, function(x) deparse(x[[1]])))[occ2] - tmp.ta1 <- lchob@passed.args$TA[[which.ta1]] - tmp.ta2 <- lchob@passed.args$TA[[which.ta2]] - - lchob@passed.args$TA[[which.ta1]] <- tmp.ta2 - lchob@passed.args$TA[[which.ta2]] <- tmp.ta1 + ### swap two TAs without temporary storage + + ta.seq <- seq_along(ta.list) + ta.swap <- replace(ta.seq, c(which.ta1, which.ta2), ta.seq[c(which.ta2, which.ta1)]) + lchob$Env$TA <- lchob$Env$TA[ta.swap] + lchob$Env$call_list[-1] <- lchob$Env$call_list[1 + ta.swap] + # swap frames + frame <- sapply(lchob$Env$actions[9+c(which.ta1, which.ta2)], function(x) attr(x, "frame")) + attr(lchob$Env$actions[[9+which.ta1]], "frame") <- frame[2] + attr(lchob$Env$actions[[9+which.ta2]], "frame") <- frame[1] + # swap actions + lchob$Env$actions[-c(1:9)] <- lchob$Env$actions[9+ta.swap] + # swap y limits + lchob$Env$ylim[frame] <- lchob$Env$ylim[rev(frame)] + + ### End swap - do.call("chartSeries.chob",list(lchob)) - write.chob(lchob,lchob@device) + lchob + #write.chob(lchob,lchob@device) } `moveTA` <- -function(ta,pos,occ=1,dev) { +function(ta,pos,occ=1,chob) { pos <- pos - 1 if(missing(ta)) stop("no TA indicator specified") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) + # default to the current chob if none specified + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) # get the current chob - lchob <- get.chob()[[dev]] + lchob <- chob # make indicator name match original call if(regexpr("^add",ta) == -1) ta <- paste("add",ta,sep='') @@ -52,27 +63,31 @@ function(ta,pos,occ=1,dev) { if(is.na(which.ta)) stop("no TA") - lchob@passed.args$TA <- append(lchob@passed.args$TA[-which.ta], - lchob@passed.args$TA[which.ta], + lchob$Env$TA <- append(lchob$Env$TA[-which.ta], + lchob$Env$TA[which.ta], after=pos) - - do.call("chartSeries.chob",list(lchob)) - write.chob(lchob,lchob@device) + lchob$Env$call_list <- append(lchob$Env$call_list[-(1+which.ta)], + lchob$Env$call_list[1+which.ta], + after=pos+1) + # move actions + lchob$Env$actions <- append(lchob$Env$actions[-(9+which.ta)], + lchob$Env$actions[9+which.ta], + after=pos+9) + + lchob + #write.chob(lchob,lchob@device) } `dropTA` <- -function(ta,occ=1,dev,all=FALSE) { +function(ta,occ=1,chob,all=FALSE) { if(all) return(do.call('dropTA', list(1:length(listTA())))) if(missing(ta)) stop("no TA indicator specified") - # default to the current device if none specified - if(missing(dev)) dev <- dev.cur() - ta.list <- listTA(dev) - # get the current chob - lchob <- get.chob()[[dev]] + if(missing(chob)) chob <- get.chob() + ta.list <- listTA(chob) sel.ta <- NULL @@ -91,22 +106,34 @@ function(ta,occ=1,dev,all=FALSE) { if(!is.na(which.ta)) { # decrease window count if necessary - if(lchob@passed.args$TA[[which.ta]]@new) - lchob@windows <- lchob@windows - 1 + #if(lchob@passed.args$TA[[which.ta]]@new) + # lchob@windows <- lchob@windows - 1 sel.ta <- c(sel.ta,which.ta) + } else { + stop("nothing to remove") } } if(is.null(sel.ta)) stop("nothing to remove") # remove TA from current list - lchob@passed.args$TA <- lchob@passed.args$TA[-sel.ta] - if(length(lchob@passed.args$TA) < 1) - lchob@passed.args$TA <- list() + ta.list <- ta.list[-sel.ta] + for(li in sel.ta) { + # number of actions of chartSeries object without TA is 9 + frame <- attr(chob$Env$actions[[9 + sel.ta]], "frame") + if(abs(frame)==2) + chob$Env$actions[[9 + sel.ta]] <- NULL + else + chob$remove_frame(frame) + chob$Env$TA[[sel.ta]] <- NULL + ncalls <- length(chob$Env$call_list) + # plot.xts(...) is included in call_list but listTA() is not + chob$Env$call_list[1 + sel.ta] <- NULL + } # redraw chart - do.call("chartSeries.chob",list(lchob)) + chob - write.chob(lchob,lchob@device) + #write.chob(lchob,lchob@device) }