Refactor addTA to use panel functionality

When "ta" is not characters of functions from TTR
(SMA, BBands, ...), shading regime or new series are
added if "ta" is logic or an object of xts class, respectively.

Author: erichung0404

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 <- [email protected]$TA
 #      [email protected]$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
 #    }
   }
 }#}}}