# core addTA base functions
#
# written by Jeffrey A. Ryan
# Copyright 2008
# Distributed under the GPL 3 or later
`funToTA` <-
function(x,drop.arg=1) {
drop.arg <- if(any(drop.arg < 1)) {
1:length(formals(x))
} else -drop.arg
fun.args <- paste(names(formals(x))[drop.arg],'=',sapply(formals(x), deparse)[drop.arg],sep='')
fun.args <- paste(gsub('=$','',fun.args),collapse=',')
paste('add',deparse(substitute(x)),'(',fun.args,') {',collapse='',sep='')
}
shading <- function(x)
{
# to be used from addTA when passed a logical object or vector
# also from new addEvents function
#
# ex. rect(shading$start-spacing, par('usr')[3],
# shading$end-spacing, par('usr')[3])
if( !is.logical(x) )
warning('need logical object')
runs <- rle(as.logical(x))
list(
start=cumsum(runs$length)[which(runs$values)] - runs$length[which(runs$values)]+1,
end=cumsum(runs$lengths)[which(runs$values)]
)
}
# addTA {{{
`addTA` <-
function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) {
if(is.character(ta)) {
if(exists(ta)) {
plot(do.call(paste('add',ta,sep=''),list(...)))
} else stop(paste('no TA method found for',paste('add',ta,sep='')))
} else {
lchob <- get.current.chob()
chobTA <- new("chobTA")
if(any(is.na(on))) {
chobTA@new <- TRUE
} else {
chobTA@new <- FALSE
chobTA@on <- on
}
nrc <- NROW(lchob@xdata)
ta <- try.xts(ta, error=FALSE)
if(is.xts(ta)) {
x <- merge(lchob@xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE))
} else {
if(NROW(ta) != nrc)
stop('non-xtsible data must match the length of the underlying series')
x <- merge(lchob@xdata, ta, join='left', retside=c(FALSE,TRUE))
}
if(is.logical(ta))
x <- as.logical(x, drop=FALSE) #identical to storage.mode(x)<-"logical"
chobTA@TA.values <- coredata(x)[lchob@xsubset,]
chobTA@name <- "chartTA"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
yrange=yrange,
colors=lchob@colors,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
isLogical=is.logical(ta),
x.labels=lchob@x.labels,
order=order,legend=legend,
pars=list(list(...)),
time.scale=lchob@time.scale)
# if(is.null(sys.call(-1))) {
# TA <- lchob@passed.args$TA
# lchob@passed.args$TA <- c(TA,chobTA)
# lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
# do.call('chartSeries.chob',list(lchob))
# #quantmod:::chartSeries.chob(lchob)
# invisible(chobTA)
# } else {
return(chobTA)
# }
}
}#}}}
# chartTA {{{
`chartTA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
tav <- x@TA.values
if(x@new) {
# draw new sub-window
y.range <- if(is.null(x@params$yrange) || length(x@params$yrange) != 2) {
seq(min(tav * 0.975, na.rm = TRUE), max(tav * 1.05, na.rm = TRUE),
length.out=length(x.range))
} else seq(x@params$yrange[1],x@params$yrange[2],length.out=length(x.range))
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
pars <- x@params$pars[[1]]
pars <- lapply(pars,
function(x) {
len <- NCOL(tav)
if(length(x) < len) {
rep(list(x), length.out=len)
} else rep(list(x),length.out=len)
})
# pars <- x@params$pars#[[1]]
# pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
col.order <- if(is.null(x@params$order)) {
1:NCOL(tav)
} else x@params$order
if(is.null(x@params$legend)) legend <- function(legend,text.col,...) {}
if(is.character(x@params$legend) && x@params$legend != "auto") {
legend("topleft", legend=x@params$legend, bty='n', y.inter=0.95)
legend <- function(legend,text.col,...) { }
}
if(!x@new) {
legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
}
#formals(legend) <- alist(legend=,text.col=,...=) #formals(graphics::legend) # all have the same formals now
legend.text <- list()
# possibly able to handle newTA functionality
if(is.null(x@params$legend.name)) x@params$legend.name <- deparse(x@call[-1][[1]])
x.pos <- 1 + spacing * (1:length(x.range))
if(NCOL(tav) == 1) {
tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
if(x@params$isLogical) {
do.call('rect',c(list(x.pos[shading(tav)$start-1] - spacing/3), list(par('usr')[3]),
list(x.pos[shading(tav)$end-1] + spacing/3), list(par('usr')[4]), tmp.pars))
# do not add a legend name for background shading. probably better to have
# the labels in another routine
} else {
do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav), tmp.pars))
legend.text[[1]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
text.col=c(x@params$colors$fg.col,last(pars$col[[1]])),bty='n',y.inter=.95)
}
} else {
for(cols in col.order) {
tmp.pars <- lapply(pars,function(x) {
p <- try(x[[cols]][[cols]],silent=TRUE)
if(inherits(p, 'try-error')) {
stop("TA parameter length must equal number of columns", call.=FALSE)
} else p
}
)
do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav[,cols]), tmp.pars))
if(cols==1) {
legend.text[[cols]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":")),
text.col=c(x@params$colors$fg.col,last(pars$col[[cols]])),bty='n',y.inter=.95)
}
# for each column, add colname: value
Col.title <- colnames(tav)[cols]
legend.text[[cols]] <- legend('topleft',
legend=c(rep('',cols),paste(Col.title,":",
sprintf("%.3f",last(na.omit(tav[,cols]))))),
text.col=pars$col[[cols]][cols],bty='n',y.inter=.95)
}
}
axis(2)
box(col=x@params$colors$fg.col)
invisible(legend.text)
} # }}}
# chartSetUp {{{
`chartSetUp` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
tav <- x@TA.values
if(x@new) {
y.range <- if(is.null(x@params$yrange) || length(x@params$yrange) != 2) {
seq(min(tav * 0.975, na.rm = TRUE), max(tav * 1.05, na.rm = TRUE),
length.out=length(x.range))
} else seq(x@params$yrange[1],x@params$yrange[2],length.out=length(x.range))
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
pars <- x@params$pars[[1]]
pars <- lapply(pars,
function(x) {
len <- NCOL(tav)
if(length(x) < len) {
rep(list(x), length.out=len)
} else rep(list(x),length.out=len)
})
# pars <- x@params$pars#[[1]]
# pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
col.order <- if(is.null(x@params$order)) {
1:NCOL(tav)
} else x@params$order
if(is.null(x@params$legend)) legend <- function(legend,text.col,...) {}
if(is.character(x@params$legend) && x@params$legend != "auto") {
legend("topleft", legend=x@params$legend, bty='n', y.inter=0.95)
legend <- function(legend,text.col,...) { }
}
if(!x@new) {
legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
}
legend.text <- list()
# possibly able to handle newTA functionality
if(is.null(x@params$legend.name)) x@params$legend.name <- deparse(x@call[-1][[1]])
if(NCOL(tav) == 1) {
tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
# if(x@params$isLogical) {
# do.call('rect',c(list(shading(tav)$start*spacing), list(par('usr')[3]),
# list(shading(tav)$end*spacing), list(par('usr')[4]), tmp.pars))
# } else
# do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav), tmp.pars))
legend.text[[1]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
text.col=c(x@params$colors$fg.col,last(pars$col[[1]])),bty='n',y.inter=.95)
} else {
for(cols in col.order) {
tmp.pars <- lapply(pars,function(x) x[[cols]][[cols]])
# do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav[,cols]), tmp.pars))
if(cols==1) {
legend.text[[cols]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":")),
text.col=c(x@params$colors$fg.col,last(pars$col[[cols]])),bty='n',y.inter=.95)
}
# for each column, add colname: value
Col.title <- colnames(tav)[cols]
legend.text[[cols]] <- legend('topleft',
legend=c(rep('',cols),paste(Col.title,":",
sprintf("%.3f",last(na.omit(tav[,cols]))))),
text.col=pars$col[[cols]][cols],bty='n',y.inter=.95)
}
}
axis(2)
box(col=x@params$colors$fg.col)
invisible(legend.text)
} # }}}
# setTA {{{
`setTA` <-
function(type=c('chartSeries','barChart','candleChart')) {
if('chartSeries' %in% type) setDefaults(chartSeries,TA=listTA())
if('barChart' %in% type) setDefaults(barChart,TA=listTA())
if('candleChart' %in% type) setDefaults(candleChart,TA=listTA())
}# }}}
# unsetTA {{{
`unsetTA` <-
function(type=c('chartSeries','barChart','candleChart')) {
if('chartSeries' %in% type) setDefaults(chartSeries,TA=NULL)
if('barChart' %in% type) setDefaults(barChart,TA=NULL)
if('candleChart' %in% type) setDefaults(candleChart,TA=NULL)
}# }}}
# listTA {{{
`listTA` <-
function(dev) {
if(missing(dev)) dev <- dev.cur()
sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call)
} # }}}
chartNULL <- function(...) return(invisible(NULL))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.