Nothing
## -*- truncate-lines: t; -*-
## Copyright (C) 2008-22 Enrico Schumann
btest <- function(prices,
signal,
do.signal = TRUE,
do.rebalance = TRUE,
print.info = NULL,
b = 1L, ## burn-in
fraction = 1, ## how much to rebalance
initial.position = 0,
initial.cash = 0,
final.position = FALSE,
cashflow = NULL,
tc = 0,
...,
add = FALSE, ## if TRUE, 'position' is flow
lag = 1,
convert.weights = FALSE,
trade.at.open = TRUE,
tol = 1e-5,
tol.p = NA,
Globals = list(),
prices0 = NULL,
include.data = FALSE,
include.timestamp = TRUE,
timestamp, instrument,
progressBar = FALSE,
variations,
variations.settings = list(),
replications) {
if (!missing(variations)) {
x <- match.call()
all_args <- as.list(x)[-1L]
all_args <- lapply(all_args, eval)
variations <- all_args$variations
all_args$variations <- NULL
vsettings <- list(method = "loop",
load.balancing = FALSE,
cores = getOption("mc.cores", 2L),
expand.grid = TRUE)
vsettings[names(variations.settings)] <- variations.settings
all_args$variations.settings <- NULL
lens <- lengths(variations)
if (vsettings$expand.grid)
cases <- do.call(expand.grid,
lapply(lens, seq_len))
else
cases <- as.data.frame(lapply(lens, seq_len))
args <- vector("list", length = nrow(cases))
for (i in seq_along(args)) {
tmp <- mapply(`[[`, variations, cases[i, ],
SIMPLIFY = FALSE)
args[[i]] <- c(all_args, tmp)
attr(args[[i]], "variation") <- tmp
}
if (is.null(vsettings$method) ||
vsettings$method == "loop") {
ans <- vector("list", length(args))
for (i in seq_along(args)) {
ans[[i]] <- do.call(btest, args[[i]])
attr(ans[[i]], "variation") <- attr(args[[i]], "variation")
}
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
} else if (vsettings$method == "parallel" ||
vsettings$method == "snow") {
if (!requireNamespace("parallel"))
stop("package ", sQuote("parallel"), " not available")
if (is.null(vsettings$cl) && is.numeric(vsettings$cores))
cl <- parallel::makeCluster(c(rep("localhost", vsettings$cores)),
type = "SOCK")
on.exit(parallel::stopCluster(cl))
ans <- parallel::parLapplyLB(cl, X = args,
fun = function(x) do.call("btest", x))
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
} else if (vsettings$method == "multicore") {
if (!requireNamespace("parallel"))
stop("package ", sQuote("parallel"), " not available")
ans <- parallel::mclapply(X = args,
FUN = function(x) do.call("btest", x),
mc.cores = vsettings$cores)
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
}
} else if (!missing(replications)) {
x <- match.call()
all_args <- as.list(x)[-1L]
all_args <- lapply(all_args, eval)
replications <- all_args$replications
all_args$replications <- NULL
vsettings <- list(method = "loop",
load.balancing = FALSE,
cores = getOption("mc.cores", 2L))
vsettings[names(variations.settings)] <- variations.settings
all_args$variations.settings <- NULL
if (is.null(vsettings$method) ||
vsettings$method == "loop") {
ans <- vector("list", replications)
for (i in seq_len(replications)) {
ans[[i]] <- do.call(btest, all_args)
attr(ans[[i]], "replication") <- i
}
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
} else if (vsettings$method == "parallel" ||
vsettings$method == "snow") {
if (!requireNamespace("parallel"))
stop("package ", sQuote("parallel"), " not available")
if (is.null(vsettings$cl) && is.numeric(vsettings$cores))
cl <- parallel::makeCluster(
c(rep("localhost", vsettings$cores)),
type = "SOCK")
on.exit(parallel::stopCluster(cl))
clusterExport(cl, "all_args", environment())
if (vsettings$load.balancing)
ans <- parallel::parLapplyLB(cl, X = seq_len(replications),
fun = function(i) {
ans <- do.call("btest", all_args)
attr(ans, "replication") <- i
ans})
else
ans <- parallel::parLapply(cl, X = seq_len(replications),
fun = function(i) {
ans <- do.call("btest", all_args)
attr(ans, "replication") <- i
ans})
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
} else if (vsettings$method == "multicore") {
if (!requireNamespace("parallel"))
stop("package ", sQuote("parallel"), " not available")
ans <- parallel::mclapply(X = seq_len(replications),
FUN = function(i) {
ans <- do.call("btest", all_args)
attr(ans, "replication") <- i
ans
},
mc.cores = vsettings$cores)
if (!is.null(vsettings$label))
names(ans) <- vsettings$label
return(ans)
}
}
L <- lag
tc_fun <- if (is.function(tc))
tc
if (!missing(timestamp) &&
(inherits(timestamp, "Date") || inherits(timestamp, "POSIXct")) &&
inherits(b, class(timestamp))) {
b <- if (b < min(timestamp))
0
else
.match_or_previous(b, timestamp)
}
if ("tradeOnOpen" %in% names(list(...)))
warning("Did you mean 'trade.at.open'? See ChangeLog 2017-11-14.")
if ("assignInGlobals" %in% names(list(...)))
warning("Did you mean 'Globals'? See ChangeLog 2017-11-14.")
if (convert.weights && initial.cash == 0 &&
(all(initial.position == 0) || is.null(prices0)))
warning(sQuote("convert.weights"), " is TRUE and ",
sQuote("initial.cash"), " is zero")
if (convert.weights && b == 0 && is.null(prices0) && lag > 0)
stop("to convert weights to positions, either specify ",
sQuote("prices0"), " or set ", sQuote("b"), " > 0")
if (add)
.NotYetUsed("add", FALSE)
if (identical(do.signal, FALSE) &&
!final.position &&
missing(signal)) {
## if only an initial position is present and should
## be valued: set a dummy signal function
signal <- function(...)
NULL
}
db.signal <- if (is.function(signal) && isdebugged(signal))
TRUE else FALSE
if (is.function(do.signal) && isdebugged(do.signal))
db.do.signal <- TRUE
else
db.do.signal <- FALSE
if (is.function(do.rebalance) && isdebugged(do.rebalance))
db.do.rebalance <- TRUE
else
db.do.rebalance <- FALSE
if (is.function(print.info) && isdebugged(print.info))
db.print.info <- TRUE
else
db.print.info <- FALSE
db.cashflow <- if (is.function(cashflow) && isdebugged(cashflow))
TRUE else FALSE
db.tc_fun <- if (is.function(tc) && isdebugged(tc))
TRUE else FALSE
if (is.null(do.signal) || identical(do.signal, TRUE)) {
do.signal <- function(...)
TRUE
} else if (identical(do.signal, FALSE) && !final.position) {
do.signal <- function(...)
FALSE
if (missing(signal))
signal <- function(...) NULL
message(sQuote("do.signal"), " is FALSE: strategy will never trade")
} else if (!missing(timestamp) && inherits(do.signal, class(timestamp))) {
rebalancing_times <- matchOrNext(do.signal, timestamp)
do.signal <- function(...)
Time(0L) %in% rebalancing_times
} else if (is.numeric(do.signal)) {
## TODO: what if Date?
rebalancing_times <- do.signal
do.signal <- function(...) {
if (Time(0L) %in% rebalancing_times)
TRUE
else
FALSE
}
} else if (is.logical(do.signal)) {
## tests on identical to TRUE,FALSE above, so length > 1
rebalancing_times <- which(do.signal)
do.signal <- function(...)
if (Time(0L) %in% rebalancing_times)
TRUE
else
FALSE
} else if (is.character(do.signal) &&
tolower(do.signal) == "firstofmonth") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(format(tmp[ii], "%Y-%m")),
FUN = head, 1)[[2L]],
tmp)
do.signal <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.signal) &&
(tolower(do.signal) == "lastofmonth" ||
tolower(do.signal) == "endofmonth")) {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(format(tmp[ii], "%Y-%m")),
FUN = tail, 1)[[2L]],
tmp)
do.signal <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.signal) &&
tolower(do.signal) == "firstofquarter") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(paste0(format(tmp[ii], "%Y"), "-", quarters(tmp[ii]))),
FUN = head, 1)[[2L]],
tmp)
do.signal <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.signal) &&
tolower(do.signal) == "lastofquarter") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(paste0(format(tmp[ii], "%Y"), "-", quarters(tmp[ii]))),
FUN = tail, 1)[[2L]],
tmp)
do.signal <- function(...)
Time(0) %in% i_rdays
}
if (is.null(do.rebalance) || identical(do.rebalance, TRUE)) {
do.rebalance <- function(...)
TRUE
} else if (identical(do.rebalance, FALSE)) {
do.rebalance <- function(...)
FALSE
warning(sQuote("do.rebalance"), " is FALSE: strategy will never trade")
} else if (identical(do.rebalance, "do.signal")) {
do.rebalance <- function(...)
computeSignal
} else if (!missing(timestamp) && inherits(do.rebalance, class(timestamp))) {
rebalancing_times <- matchOrNext(do.rebalance, timestamp)
do.rebalance <- function(...)
Time(0L) %in% rebalancing_times
} else if (is.numeric(do.rebalance)) {
rebalancing_times <- do.rebalance
do.rebalance <- function(...) {
Time(0L) %in% rebalancing_times
}
} else if (is.logical(do.rebalance)) {
## tests on identical to TRUE,FALSE above, so length > 1
rebalancing_times <- which(do.rebalance)
do.rebalance <- function(...)
if (Time(0L) %in% rebalancing_times)
TRUE
else
FALSE
} else if (is.character(do.rebalance) &&
tolower(do.rebalance) == "firstofmonth") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(format(tmp[ii], "%Y-%m")),
FUN = head, 1)[[2L]],
tmp)
do.rebalance <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.rebalance) &&
(tolower(do.rebalance) == "lastofmonth" ||
tolower(do.rebalance) == "endofmonth")) {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(format(tmp[ii], "%Y-%m")),
FUN = tail, 1)[[2L]],
tmp)
do.rebalance <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.rebalance) &&
tolower(do.rebalance) == "firstofquarter") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(paste0(format(tmp[ii], "%Y"), "-", quarters(tmp[ii]))),
FUN = head, 1)[[2L]],
tmp)
do.rebalance <- function(...)
Time(0) %in% i_rdays
} else if (is.character(do.rebalance) &&
tolower(do.rebalance) == "lastofquarter") {
tmp <- as.Date(timestamp)
if (any(is.na(tmp)))
stop("timestamp with NAs")
ii <- if (b > 0)
-seq_len(b)
else
TRUE
i_rdays <- match(aggregate(tmp[ii],
by = list(paste0(format(tmp[ii], "%Y"), "-", quarters(tmp[ii]))),
FUN = tail, 1)[[2L]],
tmp)
do.rebalance <- function(...)
Time(0) %in% i_rdays
}
## if (is.null(do.rebalance) || identical(do.rebalance, TRUE)) {
## do.rebalance <- function(...)
## TRUE
## } else if (identical(do.rebalance, FALSE)) {
## do.rebalance <- function(...)
## FALSE
## }
if (is.null(cashflow)) {
cashflow <- function(...)
0
} else if (is.numeric(cashflow)) {
cashflow <- function(...)
cashflow[1L]
}
doPrintInfo <- TRUE
if (is.null(print.info)) {
doPrintInfo <- FALSE
print.info <- function(...)
NULL
}
## functions available in within functions such as 'signal'
Open <- function(lag = L, n = NA) {
if (!is.na(n))
mO[t - (n:1), , drop = FALSE]
else
mO[t - lag, , drop = FALSE]
}
High <- function(lag = L, n = NA) {
if (!is.na(n))
mH[t - (n:1), , drop = FALSE]
else
mH[t - lag, , drop = FALSE]
}
Low <- function(lag = L, n = NA) {
if (!is.na(n))
mL[t - (n:1), , drop = FALSE]
else
mL[t - lag, , drop = FALSE]
}
Close <- function(lag = L, n = NA) {
if (!is.na(n))
mC[t - (n:1), , drop = FALSE]
else
mC[t - lag, , drop = FALSE]
}
Wealth <- function(lag = L, n = NA) {
if (!is.na(n))
v[t - (n:1)]
else
v[t - lag]
}
Cash <- function(lag = L, n = NA) {
if (!is.na(n))
cash[t - (n:1)]
else
cash[t - lag]
}
Time <- function(lag = L, n = NA) {
if (!is.na(n))
t - (n:1)
else
t - lag
}
Portfolio <- function(lag = L, n = NA) {
if (!is.na(n))
X[t - (n:1), , drop = FALSE]
else
X[t - lag, , drop = FALSE]
}
SuggestedPortfolio <- function(lag = L, n = NA) {
if (!is.na(n))
Xs[t - (n:1), , drop = FALSE]
else
Xs[t - lag, , drop = FALSE]
}
if (!missing(timestamp)) {
Timestamp <- function(lag = L, n = NA) {
if (!is.na(n))
timestamp[t - (n:1)]
else
timestamp[t - lag]
}
} else
Timestamp <- Time
## create Globals
Globals <- list2env(Globals)
## check reserved names
reservedNames <- c("Open", "High", "Low", "Close",
"Wealth", "Cash", "Time", "Timestamp",
"Portfolio", "SuggestedPortfolio", "Globals")
funs <- c("signal", "do.signal", "do.rebalance", "print.info", "cashflow")
if (!is.null(tc_fun))
funs <- c(funs, "tc_fun")
for (thisfun in funs) {
fNames <- names(formals(get(thisfun)))
for (rname in reservedNames)
if (rname %in% fNames)
stop(sQuote(rname), " cannot be used as an argument name for ",
sQuote(thisfun))}
add.args <- alist(Open = Open,
High = High,
Low = Low,
Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
formals(signal) <- c(formals(signal), add.args)
if (db.signal)
debug(signal)
formals(do.signal) <- c(formals(do.signal), add.args)
if (db.do.signal)
debug(do.signal)
formals(do.rebalance) <- c(formals(do.rebalance), add.args)
if (db.do.rebalance)
debug(do.rebalance)
formals(print.info) <- c(formals(print.info), add.args)
if (db.print.info)
debug(print.info)
formals(cashflow) <- c(formals(cashflow), add.args)
if (db.cashflow)
debug(cashflow)
if (!is.null(tc_fun)) {
formals(tc_fun) <- c(formals(tc_fun), add.args)
if (db.tc_fun)
debug(tc_fun)
}
if (is.list(prices)) {
if (length(prices) == 1L) {
mC <- prices[[1L]]
if (is.null(dim(mC)))
mC <- as.matrix(mC)
trade.at.open <- FALSE
} else if (length(prices) == 4L) {
mO <- prices[[1L]]
mH <- prices[[2L]]
mL <- prices[[3L]]
mC <- prices[[4L]]
if (is.null(dim(mO)))
mO <- as.matrix(mO)
if (is.null(dim(mH)))
mH <- as.matrix(mH)
if (is.null(dim(mL)))
mL <- as.matrix(mL)
if (is.null(dim(mC)))
mC <- as.matrix(mC)
} else
stop("see documentation on ", sQuote("prices"))
} else {
if (is.null(dim(prices)))
prices <- as.matrix(prices)
if (ncol(prices) == 1L) {
mC <- prices
trade.at.open <- FALSE
} else if (ncol(prices) == 4L) {
mO <- prices[, 1L]
mH <- prices[, 2L]
mL <- prices[, 3L]
mC <- prices[, 4L]
} else
stop("see documentation on ", sQuote("prices"))
}
## param .... settings
T <- nrow(mC)
nA <- ncol(mC)
if (!missing(timestamp) && length(timestamp) != T)
warning("length(timestamp) does not match nrow(prices)")
if (!missing(instrument) && length(instrument) != nA)
warning("length(instrument) does not match ncol(prices)")
## tc can be of length nA or length 1L
tccum <- numeric(T)
## X .... actual portfolios over time
## Xs .... signals (recommended)
X <- array(NA, dim = c(T, nA))
Xs <- array( 0, dim = c(T, nA))
colnames(X) <- colnames(mC)
colnames(Xs) <- colnames(mC)
v <- cash <- numeric(T)
v[] <- NA
if (b > 0L) {
Xs[b, ] <- X[b, ] <- initial.position
cash[b] <- initial.cash
v[b] <- initial.cash + if (any(initial.position != 0))
initial.position %*% mC[b, ] else 0
}
## initial wealth
if (any(initial.position != 0) && !is.null(prices0)) {
initial.wealth <- sum(prices0 * initial.position) + initial.cash
} else if (any(initial.position != 0)) {
message(sQuote("initial.position"), " specified, but no ", sQuote("prices0"))
initial.wealth <- initial.cash ## TODO: initial position needs be evaluated
} else
initial.wealth <- initial.cash
if (progressBar)
progr <- txtProgressBar(min = max(2L, b+1L), max = T,
initial = max(2L, b+1L),
char = if (.Platform$OS.type == "unix") "\u2588" else "|",
width = ceiling(getOption("width")*0.8),
style = 3, file = "")
## Period 1: code is only used if b == 0L
if (b == 0L) {
if (progressBar)
setTxtProgressBar(progr, t)
t <- 1L
computeSignal <- do.signal(...,
Open = Open,
High = High,
Low = Low,
Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (computeSignal) {
temp <- signal(..., Open = Open, High = High,
Low = Low, Close = Close, Wealth = Wealth,
Cash = Cash, Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (!is.null(temp)) {
if (convert.weights) {
temp0 <- temp != 0
temp[temp0] <- temp[temp0] *
initial.wealth/prices0[temp0]
}
Xs[t, ] <- temp
} else
Xs[t, ] <- initial.position
computeSignal <- FALSE
} else {
Xs[t, ] <- if (any(initial.position != 0))
initial.position
else
rep.int(0, nA)
}
## REBALANCE?
rebalance <- do.rebalance(...,
Open = Open, High = High,
Low = Low, Close = Close,
Wealth = Wealth, Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
dXs <- Xs[t, ] - if (any(initial.position != 0))
initial.position else 0
if (max(abs(dXs)) < tol)
rebalance <- FALSE
if (any(rebalance)) {
if (!is.null(tc_fun))
tc <- tc_fun(...,
Open = Open, High = High,
Low = Low, Close = Close,
Wealth = Wealth, Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
dx <- fraction * dXs
dx[!rebalance] <- 0
if (trade.at.open) ## will convert m(O|C) to vector
open <- mO[t, , drop = TRUE]
else
open <- mC[t, , drop = TRUE]
nzero <- dx != 0
sx <- dx[nzero] %*% open[nzero]
abs_sx <- (abs(dx[nzero]) * tc) %*% open[nzero]
tccum[t] <- abs_sx
cash[t] <- initial.cash - sx - abs_sx
X[t, ] <- if (any(initial.position != 0)) initial.position else 0 + dx
rebalance <- FALSE
} else {
tccum[t] <- 0
cash[t] <- initial.cash
X[t, ] <- ifelse(initial.position != 0, initial.position, 0)
}
## cashflow
cash[t] <- cash[t] +
cashflow(...,
Open = Open,
High = High,
Low = Low,
Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
v[t] <- X[t, ] %*% mC[t, ] + cash[t]
if (doPrintInfo)
print.info(..., Open = Open, High = High, Low = Low,
Close = Close, Wealth = Wealth, Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
}
## end period 1
for (t in max(2L, b+1L):T) {
if (progressBar)
setTxtProgressBar(progr, t)
t1 <- t - 1L
computeSignal <- do.signal(...,
Open = Open,
High = High,
Low = Low,
Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (computeSignal) {
temp <- signal(..., Open = Open, High = High,
Low = Low, Close = Close, Wealth = Wealth,
Cash = Cash, Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (!is.null(temp)) {
if (convert.weights) {
temp0 <- temp != 0
temp[temp0] <- temp[temp0] *
v[t1] / mC[t1, temp0]
}
Xs[t, ] <- temp
} else
Xs[t, ] <- Xs[t1, ] ## b0
computeSignal <- FALSE
} else {
Xs[t, ] <- Xs[t1, ] ## b0
}
## REBALANCE?
rebalance <- do.rebalance(..., Open = Open, High = High,
Low = Low, Close = Close,
Wealth = Wealth, Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
dXs <- Xs[t, ] - X[t1, ] ## b0
if (max(abs(dXs)) < tol)
rebalance <- FALSE
else if (!is.na(tol.p) && initial.wealth > 0 && v[t1] > 0 ) {
dXs.p <- dXs * mC[t1, ]/v[t1]
small <- abs(dXs.p) < tol.p
dXs[small] <- 0
if (all(small))
rebalance <- FALSE
}
if (any(rebalance)) {
dx <- fraction * dXs
dx[!rebalance] <- 0
if (!is.null(tc_fun))
tc <- tc_fun(...,
Open = Open, High = High,
Low = Low, Close = Close,
Wealth = Wealth, Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (trade.at.open) ## will convert m(O|C) to vector (drop == TRUE)
open <- mO[t, ]
else
open <- mC[t, ]
nzero <- dx != 0
sx <- dx[nzero] %*% open[nzero]
abs_sx <- (abs(dx[nzero]) * tc) %*% open[nzero]
tccum[t] <- tccum[t1] + abs_sx
cash[t] <- cash[t1] - sx - abs_sx
X[t, ] <- X[t1, ] + dx
rebalance <- FALSE
} else {
tccum[t] <- tccum[t1]
cash[t] <- cash[t1]
X[t, ] <- X[t1, ]
}
## cashflow
cash[t] <- cash[t] + cashflow(...,
Open = Open, High = High,
Low = Low, Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
## WEALTH
nzero <- X[t, ] != 0
v[t] <- X[t, nzero] %*% mC[t, nzero] + cash[t]
if (doPrintInfo)
print.info(..., Open = Open,
High = High,
Low = Low,
Close = Close,
Wealth = Wealth,
Cash = Cash,
Time = Time, Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
} ## end of for loop
if (progressBar)
close(progr)
if (final.position) {
message("Compute final position ... ", appendLF = FALSE)
t <- t + 1L
t1 <- t - 1L
final.pos <- signal(..., Open = Open, High = High,
Low = Low, Close = Close, Wealth = Wealth,
Cash = Cash, Time = Time,
Timestamp = Timestamp,
Portfolio = Portfolio,
SuggestedPortfolio = SuggestedPortfolio,
Globals = Globals)
if (convert.weights)
final.pos <- final.pos * v[t1] / mC[t1, ]
if (!missing(instrument))
names(final.pos) <- instrument
message("done")
}
if (!missing(instrument))
colnames(Xs) <- colnames(X) <- instrument
if (is.null(colnames(X)))
colnames(Xs) <- colnames(X) <- paste("asset", seq_len(ncol(X)))
if (missing(timestamp))
timestamp <- seq_len(nrow(X))
## ------------- [[ journal ]] -------------
## TODO include cash in journal
trades <- diff(rbind(initial.position, X))
keep <- abs(trades) > sqrt(.Machine$double.eps) & !is.na(trades)
if (any(keep)) {
j.timestamp <- list()
j.amount <- list()
j.price <- list()
j.instrument <- list()
for (cc in seq_len(ncol(X))) {
ic <- keep[, cc]
if (!any(ic))
next
ccc <- as.character(cc)
j.timestamp[[ccc]] <- timestamp[ic]
j.amount[[ccc]] <- trades[ic, cc]
j.price[[ccc]] <- mC[ic, cc]
j.instrument[[ccc]] <- rep(colnames(X)[cc], sum(ic))
}
j.timestamp <- do.call(c, j.timestamp)
j.amount <- do.call(c, j.amount)
j.price <- do.call(c, j.price)
j.instrument <- do.call(c, j.instrument)
jnl <- journal(timestamp = unname(j.timestamp),
amount = unname(j.amount),
price = unname(j.price),
instrument = unname(j.instrument))
jnl <- sort(jnl)
} else
jnl <- journal()
ans <- list(position = X,
suggested.position = Xs,
cash = cash,
wealth = v,
cum.tc = tccum,
journal = jnl,
initial.wealth = initial.wealth,
b = b,
final.position = if (final.position) final.pos else NA,
Globals = Globals)
if (include.timestamp)
ans <- c(ans,
timestamp = list(timestamp))
if (include.data)
ans <- c(ans,
prices = prices,
signal = signal,
do.signal = do.signal,
instrument = if (missing(instrument)) NULL else list(instrument),
call = match.call())
class(ans) <- "btest"
ans
}
print.btest <- function(x, ...) {
## TODO: check if timestamp exists and can be coerced to Date
cat("initial wealth",
tmp0 <- x$wealth[min(which(!is.na(x$wealth)))], " => ")
cat("final wealth ",
tmp1 <- round(x$wealth[max(which(!is.na(x$wealth)))], 2), "\n")
if (tmp0 > 0)
cat("Total return ", round(100*(tmp1/tmp0 - 1), 1), "%\n", sep = "")
invisible(x)
}
plot.btest <- function(x, y = NULL, type = "l",
xlab = "", ylab = "", ...) {
if (!is.null(x$timestamp))
plot(x$timestamp[-seq_len(x$b)], x$wealth[-seq_len(x$b)],
type = type, xlab = xlab, ylab = ylab, ...)
else
plot(x$wealth[-seq_len(x$b)], y,
type = type, xlab = xlab, ylab = ylab, ...)
invisible()
}
lines.btest <- function(x, y = NULL, type = "l",
...) {
if (!is.null(x$timestamp))
lines(x$timestamp[-seq_len(x$b)], x$wealth[-seq_len(x$b)],
type = type, ...)
else
lines(x$wealth[-seq_len(x$b)], y,
type = type, ...)
invisible()
}
atest <- btest
formals(atest)$do.signal <- FALSE
formals(atest)$do.rebalance <- FALSE
formals(atest)$final.position <- TRUE
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.