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