1#
2#  At present all TA functionality is in this file
3#
4#  TA implemented and charting optimized:
5#
6#    BBands,CCI,CMF,CMO,DPO,EMA,Envelope,MACD,Momentum,
7#    RSI,SMA,SMI,Vo,WPR
8
9#  TA implemented, charting not completed/optimized:
10#
11#    ADX,ATR,DEMA,EVWMA,Expiry,Lines,ROC,SAR,TRIX,WMA,ZLEMA
12
13#  TA not yet implemented (and some may not be)
14#
15#    CLV,CMD,OBV,KST,TDI,WHF,Aroon,ChAD,ChVol,WilliamsAD,
16#    Points, Stoch, SD, ...???
17# addMomentum {{{
18`addMomentum` <- function(n=1) {
19
20
21  lchob <- get.current.chob()
22
23  x <- as.matrix(lchob@xdata)
24
25  chobTA <- new("chobTA")
26  chobTA@new <- TRUE
27
28  #  needs to accept any arguments for x, not just close
29
30  xx <- if(is.OHLC(x)) {
31    Cl(x)
32  } else x
33
34  mom <- momentum(xx,n=n)
35
36  chobTA@TA.values <- mom[lchob@xsubset]
37  chobTA@name <- "chartMomentum"
38  chobTA@call <- match.call()
39  chobTA@params <- list(xrange=lchob@xrange,
40                        colors=lchob@colors,
41                        color.vol=lchob@color.vol,
42                        multi.col=lchob@multi.col,
43                        spacing=lchob@spacing,
44                        width=lchob@width,
45                        bp=lchob@bp,
46                        x.labels=lchob@x.labels,
47                        time.scale=lchob@time.scale,
48                        n=n)
49  if(is.null(sys.call(-1))) {
50    TA <- lchob@passed.args$TA
51    lchob@passed.args$TA <- c(TA,chobTA)
52    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
53    do.call('chartSeries.chob',list(lchob))
54    invisible(chobTA)
55  } else {
56   return(chobTA)
57  }
58} #}}}
59# chartMomentum {{{
60`chartMomentum` <-
61function(x) {
62    spacing <- x@params$spacing
63    width <- x@params$width
64
65    x.range <- x@params$xrange
66    x.range <- seq(x.range[1],x.range[2]*spacing)
67
68    multi.col <- x@params$multi.col
69    color.vol <- x@params$color.vol
70
71    n <- x@params$n
72    mom <- x@TA.values
73
74    y.range <- seq(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE),
75                   length.out=length(x.range)) * 1.05
76    plot(x.range,y.range,
77         type='n',axes=FALSE,ann=FALSE)
78    coords <- par('usr')
79    rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
80    grid(NA,NULL,col=x@params$colors$grid.col)
81
82    COLOR <- "#0033CC"
83
84    abline(h=0,col="#666666",lwd=1,lty='dotted')
85
86    lines(seq(1,length(x.range),by=spacing),mom,col=COLOR,lwd=2,type='l')
87
88    text(0, last(y.range)*.9,
89         paste("Momentum (", x@params$n, "):"),pos=4)
90
91    text(0, last(y.range)*.9,
92         paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''),
93         col = COLOR, pos = 4)
94
95    axis(2)
96    box(col=x@params$colors$fg.col)
97} # }}}
98
99# addCCI {{{
100`addCCI` <- function(n=20, maType="SMA", c=0.015) {
101
102
103  lchob <- get.current.chob()
104
105  x <- as.matrix(lchob@xdata)
106
107  chobTA <- new("chobTA")
108  chobTA@new <- TRUE
109
110  xx <- if(is.OHLC(x)) {
111    cbind(Hi(x),Lo(x),Cl(x))
112  } else x
113
114  cci <- CCI(xx,n=n,maType=maType,c=c)
115
116  chobTA@TA.values <- cci[lchob@xsubset]
117  chobTA@name <- "chartCCI"
118  chobTA@call <- match.call()
119  chobTA@params <- list(xrange=lchob@xrange,
120                        colors=lchob@colors,
121                        color.vol=lchob@color.vol,
122                        multi.col=lchob@multi.col,
123                        spacing=lchob@spacing,
124                        width=lchob@width,
125                        bp=lchob@bp,
126                        x.labels=lchob@x.labels,
127                        time.scale=lchob@time.scale,
128                        n=n,maType=maType,c=c)
129  if(is.null(sys.call(-1))) {
130    TA <- lchob@passed.args$TA
131    lchob@passed.args$TA <- c(TA,chobTA)
132    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
133    do.call('chartSeries.chob',list(lchob))
134    invisible(chobTA)
135  } else {
136   return(chobTA)
137  }
138} #}}}
139# chartCCI {{{
140`chartCCI` <-
141function(x) {
142    spacing <- x@params$spacing
143    width <- x@params$width
144
145    x.range <- x@params$xrange
146    x.range <- seq(x.range[1],x.range[2]*spacing)
147
148    multi.col <- x@params$multi.col
149    color.vol <- x@params$color.vol
150
151    n <- x@params$n
152    cci <- x@TA.values
153
154    y.range <- seq(-max(abs(cci),na.rm=TRUE),
155                   max(abs(cci),na.rm=TRUE),
156                   length.out=length(x.range))*1.05
157    plot(x.range,y.range,
158         type='n',axes=FALSE,ann=FALSE)
159    coords <- par('usr')
160    rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
161    grid(NA,NULL,col=x@params$colors$grid.col)
162
163    usr <- par('usr')
164
165    # draw shading in -100:100 y-range
166    rect(usr[1],-100,usr[2],100,col=x@params$colors$BBands$fill)
167
168    # fill upper and lower areas
169    xx <- seq(1,length(x.range),by=spacing)
170    cci.above <- ifelse(cci >=  100,cci, 100)
171    cci.below <- ifelse(cci <= -100,cci,-100)
172
173    polygon(c(xx,rev(xx)),c(cci.above,rep(100,length(xx))),col="red")
174    polygon(c(xx,rev(xx)),c(cci.below,rep(-100,length(xx))),col="red")
175
176    # draw CCI
177    lines(seq(1,length(x.range),by=spacing),cci,col='red',lwd=1,type='l')
178
179    # draw dotted guide line at 0
180    abline(h=0,col='#666666',lwd=1,lty='dotted')
181
182    # add indicator name and last value
183    text(0, last(y.range)*.9,
184         paste("Commodity Channel Index (", x@params$n, ",",
185         x@params$c,"):",sep=''),pos=4)
186    text(0, last(y.range)*.9,
187         paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red',
188         pos = 4)
189
190    axis(2)
191    box(col=x@params$colors$fg.col)
192} # }}}
193
194# addADX {{{
195`addADX` <- function(n=14, maType="EMA", wilder=TRUE) {
196
197
198  lchob <- get.current.chob()
199
200  x <- as.matrix(lchob@xdata)
201
202  chobTA <- new("chobTA")
203  chobTA@new <- TRUE
204
205  if(!is.OHLC(x)) stop("only applicable to HLC series")
206
207  adx <- ADX(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,wilder=wilder)
208
209  chobTA@TA.values <- adx[lchob@xsubset,]
210  chobTA@name <- "chartADX"
211  chobTA@call <- match.call()
212  chobTA@params <- list(xrange=lchob@xrange,
213                        colors=lchob@colors,
214                        color.vol=lchob@color.vol,
215                        multi.col=lchob@multi.col,
216                        spacing=lchob@spacing,
217                        width=lchob@width,
218                        bp=lchob@bp,
219                        x.labels=lchob@x.labels,
220                        time.scale=lchob@time.scale,
221                        n=n,maType=maType,wilder=wilder)
222  if(is.null(sys.call(-1))) {
223    TA <- lchob@passed.args$TA
224    lchob@passed.args$TA <- c(TA,chobTA)
225    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
226    do.call('chartSeries.chob',list(lchob))
227    invisible(chobTA)
228  } else {
229   return(chobTA)
230  }
231} #}}}
232# chartADX {{{
233`chartADX` <-
234function(x) {
235    spacing <- x@params$spacing
236    width <- x@params$width
237
238    x.range <- x@params$xrange
239    x.range <- seq(x.range[1],x.range[2]*spacing)
240
241    multi.col <- x@params$multi.col
242    color.vol <- x@params$color.vol
243
244    n <- x@params$n
245    adx <- x@TA.values
246    plot(x.range,seq(min(adx[,4]*.975,na.rm=TRUE),
247         max(adx[,4]*1.05,na.rm=TRUE),length.out=length(x.range)),
248         type='n',axes=FALSE,ann=FALSE)
249    coords <- par('usr')
250    rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
251    grid(NA,NULL,col=x@params$colors$grid.col)
252    # draw DIp
253    lines(seq(1,length(x.range),by=spacing),adx[,1],col='green',lwd=1,type='l')
254    # draw DIn
255    lines(seq(1,length(x.range),by=spacing),adx[,2],col='red',lwd=1,type='l')
256    # draw ADX
257    lines(seq(1,length(x.range),by=spacing),adx[,4],col='blue',lwd=2,type='l')
258
259    # draw upper and lower guidelines
260    abline(h=20,col='#666666',lwd=1,lty='dotted')
261    abline(h=40,col='#666666',lwd=1,lty='dotted')
262    #title(ylab=paste('SMI(',paste(param,collapse=','),')',sep=''))
263    axis(2)
264    box(col=x@params$colors$fg.col)
265} # }}}
266
267# addATR {{{
268`addATR` <- function(n=14, maType="EMA", ...) {
269
270
271  lchob <- get.current.chob()
272
273  x <- as.matrix(lchob@xdata)
274
275  chobTA <- new("chobTA")
276  chobTA@new <- TRUE
277
278  if(!is.OHLC(x)) stop("only applicable to HLC series")
279
280  atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...)
281
282  chobTA@TA.values <- atr[lchob@xsubset,]
283  chobTA@name <- "chartATR"
284  chobTA@call <- match.call()
285  chobTA@params <- list(xrange=lchob@xrange,
286                        colors=lchob@colors,
287                        color.vol=lchob@color.vol,
288                        multi.col=lchob@multi.col,
289                        spacing=lchob@spacing,
290                        width=lchob@width,
291                        bp=lchob@bp,
292                        x.labels=lchob@x.labels,
293                        time.scale=lchob@time.scale,
294                        n=n,maType=maType)
295  if(is.null(sys.call(-1))) {
296    TA <- lchob@passed.args$TA
297    lchob@passed.args$TA <- c(TA,chobTA)
298    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
299    do.call('chartSeries.chob',list(lchob))
300    invisible(chobTA)
301  } else {
302   return(chobTA)
303  }
304} #}}}
305# chartATR {{{
306`chartATR` <-
307function(x) {
308    spacing <- x@params$spacing
309    width <- x@params$width
310
311    x.range <- x@params$xrange
312    x.range <- seq(x.range[1],x.range[2]*spacing)
313
314    multi.col <- x@params$multi.col
315    color.vol <- x@params$color.vol
316
317    n <- x@params$n
318    atr <- x@TA.values
319    plot(x.range,seq(min(atr[,2]*.975,na.rm=TRUE),
320         max(atr[,2]*1.05,na.rm=TRUE),length.out=length(x.range)),
321         type='n',axes=FALSE,ann=FALSE)
322    coords <- par('usr')
323    rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
324    grid(NA,NULL,col=x@params$colors$grid.col)
325
326    # draw ADX
327    lines(seq(1,length(x.range),by=spacing),atr[,2],col='blue',lwd=2,type='l')
328
329    axis(2)
330    box(col=x@params$colors$fg.col)
331} # }}}
332
333# addTRIX {{{
334`addTRIX` <- function(n=20, signal=9, maType="EMA", percent=TRUE) {
335
336
337  lchob <- get.current.chob()
338
339  x <- as.matrix(lchob@xdata)
340
341  chobTA <- new("chobTA")
342  chobTA@new <- TRUE
343
344  xx <- if(is.OHLC(x)) {
345    Cl(x)
346  } else x
347
348  trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)
349
350  chobTA@TA.values <- trix[lchob@xsubset,]
351
352  chobTA@name <- "chartTRIX"
353  chobTA@call <- match.call()
354  chobTA@params <- list(xrange=lchob@xrange,
355                        colors=lchob@colors,
356                        color.vol=lchob@color.vol,
357                        multi.col=lchob@multi.col,
358                        spacing=lchob@spacing,
359                        width=lchob@width,
360                        bp=lchob@bp,
361                        x.labels=lchob@x.labels,
362                        time.scale=lchob@time.scale,
363                        n=n,signal=signal,maType=maType,percent=percent)
364  if(is.null(sys.call(-1))) {
365    TA <- lchob@passed.args$TA
366    lchob@passed.args$TA <- c(TA,chobTA)
367    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
368    do.call('chartSeries.chob',list(lchob))
369    invisible(chobTA)
370  } else {
371   return(chobTA)
372  }
373} #}}}
374# chartTRIX {{{
375`chartTRIX` <-
376function(x) {
377    spacing <- x@params$spacing
378    width <- x@params$width
379
380    x.range <- x@params$xrange
381    x.range <- seq(x.range[1],x.range[2]*spacing)
382
383    multi.col <- x@params$multi.col
384    color.vol <- x@params$color.vol
385
386    n <- x@params$n
387
388    trix <- x@TA.values
389
390    plot(x.range,seq(min(trix[,1]*.975,na.rm=TRUE),
391         max(trix[,1]*1.05,na.rm=TRUE),length.out=length(x.range)),
392         type='n',axes=FALSE,ann=FALSE)
393
394    coords <- par('usr')
395    rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
396    grid(NA,NULL,col=x@params$colors$grid.col)
397
398    # draw TRIX
399    lines(seq(1,length(x.range),by=spacing),trix[,1],col='green',lwd=1,type='l')
400    # draw Signal
401    lines(seq(1,length(x.range),by=spacing),trix[,2],col='#999999',lwd=1,type='l')
402
403    axis(2)
404    box(col=x@params$colors$fg.col)
405} # }}}
406
407# addDPO {{{
408`addDPO` <- function(n=10, maType="EMA", shift=n/2+1, percent=FALSE) {
409
410
411  lchob <- get.current.chob()
412
413  x <- as.matrix(lchob@xdata)
414
415  chobTA <- new("chobTA")
416  chobTA@new <- TRUE
417
418  # should really allow for _any_ series to be used, like MA (FIXME)
419
420  xx <- if(is.OHLC(x)) {
421    Cl(x)
422  } else x
423
424  dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)
425
426  chobTA@TA.values <- dpo[lchob@xsubset]
427
428  chobTA@name <- "chartDPO"
429  chobTA@call <- match.call()
430  chobTA@params <- list(xrange=lchob@xrange,
431                        colors=lchob@colors,
432                        color.vol=lchob@color.vol,
433                        multi.col=lchob@multi.col,
434                        spacing=lchob@spacing,
435                        width=lchob@width,
436                        bp=lchob@bp,
437                        x.labels=lchob@x.labels,
438                        time.scale=lchob@time.scale,
439                        n=n,maType=maType,shift=shift,percent=percent)
440  if(is.null(sys.call(-1))) {
441    TA <- lchob@passed.args$TA
442    lchob@passed.args$TA <- c(TA,chobTA)
443    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
444    do.call('chartSeries.chob',list(lchob))
445    invisible(chobTA)
446  } else {
447   return(chobTA)
448  }
449} #}}}
450# chartDPO {{{
451`chartDPO` <-
452function(x) {
453    spacing <- x@params$spacing
454    width <- x@params$width
455
456    x.range <- x@params$xrange
457    x.range <- seq(x.range[1],x.range[2]*spacing)
458
459    multi.col <- x@params$multi.col
460    color.vol <- x@params$color.vol
461
462    n <- x@params$n
463    dpo <- x@TA.values
464
465    y.range <- seq(-max(abs(dpo), na.rm = TRUE), max(abs(dpo),
466                   na.rm = TRUE), length.out = length(x.range)) * 1.05
467
468    if(x@new) {
469      plot(x.range,y.range,
470           type='n',axes=FALSE,ann=FALSE)
471      coords <- par('usr')
472      rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
473      grid(NA,NULL,col=x@params$colors$grid.col)
474    }
475    xx <- seq(1,length(x.range),by=spacing)
476
477    dpo.tmp <- dpo
478    dpo.tmp[is.na(dpo)] <- 0
479    dpo.positive <- ifelse(dpo.tmp >= 0,dpo.tmp,0)
480    dpo.negative <- ifelse(dpo.tmp <  0,dpo.tmp,0)
481
482    polygon(c(xx,rev(xx)),c(dpo.positive,rep(0,length(dpo))),col=x@params$colors$up.col)
483    polygon(c(xx,rev(xx)),c(dpo.negative,rep(0,length(dpo))),col=x@params$colors$dn.col)
484
485    abline(h=0,col="#999999")
486
487    text(0, last(y.range)*.9,
488         paste("De-trended Price Oscillator (", x@params$n,"):", sep = ""),
489        pos = 4)
490
491    text(0, last(y.range)*.9,
492        paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo))), sep = ""),
493        col = ifelse(last(dpo) > 0,x@params$colors$up.col,x@params$colors$dn.col),
494        pos = 4)
495
496    axis(2)
497    box(col=x@params$colors$fg.col)
498
499#    y.range <- seq(-max(abs(dpo), na.rm = TRUE), max(abs(dpo),
500#        na.rm = TRUE), length.out = length(x.range)) * 1.05
501#    plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
502#
503#    grid(NA,NULL,col=x@params$colors$grid.col)
504#
505#    # draw DPO
506#    lines(seq(1,length(x.range),by=spacing),dpo,col='green',lwd=1,type='l')
507#
508#    #title(ylab=paste('SMI(',paste(param,collapse=','),')',sep=''))
509#    axis(2)
510#    box(col=x@params$colors$fg.col)
511} # }}}
512
513# addRSI {{{
514`addRSI` <- function(n=14,maType='EMA',wilder=TRUE) {
515
516
517  lchob <- get.current.chob()
518
519  x <- as.matrix(lchob@xdata)
520
521  chobTA <- new("chobTA")
522  chobTA@new <- TRUE
523
524
525  xx <- if(is.OHLC(x)) {
526    Cl(x)
527  } else x
528
529  rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)
530  chobTA@TA.values <- rsi[lchob@xsubset]
531  chobTA@name <- "chartRSI"
532  chobTA@call <- match.call()
533  chobTA@params <- list(xrange=lchob@xrange,
534                        colors=lchob@colors,
535                        color.vol=lchob@color.vol,
536                        multi.col=lchob@multi.col,
537                        spacing=lchob@spacing,
538                        width=lchob@width,
539                        bp=lchob@bp,
540                        x.labels=lchob@x.labels,
541                        time.scale=lchob@time.scale,
542                        n=n, wilder=wilder,maType=maType)
543  if(is.null(sys.call(-1))) {
544    TA <- lchob@passed.args$TA
545    lchob@passed.args$TA <- c(TA,chobTA)
546    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
547    do.call('chartSeries.chob',list(lchob))
548    invisible(chobTA)
549  } else {
550   return(chobTA)
551  }
552} #}}}
553# chartRSI {{{
554`chartRSI` <-
555function(x) {
556    spacing <- x@params$spacing
557    width <- x@params$width
558
559    x.range <- x@params$xrange
560    x.range <- seq(x.range[1],x.range[2]*spacing)
561
562    multi.col <- x@params$multi.col
563    color.vol <- x@params$color.vol
564
565    param <- x@params$param; ma.type <- x@params$ma.type
566    rsi <- x@TA.values
567
568    y.range <- seq(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05,
569                   length.out=length(x.range))
570
571    if(x@new) {
572      plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
573
574      coords <- par('usr')
575      rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
576      grid(NA,NULL,col=x@params$colors$grid.col)
577    }
578    lines(seq(1,length(x.range),by=spacing),rsi,col='#0033CC',lwd=2,type='l')
579    lines(seq(1,length(x.range),by=spacing),rsi,col='#BFCFFF',lwd=1,lty='dotted',type='l')
580
581    text(0, last(y.range)*.9,
582         paste("Relative Strength Index (", x@params$n,"):", sep = ""),
583         pos = 4)
584
585    text(0, last(y.range)*.9,
586         paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC',
587         pos = 4)
588
589    axis(2)
590    box(col=x@params$colors$fg.col)
591} # }}}
592
593# addROC {{{
594`addROC` <- function(n=1,type=c('discrete','continuous'),col='red') {
595
596
597  lchob <- get.current.chob()
598
599  x <- as.matrix(lchob@xdata)
600
601  chobTA <- new("chobTA")
602  chobTA@new <- TRUE
603
604  xx <- if(is.OHLC(x)) {
605    Cl(x)
606  } else x
607
608  type <- match.arg(type)
609
610  roc <- ROC(xx,n=n,type=type,na.pad=TRUE)
611
612  chobTA@TA.values <- roc[lchob@xsubset]
613  chobTA@name <- "chartROC"
614  chobTA@call <- match.call()
615  chobTA@params <- list(xrange=lchob@xrange,
616                        colors=lchob@colors,
617                        multi.col=lchob@multi.col,
618                        spacing=lchob@spacing,
619                        width=lchob@width,
620                        bp=lchob@bp,
621                        x.labels=lchob@x.labels,
622                        time.scale=lchob@time.scale,
623                        n=n,type=type,col=col)
624  if(is.null(sys.call(-1))) {
625    TA <- lchob@passed.args$TA
626    lchob@passed.args$TA <- c(TA,chobTA)
627    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
628    do.call('chartSeries.chob',list(lchob))
629    invisible(chobTA)
630  } else {
631   return(chobTA)
632  }
633} #}}}
634# chartROC {{{
635`chartROC` <-
636function(x) {
637    spacing <- x@params$spacing
638    width <- x@params$width
639
640    x.range <- x@params$xrange
641    x.range <- seq(x.range[1],x.range[2]*spacing)
642
643    multi.col <- x@params$multi.col
644    color.vol <- x@params$color.vol
645
646    #param <- x@params$param; ma.type <- x@params$ma.type
647    roc <- x@TA.values
648    if(x@new) {
649      plot(x.range,seq(min(roc*.975,na.rm=TRUE),max(roc*1.05,na.rm=TRUE),length.out=length(x.range)),
650         type='n',axes=FALSE,ann=FALSE)
651      grid(NA,NULL,col=x@params$colors$grid.col)
652    }
653    lines(seq(1,length(x.range),by=spacing),roc,col=x@params$col,lwd=2,type='l')
654    #title(ylab=paste('RSI(',paste(c(n.up,collapse=','),')',sep=''))
655    axis(2)
656    box(col=x@params$colors$fg.col)
657} # }}}
658
659# addBBands {{{
660`addBBands` <- function(n=20,sd=2,maType='SMA',draw='bands',on=-1) {
661
662
663  draw.options <- c('bands','percent','width')
664  draw <- draw.options[pmatch(draw,draw.options)]
665
666  lchob <- get.current.chob()
667
668  x <- as.matrix(lchob@xdata)
669
670  chobTA <- new("chobTA")
671  if(draw=='bands') {
672    chobTA@new <- FALSE
673    } else {
674      chobTA@new <- TRUE
675      on <- NULL
676  }
677
678
679  xx <- if(is.OHLC(x)) {
680    cbind(Hi(x),Lo(x),Cl(x))
681  } else x
682
683  bb <- BBands(xx,n=n,maType=maType,sd=sd)
684
685  chobTA@TA.values <- bb[lchob@xsubset,]
686  chobTA@name <- "chartBBands"
687  chobTA@call <- match.call()
688  chobTA@on <- on
689  chobTA@params <- list(xrange=lchob@xrange,
690                        colors=lchob@colors,
691                        color.vol=lchob@color.vol,
692                        multi.col=lchob@multi.col,
693                        spacing=lchob@spacing,
694                        width=lchob@width,
695                        bp=lchob@bp,
696                        x.labels=lchob@x.labels,
697                        time.scale=lchob@time.scale,
698                        n=n,ma=maType,sd=sd,
699                        draw=draw)
700  return(chobTA)
701} #}}}
702# chartBBands {{{
703`chartBBands` <-
704function(x) {
705    spacing <- x@params$spacing
706    width <- x@params$width
707
708    x.range <- x@params$xrange
709    x.range <- seq(x.range[1],x.range[2]*spacing)
710
711    multi.col <- x@params$multi.col
712    color.vol <- x@params$color.vol
713
714    bband.col <- ifelse(!is.null(x@params$colors$BBands$col),
715                        x@params$colors$BBands$col,'red')
716    bband.fill <- ifelse(!is.null(x@params$colors$BBands$fill),
717                        x@params$colors$BBands$fill,x@params$colors$bg.col)
718
719    # bband col vector
720    # lower.band, middle.band, upper.band, %b, bb.width
721    if(length(bband.col) == 1) # no user specified
722      bband.col <- c(bband.col,'grey',rep(bband.col,3))
723
724    param <- x@params$param; ma.type <- x@params$ma.type
725
726    bb <- x@TA.values
727
728    if(x@params$draw == 'bands') {
729      # draw Bollinger Bands on price chart
730      if(x@on[1] > 0) {
731        lines(seq(1,length(x.range),by=spacing),
732              bb[,1],col=bband.col[1],lwd=1,lty='dashed')
733        lines(seq(1,length(x.range),by=spacing),
734              bb[,3],col=bband.col[3],lwd=1,lty='dashed')
735        lines(seq(1,length(x.range),by=spacing),
736              bb[,2],col=bband.col[2],lwd=1,lty='dotted')
737      } else {
738        xx <- seq(1,length(x.range),by=spacing)
739        polygon(c(xx,rev(xx)),
740                c(bb[,1],rev(bb[,3])),col=bband.fill,border=NA)
741        lines(seq(1,length(x.range),by=spacing),
742              bb[,1],col=bband.col[1],lwd=1,lty='dashed')
743        lines(seq(1,length(x.range),by=spacing),
744              bb[,3],col=bband.col[3],lwd=1,lty='dashed')
745        lines(seq(1,length(x.range),by=spacing),
746              bb[,2],col=bband.col[2],lwd=1,lty='dotted')
747      }
748
749      # return the text to be pasted
750      legend.text <- list()
751      legend.text[[1]] <- list(legend=paste("Bollinger Bands (",
752                     paste(x@params$n,x@params$sd,sep=","),") [Upper/Lower]: ",
753                     sprintf("%.3f",last(bb[,3])),"/",
754                     sprintf("%.3f",last(bb[,1])), sep = ""),
755                     text.col = bband.col[3])
756      invisible(legend.text)
757    } else
758      if(x@params$draw == 'percent') {
759        # draw %B in new frame
760        y.range <- seq(min(bb[,4], na.rm = TRUE) * .9,
761                        max(abs(bb[,4]), na.rm = TRUE) * 1.05,
762                        length.out = length(x.range))
763        plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
764        grid(NA,NULL,col=x@params$colors$grid.col)
765
766        lines(seq(1,length(x.range),by=spacing), bb[,4],
767              col=bband.col[4],lwd=1)
768
769        text(0,last(y.range) * .9, paste("Bollinger %b (",
770             paste(x@params$n,x@params$sd,sep=","), "): ",
771             sep=""), pos=4)
772        text(0,last(y.range) * .9, paste("\n\n\n",
773             sprintf("%.3f",last(bb[,4])), sep = ""),
774             pos=4, col=bband.col[4])
775
776        axis(2)
777        box(col = x@params$colors$fg.col)
778
779      } else {
780        # draw width in new frame
781        # (high band - low band) / middle band
782        bbw <- (bb[,3] - bb[,1]) / bb[,2]
783
784        y.range <- seq(min(bbw, na.rm = TRUE) * .9,
785                        max(abs(bbw), na.rm = TRUE) * 1.05,
786                        length.out = length(x.range))
787        plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
788        grid(NA,NULL,col=x@params$colors$grid.col)
789
790        lines(seq(1,length(x.range),by=spacing), bbw,
791              col=bband.col[5],lwd=1)
792
793        text(0,last(y.range) * .9, paste("Bollinger Band Width (",
794             paste(x@params$n,x@params$sd,sep=","), "): ",
795             sep=""), pos=4)
796        text(0,last(y.range) * .9, paste("\n\n\n",
797             sprintf("%.3f",last(bbw)), sep = ""),
798             pos=4, col=bband.col[5])
799
800        axis(2)
801        box(col = x@params$colors$fg.col)
802      }
803} # }}}
804
805# addEnvelope {{{
806`addEnvelope` <- function(n=20,p=2.5,maType='SMA',...,on=1) {
807
808
809  lchob <- get.current.chob()
810
811  x <- as.matrix(lchob@xdata)
812
813  chobTA <- new("chobTA")
814  chobTA@new <- FALSE
815
816  xx <- if(is.OHLC(x)) {
817    Cl(x)
818  } else x
819
820  ma <- do.call(maType,list(xx,n=n,...))
821  mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))
822
823  chobTA@TA.values <- mae[lchob@xsubset,]
824
825  chobTA@name <- "chartEnvelope"
826  chobTA@call <- match.call()
827  chobTA@on <- on
828  chobTA@params <- list(xrange=lchob@xrange,
829                        colors=lchob@colors,
830                        color.vol=lchob@color.vol,
831                        multi.col=lchob@multi.col,
832                        spacing=lchob@spacing,
833                        width=lchob@width,
834                        bp=lchob@bp,
835                        x.labels=lchob@x.labels,
836                        time.scale=lchob@time.scale,
837                        n=n,p=p,maType=maType)
838  if(is.null(sys.call(-1))) {
839    TA <- lchob@passed.args$TA
840    lchob@passed.args$TA <- c(TA,chobTA)
841    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
842    do.call('chartSeries.chob',list(lchob))
843    invisible(chobTA)
844  } else {
845   return(chobTA)
846  }
847} #}}}
848# chartEnvelope {{{
849`chartEnvelope` <-
850function(x) {
851    spacing <- x@params$spacing
852    width <- x@params$width
853
854    x.range <- x@params$xrange
855    x.range <- seq(x.range[1],x.range[2]*spacing)
856
857    multi.col <- x@params$multi.col
858    color.vol <- x@params$color.vol
859
860    mae <- x@TA.values
861    if(x@on[1] > 0) {
862      lines(seq(1,length(x.range),by=spacing),mae[,1],col='blue',lwd=1,lty='dotted')
863      lines(seq(1,length(x.range),by=spacing),mae[,3],col='blue',lwd=1,lty='dotted')
864      #lines(seq(1,length(x.range),by=spacing),mae[,2],col='grey',lwd=1,lty='dotted')
865    } else {
866      xx <- seq(1,length(x.range),by=spacing)
867      polygon(c(xx,rev(xx)), c(mae[,1],rev(mae[,3])),col='#282828',border=NA)
868      lines(seq(1,length(x.range),by=spacing),mae[,1],col='blue',lwd=1,lty='dotted')
869      lines(seq(1,length(x.range),by=spacing),mae[,3],col='blue',lwd=1,lty='dotted')
870      #lines(seq(1,length(x.range),by=spacing),mae[,2],col='grey',lwd=1,lty='dotted')
871    }
872
873    # return the text to be pasted
874    txt <- list()
875    txt[[1]] <- list(text=paste("Moving Ave. Envelope (",
876                   paste(x@params$n,x@params$p,sep=","),") [Upper/Lower]: ",
877                   sprintf("%.3f",last(mae[,3])),"/",
878                   sprintf("%.3f",last(mae[,1])), sep = ""), col = 'blue')
879    invisible(txt)
880
881} # }}}
882
883# addSAR {{{
884`addSAR` <- function(accel=c(0.02,0.2),col='blue') {
885
886
887  lchob <- get.current.chob()
888
889  x <- as.matrix(lchob@xdata)
890
891  chobTA <- new("chobTA")
892  chobTA@new <- FALSE
893
894  if(!is.OHLC(x)) stop("SAR requires HL series")
895
896  sar <- SAR(cbind(Hi(x),Lo(x)),accel=accel)
897
898  chobTA@TA.values <- sar[lchob@xsubset]
899
900  chobTA@name <- "chartSAR"
901  chobTA@call <- match.call()
902  chobTA@on <- 1
903  chobTA@params <- list(xrange=lchob@xrange,
904                        colors=lchob@colors,
905                        color.vol=lchob@color.vol,
906                        multi.col=lchob@multi.col,
907                        spacing=lchob@spacing,
908                        width=lchob@width,
909                        bp=lchob@bp,
910                        x.labels=lchob@x.labels,
911                        time.scale=lchob@time.scale,
912                        accel=accel,col=col)
913  if(is.null(sys.call(-1))) {
914    TA <- lchob@passed.args$TA
915    lchob@passed.args$TA <- c(TA,chobTA)
916    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
917    do.call('chartSeries.chob',list(lchob))
918    invisible(chobTA)
919  } else {
920   return(chobTA)
921  }
922} #}}}
923# chartSAR {{{
924`chartSAR` <-
925function(x) {
926    spacing <- x@params$spacing
927    width <- x@params$width
928
929    x.range <- x@params$xrange
930    x.range <- seq(x.range[1],x.range[2]*spacing)
931
932    multi.col <- x@params$multi.col
933    color.vol <- x@params$color.vol
934
935    sar <- x@TA.values
936    points(seq(1,length(x.range),by=spacing),sar,col=x@params$col,cex=0.5)
937} # }}}
938
939# addMACD {{{
940`addMACD` <- function(fast=12,slow=26,signal=9,type='EMA',histogram=TRUE,col) {
941
942
943  lchob <- get.current.chob()
944
945  x <- as.matrix(lchob@xdata)
946
947  chobTA <- new("chobTA")
948  chobTA@new <- TRUE
949
950  col <- if(missing(col)) col <- c('#999999','#777777',
951                              '#BBBBBB','#FF0000')
952
953  xx <- if(is.OHLC(x)) {
954    Cl(x)
955  } else x
956
957  macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)
958
959  chobTA@TA.values <- macd[lchob@xsubset,]
960
961  chobTA@name <- "chartMACD"
962  chobTA@call <- match.call()
963  chobTA@params <- list(xrange=lchob@xrange,
964                        colors=lchob@colors,
965                        spacing=lchob@spacing,
966                        width=lchob@width,
967                        bp=lchob@bp,
968                        x.labels=lchob@x.labels,
969                        time.scale=lchob@time.scale,
970                        fast=fast,slow=slow,signal=signal,
971                        col=col,histo=histogram
972                        )
973  return(chobTA)
974} #}}}
975# chartMACD {{{
976`chartMACD` <-
977function(x) {
978    spacing <- x@params$spacing
979    width <- x@params$width
980
981    x.range <- x@params$xrange
982    x.range <- seq(x.range[1],x.range[2]*spacing)
983
984    col <- x@params$col
985    macd <- x@TA.values
986
987    y.range <- seq(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE),
988                   length.out=length(x.range)) * 1.05
989
990    if(x@new) {
991      plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
992
993      coords <- par('usr')
994      rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
995      grid(NA,NULL,col=x@params$colors$grid.col)
996    }
997
998    if(x@params$histo) {
999      x.pos <- 1 + spacing * (1:NROW(macd) -1)
1000      cols <- ifelse((macd[,1]-macd[,2]) > 0, col[1],col[2])
1001      rect(x.pos - spacing/5,0,x.pos + spacing/5, macd[,1]-macd[,2],
1002           col=cols,border=cols)
1003    }
1004
1005    lines(seq(1,length(x.range),by=spacing),macd[,1],col=col[3],lwd=1)
1006    lines(seq(1,length(x.range),by=spacing),macd[,2],col=col[4],lwd=1,lty='dotted')
1007
1008    legend("topleft",
1009           legend=c(paste("Moving Average Convergence Divergence (",
1010                    paste(x@params$fast,x@params$slow,x@params$signal,sep=','),"):", sep = ""),
1011                    paste("MACD:",sprintf("%.3f",last(macd[,1]))),
1012                    paste("Signal:",sprintf("%.3f",last(macd[,2])))),
1013           text.col=c(x@params$colors$fg.col, col[3], col[4]), bty='n', y.intersp=0.95)
1014#   text(0, last(y.range)*.9,
1015#        paste("Moving Average Convergence Divergence (",
1016#        paste(x@params$fast,x@params$slow,x@params$signal,sep=','),"):", sep = ""),
1017#        pos = 4)
1018
1019#   text(0, last(y.range)*.9,
1020#       paste("\n\n\nMACD: ",sprintf("%.3f",last(macd[,1])), sep = ""),
1021#       col = col[3],pos = 4)
1022
1023#   text(0, last(y.range)*.9,
1024#       paste("\n\n\n\n\n\nSignal: ",sprintf("%.3f",last(macd[,2])), sep = ""),
1025#       col = col[4],pos = 4)
1026
1027    axis(2)
1028    box(col=x@params$colors$fg.col)
1029} # }}}
1030
1031# addShading {{{
1032`addShading` <- function(when,on=-1,overlay=TRUE,col='blue') {
1033
1034  lchob <- get.current.chob()
1035  chobTA <- new("chobTA")
1036  chobTA@new <- !overlay
1037
1038    x <- lchob@xdata
1039    i <- when
1040    tclass(x) <- "POSIXct"
1041    POSIXindex <- index(x)
1042    if (missing(i))
1043        i <- 1:NROW(x)
1044    if (timeBased(i))
1045        i <- as.character(as.POSIXct(i))
1046    if (is.character(i)) {
1047        i <- strsplit(i, ';')[[1]]
1048        i.tmp <- NULL
1049        for (ii in i) {
1050            if (!identical(grep("::", ii), integer(0))) {
1051                dates <- strsplit(ii, "::")[[1]]
1052                first.time <- ifelse(dates[1] == "", POSIXindex[1],
1053                  do.call("firstof", as.list(as.numeric(strsplit(dates[1],
1054                    ":|-|/| ")[[1]]))))
1055                last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)],
1056                  do.call("lastof", as.list(as.numeric(strsplit(dates[2],
1057                    ":|-|/| ")[[1]]))))
1058            }
1059            else {
1060                dates <- ii
1061                first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates,
1062                  ":|-|/| ")[[1]])))
1063                last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates,
1064                  ":|-|/| ")[[1]])))
1065            }
1066            i.tmp <- c(i.tmp, which(POSIXindex <= last.time &
1067                POSIXindex >= first.time))
1068        }
1069        i <- i.tmp
1070    }
1071
1072  xstart <- unique(c(i[1],i[which(diff(i) != 1)+1]))
1073  xend   <- unique(c(i[which(diff(i) != 1)-1], rev(i)[1]))
1074
1075  chobTA@TA.values <- x
1076  chobTA@name <- "chartShading"
1077  chobTA@call <- match.call()
1078  chobTA@on <- on # used for deciding when to draw...
1079  chobTA@params <- list(xrange=lchob@xrange,
1080                        yrange=lchob@yrange,
1081                        colors=lchob@colors,
1082                        spacing=lchob@spacing,
1083                        width=lchob@width,
1084                        xsubset=lchob@xsubset,
1085                        time.scale=lchob@time.scale,
1086                        xstart=xstart,xend=xend
1087                        )
1088  if(is.null(sys.call(-1))) {
1089    TA <- lchob@passed.args$TA
1090    lchob@passed.args$TA <- c(TA,chobTA)
1091    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1092    do.call('chartSeries.chob',list(lchob))
1093    invisible(chobTA)
1094  } else {
1095   return(chobTA)
1096  }
1097} # }}}
1098# chartShading {{{
1099`chartShading` <-
1100function(x) {
1101    spacing <- x@params$spacing
1102    width <- x@params$width
1103
1104    x.range <- x@params$xrange
1105    x.range <- seq(x.range[1],x.range[2]*spacing)
1106    y.range <- x@params$yrange
1107    xstart <- x@params$xstart
1108    xend <- x@params$xend
1109
1110    rect(((xstart-1)*spacing+1)-width/2, rep(y.range[1]*.95,length(xstart)),
1111         ((xend-1)*spacing+1)+width/2, rep(y.range[2]*1.05,length(xend)),
1112         col=c(x@params$colors$BBands$fill),border=NA)
1113      #abline(v=(x@params$v-1)*spacing+1,col=x@params$col)
1114} # }}}
1115
1116# addLines {{{
1117`addLines` <- function(x,h,v,on=1,overlay=TRUE,col='blue') {
1118
1119  if(missing(x)) x <- NULL
1120  if(missing(h)) h <- NULL
1121  if(missing(v)) v <- NULL
1122
1123  lchob <- get.current.chob()
1124  chobTA <- new("chobTA")
1125  chobTA@new <- !overlay
1126
1127  chobTA@TA.values <- NULL # single numeric vector
1128  chobTA@name <- "chartLines"
1129  chobTA@call <- match.call()
1130  chobTA@on <- on # used for deciding when to draw...
1131  chobTA@params <- list(xrange=lchob@xrange,
1132                        colors=lchob@colors,
1133                        color.vol=lchob@color.vol,
1134                        multi.col=lchob@multi.col,
1135                        spacing=lchob@spacing,
1136                        width=lchob@width,
1137                        bp=lchob@bp,
1138                        x.labels=lchob@x.labels,
1139                        time.scale=lchob@time.scale,
1140                        col=col,h=h,x=x,v=v)
1141  if(is.null(sys.call(-1))) {
1142    TA <- lchob@passed.args$TA
1143    lchob@passed.args$TA <- c(TA,chobTA)
1144    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1145    do.call('chartSeries.chob',list(lchob))
1146    invisible(chobTA)
1147  } else {
1148   return(chobTA)
1149  }
1150} # }}}
1151# chartLines {{{
1152`chartLines` <-
1153function(x) {
1154    spacing <- x@params$spacing
1155    width <- x@params$width
1156
1157    x.range <- x@params$xrange
1158    x.range <- seq(x.range[1],x.range[2]*spacing)
1159
1160    multi.col <- x@params$multi.col
1161    color.vol <- x@params$color.vol
1162
1163    if(!is.null(x@params$x)) {
1164      # draw lines given positions specified in x
1165      lines(x=(x@params$x-1)*spacing+1,col=x@params$col)
1166    }
1167    if(!is.null(x@params$h)) {
1168      # draw horizontal lines given positions specified in h
1169      abline(h=x@params$h,col=x@params$col)
1170    }
1171    if(!is.null(x@params$v)) {
1172      # draw vertical lines given positions specified in v
1173      abline(v=(x@params$v-1)*spacing+1,col=x@params$col)
1174    }
1175
1176} # }}}
1177
1178# addPoints {{{
1179`addPoints` <- function(x,y=NULL,type='p',pch=20,
1180                        offset=1,col=2,bg=2,cex=1,
1181                        on=1,overlay=TRUE) {
1182
1183  lchob <- get.current.chob()
1184  xdata <- as.matrix(lchob@xdata)
1185
1186  chobTA <- new("chobTA")
1187  chobTA@new <- !overlay
1188
1189
1190  chobTA@TA.values <- xdata[lchob@xsubset,]
1191  chobTA@name <- "chartPoints"
1192  chobTA@call <- match.call()
1193  chobTA@on <- on # used for deciding when to draw...
1194
1195  if(missing(bg)) bg <- col
1196
1197    xsubset <- x %in% lchob@xsubset
1198    if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths')
1199    x <- x[xsubset]
1200    if(!is.null(y))
1201      y <- y[xsubset]
1202
1203
1204  chobTA@params <- list(xrange=lchob@xrange,
1205                        colors=lchob@colors,
1206                        color.vol=lchob@color.vol,
1207                        multi.col=lchob@multi.col,
1208                        spacing=lchob@spacing,
1209                        width=lchob@width,
1210                        subset=lchob@xsubset,
1211                        x.labels=lchob@x.labels,
1212                        time.scale=lchob@time.scale,
1213                        x=x,y=y,type=type,offset=offset,
1214                        pch=pch,col=col,bg=bg,cex=cex)
1215  if(is.null(sys.call(-1))) {
1216    TA <- lchob@passed.args$TA
1217    lchob@passed.args$TA <- c(TA,chobTA)
1218    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1219    do.call('chartSeries.chob',list(lchob))
1220    invisible(chobTA)
1221  } else {
1222   return(chobTA)
1223  }
1224} # }}}
1225# chartPoints {{{
1226`chartPoints` <-
1227function(x) {
1228    spacing <- x@params$spacing
1229    width <- x@params$width
1230
1231    x.range <- x@params$xrange
1232    x.range <- seq(x.range[1],x.range[2]*spacing)
1233
1234    multi.col <- x@params$multi.col
1235    color.vol <- x@params$color.vol
1236
1237    xdata <- x@TA.values
1238    x.points <- which(x@params$subset %in% x@params$x)
1239    y.points <- x@params$y
1240    type <- x@params$type
1241    offset <- x@params$offset
1242    pch <- x@params$pch
1243    col <- x@params$col
1244    bg <- x@params$bg
1245    cex <- x@params$cex
1246
1247    # if OHLC and above - get Hi, else Lo
1248    # if univariate - get value
1249    y.data <- if(is.OHLC(xdata)) {
1250      if(offset > 1) {
1251        Hi(xdata)
1252      } else Lo(xdata)
1253    } else xdata
1254
1255    if(is.null(y.points)) y.points <- y.data[x.points] * offset
1256
1257    points(x=(x.points-1) * spacing + 1, y=y.points,
1258           type=type,pch=pch,col=col,bg=bg,cex=cex)
1259} # }}}
1260
1261# addEMA {{{
1262`addEMA` <- function(n=10,wilder=FALSE,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='blue') {
1263
1264
1265  lchob <- get.current.chob()
1266  chobTA <- new("chobTA")
1267  chobTA@new <- !overlay
1268
1269
1270  # get the appropriate data - from the approp. src
1271  if(on==1) {
1272    x <- as.matrix(lchob@xdata)
1273
1274    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1275
1276    if(is.function(with.col)) {
1277      x.tmp <- do.call(with.col,list(x))
1278    } else x.tmp <- x[,with.col]
1279  } else {
1280    # get values from TA...
1281    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1282    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1283
1284    x <- as.matrix(target.TA@TA.values)
1285
1286    if(missing(with.col)) with.col <- 1
1287
1288    if(is.function(with.col)) {
1289      x.tmp <- do.call(with.col,list(x))
1290    } else x.tmp <- x[,with.col]
1291  }
1292
1293  ma.tmp <- NULL
1294
1295  for(i in 1:length(n)) {
1296    ma <- EMA(x.tmp,n=n[i],wilder=wilder[1],
1297              ratio=ratio[1])
1298    ma.tmp <- cbind(ma.tmp,ma)
1299  }
1300
1301  chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp))
1302
1303  chobTA@name <- "chartEMA"
1304  chobTA@call <- match.call()
1305  chobTA@on <- on # used for deciding when to draw...
1306  chobTA@params <- list(xrange=lchob@xrange,
1307                        colors=lchob@colors,
1308                        color.vol=lchob@color.vol,
1309                        multi.col=lchob@multi.col,
1310                        spacing=lchob@spacing,
1311                        width=lchob@width,
1312                        bp=lchob@bp,
1313                        x.labels=lchob@x.labels,
1314                        time.scale=lchob@time.scale,
1315                        col=col,n=n,wilder=wilder,ratio=ratio)
1316  if(is.null(sys.call(-1))) {
1317    TA <- lchob@passed.args$TA
1318    lchob@passed.args$TA <- c(TA,chobTA)
1319    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1320    do.call('chartSeries.chob',list(lchob))
1321    invisible(chobTA)
1322  } else {
1323   return(chobTA)
1324  }
1325} # }}}
1326# chartEMA {{{
1327`chartEMA` <-
1328function(x) {
1329    spacing <- x@params$spacing
1330    width <- x@params$width
1331
1332    x.range <- x@params$xrange
1333    x.range <- seq(x.range[1],x.range[2]*spacing)
1334
1335    multi.col <- x@params$multi.col
1336    color.vol <- x@params$color.vol
1337
1338    if(length(x@params$n) != length(x@params$col)) {
1339      colors <- 3:10
1340    } else colors <- x@params$col
1341
1342    chart.key <- list()
1343
1344    for(li in 1:length(x@params$n)) {
1345      ma <- x@TA.values[,li]
1346
1347      if(x@new) {
1348        par(new=TRUE)
1349        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1350             type='n',axes=FALSE,ann=FALSE)
1351        coords <- par('usr')
1352        rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
1353       # title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1354        axis(2)
1355        box(col=x@params$colors$fg.col)
1356      }
1357      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1358      chart.key[[li]] <- list(text=paste("EMA (",
1359                   paste(x@params$n[li],sep=","),"): ",
1360                   sprintf("%.3f",last(ma)),
1361                   sep = ""), col = colors[li])
1362
1363    }
1364    invisible(chart.key)
1365
1366} # }}}
1367
1368# addSMA {{{
1369`addSMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='brown') {
1370
1371
1372  lchob <- get.current.chob()
1373  chobTA <- new("chobTA")
1374  chobTA@new <- !overlay
1375
1376  # get the appropriate data - from the approp. src
1377  if(on==1) {
1378    x <- as.matrix(lchob@xdata)
1379
1380    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1381
1382    if(is.function(with.col)) {
1383      x.tmp <- do.call(with.col,list(x))
1384    } else x.tmp <- x[,with.col]
1385  } else {
1386    # get values from TA...
1387    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1388    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1389
1390    x <- as.matrix(target.TA@TA.values)
1391
1392    if(missing(with.col)) with.col <- 1
1393
1394    if(is.function(with.col)) {
1395      x.tmp <- do.call(with.col,list(x))
1396    } else x.tmp <- x[,with.col]
1397  }
1398  ma.tmp <- NULL
1399  for(i in 1:length(n)) {
1400    ma <- SMA(x.tmp,n=n[i])
1401    ma.tmp <- cbind(ma.tmp,ma)
1402  }
1403
1404  chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp)) # single numeric vector
1405  chobTA@name <- "chartSMA"
1406  chobTA@call <- match.call()
1407  chobTA@on <- on # used for deciding when to draw...
1408  chobTA@params <- list(xrange=lchob@xrange,
1409                        colors=lchob@colors,
1410                        color.vol=lchob@color.vol,
1411                        multi.col=lchob@multi.col,
1412                        spacing=lchob@spacing,
1413                        width=lchob@width,
1414                        bp=lchob@bp,
1415                        x.labels=lchob@x.labels,
1416                        time.scale=lchob@time.scale,
1417                        col=col,n=n)
1418  if(is.null(sys.call(-1))) {
1419    TA <- lchob@passed.args$TA
1420    lchob@passed.args$TA <- c(TA,chobTA)
1421    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1422    do.call('chartSeries.chob',list(lchob))
1423    invisible(chobTA)
1424  } else {
1425   return(chobTA)
1426  }
1427} # }}}
1428# chartSMA {{{
1429`chartSMA` <-
1430function(x) {
1431    spacing <- x@params$spacing
1432    width <- x@params$width
1433
1434    x.range <- x@params$xrange
1435    x.range <- seq(x.range[1],x.range[2]*spacing)
1436
1437    multi.col <- x@params$multi.col
1438    color.vol <- x@params$color.vol
1439
1440    if(length(x@params$n) != length(x@params$col)) {
1441      colors <- c(4:10,3)
1442    } else colors <- x@params$col
1443
1444    chart.key <- list()
1445
1446    for(li in 1:length(x@params$n)) {
1447      ma <- x@TA.values[,li]
1448      if(x@new) {
1449        par(new=TRUE)
1450        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1451             type='n',axes=FALSE,ann=FALSE)
1452        coords <- par('usr')
1453        rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
1454        #title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1455        axis(2)
1456        box(col=x@params$colors$fg.col)
1457      }
1458      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1459      chart.key[[li]] <- list(text = paste("SMA (", paste(x@params$n[li],
1460            sep = ","), "): ", sprintf("%.3f", last(ma)), sep = ""),
1461            col = colors[li])
1462    }
1463    invisible(chart.key)
1464} # }}}
1465
1466# addWMA {{{
1467`addWMA` <- function(n=10,wts=1:n,on=1,with.col=Cl,overlay=TRUE,col='green') {
1468
1469
1470  lchob <- get.current.chob()
1471  chobTA <- new("chobTA")
1472  chobTA@new <- !overlay
1473
1474  # get the appropriate data - from the approp. src
1475  if(on==1) {
1476    x <- as.matrix(lchob@xdata)
1477
1478    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1479
1480    if(is.function(with.col)) {
1481      x.tmp <- do.call(with.col,list(x))
1482    } else x.tmp <- x[,with.col]
1483  } else {
1484    # get values from TA...
1485    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1486    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1487    x <- as.matrix(target.TA@TA.values)
1488
1489    if(missing(with.col)) with.col <- 1
1490
1491    if(is.function(with.col)) {
1492      x.tmp <- do.call(with.col,list(x))
1493    } else x.tmp <- x[,with.col]
1494  }
1495
1496  chobTA@TA.values <- x.tmp[lchob@xsubset]
1497  chobTA@name <- "chartWMA"
1498  chobTA@call <- match.call()
1499  chobTA@on <- on # used for deciding when to draw...
1500  chobTA@params <- list(xrange=lchob@xrange,
1501                        colors=lchob@colors,
1502                        color.vol=lchob@color.vol,
1503                        multi.col=lchob@multi.col,
1504                        spacing=lchob@spacing,
1505                        width=lchob@width,
1506                        bp=lchob@bp,
1507                        x.labels=lchob@x.labels,
1508                        time.scale=lchob@time.scale,
1509                        col=col,n=n,wts=wts)
1510  if(is.null(sys.call(-1))) {
1511    TA <- lchob@passed.args$TA
1512    lchob@passed.args$TA <- c(TA,chobTA)
1513    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1514    do.call('chartSeries.chob',list(lchob))
1515    invisible(chobTA)
1516  } else {
1517   return(chobTA)
1518  }
1519} # }}}
1520# chartWMA {{{
1521`chartWMA` <-
1522function(x) {
1523    spacing <- x@params$spacing
1524    width <- x@params$width
1525
1526    x.range <- x@params$xrange
1527    x.range <- seq(x.range[1],x.range[2]*spacing)
1528
1529    multi.col <- x@params$multi.col
1530    color.vol <- x@params$color.vol
1531
1532    if(length(x@params$n) < length(x@params$col)) {
1533      colors <- 3:10
1534    } else colors <- x@params$col
1535
1536    for(li in 1:length(x@params$n)) {
1537      ma <- WMA(x@TA.values,n=x@params$n[li],wts=x@params$wts)
1538      if(x@new) {
1539        par(new=TRUE)
1540        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1541             type='n',axes=FALSE,ann=FALSE)
1542        title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1543        axis(2)
1544        box(col=x@params$colors$fg.col)
1545      }
1546      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1547    }
1548} # }}}
1549
1550# addDEMA {{{
1551`addDEMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='pink') {
1552
1553
1554  lchob <- get.current.chob()
1555  chobTA <- new("chobTA")
1556  chobTA@new <- !overlay
1557
1558  # get the appropriate data - from the approp. src
1559  if(on==1) {
1560    x <- as.matrix(lchob@xdata)
1561
1562    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1563
1564    if(is.function(with.col)) {
1565      x.tmp <- do.call(with.col,list(x))
1566    } else x.tmp <- x[,with.col]
1567  } else {
1568    # get values from TA...
1569    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1570    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1571    x <- as.matrix(target.TA@TA.values)
1572
1573    if(missing(with.col)) with.col <- 1
1574
1575    if(is.function(with.col)) {
1576      x.tmp <- do.call(with.col,list(x))
1577    } else x.tmp <- x[,with.col]
1578  }
1579
1580  chobTA@TA.values <- x.tmp[lchob@xsubset]
1581  chobTA@name <- "chartDEMA"
1582  chobTA@call <- match.call()
1583  chobTA@on <- on # used for deciding when to draw...
1584  chobTA@params <- list(xrange=lchob@xrange,
1585                        colors=lchob@colors,
1586                        color.vol=lchob@color.vol,
1587                        multi.col=lchob@multi.col,
1588                        spacing=lchob@spacing,
1589                        width=lchob@width,
1590                        bp=lchob@bp,
1591                        x.labels=lchob@x.labels,
1592                        time.scale=lchob@time.scale,
1593                        col=col,n=n)
1594  if(is.null(sys.call(-1))) {
1595    TA <- lchob@passed.args$TA
1596    lchob@passed.args$TA <- c(TA,chobTA)
1597    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1598    do.call('chartSeries.chob',list(lchob))
1599    invisible(chobTA)
1600  } else {
1601   return(chobTA)
1602  }
1603} # }}}
1604# chartDEMA {{{
1605`chartDEMA` <-
1606function(x) {
1607    spacing <- x@params$spacing
1608    width <- x@params$width
1609
1610    x.range <- x@params$xrange
1611    x.range <- seq(x.range[1],x.range[2]*spacing)
1612
1613    multi.col <- x@params$multi.col
1614    color.vol <- x@params$color.vol
1615
1616    if(length(x@params$n) < length(x@params$col)) {
1617      colors <- 3:10
1618    } else colors <- x@params$col
1619
1620    for(li in 1:length(x@params$n)) {
1621      ma <- DEMA(x@TA.values,n=x@params$n[li])
1622      if(x@new) {
1623        par(new=TRUE)
1624        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1625             type='n',axes=FALSE,ann=FALSE)
1626        title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1627        axis(2)
1628        box(col=x@params$colors$fg.col)
1629      }
1630      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1631    }
1632} # }}}
1633
1634# addEVWMA {{{
1635`addEVWMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='yellow') {
1636
1637
1638  lchob <- get.current.chob()
1639  chobTA <- new("chobTA")
1640  chobTA@new <- !overlay
1641
1642  # get the appropriate data - from the approp. src
1643  if(on==1) {
1644    x <- as.matrix(lchob@xdata)
1645
1646    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1647
1648    if(is.function(with.col)) {
1649      x.tmp <- cbind(do.call(with.col,list(x)),Vo(x))
1650    } else x.tmp <- x[,with.col]
1651  } else {
1652    # get values from TA...
1653    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1654    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1655    x <- as.matrix(target.TA@TA.values)
1656
1657    if(missing(with.col)) with.col <- 1
1658
1659    if(is.function(with.col)) {
1660      x.tmp <- do.call(with.col,list(x))
1661    } else x.tmp <- x[,with.col]
1662  }
1663  if(!has.Vo(x)) return()
1664
1665  chobTA@TA.values <- cbind(x.tmp,Vo(x))[lchob@xsubset,] # Price + Volume
1666  chobTA@name <- "chartEVWMA"
1667  chobTA@call <- match.call()
1668  chobTA@on <- on # used for deciding when to draw...
1669  chobTA@params <- list(xrange=lchob@xrange,
1670                        colors=lchob@colors,
1671                        color.vol=lchob@color.vol,
1672                        multi.col=lchob@multi.col,
1673                        spacing=lchob@spacing,
1674                        width=lchob@width,
1675                        bp=lchob@bp,
1676                        x.labels=lchob@x.labels,
1677                        time.scale=lchob@time.scale,
1678                        col=col,n=n)
1679  if(is.null(sys.call(-1))) {
1680    TA <- lchob@passed.args$TA
1681    lchob@passed.args$TA <- c(TA,chobTA)
1682    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1683    do.call('chartSeries.chob',list(lchob))
1684    invisible(chobTA)
1685  } else {
1686   return(chobTA)
1687  }
1688} # }}}
1689# chartEVWMA {{{
1690`chartEVWMA` <-
1691function(x) {
1692    spacing <- x@params$spacing
1693    width <- x@params$width
1694
1695    x.range <- x@params$xrange
1696    x.range <- seq(x.range[1],x.range[2]*spacing)
1697
1698    multi.col <- x@params$multi.col
1699    color.vol <- x@params$color.vol
1700
1701    if(length(x@params$n) < length(x@params$col)) {
1702      colors <- 3:10
1703    } else colors <- x@params$col
1704
1705    for(li in 1:length(x@params$n)) {
1706      ma <- EVWMA(x@TA.values[,1],x@TA.values[,2],n=x@params$n[li])
1707      if(x@new) {
1708        par(new=TRUE)
1709        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1710             type='n',axes=FALSE,ann=FALSE)
1711        title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1712        axis(2)
1713        box(col=x@params$colors$fg.col)
1714      }
1715      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1716    }
1717} # }}}
1718
1719# addZLEMA {{{
1720`addZLEMA` <- function(n=10,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='red') {
1721
1722
1723  lchob <- get.current.chob()
1724  chobTA <- new("chobTA")
1725  chobTA@new <- !overlay
1726
1727  # get the appropriate data - from the approp. src
1728  if(on==1) {
1729    x <- as.matrix(lchob@xdata)
1730
1731    if(!is.OHLC(x) && missing(with.col)) with.col <- 1
1732
1733    if(is.function(with.col)) {
1734      x.tmp <- do.call(with.col,list(x))
1735    } else x.tmp <- x[,with.col]
1736  } else {
1737    # get values from TA...
1738    which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
1739    target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
1740
1741    if(missing(with.col)) with.col <- 1
1742
1743    x <- as.matrix(target.TA@TA.values)
1744    if(missing(with.col)) {
1745      warning('missing "with.col" argument')
1746      invisible(return())
1747    }
1748    if(is.function(with.col)) {
1749      x.tmp <- do.call(with.col,list(x))
1750    } else x.tmp <- x[,with.col]
1751  }
1752
1753  chobTA@TA.values <- x.tmp[lchob@xsubset]
1754  chobTA@name <- "chartZLEMA"
1755  chobTA@call <- match.call()
1756  chobTA@on <- on # used for deciding when to draw...
1757  chobTA@params <- list(xrange=lchob@xrange,
1758                        colors=lchob@colors,
1759                        color.vol=lchob@color.vol,
1760                        multi.col=lchob@multi.col,
1761                        spacing=lchob@spacing,
1762                        width=lchob@width,
1763                        bp=lchob@bp,
1764                        x.labels=lchob@x.labels,
1765                        time.scale=lchob@time.scale,
1766                        col=col,n=n,ratio=ratio)
1767  if(is.null(sys.call(-1))) {
1768    TA <- lchob@passed.args$TA
1769    lchob@passed.args$TA <- c(TA,chobTA)
1770    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1771    do.call('chartSeries.chob',list(lchob))
1772    invisible(chobTA)
1773  } else {
1774   return(chobTA)
1775  }
1776} # }}}
1777# chartZLEMA {{{
1778`chartZLEMA` <-
1779function(x) {
1780    spacing <- x@params$spacing
1781    width <- x@params$width
1782
1783    x.range <- x@params$xrange
1784    x.range <- seq(x.range[1],x.range[2]*spacing)
1785
1786    multi.col <- x@params$multi.col
1787    color.vol <- x@params$color.vol
1788
1789    if(length(x@params$n) < length(x@params$col)) {
1790      colors <- 3:10
1791    } else colors <- x@params$col
1792
1793    for(li in 1:length(x@params$n)) {
1794      ma <- ZLEMA(x@TA.values,n=x@params$n[li],ratio=x@params$ratio)
1795      if(x@new) {
1796        par(new=TRUE)
1797        plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
1798             type='n',axes=FALSE,ann=FALSE)
1799        title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
1800        axis(2)
1801        box(col=x@params$colors$fg.col)
1802      }
1803      lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
1804    }
1805} # }}}
1806
1807# addExpiry {{{
1808`addExpiry` <- function(type='options',lty='dotted') {
1809  lchob <- get.current.chob()
1810  chobTA <- new("chobTA")
1811  chobTA@new <- FALSE
1812
1813  # get the appropriate data - from the approp. src
1814  #if(from.fig==1) {
1815  x <- lchob@xdata
1816
1817  if(type=='options') {
1818    index.of.exp <- options.expiry(x)
1819  } else index.of.exp <- futures.expiry(x)
1820
1821  chobTA@TA.values <- index.of.exp[index.of.exp %in% lchob@xsubset] # single numeric vector
1822  chobTA@name <- "chartExpiry"
1823  chobTA@call <- match.call()
1824  chobTA@on <- 1
1825  chobTA@params <- list(xrange=lchob@xrange,
1826                        colors=lchob@colors,
1827                        color.vol=lchob@color.vol,
1828                        multi.col=lchob@multi.col,
1829                        spacing=lchob@spacing,
1830                        width=lchob@width,
1831                        bp=lchob@bp,
1832                        x.labels=lchob@x.labels,
1833                        time.scale=lchob@time.scale,
1834                        col=col,lty=lty)
1835  if(is.null(sys.call(-1))) {
1836    TA <- lchob@passed.args$TA
1837    lchob@passed.args$TA <- c(TA,chobTA)
1838    lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
1839    do.call('chartSeries.chob',list(lchob))
1840    invisible(chobTA)
1841  } else {
1842   return(chobTA)
1843  }
1844} # }}}
1845# chartExpiry {{{
1846`chartExpiry` <-
1847function(x) {
1848    spacing <- x@params$spacing
1849    width <- x@params$width
1850
1851    x.range <- x@params$xrange
1852    x.range <- seq(x.range[1],x.range[2]*spacing)
1853
1854    multi.col <- x@params$multi.col
1855    color.vol <- x@params$color.vol
1856
1857    for(ex in 1:length(x@TA.values)) {
1858      abline(v=x@TA.values[ex]*spacing,lty=x@params$lty,col=x@params$colors$Expiry)
1859    }
1860} # }}}
1861
1862# get.current.chob {{{
1863`get.current.chob` <- function() {
1864  first.chob <- which(sapply(sys.frames(),function(x) exists('chob',envir=x)))[1]
1865  if(!is.na(first.chob)) {
1866    lchob <- get('chob',envir=first.chob)
1867
1868#  if(exists('chob',envir=sys.frames()[[sys.parent()]])) {
1869#    if(identical(sys.frames()[[sys.parent()]],.GlobalEnv))
1870#      stop("why are you calling this directly?")
1871#    lchob <- get('chob',envir=sys.frames()[[sys.parent()]])
1872  } else {
1873    gchob <- get.chob()
1874    #protect against NULL device or windows not drawn to yet
1875    if(dev.cur()==1 || length(gchob) < dev.cur())
1876      stop("improperly set or missing graphics device")
1877    current.chob <- which(sapply(gchob,
1878                                 function(x) {
1879                                   ifelse(class(x)=="chob" &&
1880                                   x@device==as.numeric(dev.cur()),TRUE,FALSE)
1881                                 }))
1882    if(identical(current.chob,integer(0))) stop("no current plot")
1883    lchob <- gchob[[current.chob]]
1884  }
1885  return(lchob)
1886} #}}}
1887