findOHLC <- function() {
chob <- current.chob()
loc <- round(locator(1)$x)
ohlc <- current.chob()$Env$xdata[current.chob()$Env$xsubset][loc]
actions <- chob$Env$actions
envs <- lapply(actions[which(!sapply(actions,attr,'frame')%%2)],attr,'env')
values <- lapply(lapply(envs[sapply(envs,is.list)],`[[`,1),
function(x) x$xdata[chob$Env$xsubset][loc])
do.call('cbind',c(list(ohlc),values))
}
getSubset <- function() {
chob <- current.chob()
from <- round(locator(1)$x)
to <- round(locator(1)$x)
ohlc <- current.chob()$Env$xdata[current.chob()$Env$xsubset][from:to]
actions <- chob$Env$actions
envs <- lapply(actions[which(!sapply(actions,attr,'frame')%%2)],attr,'env')
values <- lapply(lapply(envs[sapply(envs,is.list)],`[[`,1),
function(x) x$xdata[chob$Env$xsubset][from:to])
c(list(ohlc),values)
}
# axTicksByValue {{{
axTicksByValue <-
function(x,
match.to=c(1e8,1e7,1e6,1e5,1e4,1e3,
500,300,200,150,100,
50,20,10,
5,2,1,
0.50,0.25,0.20,0.10,
0.05,0.02,0.01),
lt=20,gt=3, secondary=FALSE) {
x <- na.omit(x)
diff_range <- diff(range(x))
if(diff_range > 1)
diff_range <- diff(range(x %/% 1))
by <- match.to[which(diff_range %/% match.to > gt & diff_range %/% match.to < lt)[1]]
if(is.na(by)) {
by <- 1L
}
ticks1 <- do.call('seq.int', as.list(c(range(x)[1]%/%by*by,range(x)[2]%/%by*by,by)))
# if(length(ticks1) > 5) ticks1 <- ticks1[-c(1,length(ticks1))]
ticks1
} # }}}
#axTicksByValue <- function(x, ...) pretty(x)
# UNUSED heikin.ashi.bars {{{
heikin.ashi.bars <-
function(x, type="", spacing=1, up.col="green",dn.col="red",up.border="grey",dn.border=up.border) {
if(is.OHLC(x)) {
haCloses <- as.xts(apply(OHLC(x),1,sum))/4
haOpens <- Op(x)
haOpens <- (lag(haOpens) + lag(haCloses))/2
haHighs <- as.numeric(as.xts(apply(cbind(Hi(x),haOpens,haCloses),1,max)))
haLows <- as.numeric(as.xts(apply(cbind(Lo(x),haOpens,haCloses),1,min)))
haOpens <- as.numeric(haOpens)
haCloses <- as.numeric(haCloses)
}
bar.col <- ifelse(haOpens < haCloses, up.col, dn.col)
bar.border <- ifelse(haOpens < haCloses, up.border, dn.border)
x.pos <- spacing*(1:NROW(x))
segments(x.pos, haLows, x.pos, apply(cbind(haOpens,haCloses),1,min),col=bar.border)
segments(x.pos, haHighs, x.pos, apply(cbind(haOpens,haCloses),1,max),col=bar.border)
if (type == "candlesticks") {
rect(x.pos - spacing/3, haOpens, x.pos + spacing/3,
haCloses, col = bar.col, border = bar.border)
} else segments(x.pos, haOpens, x.pos, haCloses, col='blue')
} # }}}
# range.bars {{{
range.bars <-
function(x, type="", spacing=1, line.col="darkorange",
up.col="green",dn.col="red",up.border="grey",dn.border=up.border) {
if(is.OHLC(x) && type != "line") {
Opens <- as.numeric(Op(x))
Highs <- as.numeric(Hi(x))
Lows <- as.numeric(Lo(x))
Closes <- as.numeric(Cl(x))
if(type=="heikin.ashi") {
Closes <- as.xts(apply(OHLC(x),1,sum))/4
Opens <- Op(x)
Opens <- (lag(Opens) + lag(Closes))/2
Highs <- as.numeric(as.xts(apply(cbind(Hi(x),Opens,Closes),1,max)))
Lows <- as.numeric(as.xts(apply(cbind(Lo(x),Opens,Closes),1,min)))
Opens <- as.numeric(Opens)
Closes <- as.numeric(Closes)
type <- "candlesticks"
}
} else {
line.col <- rep(line.col, length.out=NCOL(x))
for(i in 1:NCOL(x))
lines(1:NROW(x),x[,i],lwd=2,col=line.col[i],lend=3,lty=1)
return(NULL)
}
bar.col <- ifelse(Opens < Closes, up.col, dn.col)
bar.border <- ifelse(Opens < Closes, up.border, dn.border)
x.pos <- spacing*(1:NROW(x))
if( type %in% c("ohlc", "hlc")) {
bar.border <- bar.col
bar.border[is.na(bar.border)] <- up.border
}
segments(x.pos, Lows, x.pos, apply(cbind(Opens,Closes),1,min),col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Highs, x.pos, apply(cbind(Opens,Closes),1,max),col=bar.border,lwd=1.2,lend=3)
if (type == "candlesticks") {
rect(x.pos - spacing/3, Opens, x.pos + spacing/3,
Closes, col = bar.col, border = bar.border, lwd=0.2)
} else
if (type == "matchsticks") {
bar.col[is.na(bar.col)] <- up.col
segments(x.pos, Opens, x.pos, Closes, col=bar.col,lwd=1.2,lend=3)
} else
if (type == "ohlc") {
segments(x.pos, Opens, x.pos, Closes, col=bar.border,lwd=1.2,lend=3)
segments(x.pos-1/3, Opens, x.pos, Opens, col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Closes, x.pos+1/3, Closes, col=bar.border,lwd=1.2,lend=3)
} else
if (type == "hlc") {
segments(x.pos, Opens, x.pos, Closes, col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Closes, x.pos+1/3, Closes, col=bar.border,lwd=1.2,lend=3)
}
} # }}}
# {{{ chart_theme
chart_theme <- chart_theme_white <- function() {
theme <-list(col=list(bg="#FFFFFF",
label.bg="#F0F0F0",
grid="#F0F0F0",
grid2="#F5F5F5",
ticks="#999999",
labels="#333333",
line.col="darkorange",
dn.col="red",
up.col=NA,
dn.border="#333333",
up.border="#333333"),
shading=1,
format.labels=TRUE,
coarse.time=TRUE,
rylab=TRUE,
lylab=TRUE,
grid.ticks.lwd=1,
grid.ticks.on="months")
theme$bbands <- list(col=list(fill="whitesmoke",upper="#D5D5D5",
lower="#D5D5D5",ma="#D5D5D5"),
lty=list(upper="dashed",lower="dashed",ma="dotted")
)
theme
} # }}}
# chart_pars {{{
chart_pars <- function() {
list(cex=0.6, mar=c(3,1,0,1))
} # }}}
# chart_Series {{{
# Updated: 2010-01-15
#
# chart_Series now uses a new graphical extension
# called 'replot'. This enables the accumulation
# of 'actions', in the form of (unevaluated) R
# expressions, to be stored within a replot object.
# This object is an R closure, which contains
# all the methods which are needed to perform
# graphical operations.
#
# Ideally all behavior is consistent with the
# original quantmod:::chartSeries, except the
# undesireable ones.
chart_Series <- function(x,
name=deparse(substitute(x)),
type="candlesticks",
subset="",
TA="",
pars=chart_pars(), theme=chart_theme(),
clev=0,
...) {
cs <- new.replot()
#cex <- pars$cex
#mar <- pars$mar
line.col <- theme$col$line.col
up.col <- theme$col$up.col
dn.col <- theme$col$dn.col
up.border <- theme$col$up.border
dn.border <- theme$col$dn.border
format.labels <- theme$format.labels
if(is.null(theme$grid.ticks.on)) {
xs <- x[subset]
major.grid <- c(years=nyears(xs),
months=nmonths(xs),
days=ndays(xs))
grid.ticks.on <- names(major.grid)[rev(which(major.grid < 30))[1]]
} else grid.ticks.on <- theme$grid.ticks.on
label.bg <- theme$col$label.bg
cs$subset <- function(x) {
if(FALSE) {set_ylim <- get_ylim <- set_xlim <- Env<-function(){} } # appease R parser?
if(missing(x)) {
x <- "" #1:NROW(Env$xdata)
}
Env$xsubset <<- x
set_xlim(c(1,NROW(Env$xdata[Env$xsubset])))
ylim <- get_ylim()
for(y in seq(2,length(ylim),by=2)) {
if(!attr(ylim[[y]],'fixed'))
ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE)
}
lapply(Env$actions,
function(x) {
frame <- abs(attr(x, "frame"))
fixed <- attr(ylim[[frame]],'fixed')
#fixed <- attr(x, "fixed")
if(frame %% 2 == 0 && !fixed) {
lenv <- attr(x,"env")
if(is.list(lenv)) lenv <- lenv[[1]]
min.tmp <- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE)
max.tmp <- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE)
ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed)
}
})
# reset all ylim values, by looking for range(env[[1]]$xdata)
# xdata should be either coming from Env or if lenv, lenv
set_ylim(ylim)
}
environment(cs$subset) <- environment(cs$get_asp)
if(is.character(x))
stop("'x' must be a time-series object")
if(is.OHLC(x)) {
cs$Env$xdata <- OHLC(x)
if(has.Vo(x))
cs$Env$vo <- Vo(x)
} else cs$Env$xdata <- x
#subset <- match(.index(x[subset]), .index(x))
cs$Env$xsubset <- subset
cs$Env$cex <- pars$cex
cs$Env$mar <- pars$mar
cs$set_asp(3)
cs$set_xlim(c(1,NROW(cs$Env$xdata[subset])))
cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE)))
cs$set_frame(1,FALSE)
cs$Env$clev = min(clev+0.01,1) # (0,1]
cs$Env$theme$bbands <- theme$bbands
cs$Env$theme$shading <- theme$shading
cs$Env$theme$line.col <- theme$col$line.col
cs$Env$theme$up.col <- up.col
cs$Env$theme$dn.col <- dn.col
cs$Env$theme$up.border <- up.border
cs$Env$theme$dn.border <- dn.border
cs$Env$theme$rylab <- theme$rylab
cs$Env$theme$lylab <- theme$lylab
cs$Env$theme$bg <- theme$col$bg
cs$Env$theme$grid <- theme$col$grid
cs$Env$theme$grid2 <- theme$col$grid2
cs$Env$theme$labels <- "#333333"
cs$Env$theme$label.bg <- label.bg
cs$Env$format.labels <- format.labels
cs$Env$ticks.on <- grid.ticks.on
cs$Env$grid.ticks.lwd <- theme$grid.ticks.lwd
cs$Env$type <- type
# axis_ticks function to label lower frequency ranges/grid lines
cs$Env$axis_ticks <- function(xdata,xsubset) {
ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 +
last(axTicksByTime2(xdata[xsubset],labels=TRUE),-1)
if(!theme$coarse.time || length(ticks) == 1)
return(unname(ticks))
if(min(diff(ticks)) < max(strwidth(names(ticks)))) {
ticks <- unname(ticks)
}
ticks
}
# need to add if(upper.x.label) to allow for finer control
cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]),
segments(atbt, #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][1],
atbt, #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][2], col=theme$grid, lwd=grid.ticks.lwd),
axt <- axis_ticks(xdata,xsubset),
text(as.numeric(axt),
par('usr')[3]-0.2*min(strheight(axt)),
names(axt),xpd=TRUE,cex=0.9,pos=3)),
clip=FALSE,expr=TRUE)
cs$set_frame(-1)
# background of main window
#cs$add(expression(rect(par("usr")[1],
# par("usr")[3],
# par("usr")[2],
# par("usr")[4],border=NA,col=theme$bg)),expr=TRUE)
cs$add_frame(0,ylim=c(0,1),asp=0.2)
cs$set_frame(1)
# add observation level ticks on x-axis if < 400 obs.
cs$add(expression(if(NROW(xdata[xsubset])<400)
{axis(1,at=1:NROW(xdata[xsubset]),labels=FALSE,col=theme$grid2,tcl=0.3)}),expr=TRUE)
# add "month" or "month.abb"
cs$add(expression(axt <- axTicksByTime(xdata[xsubset],format.labels=format.labels),
axis(1,at=axt, #axTicksByTime(xdata[xsubset]),
labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)),
las=1,lwd.ticks=1,mgp=c(3,1.5,0),tcl=-0.4,cex.axis=.9)),
expr=TRUE)
cs$Env$name <- name
text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)),
expression(text(NROW(xdata[xsubset]),0.5,
paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "),
col=1,adj=c(0,0),pos=2)))
cs$add(text.exp, env=cs$Env, expr=TRUE)
cs$set_frame(2)
cs$Env$axis_labels <- function(xdata,xsubset,scale=5) {
axTicksByValue(na.omit(xdata[xsubset]))
}
cs$Env$make_pretty_labels <- function(ylim) {
p <- pretty(ylim,10)
p[p > ylim[1] & p < ylim[2]]
}
#cs$add(assign("five",rnorm(10))) # this gets re-evaled each update, though only to test
#cs$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE)
#cs$add(expression(assign("alabels", pretty(range(xdata[xsubset],na.rm=TRUE)))),expr=TRUE)
#cs$add(expression(assign("alabels", pretty(get_ylim(get_frame())[[2]],10))),expr=TRUE)
cs$add(expression(assign("alabels", make_pretty_labels(get_ylim(get_frame())[[2]]))),expr=TRUE)
# add $1 grid lines if appropriate
cs$set_frame(-2)
# add minor y-grid lines
cs$add(expression(if(diff(range(xdata[xsubset],na.rm=TRUE)) < 50)
segments(1,seq(min(xdata[xsubset]%/%1,na.rm=TRUE),
max(xdata[xsubset]%/%1,na.rm=TRUE),1),
length(xsubset),
seq(min(xdata[xsubset]%/%1,na.rm=TRUE),
max(xdata[xsubset]%/%1,na.rm=TRUE),1),
col=theme$grid2, lty="dotted")), expr=TRUE)
cs$set_frame(2)
# add main y-grid lines
cs$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE)
# left axis labels
if(theme$lylab) {
cs$add(expression(text(1-1/3-max(strwidth(alabels)),
alabels, #axis_labels(xdata,xsubset),
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE)
}
# right axis labels
if(theme$rylab) {
cs$add(expression(text(NROW(xdata[xsubset])+1/3,
alabels,
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE)
}
# add main series
cs$set_frame(2)
# need to rename range.bars to something more generic, and allow type= to handle:
# ohlc, hlc, candles, ha-candles, line, area
# chart_Perf will be the call to handle relative performace plots
cs$add(expression(range.bars(xdata[xsubset],
type, 1,
fade(theme$line.col,clev),
fade(theme$up.col,clev),
fade(theme$dn.col,clev),
fade(theme$up.border,clev),
fade(theme$dn.border,clev))),expr=TRUE)
assign(".chob", cs, .plotEnv)
# handle TA="add_Vo()" as we would interactively FIXME: allow TA=NULL to work
if(!is.null(TA) && nchar(TA) > 0) {
TA <- parse(text=TA, srcfile=NULL)
for( ta in 1:length(TA)) {
if(length(TA[ta][[1]][-1]) > 0) {
cs <- eval(TA[ta])
} else {
cs <- eval(TA[ta])
}
}
}
assign(".chob", cs, .plotEnv)
cs
} #}}}
# zoom_Chart {{{
zoom_Chart <- function(subset) {
chob <- current.chob()
chob$subset(subset)
chob
}
# }}}
fade <- function(col, level) {
# adjust col toward white, (?background) by 0-1 range
cols <- character(length(col))
for(i in 1:length(col))
cols[i] <- colorRampPalette(c(col[i], "white"))(99)[level*100]
cols
}
current.chob <- function() invisible(get(".chob",.plotEnv))
use.chob <- function(use=TRUE) {
options('global.chob'=use)
}
new_ta <- function(FUN, preFUN, postFUN, on=NA, ...) {}
# add_Series {{{
add_Series <- function(x, type="candlesticks",order=NULL, on=NA, legend="auto", theme=NULL,...) {
lenv <- new.env()
lenv$name <- deparse(substitute(x))
lenv$plot_series <- function(x, series, type, ...) {
# vertical grid lines
if(FALSE) theme <- NULL
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=theme$grid)
#col=x$Env$theme$grid)
series <- merge(series, x$Env$xdata, join="outer",retside=c(TRUE,FALSE))[x$Env$xsubset]
range.bars(series, type=type)
}
lenv$xdata <- x
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(x=x,type=type,order=order,on=on,legend=legend,...)),
list(x=x,type=type,order=order,on=on,legend=legend,...))
exp <- parse(text=gsub("list","plot_series",
as.expression(substitute(list(x=current.chob(),type=type,series=get("x"), ...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$theme <- if(is.null(theme)) plot_object$Env$theme else theme
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
tav <- merge(x, xdata, join="left",retside=c(TRUE,FALSE))
lenv$upper.env <- plot_object$Env
lenv$xdata <- x
x <- x[xsubset]
if(is.na(on)) {
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(x=c(1),y=0.3, name, col=c(1),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(OHLC(x))),asp=1) # need to have a value set for ylim
plot_object$next_frame()
plot_object$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE)
# add main y-grid lines
plot_object$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE)
# left axis labels
exp <- c(expression(text(1-1/3-max(strwidth(alabels)),
alabels, #axis_labels(xdata,xsubset),
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4)),
expression(text(NROW(upper.env$xdata[xsubset])+1/3,
alabels,
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4)),exp)
# lenv$grid_lines <- function(xdata,x) { seq(-1,1) }
# # add grid lines
# exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# # add axis labels/boxes
# expression(text(0,grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,pos=2)),
# expression(text(NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,pos=4)),exp)
} else { plot_object$set_frame(sign(on)*(abs(on)+1L)) }
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} #}}}
# add_TA {{{
add_TA <- function(x, order=NULL, on=NA, legend="auto",
yaxis=list(NULL,NULL),
col=1, taType=NULL, ...) {
lenv <- new.env()
lenv$name <- deparse(substitute(x))
lenv$plot_ta <- function(x, ta, on, taType, col=col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
if(all(is.na(on))) {
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3],
axTicksByTime2(xdata[xsubset]),
par("usr")[4],
col=x$Env$theme$grid)
}
if(is.logical(ta)) {
ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset]
shade <- shading(as.logical(ta,drop=FALSE))
if(length(shade$start) > 0) # all FALSE cause zero-length results
rect(shade$start-1/3, par("usr")[3] ,shade$end+1/3, par("usr")[4], col=col,...)
} else {
# we can add points that are not necessarily at the points
# on the main series
subset.range <- paste(start(x$Env$xdata[x$Env$xsubset]),
end(x$Env$xdata[x$Env$xsubset]),sep="/")
ta.adj <- merge(n=.xts(1:NROW(x$Env$xdata[x$Env$xsubset]),
.index(x$Env$xdata[x$Env$xsubset]), tzone=indexTZ(x$Env$xdata)),ta)[subset.range]
ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
ta.y <- ta.adj[,-1]
for(i in 1:NCOL(ta.y))
lines(ta.x, as.numeric(ta.y[,i]), col=col,...)
}
}
lenv$xdata <- x
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(x=x,order=order,on=on,legend=legend,
taType=taType,col=col,...)),
list(x=x,order=order,on=on,legend=legend,
taType=taType,col=col,...))
exp <- parse(text=gsub("list","plot_ta",
as.expression(substitute(list(x=current.chob(),
ta=get("x"),on=on,
taType=taType,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
if(is.logical(x)) no.update <- TRUE else no.update <- FALSE
# this merge isn't going to work if x isn't in xdata range. Something like:
# na.approx(merge(n=.xts(1:NROW(xdata),.index(xdata)),ta)[,1])
# should allow for any time not in the original to be merged in.
# probably need to subset xdata _before_ merging, else subset will be wrong
#
#tav <- merge(x, xdata, join="right",retside=c(TRUE,FALSE))
#lenv$xdata <- tav
#tav <- tav[xsubset]
lenv$col <- col
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(is.na(on)) {
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(x=c(1,1+strwidth(name)),
y=0.3,
labels=c(name,round(last(xdata[xsubset]),5)),
col=c(1,col),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1) # need to have a value set for ylim
plot_object$next_frame()
# add grid lines, using custom function for MACD gridlines
lenv$grid_lines <- function(xdata,xsubset) {
pretty(xdata[xsubset])
}
exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
} else {
for(i in 1:length(on)) {
plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable?
lenv$grid_lines <- function(xdata,xsubset) {
pretty(xdata[xsubset])
}
exp <- c(exp,
# LHS
#expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
# noquote(format(grid_lines(xdata,xsubset),justify="right")),
# col=theme$labels,offset=0,pos=4,cex=0.9)),
# RHS
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
#}
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
}
}
plot_object
} #}}}
# add_SMA {{{
add_SMA <- function(n=10, on=1, col='brown',...) {
lenv <- new.env()
lenv$add_sma <- function(x, n, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- SMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col,...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_sma",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- SMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_EMA {{{
add_EMA <- function(n=10, on=1, col='blue',...) {
lenv <- new.env()
lenv$add_ema <- function(x, n, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- EMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_ema",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- EMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_WMA {{{
add_WMA <- function(n=10, wts=1:n, on=1, col='green',...) {
lenv <- new.env()
lenv$add_wma <- function(x, n, wts, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- WMA(Cl(xdata), n=n, wts=wts)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,wts=wts,col=col,...)), list(n=n,wts=wts,col=col,...))
exp <- parse(text=gsub("list","add_wma",as.expression(substitute(list(x=current.chob(),n=n,wts=wts,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- WMA(Cl(plot_object$Env$xdata),n=n,wts=wts)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_VMA {{{
add_VMA <- function(w, ratio=1, on=1, col='green',...) {
lenv <- new.env()
lenv$add_wma <- function(x, w, ratio, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
vma <- VMA(Cl(xdata), w=w, ratio=ratio)[xsubset]
lines(1:NROW(xdata[xsubset]), vma, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(w=w,ratio=ratio,col=col,...)), list(w=w,ratio=ratio,col=col,...))
exp <- parse(text=gsub("list","add_wma",as.expression(substitute(list(x=current.chob(),w=w,ratio=ratio,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- VMA(Cl(plot_object$Env$xdata),w=w,ratio=ratio)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_DEMA {{{
add_DEMA <- function(n=10, on=1, col='pink', ...) {
lenv <- new.env()
lenv$add_dema <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
dema <- DEMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), dema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_dema",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- DEMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_VWAP {{{
add_VWAP <- function(n=10, on=1, col='darkgrey', ...) {
lenv <- new.env()
lenv$add_vwap <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xvo <- x$Env$vo
xsubset <- x$Env$xsubset
vwap <- VWAP(Cl(xdata),xvo, n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), vwap, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_vwap",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- VWAP(Cl(plot_object$Env$xdata),plot_object$Env$vo,n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_EVWMA {{{
add_EVWMA <- function(n=10, on=1, col='darkgrey', ...) {
lenv <- new.env()
lenv$add_evwma <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xvo <- x$Env$vo
xsubset <- x$Env$xsubset
evwma <- EVWMA(Cl(xdata),xvo, n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), evwma, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_evwma",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- EVWMA(Cl(plot_object$Env$xdata),plot_object$Env$vo,n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_GMMA {{{
add_GMMA <- function(short=c(3,5,8,10,12,15),long=c(30,35,40,45,50,60), on=1, col=c('yellow','brown'),...) {
#x, short = c(3, 5, 8, 10, 12, 15), long = c(30, 35,
# 40, 45, 50, 60), maType
lenv <- new.env()
lenv$add_gmma <- function(x, short, long, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
gmma <- GMMA(Cl(xdata), short, long, maType="EMA")[xsubset]
col <- colorRampPalette(col)(length(short)+length(long))
for(i in 1:(length(short)+length(long)))
lines(1:NROW(xdata[xsubset]), gmma[,i], col=col[i],...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(short=short,long=long,col=col,...)), list(short=short,long=long,col=col,...))
exp <- parse(text=gsub("list","add_gmma",as.expression(substitute(list(x=current.chob(),short=short,long=long,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- GMMA(Cl(plot_object$Env$xdata), short=short, long=long)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_SMI {{{
add_SMI <- function (n=13, nFast=25, nSlow=2, nSig=9, maType="EMA", bounded=TRUE,...) {
lenv <- new.env()
lenv$plot_smi <- function(x, n, nFast, nSlow, nSig, maType, bounded, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
smi <- SMI(HLC(xdata),n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded)
x.pos <- 1:NROW(xdata[xsubset])
segments(axTicksByTime2(xdata[xsubset]),
range(na.omit(smi))[1],
axTicksByTime2(xdata[xsubset]),
range(na.omit(smi))[2], col=x$Env$theme$grid)
lines(x.pos, smi[xsubset,1], col=x$Env$theme$smi$col$smi, lwd=2,...)
lines(x.pos, smi[xsubset,2], col=x$Env$theme$smi$col$signal, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,maType=maType,bounded=bounded,...)),
list(n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,maType=maType,bounded=bounded,...))
exp <- parse(text=gsub("list","plot_smi",
as.expression(substitute(list(x=current.chob(),
n=n,nFast=nFast,
nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded,...)))),
srcfile=NULL)
plot_object <- current.chob()
if(is.null(plot_object$Env$theme$smi)) {
plot_object$Env$theme$smi$col$smi <- "orange"
plot_object$Env$theme$smi$col$signal <- "darkgrey"
}
xsubset <- plot_object$Env$xsubset
smi <- SMI(HLC(plot_object$Env$xdata),n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded)
plot_object$add_frame(ylim=c(0,1),asp=0.2)
plot_object$next_frame()
lenv$xdata <- structure(smi,.Dimnames=list(NULL, c("smi","signal")))
text.exp <- expression(text(c(1,
1+strwidth(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep="")),
1+strwidth(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep=""))+strwidth("-22.22222")),
0.3,
c(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep=""),
round(last(xdata[xsubset,1]),5),
round(last(xdata[xsubset,2]),5)),
col=c(1,theme$smi$col$smi,theme$smi$col$signal),adj=c(0,0),cex=0.9,offset=0,pos=4))
#plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border=NA)),expr=TRUE)
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(smi)),fixed=TRUE ,asp=1)
plot_object$next_frame()
# add grid lines
lenv$grid_lines <- function(xdata,x) { seq(-50,50,50) }
exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)), exp,
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
# exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# # add axis labels/boxes
# expression(text(0,grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,offset=0,pos=2)),
# expression(text(length(xsubset),grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,offset=0,pos=4)),exp)
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_RSI {{{
add_RSI <- function (n=14, maType="EMA", wilder=TRUE, ..., RSIup=70, RSIdn=30) {
# added in wilder=TRUE to handle missingness behavior in original TTR::RSI call
lenv <- new.env()
lenv$plot_rsi <- function(x, n, maType, wilder, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
rsi <- RSI(Cl(xdata),n=n,maType=maType,wilder=wilder)[xsubset]
x.pos <- 1:NROW(rsi)
theme <- x$Env$theme$rsi
# vertical grid lines
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=x$Env$theme$grid)
lines(x.pos, rep(RSIdn,length(x.pos)), col=theme$col$lines, lwd=1,lty=2,lend=2,...)
lines(x.pos, rep(RSIup,length(x.pos)), col=theme$col$lines, lwd=1,lty=2,lend=2,...)
lines(x.pos, rsi[,1], col=x$Env$theme$rsi$col$rsi, lwd=1.5,...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,maType=maType,wilder=wilder,...)),
list(n=n,maType=maType,wilder=wilder,...))
exp <- parse(text=gsub("list","plot_rsi",
as.expression(substitute(list(x=current.chob(),
n=n,maType=maType,wilder=wilder,...)))),
srcfile=NULL)
plot_object <- current.chob()
if(is.null(plot_object$Env$theme$rsi)) {
plot_object$Env$theme$rsi$col$rsi <- "saddlebrown"
plot_object$Env$theme$rsi$col$lines <- "orange2"
}
xsubset <- plot_object$Env$xsubset
rsi <- RSI(Cl(plot_object$Env$xdata),n=n,maType=maType,wilder=wilder)
plot_object$add_frame(ylim=c(0,1),asp=0.2)
plot_object$next_frame()
lenv$xdata <- structure(rsi,.Dimnames=list(NULL, "rsi"))
text.exp <- expression(text(c(1,
1+strwidth(paste("RSI(",n,"):",sep=""))),
0.3,
c(paste("RSI(",n,"):",sep=""),
round(last(xdata[xsubset]),5)),
col=c(1,theme$rsi$col$rsi),adj=c(0,0),cex=0.9,offset=0,pos=4))
#plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE)
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=c(0,100),asp=1,fixed=TRUE)
plot_object$next_frame()
# add grid lines
lenv$grid_lines <- function(xdata,x) { c(RSIdn,RSIup) }
# add grid lines
exp <- c(expression(segments(1, grid_lines(xdata,xsubset),
NROW(xdata[xsubset]), grid_lines(xdata,xsubset), col=theme$grid)),exp,
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
skeleton_TA <- function(on, arg, ...) {
# NON-FUNCTIONING
lenv <- new.env()
lenv$plot_ta <- function(x, arg, ...) {
# fill in body of low level plot calls here
# use a switch based on type of TA to draw: bands, bars, lines, dots...
}
mapply(function(name, value) {assign(name,value,envir=lenv)},
names(list(arg=arg,...)),
list(arg=arg,...))
exp <- parse(text=gsub("list","plot_ta",
as.expression(substitute(list(x=current.chob(),
arg=arg,
...)))), srcfile=NULL)
chob <- current.chob()
xsubset <- chob$Env$xsubset
preFUN <- ""
FUN <- ""
postFUN <- ""
chob$add_frame(ylin=c(0,1),asp=0.15)
chob$next_frame()
}
# add_MACD {{{
add_MACD <- function(fast=12,slow=26,signal=9,maType="EMA",histogram=TRUE,...) {
lenv <- new.env() # local environment for add_MACD call
# plot_macd draws the indicator using the data from the first(only) call to
# add_MACD. This is a bit analogous to chartMACD in the first quantmod versions
lenv$plot_macd <- function(x, fast, slow, signal, maType, histogram,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
macd <- macd[xsubset]
# vertical grid lines
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=x$Env$theme$grid)
# histogram
x.pos <- 1:NROW(macd)
if(histogram) {
macd.hist <- macd[,1] - macd[,2]
bar.col <- ifelse(macd.hist > 0, x$Env$theme$macd$up.col, x$Env$theme$macd$dn.col)
rect(x.pos-1/3, 0, x.pos+1/3, macd.hist, col=bar.col, border="grey", lwd=0.2, ...) # base graphics call
}
# macd line
lines(x.pos, macd[,1], col=x$Env$theme$macd$macd, lwd=2,,lty=1,...)
# signal line
lines(x.pos, macd[,2], col=x$Env$theme$macd$signal, lty=3,...)
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(fast=fast,slow=slow,signal=signal,maType=maType,histogram=histogram,...)),
list(fast=fast,slow=slow,signal=signal,maType=maType,histogram=histogram,...))
# exp will be what is re-evaluated during redrawing (subset, new TA, etc)
# we need to build this piece by piece
exp <- parse(text=gsub("list","plot_macd",
as.expression(substitute(list(x=current.chob(),fast=fast,slow=slow,signal=signal,maType=maType,
histogram=histogram,...)))),
srcfile=NULL)
# plot_object is the current list of actions, and chart 'state'
plot_object <- current.chob()
# now we can evaluate plot_object, as the parse/substitute is behind us
# check if the theme has a macd component, if not set defaults here
if(is.null(plot_object$Env$theme$macd)) {
plot_object$Env$theme$macd$macd <- "#555555"
plot_object$Env$theme$macd$signal <- "black"
plot_object$Env$theme$macd$up.col <- "green"
plot_object$Env$theme$macd$dn.col <- "red"
}
# copy some Env data to local, make it cleaner to read
xdata <- plot_object$Env$xdata # original (OHLC) series
xsubset <- plot_object$Env$xsubset # current subset
# calculate our indicator here
macd <- MACD(Cl(xdata),fast,slow,signal,maType)
lenv$xdata <- structure(cbind(macd,macd[,1]-macd[,2]),.Dimnames=list(NULL,c("macd","signal","histogram")))
lenv$macd <- cbind(macd,macd[,1]-macd[,2])
# text annotation
plot_object$add_frame(ylim=c(0,1),asp=0.15) # add the header frame
plot_object$next_frame() # move to header frame
text.exp <- expression(text(x=c(1,
1+strwidth(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep="")),
1+strwidth(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep=""))+strwidth("5")*7),
y=0.3,
labels=c(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep=""),round(last(xdata[xsubset,1]),5),
round(last(xdata[xsubset,2]),5)),
col=c(1,theme$macd$macd,theme$macd$signal),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
# main MACD plot from expression above
plot_object$add_frame(ylim=range(na.omit(lenv$macd[xsubset])),fixed=FALSE,asp=1)
plot_object$next_frame()
# add grid lines, using custom function for MACD gridlines
lenv$grid_lines <- function(xdata,xsubset) {
axTicksByValue(xdata[xsubset],c(5,4,3,2,1),gt=3)
}
exp <- c(expression(segments(1,grid_lines(xdata,xsubset),length(xsubset),grid_lines(xdata,xsubset),
col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
# add 'exp' to actions list of plot_object
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
# return plot_object to allow for auto-printing
plot_object
} # }}}
# add_BBands {{{
add_BBands <- function(n=20, maType="SMA", sd=2, on=-1, ...) {
lenv <- new.env()
lenv$plot_bbands <- function(x, n, maType, sd, on, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
col <- x$Env$theme$bbands$col
lty <- x$Env$theme$bbands$lty
bbands <- coredata(BBands(Cl(xdata),n=n, maType,sd)[xsubset])
if(on < 0) {
xx <- do.call("seq",as.list(x$get_xlim()))
polygon(c(xx,rev(xx)), c(bbands[,1],rev(bbands[,3])),col=col$fill,border=NA)
lines(1:NROW(xdata[xsubset]), bbands[,1], lty=lty$upper, col=col$upper,...)
lines(1:NROW(xdata[xsubset]), bbands[,3], lty=lty$lower, col=col$lower,...)
lines(1:NROW(xdata[xsubset]), bbands[,2], lty=lty$ma, col=col$ma,...)
} else {
lines(1:NROW(xdata[xsubset]), bbands[,1], lty=lty$upper, ...)
lines(1:NROW(xdata[xsubset]), bbands[,3], lty=lty$lower, ...)
lines(1:NROW(xdata[xsubset]), bbands[,2], lty=lty$ma, ...)
}
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,maType=maType,sd=sd,on=on,...)), list(n=n,maType=maType,sd=sd,on=on,...))
exp <- parse(text=gsub("list","plot_bbands",as.expression(substitute(list(x=current.chob(),n=n,maType=maType,
sd=sd,on=on,...)))),srcfile=NULL)
# save data that is drawn on charts
chob <- current.chob()
xdata <- chob$Env$xdata
lenv$xdata <- BBands(Cl(xdata),n=n, maType,sd)[,-4] # pctB is bad for ylim calculation on subset
chob$set_frame(sign(on)*(abs(on)+1L)) # need to adjust for header offset
chob$add(exp,env=c(lenv, chob$Env),expr=TRUE)
chob
} # }}}
# add_Vo {{{
add_Vo <- function(...) {
lenv <- new.env()
lenv$plot_vo <- function(x, ...) {
# this is local to this function, but can be anywhere visible
xdata <- x$Env$xdata # internal main series
xsubset <- x$Env$xsubset # subset of series to plot
vo <- x$Env$vo[xsubset] # get and set ylim
if(is.OHLC(xdata[xsubset])) {
Opens <- as.numeric(Op(xdata[xsubset]))
Highs <- as.numeric(Hi(xdata[xsubset]))
Lows <- as.numeric(Lo(xdata[xsubset]))
Closes <- as.numeric(Cl(xdata[xsubset]))
}
bar.col <- ifelse(Opens < Closes, x$Env$theme$up.col, x$Env$theme$dn.col)
bar.border <- ifelse(Opens < Closes, x$Env$theme$up.border, x$Env$theme$dn.border)
#cur_ylim <- x$get_ylim()
#cur_ylim[[x$get_frame()]] <- range(vo)
#x$set_ylim(cur_ylim)
x.pos <- 1:NROW(vo)
min.vol <- min(vo)
segments(axTicksByTime(xdata[xsubset],ticks.on=x$Env$ticks.on),
range(na.omit(vo))[1],
axTicksByTime(xdata[xsubset],ticks.on=x$Env$ticks.on),
range(na.omit(vo))[2], col=x$Env$theme$grid)
rect(x.pos-1/3, min.vol, x.pos+1/3, vo, col=bar.col, border=bar.border,...) # base graphics call
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(...)), list(...))
exp <- parse(text=gsub("list","plot_vo",as.expression(substitute(list(x=current.chob(),...)))),
srcfile=NULL)
plot_object <- current.chob()
xdata <- plot_object$Env$vo
xsubset <- plot_object$Env$xsubset
theme <- plot_object$theme
vo <- xdata[xsubset]
lenv$xdata <- xdata # xdata in lenv is
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(c(0,
0+strwidth(paste("Volume:",sep=""))),
0.5,
c(paste("Volume:",sep=""),prettyNum(last(xdata[xsubset]),big.mark=",")),
col=ifelse(diff(last(xdata[xsubset],2)) >0, theme$up.col, theme$dn.col),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border=NA))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
lenv$grid_lines <- function(xdata,x) { seq(0,1) }
# add grid lines
exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# add axis labels/boxes
expression(text(0,grid_lines(xdata,xsubset),
sprintf("%+d",grid_lines(xdata,xsubset)),
col=theme$labels,offset=0,pos=2)),
expression(text(length(xsubset),grid_lines(xdata,xsubset),
sprintf("%+d",grid_lines(xdata,xsubset)),
col=theme$labels,offset=0,pos=4)),exp)
plot_object$add_frame(ylim=range(vo),asp=1) # need to have a value set for ylim
plot_object$next_frame()
plot_object$replot(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
update_charting_warning <- function() {
if(is.null(getOption("chartSeries_warning"))) {
warning("chartSeries functionality is being deprecated for chart_Series")
options(chartSeries_warning=TRUE)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.