###############################################################
################ Fts class definitions ####################
###############################################################
###############################################################
## layout of an fts object is
## a matrix with a dates attribute attached
fts <- function(index,data) {
if(missing(index)) stop("missing index")
if(missing(data)) stop("missing data")
stopifnot(length(index)==NROW(data))
structure(as.matrix(data),index=index,class=c("fts","zoo"))
}
as.fts <- function(x) {
UseMethod("as.fts")
}
as.fts.default <- function(x) {
if(!is.null(dim(x))) {
dts <- rownames(x)
} else {
dts <- names(x)
}
fts(index=as.Date(dts),data=x)
}
as.fts.data.frame <- function(x) {
stopifnot(ncol(x)>1)
stopifnot(any(c("Date","POSIXct") %in% class(x[,1])))
ans <- fts(index=x[,1],data=x[,-1])
colnames(ans) <- colnames(x)[-1]
ans
}
as.fts.zoo <- function(x) fts(index=attr(x,"index"),data=as.matrix(coredata(x)))
as.matrix.fts <- function(x, ...)
structure(matrix(as.numeric(x),nrow=nrow(x),ncol=ncol(x)),dimnames=list(format(index(x),"%Y%m%d"),colnames(x)))
as.dataframe.fts <- function(x, ...) {
ans <- data.frame(x)
rownames(ans) <- format(index(x),"%Y%m%d")
ans
}
## create an fts object given dates and column names
template.fts <- function(index,cnames) {
ans <- fts(index=index,
data=matrix(nrow=length(index),ncol=length(cnames)))
colnames(ans) <- cnames
ans
}
Ops.fts <- function (e1, e2) {
if(missing(e2)) {
.Class <- "matrix"
NextMethod()
} else {
c.e1 <- class(e1)
c.e2 <- class(e2)
if("fts" %in% c.e1 && "fts" %in% c.e2) {
nce1 <- NCOL(e1)
nce2 <- NCOL(e2)
if(nce1!=nce2 && nce1!=1 && nce2!=1) {
stop("Ops.fts: non conformable data.")
}
stopifnot(all.equal(class(index(e1)),class(index(e2))))
i.dates <- intersect(index(e1),index(e2))
class(i.dates) <- class(index(e1))
## if there is an intersection, the do the Op
if(length(i.dates)) {
e1 <- e1[i.dates,]
e2 <- e2[i.dates,]
if(nce1==1 && nce2!=1) {
e1 <- rep(e1,nce2)
} else if(nce1!=1 && nce2==1) {
e2 <- rep(e2,nce1)
}
.Class <- "matrix"
ans <- NextMethod()
attr(ans,"index") <- i.dates
class(ans) <- c("fts","zoo")
} else {
## no matching dates, return NULL
ans <- NULL
}
} else {
.Class <- "matrix"
ans <- NextMethod()
if("fts" %in% c.e1) {
ans.dates <- attr(e1,"index")
} else {
ans.dates <- attr(e2,"index")
}
attr(ans,"index") <- ans.dates
class(ans) <- c("fts","zoo")
}
ans
}
}
print.fts <- function(x, ...) {
cnms <- colnames(x)
dnms <- list(format(index(x)),cnms)
dims <- dim(x)
attributes(x) <- NULL
dim(x) <- dims
dimnames(x) <- dnms
print(x,...)
invisible(x)
}
"[.fts" <- function(x,i,j,...,drop=FALSE) {
if(missing(i)) i <- 1:nrow(x)
if(missing(j)) j <- 1:ncol(x)
##
##if(typeof(i)=="character") {
## i <- guess.index(i,index(x))
##}
## if we have dates, then use them
if(any(c("Date","POSIXct") %in% class(i))) {
i <- match(i,index(x))
}
## FIXME: not sure about this hack...
##i <- i[!is.na(i)]
##j <- j[!is.na(j)]
ans.dates <- index(x)[i]
ans <- unclass(x)[i,j,...,drop=drop]
attr(ans,"index") <- ans.dates
class(ans) <- c("fts","zoo")
ans
}
"[<-.fts" <- function(x, i = TRUE, j = TRUE, ..., value) {
## if we have dates, then use them
if(!missing(i)) {
if(any(c("Date","POSIXct") %in% class(i))) {
i <- match(i,index(x))
} else if (mode(i)=="logical") {
i <- which(i)
}
}
.Class <- "matrix"
NextMethod()
}
## apply a function to an fts row
row.apply <- function(x,FUN,...) {
ans <- apply(x,1,FUN,...)
if(!is.null(dim(ans))) {
ans <- t(ans)
rownames(ans) <- NULL
}
fts(index=index(x),data=ans)
}
row.any <- function(x) apply(x,1,any)
row.all <- function(x) apply(x,1,all)
col.any <- function(x) apply(x,2,any)
col.all <- function(x) apply(x,2,all)
## apply a function to an fts column
column.apply <- function(x,FUN,...) {
apply(x,2,FUN,...)
}
remove.na.rows <- function(x) x[!row.any(is.na(x)),]
remove.all.na.rows <- function(x) x[!row.all(is.na(x)),]
as.data.frame.fts <- function(x,row.names = NULL, optional = FALSE, check.names = TRUE,...) {
data.frame(asofdate=index(x),as.data.frame.matrix(unclass(x),optional=optional),check.names=check.names)
}
as.matrix.fts <- function(x, ...) {
rownames(x) <- format(index(x))
attr(x,"index") <- NULL
class(x) <- "matrix"
x
}
rbind.fts <- function(...) {
x <- list(...)
## check for same number of cols
if(length(unique(unlist(lapply(x,ncol))))!=1) {
stop("unequal number of cols in arguments.")
}
## unclass data
ans.unclass <- lapply(x,unclass)
## do rbind
ans.data <- do.call(rbind,ans.unclass)
## get dates
ans.dates <- do.call(c,lapply(x,index))
## sort it
new.order <- order(ans.dates)
## must do data before we sort dates
ans.data <- ans.data[new.order,,drop=F]
ans.dates <- ans.dates[new.order]
fts(index=ans.dates,data=ans.data)
}
cbind.fts <- function(...) {
x <- list(...)
ans.index <- sort(unique(unlist(lapply(x,index))))
class(ans.index) <- class(index(x[[1]]))
nrow.ans <- length(ans.index)
ncol.list <- lapply(x,ncol)
ncol.ans <- sum(unlist(ncol.list))
ans <- matrix(NA,nrow=nrow.ans,ncol=ncol.ans)
## starting col
start.col <- 1
## fill the answer
for(i in 1:length(x)) {
## guard against null contracts from LIM
if(!is.null(x[[i]])) {
end.col <- start.col + ncol.list[[i]] - 1
ans[match(index(x[[i]]),ans.index),start.col:end.col] <- x[[i]]
start.col <- end.col + 1
}
}
## set attributes
## fix blank cnames
cnames.list <- lapply(x,colnames)
colnames(ans) <- fix.cnames(cnames.list)
attr(ans,"index") <- ans.index
class(ans) <- c("fts","zoo")
ans
}
fix.cnames <- function(cnames.list) {
null.cnames <- unlist(lapply(cnames.list,is.null))
for(i in 1:length(cnames.list)) {
if(null.cnames[i]) {
cnames.list[[i]] <- ""
}
}
unlist(cnames.list)
}
trim <- function(x,trim.dates) {
new.dates <- sort(intersect(index(x),trim.dates))
class(new.dates) <- class(index(x))
x[new.dates,]
}
cumsum.fts <- function(x) fts(index=index(x),data=apply(x,2,cumsum))
cumprod.fts <- function(x) fts(index=index(x),data=apply(x,2,cumprod))
cummax.fts <- function(x) fts(index=index(x),data=apply(x,2,cummax))
cummin.fts <- function(x) fts(index=index(x),data=apply(x,2,cummin))
###############################################################
################### Date Functions ############################
###############################################################
###############################################################
## return the dates just when the fts is true
event.dates <- function(x) {
stopifnot(ncol(x)==1)
index(x)[as.logical(x)&!is.na(x)]
}
## find date intersection of all tseries
intersect.all <- function(...) {
x <- list(...)
dts <- lapply(x,index)
ans <- dts[[1]]
if(length(dts) > 1) {
for(i in 2:length(x)) {
ans <- intersect(ans,dts[[i]])
}
}
class(ans) <- class(index(x[[1]]))
ans
}
###############################################################
################ Calls to External Library ####################
###############################################################
###############################################################
moving.mean <- function(x,periods) {
.Call("movingMean",x,as.integer(periods),PACKAGE="fts")
}
moving.sum <- function(x,periods) {
.Call("movingSum",x,as.integer(periods),PACKAGE="fts")
}
moving.product <- function(x,periods) {
.Call("movingProduct",x,as.integer(periods),PACKAGE="fts")
}
moving.max <- function(x,periods) {
.Call("movingMax",x,as.integer(periods),PACKAGE="fts")
}
moving.min <- function(x,periods) {
.Call("movingMin",x,as.integer(periods),PACKAGE="fts")
}
moving.rank <- function(x,periods) {
.Call("movingRank",x,as.integer(periods),PACKAGE="fts")
}
moving.sd <- function(x,periods) {
.Call("movingStdev",x,as.integer(periods),PACKAGE="fts")
}
expanding.max <- function(x) {
.Call("expandingMax",x,PACKAGE="fts")
}
expanding.min <- function(x) {
.Call("expandingMin",x,PACKAGE="fts")
}
moving.cor <- function(x,y,periods) {
.Call("movingCor", x, y, as.integer(periods),PACKAGE="fts")
}
moving.cov <- function(x,y,periods) {
.Call("movingCov", x, y, as.integer(periods),PACKAGE="fts")
}
since.na <- function(x) {
.Call("sinceNA",x,PACKAGE="fts")
}
lag.fts <- function(x, k, ...) {
stopifnot(k > -1)
ans <- .Call("lag", x, as.integer(k),PACKAGE="fts")
ans
}
lead <- function(x, k, ...) {
UseMethod("lead")
}
lead.fts <- function(x, k, ...) {
if(k < 0) stop("only positive values of k are allowed")
.Call("lead",x ,as.integer(k),PACKAGE="fts")
}
diff.fts <- function(x, k, ...) {
stopifnot(k > 0)
ans <- .Call("diff", x, as.integer(k),PACKAGE="fts")
attr(ans,"ticker") <- attr(x,"ticker")
ans
}
fill.fwd <- function(x) {
.Call("fillForward",x,PACKAGE="fts")
}
fill.bwd <- function(x) {
.Call("fillBackward",x,PACKAGE="fts")
}
fill.value <- function(x,value) {
.Call("fillValue",x,value,PACKAGE="fts")
}
pad <- function(x,pad.dates) {
stopifnot(all.equal(class(index(x)),class(pad.dates)))
if(storage.mode(pad.dates)!=storage.mode(index(x))) storage.mode(pad.dates) <- storage.mode(index(x))
.Call("pad",x,pad.dates,PACKAGE="fts")
}
monthly.sum <- function(x) {
.Call("monthlySum",x,PACKAGE="fts")
}
to.yearly <- function(x) {
.Call("toYearly",x,PACKAGE="fts")
}
to.quarterly <- function(x) {
.Call("toQuarterly",x,PACKAGE="fts")
}
to.monthly <- function(x) {
.Call("toMonthly",x,PACKAGE="fts")
}
to.weekly <- function(x) {
.Call("toWeekly",x,PACKAGE="fts")
}
to.daily <- function(x) {
.Call("toDaily",x,PACKAGE="fts")
}
to.hourly <- function(x) {
.Call("toHourly",x,PACKAGE="fts")
}
to.minute <- function(x) {
.Call("toMinute",x,PACKAGE="fts")
}
to.second <- function(x) {
.Call("toSecond",x,PACKAGE="fts")
}
to.day.of.week <- function(x,day.of.week,beginning.of.period=TRUE) {
dts <- index(x)
stopifnot(class(dts)=="Date")
end.date <- dts[nrow(x)]
end.date <- end.date + 6
pad.days <- seq(from=dts[1],to=end.date,by="days")
## seq changes storage mode
storage.mode(pad.days) <- storage.mode(dts)
pad.days <- pad.days[as.POSIXlt(pad.days)$wday==day.of.week]
x.filled <- fill.fwd(pad(x,pad.days))
ans <- x.filled[as.POSIXlt(index(x.filled))$wday == day.of.week,]
if(beginning.of.period) {
index(ans) <- index(ans) - 6
}
ans
}
###############################################################
############ Plotting functions for Fts Objects ###########
###############################################################
###############################################################
plot.fts <- function(x, type="l", xlab="Date", ylab=substitute(x), ...) {
x.range <- c(min(index(x)), max(index(x)))
y.range <- c(min(x, na.rm=TRUE), max(x, na.rm=TRUE))
plot(x.range, y.range, type="n", xlab=xlab, ylab=ylab, ...)
params <- lapply(list(type = type, ...), rep, length.out = ncol(x))
for (i in seq(ncol(x))) {
args <- c(list(xy.coords(index(x), x[,i])),
lapply(params, `[`, i))
do.call(plot.xy, args)
}
}
## drop out rows that do not have the required number of observations
filter.min.obs <- function(x,obs.required) {
obs <- apply(!is.na(x),1,sum)
x[obs >= obs.required,]
}
###############################################################
################### Technical Analysis #######################
###############################################################
###############################################################
ema <- function(x,periods) {
.Call("ema",x,as.integer(periods),PACKAGE="fts")
}
rsi <- function(x,periods) {
x.up <- x
x.up[x<0] <- 0
x.down <- x
x.down[x>0] <- 0
x.avg.up <- ema(x.up, periods)
x.avg.down <- ema(x.down, periods)
100 - 100/(1 - x.avg.up/x.avg.down)
}
ma.crossover.down <- function(x,n) {
has.close <- !is.null(colnames(x)) && "close" %in% colnames(x)
stopifnot(has.close || ncol(x) == 1)
col <- ifelse(has.close,"close",1)
x <- x[,col]
xma <- moving.mean(x,n)
x < xma & lag(x,1) > lag(xma,1)
}
ma.crossover.up <- function(x,n) {
has.close <- !is.null(colnames(x)) && "close" %in% colnames(x)
stopifnot(has.close || ncol(x) == 1)
col <- ifelse(has.close,"close",1)
x <- x[,col]
xma <- moving.mean(x,n)
x > xma & lag(x,1) < lag(xma,1)
}
ma.crossover <- function(x,n) {
ma.crossover.up(x,n) - ma.crossover.down(x,n)
}
lower.low <- function(x) {
stopifnot("low" %in% colnames(x))
xl <- x[,"low"]
xl < lag(xl,1)
}
higher.high <- function(x) {
stopifnot("high" %in% colnames(x))
xh <- x[,"high"]
xh > lag(xh,1)
}
repeated <- function(x, times) {
stopifnot(ncol(x)==1 && mode(x)=="logical")
moving.sum(x,times)==as.integer(times)
}
new.low <- function(x,n) {
stopifnot("low" %in% colnames(x))
moving.rank(x[,"low"],n)==1
}
new.high <- function(x,n) {
stopifnot("high" %in% colnames(x))
moving.rank(x[,"high"],n)==as.integer(n)
}
above.ma <- function(x,n) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xc > moving.mean(xc,n)
}
below.ma <- function(x,n) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xc < moving.mean(xc,n)
}
ma.d <- function(x,n) {
above.ma(x,n) - below.ma(x,n)
}
higher.low <- function(x) {
stopifnot("low" %in% colnames(x))
xl <- x[,"low"]
xl > lag(xl,1)
}
lower.high <- function(x) {
stopifnot("high" %in% colnames(x))
xh <- x[,"high"]
xh < lag(xh,1)
}
up <- function(x) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xc > lag(xc,1)
}
down <- function(x) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xc < lag(xc,1)
}
pct.chg <- function(x) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
diff(xc,1) / lag(xc,1) * 100
}
inside.day <- function(x) {
stopifnot(all(c("high","low") %in% colnames(x)))
xh <- x[,"high"]
xl <- x[,"low"]
xh < lag(xh,1) & xl > lag(xl,1)
}
inside.day.up <- function(x) {
inside.day(x) & up(x)
}
inside.day.down <- function(x) {
inside.day(x) & down(x)
}
inside.day.direction <- function(x) {
inside.day.up(x) - inside.day.down(x)
}
outside.day <- function(x) {
stopifnot(all(c("high","low") %in% colnames(x)))
xh <- x[,"high"]
xl <- x[,"low"]
xh > lag(xh,1) & xl < lag(xl,1)
}
outside.day.up <- function(x) {
outside.day(x) & up(x)
}
outside.day.down <- function(x) {
outside.day(x) & down(x)
}
outside.day.direction <- function(x) {
outside.day.up(x) - outside.day.down(x)
}
hl.oc.ratio <- function(x) {
stopifnot(all(c("open","high","low","close") %in% colnames(x)))
abs(x[,"close"] - x[,"open"]) / (x[,"high"] - x[,"low"])
}
gap.up <- function(x) {
stopifnot(all(c("open","high","low","close") %in% colnames(x)))
xh <- x[,"high"]
xo <- x[,"open"]
xo > lag(xh,1)
}
gap.down <- function(x) {
stopifnot(all(c("open","high","low","close") %in% colnames(x)))
xl <- x[,"low"]
xo <- x[,"open"]
xo < lag(xl,1)
}
gap.up.continue <- function(x) {
gap.up(x) & up(x)
}
gap.down.continue <- function(x) {
gap.down(x) & down(x)
}
gap.continue <- function(x) {
gap.up.continue(x) - gap.down.continue(x)
}
gap.up.reverse <- function(x) {
gap.up(x) & down(x)
}
gap.down.reverse <- function(x) {
gap.down(x) & up(x)
}
gap.reverse <- function(x) {
gap.up.reverse(x) - gap.down.reverse(x)
}
gap.direction <- function(x) {
gap.up(x) - gap.down(x)
}
rsi.crossover.up <- function(x,periods,thresh) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xd <- diff(xc,1)
x.rsi <- rsi(xd,periods)
x.rsi <- x.rsi[!is.na(x.rsi),]
x.rsi < thresh & lag(x.rsi,1) > thresh
}
rsi.crossover.down <- function(x, periods, thresh) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xd <- diff(xc,1)
x.rsi <- rsi(xd,periods)
x.rsi <- x.rsi[!is.na(x.rsi),]
x.rsi > thresh & lag(x.rsi,1) < thresh
}
rsi.crossover <- function(x,periods, thresh) {
rsi.crossover.up(x,periods,thresh) - rsi.crossover.down(x,periods,thresh)
}
ma.distance <- function(x, periods) {
stopifnot("close" %in% colnames(x))
xc <- x[,"close"]
xma <- moving.mean(xc,periods)
(xc - xma) / xc * 100
}
trend.day.up <- function(x,thresh=0.2) {
stopifnot(all(c("open","high","low","close") %in% colnames(x)))
xo <- x[,"open"]
xh <- x[,"high"]
xl <- x[,"low"]
xc <- x[,"close"]
day.range <- xh - xl
open.low <- (xo - xl) / day.range
high.close <- (xh - xc) / day.range
open.low <= thresh & high.close <= thresh
}
trend.day.down <- function(x,thresh=0.2) {
stopifnot(all(c("open","high","low","close") %in% colnames(x)))
xo <- x[,"open"]
xh <- x[,"high"]
xl <- x[,"low"]
xc <- x[,"close"]
day.range <- xh - xl
open.high <- (xh - xo) / day.range
low.close <- (xc - xl) / day.range
open.high <= thresh & low.close <= thresh
}
trend.day <- function(x,thresh=.2) {
trend.day.up(x,thresh) - trend.day.down(x,thresh)
}
cor.by.row <- function(x,y) {
i.dts <- sort(intersect(index(x),index(y)))
class(i.dts) <- class(index(x))
ans <- template.fts(i.dts,"cor")
for(i in 1:length(i.dts)) {
ans[i,] <- cor(as.vector(x[i.dts[i],]),as.vector(y[i.dts[i],]))
}
ans
}
stopr <- function(x, level, p) {
stopifnot(ncol(x)==1L)
stopifnot(level < 0)
stopifnot(p > 0)
stopifnot(length(level)==1L)
stopifnot(length(p)==1L)
ans <- .Call("stopr", x, as.double(level), as.integer(p),PACKAGE="fts")
ans
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.