#' Update scorecard data
#'
#' Creates a scorecard workspace file by updating all actual, benchmark,
#' and out-of-sample model performance statistics. Uses
#' a manual transaction history for actual performance. Uses a
#' scorecard definition file (YAML format) to identify model names, types,
#' and configuration settings for actual, buy-hold, and OOS analysis.
#' For each model referred to in the scorecard definition file, there
#' is a corresponding model configuration file (YAML format).
#' @param scorecard_dir the scorecard output directory for scorecard
#' workspace archive
#' @param scorecard_file the path to the scorecard configuration file (YAML)
#' @param transaction_file the path to the transactions mapping file (CSV)
#' @param date_start the analysis history time start, sufficiently long
#' to accommoate model technical indicator generation
#' @param init_date the partnership scorecard start date, used
#' for buy-hold start and other purposes
#' @param switch_date the first date for transactions to be considered
#' part of the partnership model operations regime
#' @param init_eq an initial equity value to be used for each model
#' when computing out-of-sample performance
#' @return nothing, side effects are writing workspace archive
#' (an environment object) to disk
#' @seealso scorecard_produce
#' @export
scorecard_update <- function(scorecard_dir=NA,
scorecard_file=NA,
transaction_file=NA,
date_start="2012-01-01",
init_date="2016-08-01",
switch_date="2016-08-05",
init_eq=250000) {
# sequence the dependencies
require(magrittr,quietly=TRUE)
require(tidyr,quietly=TRUE)
require(xts,quietly=TRUE)
require(blotter,quietly=TRUE)
require(ggplot2,quietly=TRUE)
# options for many functions
o1 <- options("stringsAsFactors" = FALSE)
# o2 <- options("getSymbols.auto.assign" = FALSE)
# o3 <- options("getSymbols.warning4.0" = FALSE)
on.exit(options(o1), add=TRUE)
# on.exit(options(o2), add=TRUE)
# on.exit(options(o3), add=TRUE)
`%nin%` <- Negate(`%in%`)
# production algorithm
cash_ticker <- "#CASH"
benchmark_symbol <- "SPY"
Sys.setenv(TZ = "UTC")
acct_name <- "ggcm"
port_name <- "model"
refresh_date <- lubridate::today()
# check output location now so we don't wait to discover it's missing
# existence handles symbolic links, but does not check access
if (is.na(scorecard_dir) || stringr::str_length(scorecard_dir) < 1) {
stop("Scorecard output directory missing: use argument scorecard_dir")
}
# 1. initialize scorecard framework
if ( is.na(scorecard_file) || !file.exists(scorecard_file)) {
stop("Scorecard input file missing: use argument scorecard_file")
}
scorecard <- yaml::yaml.load_file(scorecard_file)
scorecard$table$activated <- lapply(scorecard$table$activated, function(i){
i$status <- "activated"
return(i)
})
scorecard$table$candidate <- lapply(scorecard$table$candidate, function(i){
i$status <- "candidate"
return(i)
})
scorecard$table$deactivated <- lapply(scorecard$table$deactivated, function(i){
i$status <- "deactivated"
return(i)
})
scorecard$table$retired <- lapply(scorecard$table$retired, function(i){
i$status <- "retired"
return(i)
})
# universe of tickers across all baskets
scorecard_tickers <- c() # filled later as set union
# 2. initialize transaction history
if ( is.na(transaction_file) || !file.exists(transaction_file))
stop(paste("Cannot find transaction CSV file", transaction_file))
# transactions from manual file
get_transactions <- function(f) {
#suppressPackageStartupMessages(require(dplyr))
tdf <- read.csv(transaction_file,stringsAsFactors = FALSE) %>%
dplyr::filter(Model!="") %>%
dplyr::mutate(Date=as.Date(Date,format="%m/%d/%y"))
#unloadNamespace("dplyr")
return(tdf)
}
transactions.df <- get_transactions(transaction_file)
transaction_tickers <- unique( subset(transactions.df,
Ticker!=cash_ticker)[,'Ticker'] )
# identify model configuration files from scorecard
scorecard_table <- c(
scorecard$table$activated,
scorecard$table$candidate,
scorecard$table$deactivated,
scorecard$table$retired
)
model_files <-
unlist(lapply(scorecard_table, function(x)
return (x$config)))
# compute benchmark returns applicable to every model
ignore <- scorecard:::get_and_adjust(benchmark_symbol,
init_date,
switch_date,
scorecard_tickers,
adjust=TRUE)
scorecard_tickers <- union(scorecard_tickers, benchmark_symbol)
benchmark_returns <- diff(quantmod::Cl(log(get(benchmark_symbol))))[-1, ]
colnames(benchmark_returns) <- "Benchmark"
benchmark_cumulatives <-
cumprod(1 + benchmark_returns)
benchmark_annual_percent <-
as.numeric(PerformanceAnalytics::Return.annualized(benchmark_returns)) * 100
benchmark_calmar_ratio <-
as.numeric(PerformanceAnalytics::CalmarRatio(benchmark_returns))
benchmark_sortino_ratio <-
as.numeric(PerformanceAnalytics::SortinoRatio(benchmark_returns, MAR = 0))
benchmark_max_drawdown_percent <-
PerformanceAnalytics::maxDrawdown(benchmark_returns) * 100
# load model configurations
scorecard_table <- lapply(scorecard_table, function(scorecard_row){
if ( "config" %in% names(scorecard_row) ) {
scorecard_row$model <-
yaml::yaml.load_file(file.path("models",
scorecard_row$config))
}
return(scorecard_row)
})
##########
# compute actual performance by transaction for traded models
# assumes model loaded into row during prior iteration
# assumes backet element history loaded during prior iteration
if ( isNamespaceLoaded("dplyr") )
unloadNamespace("dplyr")
scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
model_name <- scorecard_row$id
rv <- scorecard_row
# skip rows not activated
if ( length(scorecard_row$model) > 0) {
if ( scorecard_row$status == "activated") {
if ( getOption("verbose"))
message(paste("Computing actuals for", model_name))
model_basket <- scorecard_row$model$config$basket
# clear the blotter account and portfolios for this model
# use actual initial equity value from scorecard
ignore <- scorecard:::reset_quantstrat()
ignore <- blotter::initPortf(name = port_name,
model_basket,
initDate = init_date,
currency = "USD")
ignore <- blotter::initAcct(name = acct_name,
portfolios = c(port_name),
initDate = init_date,
initEq = init_eq)
ignore <- sapply(model_basket, function(m) {
FinancialInstrument::stock(m, currency = "USD")
})
# ensure basket element tickers have been fetched
# do NOT adjust prices here for actual performance
ignore <- scorecard:::get_and_adjust(model_basket,
init_date,
switch_date,
scorecard_tickers,
adjust=FALSE)
scorecard_tickers <<- base::union(scorecard_tickers, model_basket)
# add transactions to blotter
model_transactions.df <-
subset(transactions.df, Model == scorecard_row$model$model )
model_non_cash.df <-
subset(model_transactions.df, Ticker != cash_ticker)
model_cash.df <-
subset(model_transactions.df, Ticker == cash_ticker)
# perform cash transactions
ignore <- by(model_cash.df,
seq_len(nrow(model_cash.df)),
function(ti){
rv <- switch(ti$Action,
"Buy" = function(ti) {
if ( getOption("verbose"))
message(paste("Add cash transaction",
ti$Date,
ti$Shares,
ti$Note))
addAcctTxn(
Account = acct_name,
TxnDate = ti$Date,
TxnType = "Additions",
Amount = ti$Shares, # positive
verbose = getOption("verbose")
)
},
"Sell" = function(ti) {
if ( getOption("verbose"))
message(paste("Remove cash transaction",
ti$Date,
ti$Shares,
ti$Note))
addAcctTxn(
Account = acct_name,
TxnDate = ti$Date,
TxnType = "Withdrawals",
Amount = ti$Shares, # negative
verbose = getOption("verbose")
)
},
function(ti) {
warning(paste("Actual cash switch did not match",
ti$ie.type))
}
)
rv(ti)
})
ignore <- blotter::updatePortf(port_name)
ignore <- blotter::updateAcct(acct_name)
ignore <- blotter::updateEndEq(acct_name)
# perform non-cash transactions
ignore <- by(model_non_cash.df,
seq_len(nrow(model_non_cash.df)),
function(ti) {
# switch returns a function having ti parameter
rv <- switch(ti$Action,
"Buy" = function(ti) {
if ( getOption("verbose"))
message(paste("Buy transaction",
ti$Date,
ti$Ticker,
ti$Shares))
if ( ti$Shares < 0 )
warning(paste("Buy transaction",
ti$Date,
ti$Ticker,
ti$Shares,
"shares negative"))
fees <- ifelse(is.na(ti$Comm), 0, -abs(ti$Comm))
if ( ti$Ticker != cash_ticker ) {
addTxn(
Portfolio = port_name,
Symbol = ti$Ticker,
TxnDate = ti$Date,
TxnPrice = ti$Price,
TxnQty = ti$Shares,
TxnFees = fees,
verbose = getOption("verbose")
)
}
},
"Sell" = function(ti) {
if ( getOption("verbose"))
message(paste("Sell transaction",
ti$Date,
ti$Ticker,
ti$Shares))
if ( ti$Shares > 0 )
warning(paste("Sell transaction",
ti$Date,
ti$Ticker,
ti$Shares,
"shares positive"))
fees <- ifelse(is.na(ti$Comm),0,-abs(ti$Comm))
if ( ti$Ticker != cash_ticker ) {
addTxn(
Portfolio = port_name,
Symbol = ti$Ticker,
TxnDate = ti$Date,
TxnPrice = ti$Price,
TxnQty = ti$Shares,
TxnFees = fees,
verbose = getOption("verbose")
)
}
},
function(ti) {
warning(paste("Actual non-cash switch did not match",
ti$ie.type))
}
)
rv(ti)
}
) # by transaction
last_date <- xts::last(model_transactions.df)$date
ignore <- blotter::updatePortf(port_name)
ignore <- blotter::updateAcct(acct_name)
ignore <-blotter::updateEndEq(acct_name)
# portfolio plot sanity check
model_stats <- blotter::getAccount(acct_name)$portfolios$model
# account-level equity, return, cumulative
account_summary <- blotter::getAccount(acct_name)$summary
asr <- diff( log( account_summary$End.Eq ))
colnames(asr) <- "Return"
asr[1, 'Return'] <- 0
asr$Cumulative <- cumprod( 1 + asr$Return )
account_summary <- merge( account_summary, asr)
p1 <-
scorecard:::plot_model_stat(account_summary$End.Eq,
paste(model_name,
"Account Stats: Ending Equity"))
# component returns
pr <- blotter::PortfReturns(acct_name,
Portfolios = port_name,
period = "daily")
colnames(pr) <- gsub(".DailyEndEq", "", colnames(pr))
cr <- cumprod(1 + pr)
# account returns
# NB: doesn't account for cash
#ar <- blotter::AcctReturns(acct_name)
#colnames(ar) <- "Actual"
#ar[1,1] <- 0
#ar[is.na(ar)] <- 0
#ar$Cumulative <- cumprod(1+ar)
# portfolio return status
pm <- pr
pm$Actual <- rowSums(pm, na.rm = TRUE)
pm$Cumulative <- cumprod(1 + pm$Actual)
# individual component position plots, saved as list, NA if no position
# use plot(cplots[[1]]) to recover graphic
cplots <- lapply(model_basket, function(mt) {
pf <- blotter::getPortfolio(port_name)
position <- pf$symbols[[mt]]$txn$Pos.Qty
rv <- NA
if (nrow(position) > 1)
rv <- scorecard:::plot_position(port_name, mt)
return(rv)
})
# component return plots
pr.df <- data.frame(pr)
pr.df$Date = zoo::index(pr)
gf <- pr.df %>%
tidyr::gather(Symbol, Return, -Date)
p2 <-
ggplot2::ggplot(gf,
ggplot2::aes(x = Date,
y = Return,
color = Symbol)) +
ggplot2::geom_line() +
ggplot2::facet_wrap( ~ Symbol,
nrow = 3,
scales = "fixed") +
ggplot2::xlab(NULL) +
ggplot2::guides(color = FALSE) +
ggplot2::ggtitle(paste(model_name, "Basket Element Returns"))
p3 <-
ggplot2::ggplot(gf,
ggplot2::aes(x = Return,
fill = Symbol,
color = Symbol)) +
ggplot2::geom_histogram(binwidth = 0.01) +
ggplot2::geom_density() +
ggplot2::guides(fill = FALSE, color = FALSE) +
ggplot2::facet_wrap( ~ Symbol, nrow = 3, scales = "fixed") +
ggplot2::ylab("Frequency") +
ggplot2::xlab(paste("Daily Returns",
min(gf$Date),
"to",
max(gf$Date),
sep = " ")) +
ggplot2::ggtitle(paste(model_name,
"Basket Element Return Distributions"))
# component cumulative returns
cr_df <- data.frame(cr)
cr_df$Date = zoo::index(cr)
gf <- cr_df %>%
tidyr::gather(Symbol, Return, -Date)
p4 <-
ggplot2::ggplot(gf,
ggplot2::aes(x = Date,
y = Return,
color = Symbol)) +
ggplot2::geom_line() +
ggplot2::xlab(NULL) +
ggplot2::ylab("Component Return") +
ggplot2::guides(color = FALSE) +
ggplot2::ggtitle(paste(model_name, "Model Component Cumulative Return"))
p4 <- directlabels::direct.label(p4)
# account cumulative return and drawdown
p5xts <- account_summary$Return
index(p5xts) <- as.Date(index(p5xts))
p5 <- suppressWarnings(scorecard:::gg_charts_summary_2(p5xts,
"Account-Level Return and Drawdown"))
p5 <- p5 +
guides(color=FALSE) +
scale_x_date(date_breaks = "1 month",
date_minor_breaks = "1 week",
date_labels="%b %y")
# trade stats
stats <- blotter::tradeStats(port_name)
stats <- scorecard:::format_trade_stats(stats)
# model performance ratios
annual_percent <-
as.numeric(PerformanceAnalytics::Return.annualized(pm$Actual)) * 100
calmar_ratio <-
as.numeric(PerformanceAnalytics::CalmarRatio(pm$Actual))
sortino_ratio <-
as.numeric(PerformanceAnalytics::SortinoRatio(pm$Actual, MAR = 0))
max_drawdown_percent <-
PerformanceAnalytics::maxDrawdown(pm$Actual) * 100
# store in scorecard row for later presentation
scorecard_row$actual <- list(
r = pr,
c = cr,
account = account_summary,
portfolio = pm,
cagr = annual_percent,
mdd = max_drawdown_percent,
sortino = sortino_ratio,
calmar = calmar_ratio,
p1 = p1,
p2 = p2,
p3 = p3,
p4 = p4,
p5 = p5,
cplots = cplots,
stats = stats
)
rv <- scorecard_row
}}
return(rv)
}) # lapply
# compute buy-hold returns for each model, including retired
scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
scorecard_row$model <- NA
model_name <- scorecard_row$id
if ( !is.null(scorecard_row$config) ) {
# read the model file
if ( getOption("verbose") )
message(paste("Working", model_name, "buy-hold basket comparison"))
scorecard_row$model <-
yaml::yaml.load_file(file.path("models",
scorecard_row$config))
basket <- scorecard_row$model$config$basket
# save benchmark performance, currently same for each model
scorecard_row$benchmark.cagr <- benchmark_annual_percent
scorecard_row$benchmark.calmar <- benchmark_calmar_ratio
scorecard_row$benchmark.sortino <- benchmark_sortino_ratio
scorecard_row$benchmark.mdd <- benchmark_max_drawdown_percent
# initialize quantstrat objects and blotter
ignore <- scorecard:::reset_quantstrat()
ignore <- blotter::initPortf("buyhold.port",
symbols = basket,
initDate = init_date)
ignore <- blotter::initAcct("buyhold.acct",
portfolios = "buyhold.port",
initDate = init_date,
initEq = init_eq)
ignore <- sapply(basket, function(m) {
FinancialInstrument::stock(m, currency = "USD")
})
# ensure basket element tickers have been fetched
ignore <- scorecard:::get_and_adjust(basket,
init_date,
switch_date,
scorecard_tickers,
adjust = TRUE)
scorecard_tickers <<- base::union(scorecard_tickers, basket)
# add a buy transaction for each ticker at switch date, equal weight
buyhold_equal_equity <- init_eq / length(basket)
buyhold_equal_weights <- rep(1.0 / length(basket), length(basket))
for (ticker in basket) {
history <- get(ticker)
price <- as.numeric(quantmod::Cl(history[switch_date, ]))
quantity <- buyhold_equal_equity / price
# buy on switch date
addTxn(
Portfolio = "buyhold.port",
Symbol = ticker,
TxnDate = switch_date,
TxnPrice = price,
TxnQty = quantity,
TxnFees = -4.95,
verbose = getOption("verbose")
)
if ( getOption("verbose") )
print(paste(ticker,switch_date,price,quantity))
}
ignore <- updatePortf("buyhold.port")
ignore <- blotter::updateAcct("buyhold.acct")
ignore <- blotter::updateEndEq("buyhold.acct")
# create buy-hold account plot, save in row
buyhold.summary <- blotter::getAccount("buyhold.acct")$summary
bhp1 <- scorecard:::plot_model_stat(
buyhold.summary$End.Eq,
paste(model_name, "Buy-Hold Equal-Weight Basket Stats: Ending Equity"
)
)
bhr <- blotter::PortfReturns("buyhold.acct",
Portfolios = "buyhold.port",
period = "daily")
colnames(bhr) <- gsub(".DailyEndEq", "", colnames(bhr))
bhc <- cumprod(1 + bhr)
# append columns for portfolio
bhp <- bhr
bhp$BuyHold <- rowSums(bhp, na.rm = TRUE)
bhp$Cumulative <- cumprod(1 + bhp$BuyHold)
# basket component cumulative returns
# bhc.df <- data.frame(bhc) %>% mutate(Date = index(bhc))
bhc.df <- data.frame(bhc)
bhc.df$Date <- zoo::index(bhc)
gf <- bhc.df %>% gather(Symbol, Return, -Date)
bhp2 <-
ggplot2::ggplot(gf, ggplot2::aes(x = Date, y = Return, color = Symbol)) +
ggplot2::geom_line() +
ggplot2::xlab(NULL) +
ggplot2::ylab("Component Return") +
ggplot2::guides(color = FALSE) +
ggplot2::ggtitle(paste(model_name,
"Buy-Hold Basket Component Cumulative Return"))
bhp2 <- directlabels::direct.label(bhp2)
# basket aggregate cumulative return
bhc.df <- data.frame(bhp$Cumulative)
bhc.df$Date <- index(bhp$Cumulative)
bhp3 <-
ggplot2::ggplot(bhc.df, ggplot2::aes(x = Date, y = Cumulative)) +
ggplot2::geom_line(color = "blue") +
ggplot2::xlab(NULL) +
ggplot2::ylab("Cumulative Return") +
ggplot2::ggtitle(paste(model_name,
"Buy-Hold Equal-Weight Basket Cumulative Return"))
bh_annual_percent <-
as.numeric(PerformanceAnalytics::Return.annualized(bhp$BuyHold)) * 100
bh_calmar_ratio <-
as.numeric(PerformanceAnalytics::CalmarRatio(bhp$BuyHold))
bh_sortino_ratio <-
as.numeric(PerformanceAnalytics::SortinoRatio(bhp$BuyHold,
MAR = 0))
bh_max_drawdown_percent <-
PerformanceAnalytics::maxDrawdown(bhp$BuyHold) * 100
# store in scorecard
scorecard_row$buyhold <- list(
r = bhr,
c = bhc,
portfolio = bhp,
cagr = bh_annual_percent,
mdd = bh_max_drawdown_percent,
sortino = bh_sortino_ratio,
calmar = bh_calmar_ratio,
p1 = bhp1,
p2 = bhp2,
p3 = bhp3
)
}
return(scorecard_row)
})
##########
# process out-of-sample results for every model
# re-fetch tickers for all models, ensuring sufficient history
# fetch start date should be oldest backtest stop date
backtest_stops <- sapply(scorecard_table, function(sr){
rv <- NA
if ( length(sr$model) > 1 ) {
rv <- sr$model$backtest$stop
}
return(rv)
})
oos_start_date <- min(c(backtest_stops, date_start), na.rm = TRUE)
# re-query the tickers including benchmark
# for ( ticker in base::union(scorecard_tickers, benchmark_symbol) ) {
# if ( getOption("verbose") )
# message(paste("Fetching", ticker))
# dx <- quantmod::getSymbols(
# ticker,
# from = oos_start_date,
# index.class = c("POSIXt", "POSIXct"),
# warnings = FALSE,
# verbose = getOption("verbose"),
# auto.assign = FALSE,
# adjust = TRUE
# )
# if ( any(is.na(dx)))
# dx <- zoo::na.approx(dx)
# colnames(dx) <- gsub(paste(ticker, ".", sep = ""), "", colnames(dx))
# assign(ticker, dx, envir = .GlobalEnv) # put back into global environment
# }
scorecard:::get_and_adjust( base::union(scorecard_tickers, benchmark_symbol),
init_date= oos_start_date,
switch_date = oos_start_date)
# save a copy of the scorecard basket for reset before each model run
scorecard_history <- new.env()
for (ticker in scorecard_tickers) {
assign(ticker, get(ticker), envir = scorecard_history)
}
# now run the non-retired models with data already acquired
# these will trim individual use of the time series to actual OOS start date
scorecard_table <- lapply(scorecard_table, function(scorecard_row) {
model_name <- scorecard_row$id
rv <- scorecard_row
if (scorecard_row$status != "retired") {
if (length(scorecard_row$model) > 1) {
f <- scorecard_row$model$config[["function"]]
if (! is.null(f)) {
if (stringr::str_length(f) > 0) {
if (getOption("verbose"))
message(paste("Processing out-of-sample results for", model_name))
update_model <- match.fun(f) # may throw an error
for (ticker in scorecard_tickers) {
assign(ticker,
get(ticker,
envir = scorecard_history),
envir = .GlobalEnv)
}
if (getOption("verbose"))
message(scorecard_row$config)
rv <- update_model(scorecard_row)
}
}
}
}
return(rv)
})
########
# Content completed, ready to process scorecard output
# Save workspace for reference, audting, debugging
if ( getOption("verbose"))
message("Saving workspace...")
if ( ! dir.exists(scorecard_dir) ) {
dir.create(scorecard_dir,
showWarnings = getOption("verbose"),
recursive = TRUE)
warning(paste("Scorecard output directory created:",
scorecard_dir))
}
image_date <- format(lubridate::today("America/Chicago"), "%Y%m%d")
image_file <- file.path(scorecard_dir,
paste0(image_date,
"_",
"scorecard",
"_",
"workspace",
".RData"))
save(
scorecard_table,
model_files,
init_date,
image_date,
refresh_date,
oos_start_date,
transactions.df,
file=image_file
)
if (getOption("verbose"))
message(paste0("Saved workspace to", image_file))
#######
# All done preparing data, reduce and produce elsewhere
if (getOption("verbose"))
message("Scorecard data preparation complete")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.