## -*- 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
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.