From b46bfb94058d2e1633e630ee700aef6afc005e20 Mon Sep 17 00:00:00 2001 From: jackylaucf Date: Mon, 6 Mar 2017 10:02:10 +0800 Subject: [PATCH] SIT-repository --- R/aa.bl.r | 214 + R/aa.gmpl.r | 617 ++ R/aa.omega.r | 245 + R/aa.r | 2048 +++++ R/aa.test.r | 2225 ++++++ R/branchbound.r | 309 + R/bt.r | 2194 +++++ R/bt.share.r | 3010 +++++++ R/bt.share.test.r | 163 + R/bt.stop.r | 488 ++ R/bt.stop.test.r | 561 ++ R/bt.summary.r | 603 ++ R/bt.test.r | 10150 ++++++++++++++++++++++++ R/cluster.r | 103 + R/data.proxy.r | 327 + R/data.r | 2951 +++++++ R/factor.model.r | 337 + R/factor.model.test.r | 1772 +++++ R/fundamental.data.r | 227 + R/fundamental.test.r | 233 + R/interactive.r | 122 + R/min.corr.paper.r | 718 ++ R/optimization.r | 842 ++ R/plot.table.r | 424 + R/plota.r | 1166 +++ R/random.r | 591 ++ R/rfinance2012.r | 946 +++ R/rfinance2013.r | 452 ++ R/rfinance2014.r | 502 ++ R/shiny.R | 170 + R/strategy.r | 3250 ++++++++ R/ta.r | 542 ++ R/utils.r | 2213 ++++++ Readme.pkg.txt | 74 + Readme.txt | 87 + SIT.tar.gz | Bin 0 -> 298590 bytes Shiny/january.seasonality/global.R | 8 + Shiny/january.seasonality/server.R | 153 + Shiny/january.seasonality/ui.R | 67 + Shiny/market.filter/global.R | 8 + Shiny/market.filter/server.R | 193 + Shiny/market.filter/ui.R | 69 + Shiny/multi.stock/global.R | 8 + Shiny/multi.stock/server.R | 113 + Shiny/multi.stock/ui.R | 60 + Shiny/one.stock/global.R | 8 + Shiny/one.stock/server.R | 130 + Shiny/one.stock/ui.R | 62 + Shiny/retirement.withdrawal/server.r | 117 + Shiny/retirement.withdrawal/ui.r | 75 + Shiny/sector.rotation/global.R | 8 + Shiny/sector.rotation/server.R | 214 + Shiny/sector.rotation/ui.R | 78 + creategz.bat | 37 + make.sit.pkg.r | 140 + pkg/DESCRIPTION | 49 + pkg/NAMESPACE | 519 ++ pkg/R/SIT-package.R | 68 + pkg/R/aa.bl.r | 214 + pkg/R/aa.gmpl.r | 617 ++ pkg/R/aa.omega.r | 245 + pkg/R/aa.r | 2048 +++++ pkg/R/aa.test.r | 2225 ++++++ pkg/R/branchbound.r | 309 + pkg/R/bt.r | 2194 +++++ pkg/R/bt.stop.r | 488 ++ pkg/R/bt.stop.test.r | 561 ++ pkg/R/bt.summary.r | 603 ++ pkg/R/bt.test.r | 10150 ++++++++++++++++++++++++ pkg/R/data.proxy.r | 327 + pkg/R/data.r | 2951 +++++++ pkg/R/factor.model.r | 337 + pkg/R/factor.model.test.r | 1772 +++++ pkg/R/fundamental.data.r | 227 + pkg/R/fundamental.test.r | 233 + pkg/R/min.corr.paper.r | 718 ++ pkg/R/optimization.r | 842 ++ pkg/R/plot.table.r | 424 + pkg/R/plota.r | 1166 +++ pkg/R/random.r | 591 ++ pkg/R/rfinance2012.r | 946 +++ pkg/R/shiny.r | 170 + pkg/R/strategy.r | 3250 ++++++++ pkg/R/ta.r | 542 ++ pkg/R/utils.r | 2213 ++++++ pkg/man/FilenameFunctions.Rd | 27 + pkg/man/ListEnvFunctions.Rd | 13 + pkg/man/PlotaColorTheme.Rd | 43 + pkg/man/SIT.Rd | 75 + pkg/man/StringFunctions.Rd | 25 + pkg/man/TimingFunctions.Rd | 33 + pkg/man/XTSFunctions.Rd | 33 + pkg/man/beta.degree.Rd | 25 + pkg/man/bt.apply.min.weight.Rd | 34 + pkg/man/bt.apply.round.weight.Rd | 11 + pkg/man/bt.start.dates.Rd | 10 + pkg/man/col.add.alpha.Rd | 24 + pkg/man/compute.cor.Rd | 20 + pkg/man/count.Rd | 24 + pkg/man/create.monthly.table.Rd | 22 + pkg/man/createNonReactiveTextInput.Rd | 25 + pkg/man/dates2index.Rd | 37 + pkg/man/flip.xts.Rd | 16 + pkg/man/getSymbols.extra.Rd | 28 + pkg/man/getSymbols.sit.Rd | 45 + pkg/man/ifna.Rd | 24 + pkg/man/ifnull.Rd | 24 + pkg/man/iif.Rd | 26 + pkg/man/index.xts.Rd | 22 + pkg/man/join.Rd | 24 + pkg/man/len.Rd | 21 + pkg/man/load.packages.Rd | 31 + pkg/man/lookup.index.Rd | 28 + pkg/man/make.stock.xts.Rd | 20 + pkg/man/make.xts.Rd | 24 + pkg/man/map2monthly.Rd | 23 + pkg/man/mlag.Rd | 25 + pkg/man/plot.table.Rd | 48 + pkg/man/plota.Rd | 69 + pkg/man/plota.add.copyright.Rd | 16 + pkg/man/plota.format.Rd | 26 + pkg/man/plota.grid.Rd | 13 + pkg/man/plota.layout.Rd | 31 + pkg/man/plota.legend.Rd | 39 + pkg/man/plota.lines.Rd | 24 + pkg/man/plota.matplot.Rd | 34 + pkg/man/plota.recession.Rd | 38 + pkg/man/plota.stacked.Rd | 37 + pkg/man/plota.x.highlight.Rd | 22 + pkg/man/plota.y.highlight.Rd | 46 + pkg/man/plota2Y.Rd | 45 + pkg/man/proxy.overlay.plot.Rd | 33 + pkg/man/proxy.prices.Rd | 30 + pkg/man/proxy.test.Rd | 32 + pkg/man/read.xts.Rd | 34 + pkg/man/rep.col.Rd | 24 + pkg/man/rep.row.Rd | 24 + pkg/man/repmat.Rd | 28 + pkg/man/run.count.Rd | 24 + pkg/man/scale.one.Rd | 23 + pkg/man/spl.Rd | 24 + pkg/man/tableColor.Rd | 27 + pkg/man/trim.Rd | 22 + pkg/man/write.xts.Rd | 29 + pkg/man/xts2ts.Rd | 19 + sit.gz | Bin 0 -> 156697 bytes sit.lite.gz | Bin 0 -> 101996 bytes 147 files changed, 81146 insertions(+) create mode 100644 R/aa.bl.r create mode 100644 R/aa.gmpl.r create mode 100644 R/aa.omega.r create mode 100644 R/aa.r create mode 100644 R/aa.test.r create mode 100644 R/branchbound.r create mode 100644 R/bt.r create mode 100644 R/bt.share.r create mode 100644 R/bt.share.test.r create mode 100644 R/bt.stop.r create mode 100644 R/bt.stop.test.r create mode 100644 R/bt.summary.r create mode 100644 R/bt.test.r create mode 100644 R/cluster.r create mode 100644 R/data.proxy.r create mode 100644 R/data.r create mode 100644 R/factor.model.r create mode 100644 R/factor.model.test.r create mode 100644 R/fundamental.data.r create mode 100644 R/fundamental.test.r create mode 100644 R/interactive.r create mode 100644 R/min.corr.paper.r create mode 100644 R/optimization.r create mode 100644 R/plot.table.r create mode 100644 R/plota.r create mode 100644 R/random.r create mode 100644 R/rfinance2012.r create mode 100644 R/rfinance2013.r create mode 100644 R/rfinance2014.r create mode 100644 R/shiny.R create mode 100644 R/strategy.r create mode 100644 R/ta.r create mode 100644 R/utils.r create mode 100644 Readme.pkg.txt create mode 100644 Readme.txt create mode 100644 SIT.tar.gz create mode 100644 Shiny/january.seasonality/global.R create mode 100644 Shiny/january.seasonality/server.R create mode 100644 Shiny/january.seasonality/ui.R create mode 100644 Shiny/market.filter/global.R create mode 100644 Shiny/market.filter/server.R create mode 100644 Shiny/market.filter/ui.R create mode 100644 Shiny/multi.stock/global.R create mode 100644 Shiny/multi.stock/server.R create mode 100644 Shiny/multi.stock/ui.R create mode 100644 Shiny/one.stock/global.R create mode 100644 Shiny/one.stock/server.R create mode 100644 Shiny/one.stock/ui.R create mode 100644 Shiny/retirement.withdrawal/server.r create mode 100644 Shiny/retirement.withdrawal/ui.r create mode 100644 Shiny/sector.rotation/global.R create mode 100644 Shiny/sector.rotation/server.R create mode 100644 Shiny/sector.rotation/ui.R create mode 100644 creategz.bat create mode 100644 make.sit.pkg.r create mode 100644 pkg/DESCRIPTION create mode 100644 pkg/NAMESPACE create mode 100644 pkg/R/SIT-package.R create mode 100644 pkg/R/aa.bl.r create mode 100644 pkg/R/aa.gmpl.r create mode 100644 pkg/R/aa.omega.r create mode 100644 pkg/R/aa.r create mode 100644 pkg/R/aa.test.r create mode 100644 pkg/R/branchbound.r create mode 100644 pkg/R/bt.r create mode 100644 pkg/R/bt.stop.r create mode 100644 pkg/R/bt.stop.test.r create mode 100644 pkg/R/bt.summary.r create mode 100644 pkg/R/bt.test.r create mode 100644 pkg/R/data.proxy.r create mode 100644 pkg/R/data.r create mode 100644 pkg/R/factor.model.r create mode 100644 pkg/R/factor.model.test.r create mode 100644 pkg/R/fundamental.data.r create mode 100644 pkg/R/fundamental.test.r create mode 100644 pkg/R/min.corr.paper.r create mode 100644 pkg/R/optimization.r create mode 100644 pkg/R/plot.table.r create mode 100644 pkg/R/plota.r create mode 100644 pkg/R/random.r create mode 100644 pkg/R/rfinance2012.r create mode 100644 pkg/R/shiny.r create mode 100644 pkg/R/strategy.r create mode 100644 pkg/R/ta.r create mode 100644 pkg/R/utils.r create mode 100644 pkg/man/FilenameFunctions.Rd create mode 100644 pkg/man/ListEnvFunctions.Rd create mode 100644 pkg/man/PlotaColorTheme.Rd create mode 100644 pkg/man/SIT.Rd create mode 100644 pkg/man/StringFunctions.Rd create mode 100644 pkg/man/TimingFunctions.Rd create mode 100644 pkg/man/XTSFunctions.Rd create mode 100644 pkg/man/beta.degree.Rd create mode 100644 pkg/man/bt.apply.min.weight.Rd create mode 100644 pkg/man/bt.apply.round.weight.Rd create mode 100644 pkg/man/bt.start.dates.Rd create mode 100644 pkg/man/col.add.alpha.Rd create mode 100644 pkg/man/compute.cor.Rd create mode 100644 pkg/man/count.Rd create mode 100644 pkg/man/create.monthly.table.Rd create mode 100644 pkg/man/createNonReactiveTextInput.Rd create mode 100644 pkg/man/dates2index.Rd create mode 100644 pkg/man/flip.xts.Rd create mode 100644 pkg/man/getSymbols.extra.Rd create mode 100644 pkg/man/getSymbols.sit.Rd create mode 100644 pkg/man/ifna.Rd create mode 100644 pkg/man/ifnull.Rd create mode 100644 pkg/man/iif.Rd create mode 100644 pkg/man/index.xts.Rd create mode 100644 pkg/man/join.Rd create mode 100644 pkg/man/len.Rd create mode 100644 pkg/man/load.packages.Rd create mode 100644 pkg/man/lookup.index.Rd create mode 100644 pkg/man/make.stock.xts.Rd create mode 100644 pkg/man/make.xts.Rd create mode 100644 pkg/man/map2monthly.Rd create mode 100644 pkg/man/mlag.Rd create mode 100644 pkg/man/plot.table.Rd create mode 100644 pkg/man/plota.Rd create mode 100644 pkg/man/plota.add.copyright.Rd create mode 100644 pkg/man/plota.format.Rd create mode 100644 pkg/man/plota.grid.Rd create mode 100644 pkg/man/plota.layout.Rd create mode 100644 pkg/man/plota.legend.Rd create mode 100644 pkg/man/plota.lines.Rd create mode 100644 pkg/man/plota.matplot.Rd create mode 100644 pkg/man/plota.recession.Rd create mode 100644 pkg/man/plota.stacked.Rd create mode 100644 pkg/man/plota.x.highlight.Rd create mode 100644 pkg/man/plota.y.highlight.Rd create mode 100644 pkg/man/plota2Y.Rd create mode 100644 pkg/man/proxy.overlay.plot.Rd create mode 100644 pkg/man/proxy.prices.Rd create mode 100644 pkg/man/proxy.test.Rd create mode 100644 pkg/man/read.xts.Rd create mode 100644 pkg/man/rep.col.Rd create mode 100644 pkg/man/rep.row.Rd create mode 100644 pkg/man/repmat.Rd create mode 100644 pkg/man/run.count.Rd create mode 100644 pkg/man/scale.one.Rd create mode 100644 pkg/man/spl.Rd create mode 100644 pkg/man/tableColor.Rd create mode 100644 pkg/man/trim.Rd create mode 100644 pkg/man/write.xts.Rd create mode 100644 pkg/man/xts2ts.Rd create mode 100644 sit.gz create mode 100644 sit.lite.gz diff --git a/R/aa.bl.r b/R/aa.bl.r new file mode 100644 index 0000000..e39e8da --- /dev/null +++ b/R/aa.bl.r @@ -0,0 +1,214 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Black-Litterman model Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Black-Litterman model Functions +############################################################################### +# He & Litterman: The intuition Behind Black- Litterman Model Portfolios +# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL +# note (5) +# +#' @export +bl.compute.risk.aversion <- function(bench, risk.free = 0) +{ + # The implied risk aversion coefficient can be estimated by dividing + # the expected excess return by the variance of the portfolio + lambda = mean(coredata(bench) - coredata(risk.free)) / var(coredata(bench)) + return( as.double(lambda) ) +} + +# He & Litterman: The intuition Behind Black- Litterman Model Portfolios +# formulas (2) +# +# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL +# formulas (1) +# +# use reverse optimization to compute the vector of equilibrium returns +#' @export +bl.compute.eqret <- function +( + risk.aversion, # Risk Aversion + cov, # Covariance matrix + cap.weight, # Market Capitalization Weights + risk.free = 0 # Rsik Free Interest Rate +) +{ + return( risk.aversion * cov %*% as.vector(cap.weight) + as.double(risk.free)) +} + +# He & Litterman: The intuition Behind Black- Litterman Model Portfolios +# formulas (8), (9), (10) +# compute the posterior estimate of the returns and covariance +#' @export +bl.compute.posterior <- function +( + mu, # Equilibrium returns + cov, # Covariance matrix + pmat=NULL, # Views pick matrix + qmat=NULL, # View mean vector + tau=0.025, # Measure of uncertainty of the prior estimate of the mean returns + confidences=NULL # Confidence of each view +) +{ + out = list() + + if( !is.null(pmat) ) { + if( is.null(confidences) ) { + # The Black-Litterman Model In Detail by Jay Walters + # Assume that the variance of the views will be proportional to the variance of the asset + # returns, just as the variance of the prior distribution is. He and Litterman (1999) + # This specification of the variance, or uncertainty, of the views essentially equally weights the investor's + # views and the market equilibrium weights. By including tau in the expression, the final solution becomes + # independent of tau as well. + + # contactenate 1 and remove first row, col ([-1,-1]) to work properly with single view + omega = diag(c(1,diag(tau * pmat %*% cov %*% t(pmat))))[-1,-1] + } else { + omega = diag(c(1,confidences))[-1,-1] + } + + temp = solve(solve(tau * cov) + t(pmat) %*% solve(omega) %*% pmat) + + out$cov = cov + temp + + out$expected.return = temp %*% (solve(tau * cov) %*% mu + t(pmat) %*% solve(omega) %*% qmat) + } else { # no views + temp = tau * cov + + out$cov = cov + temp + + out$expected.return = temp %*% (solve(tau * cov) %*% mu ) + + } + return(out) +} + + +# He & Litterman: The intuition Behind Black- Litterman Model Portfolios +# formulas (13) +# +# T. Idzorek: A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL +# formulas (2) +# +# compute the portfolio weights for the optimal portfolio on the unconstrained efficient frontier +#' @export +bl.compute.optimal <- function(risk.aversion, mu, cov) +{ + return( (1/risk.aversion) * solve(cov) %*% mu ) +} + + + +aa.black.litterman.examples <- function() +{ + # He & Litterman: The intuition Behind Black- Litterman Model Portfolios. + + data = + '1,0.4880,0.4780,0.5150,0.4390,0.5120,0.4910 + 0.4880,1,0.6640,0.6550,0.3100,0.6080,0.7790 + 0.4780,0.6640,1,0.8610,0.3550,0.7830,0.6680 + 0.5150,0.6550,0.8610,1,0.3540,0.7770,0.6530 + 0.4390,0.3100,0.3550,0.3540,1,0.4050,0.3060 + 0.5120,0.6080,0.7830,0.7770,0.4050,1,0.6520 + 0.4910,0.7790,0.6680,0.6530,0.3060,0.6520,1' + + Corrmat = matrix( as.double(spl( gsub('\n', ',', data), ',')), + nrow = len(spl(data, '\n')), byrow=TRUE) + + RiskAversion = 2.5 + + stdevs = c(16.0, 20.3, 24.8, 27.1, 21.0, 20.0, 18.7)/100 + + MktWeight = c(1.6, 2.2, 5.2, 5.5, 11.6, 12.4, 61.5)/100 + + tau = 0.05 + + Covmat = Corrmat * (stdevs %*% t(stdevs)) + + EqRiskPrem = RiskAversion * Covmat %*% MktWeight +EqRiskPrem = bl.compute.eqret(RiskAversion, Covmat, MktWeight) + + AssetNames = c('Australia','Canada','France','Germany','Japan','UK','USA') + + Table2 = cbind(AssetNames, round(cbind(stdevs, MktWeight, EqRiskPrem) * 100,1)) + colnames(Table2) = c('Assets','Std Dev','Weq','PI') + Table2 + + #View1 is The German Equity Market Will Outperform the rest of European Markets by 5% a year. + P = matrix(c(0, 0, -29.5, 100, 0, -70.5, 0)/100, nrow=1) + Q = 5/100 + + Omega = diag(c(1,diag(tau * P %*% Covmat %*% t(P))))[-1,-1] + + PostCov = solve(solve(tau*Covmat) + (t(P) %*% solve(Omega) %*% P)) + + SigmaP = Covmat + PostCov + + ExpRet = PostCov %*% (solve(tau * Covmat) %*% EqRiskPrem + t(P) %*% solve(Omega) %*% Q) + +post = bl.compute.posterior(EqRiskPrem, Covmat, P, Q, tau) + ExpRet = post$expected.return + SigmaP = post$cov + + OptimalWeights = (1/RiskAversion) * solve(SigmaP) %*% ExpRet +OptimalWeights = bl.compute.optimal(RiskAversion, ExpRet, SigmaP) + + Tab4Col4 = OptimalWeights - (MktWeight)/(1+tau) + + Table4 = cbind(AssetNames, round(cbind(t(P), ExpRet, OptimalWeights, round(Tab4Col4 * 1000)/1000)*100,1)) + colnames(Table4) = c('Assets', 'P', 'MU', 'W','W - Weq/1+tau') + Table4 + + + # example from Thomas M. Idzorek's paper "A STEP-BY-STEP GUIDE TO THE BLACK-LITTERMAN MODEL" + x = + c(0.001005,0.001328,-0.000579,-0.000675,0.000121,0.000128,-0.000445,-0.000437 , + 0.001328,0.007277,-0.001307,-0.000610,-0.002237,-0.000989,0.001442,-0.001535 , + -0.000579,-0.001307,0.059852,0.027588,0.063497,0.023036,0.032967,0.048039 , + -0.000675,-0.000610,0.027588,0.029609,0.026572,0.021465,0.020697,0.029854 , + 0.000121,-0.002237,0.063497,0.026572,0.102488,0.042744,0.039943,0.065994 , + 0.000128,-0.000989,0.023036,0.021465,0.042744,0.032056,0.019881,0.032235 , + -0.000445,0.001442,0.032967,0.020697,0.039943,0.019881,0.028355,0.035064 , + -0.000437,-0.001535,0.048039,0.029854,0.065994,0.032235,0.035064,0.079958 ) + + varCov <- matrix(x, ncol = 8, nrow = 8) + mu <- c(0.08, 0.67,6.41, 4.08, 7.43, 3.70, 4.80, 6.60) / 100 + pick <- matrix(0, ncol = 8, nrow = 3, dimnames = list(NULL, letters[1:8])) + pick[1,7] <- 1 + pick[2,1] <- -1; pick[2,2] <- 1 + pick[3, 3:6] <- c(0.9, -0.9, .1, -.1) + +post = bl.compute.posterior(mu, varCov, pick, c(0.0525, 0.0025, 0.02), tau = 0.025) + + library(BLCOP) + confidences <- 1 / c(0.000709, 0.000141, 0.000866) + myViews <- BLViews(pick, c(0.0525, 0.0025, 0.02), confidences, letters[1:8]) + myPosterior <- posteriorEst(myViews, tau = 0.025, mu, varCov ) + myPosterior + + + myPosterior@posteriorMean - post$expected.return + myPosterior@posteriorCovar - post$cov + + + +} diff --git a/R/aa.gmpl.r b/R/aa.gmpl.r new file mode 100644 index 0000000..8bb8c84 --- /dev/null +++ b/R/aa.gmpl.r @@ -0,0 +1,617 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Read GNU MathProg model +# Copyright (C) 2012 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Read GNU MathProg model +# based on Rglpk_read_file, modified to eliminate objective fn from constraint matrix +#' @export +############################################################################### +Rglpk.read.model <- function(file, type = c("MPS_fixed", "MPS_free", "CPLEX_LP", "MathProg"), ignore_first_row = FALSE, verbose = FALSE){ + if(!file.exists(file)) stop(paste("There is no file called", file, "!")) + + type_db <- c("MPS_fixed" = 1L, "MPS_free" = 2L, "CPLEX_LP" = 3L, "MathProg" = 4L) + obj <- list(file = tools::file_path_as_absolute(file), type = type_db[match.arg(type)]) + + meta_data <- Rglpk:::glp_get_meta_data_from_file(obj, verbose) + milp_data <- Rglpk:::glp_retrieve_MP_from_file(meta_data, ignore_first_row, verbose) + MP_data <- Rglpk:::glp_merge_MP_data(meta_data, milp_data) + + dir_db <- c("free" = 1L, ">=" = 2L, "<=" = 3L, "DB" = 4L, "==" = 5L) + MP_data$direction_of_constraints <- names(dir_db[MP_data$direction_of_constraints]) + + types <- rep("C", length.out = MP_data$n_objective_vars) + if(any(MP_data$objective_var_is_integer)) types[MP_data$objective_var_is_integer] <- "I" + if(any(MP_data$objective_var_is_binary)) types[MP_data$objective_var_is_binary] <- "B" + MP_data$types = types + + # remove objective fn from constraints + index = which(MP_data$direction_of_constraints == 'free') + if( length(index) > 0 ) { + MP_data$constraint_matrix = as.matrix(MP_data$constraint_matrix)[-index,] + MP_data$direction_of_constraints = MP_data$direction_of_constraints[-index] + MP_data$right_hand_side = MP_data$right_hand_side[-index] + } + MP_data +} + + +############################################################################### +# Create constraints structure from model data (Rglpk.read.model) +#' @export +############################################################################### +Rglpk.create.constraints <- function( prob ) +{ + #-------------------------------------------------------------------------- + # Create constraints + #-------------------------------------------------------------------------- + n = prob$n_objective_vars + + lb = rep(NA,n) + lb[prob$bounds$lower$ind] = prob$bounds$lower$val + ub = rep(NA,n) + ub[prob$bounds$upper$ind] = prob$bounds$upper$val + constraints = new.constraints(n, lb = lb, ub = ub) + + # binary variables + constraints$binary.index = which(prob$objective_var_is_binary == 1) + if(len(constraints$binary.index) == 0) constraints$binary.index = 0 + + #constraints + if(is.null(dim(prob$constraint_matrix))) { + prob$constraint_matrix = matrix(prob$constraint_matrix) + } else { + prob$constraint_matrix = t(prob$constraint_matrix) + } + + index = which(prob$direction_of_constraints == '==') + if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '=', b = prob$right_hand_side[index], constraints) + + index = which(prob$direction_of_constraints == '<=') + if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '<=', b = prob$right_hand_side[index], constraints) + + index = which(prob$direction_of_constraints == '>=') + if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '>=', b = prob$right_hand_side[index], constraints) + + # objective function + f.obj = prob$objective_coefficients + dir = ifelse(prob$maximize, 'max', 'min') + + prob$names = prob$objective_vars_names + prob$tickers = prob$objective_vars_names + + # find tickers wgt[AAPL] + if(len(grep('\\[',prob$objective_vars_names)) > 0) { + temp = matrix(spl(gsub(']','', prob$objective_vars_names),'\\['), nr=2) + prob$names = temp[1,] + prob$tickers = temp[2,] + } + + return(list(constraints=constraints, f.obj=f.obj, dir=dir, prob=prob)) +} + + + + +############################################################################### +# Parse Views / Constraints using GNU Mathprog specifications +#' @export +############################################################################### +parse.views = function(symbolnames, views) { + load.packages('Rglpk') + + views = parse.expr(views) + if (len(views)==0) + return(list( + A = matrix(0, nr=0, nc=len(symbolnames)), + b = c(), + meq = 0 + )) + +model.file = tempfile('temp.model') +on.exit(unlink(model.file)) + + # create GNU MathProg model + cat(" +############################################################################### +# Define Variables +", join(paste0('var ', symbolnames, '>=0;'),'\n'), " + +# Define Objective +minimize objective : ", join(symbolnames, '+'), "; + +# Define Constraints +", join(paste0('V', 1:len(views), ':', views,';'),'\n'), " + +############################################################################### + ", file = model.file, append = FALSE) + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + # read model + model = Rglpk.read.model(model.file,type = 'MathProg') + + # convert GNU MathProg model to constraint used in solve.QP + temp = Rglpk.create.constraints(model)$constraints + + A = t(as.matrix(temp$A)) + colnames(A) = symbolnames + + list( + A = A, + b = temp$b, + meq = temp$meq + ) +} + + + +############################################################################### +# Helper function to find Minimum Variance Portfolio +#' @export +############################################################################### +min.var.portfolio.gmpl <- function(ia, constraints) +{ + #-------------------------------------------------------------------------- + # Adjust Covariance matrix + #-------------------------------------------------------------------------- + load.packages('quadprog,corpcor') + + cov.temp = ia$cov + + # check if there are dummy variables + n0 = ia$n + n = nrow(constraints$A) + if( n != nrow(cov.temp) ) { + temp = matrix(0, n, n) + temp[1:n0, 1:n0] = cov.temp[1:n0, 1:n0] + cov.temp = temp + } + + if(!is.positive.definite(cov.temp)) { + cov.temp <- make.positive.definite(cov.temp, 0.000000001) + } + + #-------------------------------------------------------------------------- + # Solve QP problem + #-------------------------------------------------------------------------- + binary.vec = 0 + if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index + + sol = solve.QP.bounds(Dmat = cov.temp, dvec = rep(0, nrow(cov.temp)) , + Amat=constraints$A, bvec=constraints$b, constraints$meq, + lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec) + + if(binary.vec[1] != 0) cat(sol$counter,'QP calls made to solve problem with', len(binary.vec), 'binary variables using Branch&Bound', '\n') + + x = sol$solution[1:ia$n] + names(x) = ia$symbols + + return(x) +} + + +############################################################################### +# Portfolio Optimization: Specify constraints with GNU MathProg language +# +# Examples: +# http://en.wikibooks.org/wiki/GLPK/GMPL_%28MathProg%29 +# http://en.wikibooks.org/wiki/GLPK/Literature#Official_GLPK_documentation +# +# The GNU Linear Programming Kit (GLPK) : Resources, Tutorials +# http://spokutta.wordpress.com/tag/gnu-mathprog/ +############################################################################### +portopt.mathprog.test <- function( ) +{ + #***************************************************************** + # Load packages + #****************************************************************** + load.packages('quantmod,quadprog,corpcor') + + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + tickers = dow.jones.components() + ia = aa.test.create.ia.custom(tickers, dates = '2000::2010') + + #-------------------------------------------------------------------------- + # Create Constraints & Solve QP problem + #-------------------------------------------------------------------------- + n = ia$n + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # Solve QP problem + x = min.var.portfolio.gmpl(ia, constraints) + + # plot weights +png(filename = 'plot1.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio') +dev.off() + + + + + + + #***************************************************************** + # Load packages + #****************************************************************** + # load Rglpk to read GNU MathProg files + load.packages('Rglpk') + + #-------------------------------------------------------------------------- + # Create Constraints: GNU MathProg model + #-------------------------------------------------------------------------- + model.file = 'model1.mod' + + # create GNU MathProg model + cat(' +############################################################################### +set SYMBOLS ; + +# set min/max weights for individual stocks +var weight{i in SYMBOLS} >= 0, <= 1 ; + +# objective function, NOT USED +minimize alpha : sum{i in SYMBOLS} weight[i] ; + +# weights must sum to 1 (fully invested) +subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ; + +data; + +set SYMBOLS := ', ia$symbols, '; +############################################################################### + ', file = model.file, append = FALSE) + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + # read model + model = Rglpk.read.model(model.file,type = 'MathProg') + + # convert GNU MathProg model to constraint used in solve.QP + constraints = Rglpk.create.constraints(model)$constraints + + # Solve QP problem + x = min.var.portfolio.gmpl(ia, constraints) + + # plot weights +png(filename = 'plot2.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model') +dev.off() + + + #-------------------------------------------------------------------------- + # Create Constraints: GNU MathProg model + # Control Minimum Investment and Number of Assets: Portfolio Cardinality Constraints + # http://systematicinvestor.wordpress.com/2011/10/20/minimum-investment-and-number-of-assets-portfolio-cardinality-constraints/ + #-------------------------------------------------------------------------- + model.file = 'model2.mod' + + # create GNU MathProg model + cat(' +############################################################################### +set SYMBOLS ; + +# set min/max weights for individual stocks +var weight{i in SYMBOLS} >= 0, <= 1 ; + +# add binary, 1 if held, 0 if not held +var held{SYMBOLS} binary; + +# objective function, NOT USED +minimize alpha : sum{i in SYMBOLS} weight[i] ; + +# weights must sum to 1 (fully invested) +subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ; + +# min weight constraint for individual asset +subject to MinWgt {i in SYMBOLS} : weight[i] >= 0.025 * held[i]; + +# max weight constraint for individual asset +subject to MaxWgt {i in SYMBOLS} : weight[i] <= .20 * held[i] ; + +# number of stocks in portfolio +subject to MaxAssetsLB : 0 <= sum {i in SYMBOLS} held[i] ; +subject to MaxAssetsUB : sum {i in SYMBOLS} held[i] <= 6 ; + +data; + +set SYMBOLS := ', ia$symbols, '; +############################################################################### + ', file = model.file, append = FALSE) + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + # read model + model = Rglpk.read.model(model.file,type = 'MathProg') + + # convert GNU MathProg model to constraint used in solve.QP + constraints = Rglpk.create.constraints(model)$constraints + + # Solve QP problem + x = min.var.portfolio.gmpl(ia, constraints) + + # plot weights +png(filename = 'plot3.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Minimum Investment and Number of Assets Constraints') +dev.off() + + + #-------------------------------------------------------------------------- + # Create Constraints: GNU MathProg model + # Control Long and Short positions based on 130/30 Portfolio Construction + # http://systematicinvestor.wordpress.com/2011/10/18/13030-porfolio-construction/ + #-------------------------------------------------------------------------- + model.file = 'model3.mod' + + # create GNU MathProg model + cat(' +############################################################################### +set SYMBOLS ; + +# set min/max weights for individual stocks +var long {i in SYMBOLS} >= 0, <= 0.8 ; +var short{i in SYMBOLS} >= 0, <= 0.5 ; + +# add binary, 1 if long, 0 if short +var islong{SYMBOLS} binary; + +# objective function, NOT USED +minimize alpha : sum{i in SYMBOLS} long[i] ; + +# weights must sum to 1 (fully invested) +subject to fully_invested : sum{i in SYMBOLS} (long[i] - short[i]) = 1 ; + +# leverage is 1.6 = longs + shorts +subject to leverage : sum{i in SYMBOLS} (long[i] + short[i]) = 1.6 ; + +# force long and short to be mutually exclusive (only one of them is greater then 0 for each i) +subject to long_flag {i in SYMBOLS} : long[i] <= islong[i] ; +subject to short_flag {i in SYMBOLS} : short[i] <= (1 - islong[i]) ; + +data; + +set SYMBOLS := ', ia$symbols, '; +############################################################################### + ', file = model.file, append = FALSE) + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + # read model + model = Rglpk.read.model(model.file,type = 'MathProg') + + # convert GNU MathProg model to constraint used in solve.QP + constraints = Rglpk.create.constraints(model)$constraints + + # Solve QP problem, modify Input Assumptions to include short positions + x = min.var.portfolio.gmpl(aa.test.ia.add.short(ia), constraints) + + # Compute total weight = longs - short + x = x[1:ia$n] - x[-c(1:ia$n)] + + # plot weights +png(filename = 'plot4.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with 130:30 Constraints') +dev.off() + + + + + + # reduce problem size + ia = aa.test.create.ia.custom(tickers[1:15], dates = '2000::2010') + + #-------------------------------------------------------------------------- + # Create Constraints: GNU MathProg model + # Turnover Constraints : Control Maximum Trade Size and Number of Trades + #-------------------------------------------------------------------------- + model.file = 'model4.mod' + + # create parameters to hold Current Weight + param = ia$cov[,1,drop=F] + colnames(param) = 'CurWgt' + param[,'CurWgt'] = 1/ia$n + + + # create GNU MathProg model + cat(' +############################################################################### +set SYMBOLS ; + +param CurWgt{SYMBOLS} ; + +# set min/max weights for individual stocks +var weight{i in SYMBOLS} >= 0, <= 1 ; + +# TradePos[i] - TradeNeg[i] = CurWgt[i] - weight[i] +var TradePos{i in SYMBOLS} >= 0 ; +var TradeNeg{i in SYMBOLS} >= 0 ; + +# Only one of TradePos or TradeNeg is > 0 +var TradeFlag{SYMBOLS} binary; + +# add binary, 1 if traded, 0 if not traded +var trade{SYMBOLS} binary; + +# objective function, NOT USED +minimize alpha : sum{i in SYMBOLS} weight[i] ; + +# weights must sum to 1 (fully invested) +subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ; + +# setup Trades for individual asset +subject to TradeRange {i in SYMBOLS} : (CurWgt[i] - weight[i]) = (TradePos[i] - TradeNeg[i]) ; + +# Only one of TradePos or TradeNeg is > 0 +subject to TradeFlagPos {i in SYMBOLS} : TradePos[i] <= 100 * TradeFlag[i]; +subject to TradeFlagNeg {i in SYMBOLS} : TradeNeg[i] <= 100 * (1 - TradeFlag[i]); + +# min trade size constraint for individual asset +subject to MinTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) >= 0.01 * trade[i]; +subject to MaxTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) <= .90 * trade[i] ; + +# number of trades in portfolio +subject to MaxTrade : sum {i in SYMBOLS} trade[i] <= 48 ; + +data; + +set SYMBOLS := ', ia$symbols, '; + +param : CurWgt:= + ', file = model.file, append = FALSE) + +write.table(param, sep='\t', quote = F, col.names = F, file = model.file, append = TRUE) +cat('; +############################################################################### + ', file = model.file, append = TRUE) + + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + model = Rglpk.read.model(model.file,type = 'MathProg') + constraints = Rglpk.create.constraints(model)$constraints + + + # Solve QP problem + x = min.var.portfolio.gmpl(ia, constraints) + sqrt(x %*% ia$cov %*% x) + + + # plot weights +png(filename = 'plot5.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Turnover Constraints') +dev.off() + + + + + + + + + + +# reduce problem size +ia = aa.test.create.ia.custom(tickers[1:10], dates = '2000::2010') + + + #-------------------------------------------------------------------------- + # Create Constraints: GNU MathProg model + # Turnover Constraints : Control Maximum Trade Size and Number of Trades + #-------------------------------------------------------------------------- + model.file = 'model4.mod' + + # create parameters to hold Current Weight + param = ia$cov[,1,drop=F] + colnames(param) = 'CurWgt' + param[,'CurWgt'] = 1/ia$n + + + # create GNU MathProg model + cat(' +############################################################################### +set SYMBOLS ; + +param CurWgt{SYMBOLS} ; + +# set min/max weights for individual stocks +var weight{i in SYMBOLS} >= 0, <= 1 ; + +# TradePos[i] - TradeNeg[i] = CurWgt[i] - weight[i] +var TradePos{i in SYMBOLS} >= 0 ; +var TradeNeg{i in SYMBOLS} >= 0 ; + +# Only one of TradePos or TradeNeg is > 0 +var TradeFlag{SYMBOLS} binary; + +# add binary, 1 if traded, 0 if not traded +var trade{SYMBOLS} binary; + +# objective function, NOT USED +minimize alpha : sum{i in SYMBOLS} weight[i] ; + +# weights must sum to 1 (fully invested) +subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ; + +# setup Trades for individual asset +subject to TradeRange {i in SYMBOLS} : (CurWgt[i] - weight[i]) = (TradePos[i] - TradeNeg[i]) ; + +# Only one of TradePos or TradeNeg is > 0 +subject to TradeFlagPos {i in SYMBOLS} : TradePos[i] <= 100 * TradeFlag[i]; +subject to TradeFlagNeg {i in SYMBOLS} : TradeNeg[i] <= 100 * (1 - TradeFlag[i]); + +# min trade size constraint for individual asset +subject to MinTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) >= 0.05 * trade[i]; +subject to MaxTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) <= .20 * trade[i] ; + +# number of trades in portfolio +subject to MaxTrade : sum {i in SYMBOLS} trade[i] <= 8 ; + +data; + +set SYMBOLS := ', ia$symbols, '; + +param : CurWgt:= + ', file = model.file, append = FALSE) + +write.table(param, sep='\t', quote = F, col.names = F, file = model.file, append = TRUE) +cat('; +############################################################################### + ', file = model.file, append = TRUE) + + + #-------------------------------------------------------------------------- + # Read GNU MathProg model/Setup constraints/Solve QP problem + #-------------------------------------------------------------------------- + model = Rglpk.read.model(model.file,type = 'MathProg') + constraints = Rglpk.create.constraints(model)$constraints + + + # Solve QP problem + x = min.var.portfolio.gmpl(ia, constraints) + sqrt(x %*% ia$cov %*% x) + + + # plot weights +png(filename = 'plot6.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white') + barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Turnover Constraints') +dev.off() + + + + + +} + + + + \ No newline at end of file diff --git a/R/aa.omega.r b/R/aa.omega.r new file mode 100644 index 0000000..2a4d9fc --- /dev/null +++ b/R/aa.omega.r @@ -0,0 +1,245 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Optimizing Omega Ration Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + +############################################################################### +# Omega +# page 6,9, Optimizing Omega by H. Mausser, D. Saunders, L. Seco +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# The Omega function has the form +# MAX [ SUM 1/T * u.j ] +# [ SUM r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T +# [ SUM 1/T * d.j ] = 1 +# u.j, d.j >= 0, for each j = 1,...,T +# +# Binary b.j enforces that only one of u.j or d.j is greter than 0 +# u.j <= b.j +# d.j <= 1 - b.j +#' @export +############################################################################### +add.constraint.omega <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega + + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add u.j, d.j, t + constraints = add.variables(2*nt + 1, constraints, lb = c(rep(0,2*nt),-Inf)) + # Aw < b => Aw1 - bt < 0 + constraints$A[n + 2*nt + 1, ] = -constraints$b + constraints$b[] = 0 + + # lb/ub same transformation + index = which( constraints$ub[1:n] < +Inf ) + if( len(index) > 0 ) { + a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$ub[1:n]) + constraints = add.constraints(a[, index], rep(0, len(index)), '<=', constraints) + } + + index = which( constraints$lb[1:n] > -Inf ) + if( len(index) > 0 ) { + a = rbind( diag(n), matrix(0, 2*nt, n), -constraints$lb[1:n]) + constraints = add.constraints(a[, index], rep(0, len(index)), '>=', constraints) + } + + constraints$lb[1:n] = -Inf + constraints$ub[1:n] = Inf + + + # [ SUM r.ij * x.i ] - u.j + d.j - L * t = 0, for each j = 1,...,T + a = rbind( matrix(0, n, nt), -diag(nt), diag(nt), -omega) + a[1 : n0, ] = t(ia$hist.returns) + constraints = add.constraints(a, rep(0, nt), '=', constraints) + + # [ SUM 1/T * d.j ] = 1 + constraints = add.constraints(c( rep(0,n), rep(0,nt), (1/nt) * rep(1,nt), 0), 1, '=', constraints) + + # objective : Omega + # [ SUM 1/T * u.j ] + constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, nt), rep(0, nt), 0), value, type[1], constraints) + + return( constraints ) +} + +#' @export +portfolio.omega <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n] + if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega + + portfolio.returns = weight %*% t(ia$hist.returns) + return( apply(portfolio.returns, 1, function(x) mean(pmax(x - omega,0)) / mean(pmax(omega - x,0)) ) ) +} + + +############################################################################### +# Find portfolio that Maximizes Omega +#' @export +############################################################################### +max.omega.portfolio <- function +( + ia, # input assumptions + constraints, # constraints + type = c('mixed', 'lp', 'nlp') +) +{ + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + type = type[1] + + if(type == 'mixed' || type == 'lp') { + sol = optimize.portfolio(ia, constraints, add.constraint.omega, portfolio.omega, 'max', T) + + x = rep(NA, n) + if(!inherits(sol, 'try-error') && sol$status ==0) { + x0 = sol$solution[1:n] + u = sol$solution[(1+n):(n+nt)] + d = sol$solution[(n+nt+1):(n+2*nt)] + t = sol$solution[(n+2*nt+1):(n+2*nt+1)] + x = x0/t + } + } + + #portfolio.omega(t(x),ia) + #sol$value + + if((type == 'mixed' && (sol$status !=0 || any( u*d != 0 ) )) || type == 'nlp') { + # Try solving problem using Rdonlp2 + if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega + + # omega + fn <- function(x){ + portfolio.returns = x %*% t(ia$hist.returns) + mean(pmax(portfolio.returns - omega,0)) / mean(pmax(omega - portfolio.returns,0)) + } + + x = optimize.portfolio.nlp(ia, constraints, fn, direction = 'max') + #portfolio.omega(t(x),ia) + } + + return( x ) +} + + +############################################################################### +# Create efficient frontier +#' @export +############################################################################### +portopt.omega <- function +( + ia, # Input Assumptions + constraints = NULL, # Constraints + nportfolios = 50, # Number of portfolios + name = 'Omega' # Name +) +{ + # set up output + out = list(weight = matrix(NA, nportfolios, nrow(constraints$A))) + colnames(out$weight) = rep('', ncol(out$weight)) + colnames(out$weight)[1:ia$n] = ia$symbols + + + ef.risk = portopt(ia, constraints, 2) + + # maximum return portfolio + out$weight[nportfolios, ] = ef.risk$weight[2,] + + # minimum risk portfolio + out$weight[1, ] = ef.risk$weight[1,] + constraints$x0 = out$weight[1, ] + + # find points on efficient frontier + out$return = portfolio.return(out$weight, ia) + target = seq(out$return[1], out$return[nportfolios], length.out = nportfolios) + + constraints = add.constraints(c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)), + target[1], type = '<=', constraints) + + for(i in 1:nportfolios ) { + cat('i =', i, '\n') + + constraints$b[ len(constraints$b) ] = -target[i] + out$weight[i, ] = max.omega.portfolio(ia, constraints) + + constraints$x0 = out$weight[i, ] + } + + + # compute risk / return + out$return = portfolio.return(out$weight, ia) + out$risk = portfolio.risk(out$weight, ia) + out$name = name + + return(out) +} + + +############################################################################### +# Plot Omega Ratio for given portfolios (weights) +#' @export +############################################################################### +plot.omega <- function +( + weight, # weight + ia # input assumptions +) +{ + omegafn = function(x,L) { mean(pmax(x-L,0)) / mean(pmax(L-x,0)) } + + if(is.null(ia$parameters.omega)) omega = 0 else omega = ia$parameters.omega + + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + + threshhold = quantile(portfolio.returns, probs = c(0.05, 0.95)) + threshhold = seq(threshhold[1], threshhold[2], length.out = 100) + + par(mar = c(4,4,2,1), cex = 0.8) + for(i in 1:nrow(weight)) { + data = sapply(threshhold, function(L) omegafn(portfolio.returns[i, ], L)) + + if(i==1) plot(threshhold,log(data), type='l', col=i, + xlab='Threshhold', ylab='Log(Omega)', main='Portfolio Omega') + lines(threshhold, log(data), col=i) + } + abline(v = omega, col='orange') + grid() + plota.legend(rownames(weight) ,1:nrow(weight), x = 'bottomleft') +} + diff --git a/R/aa.r b/R/aa.r new file mode 100644 index 0000000..46d2a86 --- /dev/null +++ b/R/aa.r @@ -0,0 +1,2048 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Asset Allocation Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Building constraints for quadprog, solve.QP +# min(-d^T w.i + 1/2 w.i^T D w.i) constraints A^T w.i >= b_0 +# the first meq constraints are treated as equality constraints, +# all further as inequality constraints +############################################################################### +# new.constraints - create new constraints structure +#' @export +############################################################################### +new.constraints <- function +( + n, # number of variables + A = NULL, # matrix with constraints + b = NULL, # vector b + type = c('=', '>=', '<='), # type of constraints + lb = NA, # vector with lower bounds + ub = NA # vector with upper bounds +) +{ + meq = 0 + if ( is.null(A) || is.na(A) || is.null(b) || is.na(b) ) { + A = matrix(0, n, 0) + b = c() + } else { + if ( is.null(dim(A)) ) dim(A) = c(len(A), 1) + + if ( type[1] == '=' ) meq = len(b) + if ( type[1] == '<=' ) { + A = -A + b = -b + } + } + + if ( is.null(lb) || is.na(lb) ) lb = rep(NA, n) + if ( len(lb) != n ) lb = rep(lb[1], n) + + if ( is.null(ub) || is.na(ub) ) ub = rep(NA, n) + if ( len(ub) != n ) ub = rep(ub[1], n) + + + return( list(n = n, A = A, b = b, meq = meq, lb = lb, ub = ub) ) +} + +############################################################################### +# add.constraints - add to existing constraints structure +#' @export +############################################################################### +add.constraints <- function +( + A, # matrix with constraints + b, # vector b + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + if(is.null(constraints)) constraints = new.constraints(n = nrow(A)) + + if(is.null(dim(A))) A = matrix(A) + + if(len(b) == 1) b = rep(b, ncol(A)) + + if ( type[1] == '=' ) { + constraints$A = cbind( A, constraints$A ) + constraints$b = c( b, constraints$b ) + constraints$meq = constraints$meq + len(b) + } + + if ( type[1] == '>=' ) { + constraints$A = cbind( constraints$A, A ) + constraints$b = c( constraints$b, b ) + } + + if ( type[1] == '<=' ) { + constraints$A = cbind( constraints$A, -A ) + constraints$b = c( constraints$b, -b ) + } + + return( constraints ) +} + +############################################################################### +# add.variables - add to existing constraints structure +#' @export +############################################################################### +add.variables <- function +( + n, # number of variables to add + constraints, # constraints structure + lb = NA, # vector with lower bounds + ub = NA # vector with upper bounds +) +{ + constraints$A = rbind( constraints$A, matrix(0, n, len(constraints$b)) ) + + if ( is.null(lb) || is.na(lb) ) lb = rep(NA, n) + if ( len(lb) != n ) lb = rep(lb[1], n) + + if ( is.null(ub) || is.na(ub) ) ub = rep(NA, n) + if ( len(ub) != n ) ub = rep(ub[1], n) + + constraints$lb = c(constraints$lb, lb) + constraints$ub = c(constraints$ub, ub) + constraints$n = constraints$n + n + + return( constraints ) +} + + +############################################################################### +# delete.constraints - remove specified constraints from existing constraints structure +#' @export +############################################################################### +delete.constraints <- function +( + delete.index, # index of constraints to delete + constraints # constraints structure +) +{ + constraints$A = constraints$A[, -delete.index, drop=F] + constraints$b = constraints$b[ -delete.index] + constraints$meq = constraints$meq - len(intersect((1:constraints$meq), delete.index)) + return( constraints ) +} + +#' @export +type.constraints <- function(constraints) +{ + c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq)) +} + + +############################################################################### +# create.basic.constraints - create basic constraints +#' @export +############################################################################### +create.basic.constraints <- function( + n, + const.lb = 0, + const.ub = 1, + const.sum = 1 +) +{ + if(len(const.lb) == 1) const.lb = rep(const.lb, n) + if(len(const.ub) == 1) const.ub = rep(const.ub, n) + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = const.lb, ub = const.ub) + constraints = add.constraints(diag(n), type='>=', b=const.lb, constraints) + constraints = add.constraints(diag(n), type='<=', b=const.ub, constraints) + + # SUM x.i = 1 + if(!is.na(const.sum)) + constraints = add.constraints(rep(1, n), type = '=', b=const.sum, constraints) + + return(constraints) +} + + +############################################################################### +# create.basic.constraints - create basic constraints +#' @export +############################################################################### +merge.constraints <- function(constraints1, constraints2) { + if(constraints1$n != constraints2$n) stop('merge.constraints: both constraints must be based on same number of assets') + + if(constraints2$meq > 0) { + constraints1$A = cbind( constraints2$A[,1:constraints2$meq], constraints1$A, constraints2$A[,-c(1:constraints2$meq)] ) + constraints1$b = c( constraints2$b[1:constraints2$meq], constraints1$b, constraints2$b[-c(1:constraints2$meq)] ) + constraints1$meq = constraints1$meq + constraints2$meq + } else { + constraints1$A = cbind( constraints1$A, constraints2$A) + constraints1$b = c(constraints1$b, constraints2$b) + } + + constraints1$lb = pmax(constraints1$lb, constraints2$lb, na.rm=T) + constraints1$ub = pmin(constraints1$ub, constraints2$ub, na.rm=T) + + constraints1 +} + + + +############################################################################### +# General interface to Finding portfolio that Minimizes Given Risk Measure +#' @export +############################################################################### +min.portfolio <- function +( + ia, # input assumptions + constraints, # constraints + add.constraint.fn, + min.risk.fn +) +{ + optimize.portfolio(ia, constraints, add.constraint.fn, min.risk.fn) +} + +#' @export +optimize.portfolio <- function +( + ia, # input assumptions + constraints, # constraints + add.constraint.fn, + min.risk.fn, + direction = 'min', + full.solution = F +) +{ + # load / check required packages + load.packages('quadprog,corpcor,lpSolve,kernlab') + + + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # objective is stored as a last constraint + constraints = match.fun(add.constraint.fn)(ia, 0, '>=', constraints) + + f.obj = constraints$A[, ncol(constraints$A)] + constraints = delete.constraints( ncol(constraints$A), constraints) + + # setup constraints + f.con = constraints$A + f.dir = c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq)) + f.rhs = constraints$b + + # find optimal solution + x = NA + + binary.vec = 0 + if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index + + sol = try(solve.LP.bounds(direction, f.obj, t(f.con), f.dir, f.rhs, + lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec, + default.lb = -100), TRUE) + + if(!inherits(sol, 'try-error')) { + x = sol$solution[1:n] + + #cat('sol.objval =', sol$objval, '\n') + + # to check + if( F ) { + f.obj %*% sol$solution - match.fun(min.risk.fn)(t(x), ia) + } + } + + if( full.solution ) x = sol + return( x ) +} + +############################################################################### +# Rdonlp2 only works with R version before 2.9 +# Rdonlp2 is not avilable for latest version of R +# for more help please visit http://arumat.net/Rdonlp2/ +# +# Conditions of use: +# 1. donlp2 is under the exclusive copyright of P. Spellucci +# (e-mail:spellucci@mathematik.tu-darmstadt.de) +# "donlp2" is a reserved name +# 2. donlp2 and its constituent parts come with no warranty, whether ex- +# pressed or implied, that it is free of errors or suitable for any +# specific purpose. +# It must not be used to solve any problem, whose incorrect solution +# could result in injury to a person , institution or property. +# It is at the users own risk to use donlp2 or parts of it and the +# author disclaims all liability for such use. +# 3. donlp2 is distributed "as is". In particular, no maintenance, support +# or trouble-shooting or subsequent upgrade is implied. +# 4. The use of donlp2 must be acknowledged, in any publication which contains +# results obtained with it or parts of it. Citation of the authors name +# and netlib-source is suitable. +# 5. The free use of donlp2 and parts of it is restricted for research purposes +# commercial uses require permission and licensing from P. Spellucci. +#' @export +############################################################################### +optimize.portfolio.nlp <- function +( + ia, # input assumptions + constraints, # constraints + fn, + nl.constraints = NULL, # Non-Linear constraints + direction = 'min', + full.solution = F +) +{ + # Rdonlp2 only works with R version before 2.9 + load.packages('Rdonlp2', repos ='http://R-Forge.R-project.org') + + # fnscale(1) - set -1 for maximization instead of minimization. + if( direction == 'min' ) fnscale = 1 else fnscale = -1 + + # control structure: as.numeric( sessionInfo()$R.version$minor ) < 9 + cntl = donlp2Control() + cntl$silent = T + cntl$fnscale = fnscale + cntl$iterma =10000 + cntl$nstep = 100 + cntl$epsx = 1e-10 + + # lower/upper bounds + par.l = constraints$lb + par.u = constraints$ub + + # intial guess + p = rep(1, nrow(constraints$A)) + if(!is.null(constraints$x0)) { + # if no NA's in constraints$x0 + if( sum(is.na(constraints$x0)) == 0) p = constraints$x0 + } + + # linear constraints + A = t(constraints$A) + lin.l = constraints$b + lin.u = constraints$b + lin.u[ -c(1:constraints$meq) ] = +Inf + + # find optimal solution + x = NA + + if( !is.null(nl.constraints) ) { + sol = donlp2(p, fn, + par.lower=par.l, par.upper=par.u, + A=A, lin.u=lin.u, lin.l=lin.l, + control=cntl, + nlin=nl.constraints$constraints, + nlin.upper=nl.constraints$upper, nlin.lower=nl.constraints$lower + ) + } else { + sol = donlp2(p, fn, + par.lower=par.l, par.upper=par.u, + A=A, lin.u=lin.u, lin.l=lin.l, + control=cntl) + } + + if(!inherits(sol, 'try-error')) { + x = sol$par + } + + if( full.solution ) x = sol + return( x ) +} + + + + + +############################################################################### +# Maximum Loss +# page 34, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# The Maximum Loss (MaxLoss) function has the form +# w +# such that +# - [ SUM r.ij * x.i ] < w, for each j = 1,...,T +#' @export +############################################################################### +add.constraint.maxloss <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add w + constraints = add.variables(1, constraints) + + # - [ SUM r.ij * x.i ] < w, for each j = 1,...,T + a = rbind( matrix(0, n, nt), 1) + a[1 : n0, ] = t(ia$hist.returns) + constraints = add.constraints(a, rep(0, nt), '>=', constraints) + + # objective : maximum loss, w + constraints = add.constraints(c(rep(0, n), 1), value, type[1], constraints) + + return( constraints ) +} + +#' @export +portfolio.maxloss <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + return( -apply(portfolio.returns, 1, min) ) +} + +#' @export +min.maxloss.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.maxloss, portfolio.maxloss) + +} + + + + + + + + + + +############################################################################### +# Mean-Absolute Deviation (MAD) +# page 33, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# The Mean-Absolute Deviation (MAD) function has the form +# 1/T * [ SUM (u+.j + u-.j) ] +# such that +# [ SUM r.ij * x.i ] - 1/T * [ SUM [ SUM r.ij * x.i ] ] = u+.j - u-.j , for each j = 1,...,T +# u+.j, u-.j >= 0, for each j = 1,...,T +#' @export +############################################################################### +add.constraint.mad <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add u+.j, u-.j + constraints = add.variables(2 * nt, constraints, lb = 0) + + # [ SUM r.ij * x.i ] - 1/T * [ SUM [ SUM r.ij * x.i ] ] = u+.j - u-.j , for each j = 1,...,T + a = rbind( matrix(0, n, nt), -diag(nt), diag(nt)) + a[1 : n0, ] = t(ia$hist.returns) - repmat(colMeans(ia$hist.returns), 1, nt) + constraints = add.constraints(a, rep(0, nt), '=', constraints) + + # objective : Mean-Absolute Deviation (MAD) + # 1/T * [ SUM (u+.j + u-.j) ] + constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, 2 * nt)), value, type[1], constraints) + + return( constraints ) +} + +#' @export +portfolio.mad <- function +( + weight, # weight + ia # input assumptions +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + return( apply(portfolio.returns, 1, function(x) mean(abs(x - mean(x))) ) ) +} + +#' @export +min.mad.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.mad, portfolio.mad) +} + + + + + + + + + + +############################################################################### +# Conditional Value at Risk (CVaR) +# page 30-32, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# The Conditional Value at Risk (CVaR) function has the form +# E + 1/(1-a) * 1/T * [ SUM w.j ] +# -E - [ SUM r.ij * x.i ] < w.j, for each j = 1,...,T +# w.j >= 0, for each j = 1,...,T +#' @export +############################################################################### +add.constraint.cvar <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add w.j, E + constraints = add.variables(nt + 1, constraints, lb = c(rep(0,nt),-Inf)) + + # -E - [ SUM r.ij * x.i ] < w.j, for each j = 1,...,T + a = rbind( matrix(0, n, nt), diag(nt), 1) + a[1 : n0, ] = t(ia$hist.returns) + constraints = add.constraints(a, rep(0, nt), '>=', constraints) + + # objective : Conditional Value at Risk (CVaR) + # E + 1/(1-a) * 1/T * [ SUM w.j ] + constraints = add.constraints(c(rep(0, n), (1/(1-alpha))* (1/nt) * rep(1, nt), 1), value, type[1], constraints) + + return( constraints ) +} + +# average of portfolio returns that are below portfolio's VaR +#' @export +portfolio.cvar <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + portfolio.returns = weight %*% t(ia$hist.returns) + return( apply(portfolio.returns, 1, function(x) -compute.cvar(x, 1-alpha) ) ) +} + +#' @export +min.cvar.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.cvar, portfolio.cvar) +} + +############################################################################### +# portfolio.var +#' @export +############################################################################### +portfolio.var <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + portfolio.returns = weight %*% t(ia$hist.returns) + return( apply(portfolio.returns, 1, function(x) -compute.var(x, 1-alpha) ) ) +} + +############################################################################### +# compute.var/cvar - What is the most I can with a 95% level of confidence expect to lose +# http://www.investopedia.com/articles/04/092904.asp +############################################################################### +#compute.var <- function(x, alpha){ return( -quantile(x, probs = (1-alpha)) )} +#compute.cvar <- function(x, alpha) { return( -mean(x[ x < quantile(x, probs = (1-alpha)) ]) )} + + + + + + + + + + +############################################################################### +# Conditional Drawdown at Risk (CDaR) +# page 33, Comparative Analysis of Linear Portfolio Rebalancing Strategies by Krokhmal, Uryasev, Zrazhevsky +# page 15-20, Portfolio Optimization Using Conditional Value-At-Risk and Conditional Drawdown-At-Risk by Enn Kuutan +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# The Conditional Drawdown at Risk (CDaR) function has the form +# E + 1/(1-a) * 1/T * [ SUM w.j ] +# u.j - [ SUM [ SUM r.ij ] * x.i ] - E < w.j, for each j = 1,...,T +# [ SUM [ SUM r.ij ] * x.i ] < u.j, for each j = 1,...,T +# u.j-1 < u.j, for each j = 1,...,T - portfolio high water mark +# w.j >= 0, for each j = 1,...,T +# +# Please note that MaxDD and AvgDD are special cases of CDaR i.e. +# MaxDD is CDaR with alpha = 1 +# AvgDD is CDaR with alpha = 0 +# DRAWDOWN MEASURE IN PORTFOLIO OPTIMIZATION, ALEXEI CHEKHLOV, STANISLAV URYASEV, MICHAEL ZABARANKIN +# Proposition 3.4, page 25(13) +# http://www.math.columbia.edu/~chekhlov/IJTheoreticalAppliedFinance.8.1.2005.pdf +# +#' @export +############################################################################### +add.constraint.cdar <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add w.j, E, u.j + constraints = add.variables(2*nt + 1, constraints, lb = c(rep(0,nt), rep(-Inf,nt+1))) + + # u.j - [ SUM [ SUM r.ij ] * x.i ] - E < w.j, for each j = 1,...,T + a = rbind( matrix(0, n, nt), diag(nt), 1, -diag(nt)) + a[1 : n0, ] = t(apply( t(ia$hist.returns), 1, cumsum)) + constraints = add.constraints(a, rep(0, nt), '>=', constraints) + + # [ SUM [ SUM r.ij ] * x.i ] < u.j, for each j = 1,...,T + a = rbind( matrix(0, n, nt), 0*diag(nt), 0, diag(nt)) + a[1 : n0, ] = -t(apply( t(ia$hist.returns), 1, cumsum)) + constraints = add.constraints(a, rep(0, nt), '>=', constraints) + + # u.j-1 < u.j, for each j = 1,...,T - portfolio high water mark is increasing + temp = diag(nt); + temp[-nt,-1]=-diag((nt-1)) + diag(temp) = 1 + a = rbind( matrix(0, n, nt), 0*diag(nt), 0, temp) + a = a[,-1] + constraints = add.constraints(a, rep(0, (nt-1)), '>=', constraints) + + # objective : Conditional Drawdown at Risk (CDaR) + # E + 1/(1-a) * 1/T * [ SUM w.j ] + constraints = add.constraints(c(rep(0, n), (1/(1-alpha))* (1/nt) * rep(1, nt), 1, rep(0, nt)), value, type[1], constraints) + + return( constraints ) +} + +#' @export +portfolio.cdar <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + portfolio.returns = weight %*% t(ia$hist.returns) + # use CVaR formula + return( apply(portfolio.returns, 1, + function(x) { + x = cumsum(x) + x = x - cummax(x) + -compute.cvar(x, 1-alpha) + } + )) + +} + +#' @export +min.cdar.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.cdar, portfolio.cdar) +} + +############################################################################### +# Compute CDaR based on data +#' @export +############################################################################### +portfolio.cdar.real <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + if(is.null(ia$parameters.alpha)) alpha = 0.95 else alpha = ia$parameters.alpha + + portfolio.returns = weight %*% t(ia$hist.returns) + out = rep(0, nrow(weight)) + + for( i in 1:nrow(weight) ) { + portfolio.equity = cumprod(1 + portfolio.returns[i,]) + x = compute.drawdowns(portfolio.equity) + + # use CVaR formula + out[i] = compute.cvar(x, alpha) + } + + return( out ) +} + +############################################################################### +# Compute Portfolio Drawdowns +#' @export +############################################################################### +compute.drawdowns <- function( portfolio.equity, make.plot = FALSE ) +{ + temp = portfolio.equity / cummax(portfolio.equity) - 1 + temp = c(temp, 0) + + drawdown.start = which( temp == 0 & mlag(temp, -1) != 0 ) + drawdown.end = which( temp == 0 & mlag(temp, 1) != 0 ) + + if(make.plot) { + plot((1:len(temp)), temp, type='l') + points((1:len(temp))[drawdown.start] , temp[drawdown.start], col='red') + points((1:len(temp))[drawdown.end] , temp[drawdown.end], col='blue') + } + + return( apply(cbind(drawdown.start, drawdown.end), 1, + function(x){ min(temp[ x[1]:x[2] ], na.rm=T)} ) + ) +} + + + + + + + + + + +############################################################################### +# Find portfolio that Minimizes Average Correlation +# Rdonlp2 only works with R version before 2.9 +# Rdonlp2 is not avilable for latest version of R +# for more help please visit http://arumat.net/Rdonlp2/ +# +# Conditions of use: +# 1. donlp2 is under the exclusive copyright of P. Spellucci +# (e-mail:spellucci@mathematik.tu-darmstadt.de) +# "donlp2" is a reserved name +# 2. donlp2 and its constituent parts come with no warranty, whether ex- +# pressed or implied, that it is free of errors or suitable for any +# specific purpose. +# It must not be used to solve any problem, whose incorrect solution +# could result in injury to a person , institution or property. +# It is at the users own risk to use donlp2 or parts of it and the +# author disclaims all liability for such use. +# 3. donlp2 is distributed "as is". In particular, no maintenance, support +# or trouble-shooting or subsequent upgrade is implied. +# 4. The use of donlp2 must be acknowledged, in any publication which contains +# results obtained with it or parts of it. Citation of the authors name +# and netlib-source is suitable. +# 5. The free use of donlp2 and parts of it is restricted for research purposes +# commercial uses require permission and licensing from P. Spellucci. +#' @export +############################################################################### +min.avgcor.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + cov = ia$cov[1:ia$n, 1:ia$n] + s = sqrt(diag(cov)) + + # avgcor + fn <- function(x){ + sd_x = sqrt( t(x) %*% cov %*% x ) + mean( ( x %*% cov ) / ( s * sd_x ) ) + } + + + x = optimize.portfolio.nlp(ia, constraints, fn) + + return( x ) +} + +#' @export +portfolio.avgcor <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + cov = ia$cov[1:ia$n, 1:ia$n] + s = sqrt(diag(cov)) + + + return( apply(weight, 1, function(x) { + sd_x = sqrt( t(x) %*% cov %*% x ) + mean( ( x %*% cov ) / ( s * sd_x ) ) + }) ) +} + +############################################################################### +# Use Correlation instead of Variance in Find Minimum Risk Portfolio +# (i.e. assume all assets have same risk = 1) +#' @export +############################################################################### +min.cor.insteadof.cov.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + if(is.null(ia$cov.temp)) ia$cov.temp = ia$cov + + sol = solve.QP.bounds(Dmat = ia$correlation, dvec = rep(0, nrow(ia$cov.temp)) , + Amat=constraints$A, bvec=constraints$b, constraints$meq, + lb = constraints$lb, ub = constraints$ub) + return( sol$solution ) +} + + +############################################################################### +# portfolio.avgcor - average correlation +#' @export +############################################################################### +portfolio.avgcor.real <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + + return( apply(portfolio.returns, 1, function(x) mean(cor(ia$hist.returns, x)) ) ) +} + + + + + + + + + + +############################################################################### +# Mean-Lower-Semi-Absolute Deviation (M-LSAD) +# page 6, Portfolio Optimization under Lower Partial Risk Measure by H. Konno, H. Waki and A. Yuuki +# http://www.kier.kyoto-u.ac.jp/fe-tokyo/workingpapers/AFE-KyotoU_WP01-e.html +# +# Let x.i , i= 1,...,n be weights of instruments in the portfolio. +# Let us suppose that j = 1,...,T scenarios of returns are available +# ( r.ij denotes return of i -th asset in the scenario j ). +# +# Mean-Lower-Semi-Absolute Deviation (M-LSAD) function has the form +# 1/T * [ SUM z.j ] +# such that +# - [ SUM (r.ij - r.i) * x.i ] <= z.j , for each j = 1,...,T +# z.j >= 0, for each j = 1,...,T +#' @export +############################################################################### +add.constraint.mad.downside <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add z.j + constraints = add.variables(nt, constraints, lb = 0) + + # - [ SUM (r.ij - r.i) * x.i ] <= z.j , for each j = 1,...,T + a = rbind( matrix(0, n, nt), diag(nt)) + if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) { + a[1 : n0, ] = t(ia$hist.returns) - repmat(colMeans(ia$hist.returns), 1, nt) + constraints = add.constraints(a, rep(0, nt), '>=', constraints) + } else { + # MAR - [ SUM r.ij * x.i ] <= z.j , for each j = 1,...,T + a[1 : n0, ] = t(ia$hist.returns) + constraints = add.constraints(a, rep(ia$parameters.mar, nt), '>=', constraints) + } + + + # objective : Mean-Lower-Semi-Absolute Deviation (M-LSAD) + # 1/T * [ SUM z.j ] + constraints = add.constraints(c(rep(0, n), (1/nt) * rep(1, nt)), value, type[1], constraints) + + return( constraints ) +} + +#' @export +portfolio.mad.downside <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + + if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) { + return( apply(portfolio.returns, 1, function(x) mean(pmax(mean(x) - x, 0)) ) ) + } else { + return( apply(portfolio.returns, 1, function(x) mean(pmax(ia$parameters.mar - x, 0)) ) ) + } +} + +#' @export +min.mad.downside.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.mad.downside, portfolio.mad.downside) +} + + + + + + + + + + +############################################################################### +# Mean-Lower Semi-Variance (MV) +# page 6, Portfolio Optimization under Lower Partial Risk Measure by H. Konno, H. Waki and A. Yuuki +# http://www.kier.kyoto-u.ac.jp/fe-tokyo/workingpapers/AFE-KyotoU_WP01-e.html +# +# Same logic as add.constraint.mad.downside, but minimize (z.j)^2 +# use quadratic solver +#' @export +############################################################################### +portfolio.risk.downside <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + + if(is.null(ia$parameters.mar) || is.na(ia$parameters.mar)) { + return( apply(portfolio.returns, 1, function(x) sqrt(mean(pmax(mean(x) - x, 0)^2)) ) ) + } else { + return( apply(portfolio.returns, 1, function(x) sqrt(mean(pmax(ia$parameters.mar - x, 0)^2)) ) ) + } +} + +#' @export +min.risk.downside.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # objective is stored as a last constraint + constraints = add.constraint.mad.downside(ia, 0, '>=', constraints) + + f.obj = constraints$A[, ncol(constraints$A)] + constraints = delete.constraints( ncol(constraints$A), constraints) + + # setup Dmat + Dmat = diag( len(f.obj) ) + diag(Dmat) = f.obj + if(!is.positive.definite(Dmat)) { + Dmat <- make.positive.definite(Dmat) + } + + + # find optimal solution + x = NA + + binary.vec = 0 + if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index + + sol = try(solve.QP.bounds(Dmat = Dmat, dvec = rep(0, nrow(Dmat)) , + Amat=constraints$A, bvec=constraints$b, constraints$meq, + lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec),TRUE) + + + if(!inherits(sol, 'try-error')) { + x = sol$solution[1:n] + + + # to check + if( F ) { + sol$solution %*% Dmat %*% (sol$solution) - portfolio.risk.downside(t(x), ia)^2 + } + } + + return( x ) +} + + + + + + + + + +############################################################################### +# Gini mean difference +# The mean difference is also known as the absolute mean difference and the Gini mean difference +# http://en.wikipedia.org/wiki/Mean_difference +# +# The Generation of Mean Gini Efficient Sets by J. Okunev (1991) +# Can be made more efficient by solving for dual +#' @export +############################################################################### +add.constraint.gini <- function +( + ia, # input assumptions + value, # b value + type = c('=', '>=', '<='), # type of constraints + constraints # constraints structure +) +{ + n0 = ncol(ia$hist.returns) + n = nrow(constraints$A) + nt = nrow(ia$hist.returns) + + # adjust constraints, add a.long, a.short 2 * nt*(nt-1)/2 + constraints = add.variables(nt*(nt-1), constraints, lb=0) + + # [ SUM x.i * (r.ij - r.ik) ] - a.long.jk + a.short.jk = 0 + # for each j = 1,...,T , k>j + a = matrix(0, n0 + nt*(nt-1), nt*(nt-1)/2) + diag(a[(n0+1) : (n0 + nt*(nt-1)/2), ]) = -1 + diag(a[(n0+1+nt*(nt-1)/2) : (n0 + nt*(nt-1)), ]) = 1 + #a = rbind( matrix(0, n, nt*(nt-1)/2), -diag(nt*(nt-1)/2), diag(nt*(nt-1)/2)) + # a[1 : n0, ] = t(ia$hist.returns) + hist.returns = as.matrix(ia$hist.returns) + + i.start = 0 + for(t in 1:(nt-1)) { + index = (i.start+1) : (i.start + nt -t) + for(i in 1:n0) { + a[i, index] = ( hist.returns[t,i] - hist.returns[,i] ) [ (t+1) : nt ] + } + i.start = i.start + nt -t + + } + + constraints = add.constraints(a, 0, '=', constraints) + + # objective : maximum loss, w + constraints = add.constraints(c(rep(0, n), rep(1, nt*(nt-1))), value, type[1], constraints) + + return( constraints ) +} + +#' @export +min.gini.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + min.portfolio(ia, constraints, add.constraint.gini, portfolio.gini.coefficient) + +} + + +#' @export +portfolio.gini.coefficient <- function +( + weight, # weight + ia # input assumptions +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + + n = ncol(portfolio.returns) + + +#portfolio.returns = rnorm(100) +#n = len(portfolio.returns) +# +# http://en.wikipedia.org/wiki/Mean_difference +#sum(outer(portfolio.returns, portfolio.returns, function(x,y) abs(x-y))) / (n*(n-1)) +# +# unmht:///file.5/C:/Desktop/1save/blog_entries/ERC/Gini%20Coefficient%20--%20from%20Wolfram%20MathWorld.mht/ +#temp = sort(portfolio.returns, decreasing = F) +#2* sum( (2*(1:n) - n - 1) * temp ) / (n*(n-1) ) + + + + one.to.n = 1:n + out = weight[,1] * NA + out[] = apply( portfolio.returns, 1, function(x) { + temp = sort(x, decreasing = F) + sum( (2*one.to.n - n - 1) * temp ) + } ) + out = 2 * out /(n*(n-1)) + return(out) +} + + + + + + +############################################################################### +# Solve LP Portfolio Problem +#' @export +############################################################################### +lp.obj.portfolio <- function +( + ia, # input assumptions + constraints, # constraints + f.obj = c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)), + direction = 'min' +) +{ + x = NA + + binary.vec = 0 + if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index + + sol = try(solve.LP.bounds(direction, f.obj, + t(constraints$A), + c(rep('=', constraints$meq), rep('>=', len(constraints$b) - constraints$meq)), + constraints$b, lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec), TRUE) + + if(!inherits(sol, 'try-error')) { + x = sol$solution + } + + return( x ) +} + +############################################################################### +# Find Maximum Return Portfolio +############################################################################### +# maximize C x +# subject to A x <= B +#' @export +############################################################################### +max.return.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + lp.obj.portfolio(ia, constraints, direction = 'max') +} + +############################################################################### +# portfolio.return - weight * expected.return +#' @export +############################################################################### +portfolio.return <- function +( + weight, # weight + ia # input assumptions +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + weight = weight[, 1:ia$n, drop=F] + portfolio.return = weight %*% ia$expected.return + return( portfolio.return ) +} + +############################################################################### +# portfolio.geometric.return +#' @export +############################################################################### +portfolio.geometric.return <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + portfolio.returns = weight %*% t(ia$hist.returns) + return( apply(portfolio.returns, 1, function(x) (prod(1+x)^(1/len(x)))^ia$annual.factor - 1 ) ) +} + + +############################################################################### +# Find Maximum Geometric Return Portfolio +#' @export +############################################################################### +max.geometric.return.portfolio <- function +( + ia, # input assumptions + constraints, # constraints + min.risk, + max.risk +) +{ + # Geometric return + fn <- function(x){ + portfolio.returns = x %*% t(ia$hist.returns) + prod(1 + portfolio.returns) + } + + # Nonlinear constraints + nlcon1 <- function(x){ + sqrt(t(x) %*% ia$cov %*% x) + } + + nl.constraints = list() + nl.constraints$constraints = list(nlcon1) + nl.constraints$upper = c(max.risk) + nl.constraints$lower = c(min.risk) + + x = optimize.portfolio.nlp(ia, constraints, fn, nl.constraints, direction = 'max') + + return( x ) +} + +############################################################################### +# portfolio.unrebalanced.return +# http://www.effisols.com/mvoplus/sample1.htm +#' @export +############################################################################### +portfolio.unrebalanced.return <- function +( + weight, # weight + ia # input assumptions +) +{ + weight = weight[, 1:ia$n, drop=F] + + total.return = apply(1+ia$hist.returns,2,prod) + total.portfolio.return = weight %*% total.return / rowSums(weight) + total.portfolio.return = (total.portfolio.return^(1/nrow(ia$hist.returns)))^ia$annual.factor - 1 + return( total.portfolio.return ) +} + + + + + + + + + + +############################################################################### +# Functions to convert between Arithmetic and Geometric means +############################################################################### +# page 8, DIVERSIFICATION, REBALANCING, AND THE GEOMETRIC MEAN FRONTIER by W. Bernstein and D. Wilkinson (1997) +#' @export +############################################################################### +geom2aritm <- function(G, V, a, b) +{ + (2*G + a*V^2) / (1 - b*G + sqrt((1+b*G)^2 + 2*a*b*V^2)) +} + +#' @export +aritm2geom <- function(R, V, a, b) +{ + R - a*V^2 / (2*(1 + b*R)) +} + +############################################################################### +# page 14, A4, On the Relationship between Arithmetic and Geometric Returns by D. Mindlin +#' @export +############################################################################### +geom2aritm4 <- function(G, V) +{ + (1+G)*sqrt(1/2 + 1/2*sqrt(1 + 4*V^2/(1+G)^2)) - 1 +} + +#' @export +aritm2geom4 <- function(R, V) +{ + (1+R)/(sqrt(1 + V^2/(1+R)^2)) - 1 +} + + +############################################################################### +# Find Portfolio with Minimum Risk and given Target Return +#' @export +############################################################################### +target.return.portfolio.helper <- function +( + ia, # input assumptions + constraints, # constraints + target.return +) +{ + constraints.target = add.constraints(ia$expected.return, type='>=', b=target.return, constraints) + sol = try(min.var.portfolio(ia, constraints.target), silent = TRUE) + + if(inherits(sol, 'try-error')) + sol = max.return.portfolio(ia, constraints) + + sol +} + +#' @export +target.return.portfolio <- function +( + target.return, + annual.factor = 252 +) +{ + target.return = as.double(target.return[1]) + if(target.return > 1) target.return = target.return / 100 + target.return = target.return / annual.factor + + function + ( + ia, # input assumptions + constraints # constraints + ) + { + target.return.portfolio.helper(ia, constraints, target.return) + } +} + +############################################################################### +# Find Portfolio with Minimum Risk and given Target Risk +#' @export +############################################################################### +target.risk.portfolio.helper <- function +( + ia, # input assumptions + constraints, # constraints + target.risk, + silent = T, + min.w = NA, + max.w = NA +) +{ + if( is.na(max.w) ) max.w = max.return.portfolio(ia, constraints) + if( is.na(min.w) ) min.w = min.var.portfolio(ia, constraints) + + max.r = portfolio.return(max.w, ia) + min.r = portfolio.return(min.w, ia) + + max.s = portfolio.risk(max.w, ia) + min.s = portfolio.risk(min.w, ia) + + if( target.risk >= min.s & target.risk <= max.s ) { + # function to compute risk given return x + f <- function (x, ia, constraints, target.risk) { + portfolio.risk(target.return.portfolio.helper(ia, constraints, x), ia) - target.risk + } + + f.lower = min.s - target.risk + f.upper = max.s - target.risk + + sol = uniroot(f, c(min.r, max.r), f.lower=f.lower, f.upper=f.upper, tol = 0.0001, + ia=ia, constraints=constraints, target.risk=target.risk) + if(!silent) cat('Found solution in', sol$iter, 'itterations', '\n') + return( target.return.portfolio.helper(ia, constraints, sol$root) ) + } else if( target.risk < min.s ) { + return( min.w ) + } else { + return( max.w ) + } + + stop(paste('target.risk =', target.risk, 'is not possible, max risk =', max.s, ', min risk =', min.s)) +} + +#' @export +target.risk.portfolio <- function +( + target.risk, + annual.factor = 252 +) +{ + target.risk = as.double(target.risk[1]) + if(target.risk > 1) target.risk = target.risk / 100 + target.risk = target.risk / sqrt(annual.factor) + + function + ( + ia, # input assumptions + constraints # constraints + ) + { + target.risk.portfolio.helper(ia, constraints, target.risk) + } +} + + + +############################################################################### +# Find Minimum Risk Portfolio +############################################################################### +# solve.QP function from quadprog library +# min(-d^T w.i + 1/2 w.i^T D w.i) constraints A^T w.i >= b_0 +#' @export +############################################################################### +min.risk.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + x = NA + + binary.vec = 0 + if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index + + if(is.null(ia$cov.temp)) ia$cov.temp = ia$cov + + + sol = try(solve.QP.bounds(Dmat = ia$cov.temp, dvec = rep(0, nrow(ia$cov.temp)) , + Amat=constraints$A, bvec=constraints$b, constraints$meq, + lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec),TRUE) + + if(!inherits(sol, 'try-error')) { + if(binary.vec[1] != 0) cat(sol$counter,'QP calls made to solve problem with', len(constraints$binary.index), 'binary variables using Branch&Bound', '\n') + + x = sol$solution; + } + + return( x ) +} + +############################################################################### +# portfolio.risk - square root of portfolio volatility +#' @export +############################################################################### +portfolio.risk <- function +( + weight, # weight + ia # input assumptions +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + weight = weight[, 1:ia$n, drop=F] + cov = ia$cov[1:ia$n, 1:ia$n] + + return( apply(weight, 1, function(x) sqrt(t(x) %*% cov %*% x)) ) +} + + + + +############################################################################### +# Find Equal-Risk-Contribution (ERC) Portfolio +# +# Unproxying weight constraints by Pat Burns +# http://www.portfolioprobe.com/2011/04/13/unproxying-weight-constraints/ +# +# Analytical Solution for the Equal-Risk-Contribution Portfolio +# http://www.wilmott.com/messageview.cfm?catid=34&threadid=38497 +# +# Equally-weighted risk contributions: a new method to build risk balanced diversified portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008) +# http://www.thierry-roncalli.com/download/erc-slides.pdf +# +# On the property of equally-weighted risk contributions portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008) +# http://www.thierry-roncalli.com/download/erc.pdf +# +# Matlab code for Equal Risk Contribution Portfolio by Farid Moussaoui +# http://mfquant.net/erc_portfolio.html +#' @export +############################################################################### +find.erc.portfolio <- function +( + ia, # input assumptions + constraints # constraints +) +{ + cov = ia$cov[1:ia$n, 1:ia$n] + + # obj + fn <- function(x){ + risk.contribution = (x * (cov %*% x)) + sum( abs(risk.contribution - mean(risk.contribution)) ) + } + + x = optimize.portfolio.nlp(ia, constraints, fn) + + return( x ) +} + +#' @export +find.erc.portfolio.simple <- function +( + ia, # input assumptions + constraints # constraints +) +{ + cov = ia$cov[1:ia$n, 1:ia$n] + + # obj + fn <- function(x){ + # sum(x) = 1 + if (sum(x) == 0) x = x + 1e-2 + x = x / sum(x) + + risk.contribution = (x * (cov %*% x)) + var(as.double(risk.contribution)) + } + + + x0 = 1/sqrt(diag(cov)) + x0 = x0 / sum(x0) + + x = nlminb(start = x0, objective = fn, lower = constraints$lb, upper = constraints$ub) + + x$par = x$par / sum(x$par) + return(x$par) +} + + + +find.erc.portfolio.test <- function() { + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia.rebal() + n = ia$n + + + #-------------------------------------------------------------------------- + # Construct ERC Equal-Risk Portfolio + #-------------------------------------------------------------------------- + x0 = 1/sqrt(diag(ia$cov)) + temp = x0 / sum(x0) + rc.temp = portfolio.risk.contribution(temp, ia) + rc.temp = abs(as.vector(rc.temp)) + plot(rc.temp,ylim=c(0,0.4)) + + diff(range(rc.temp)) + sd(rc.temp) + + + + + #-------------------------------------------------------------------------- + # Create constraints + #-------------------------------------------------------------------------- + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + #-------------------------------------------------------------------------- + # Construct ERC Equal-Risk-Contribution Portfolio + #-------------------------------------------------------------------------- + temp = find.erc.portfolio(ia, constraints) + rc.temp = portfolio.risk.contribution(temp, ia) + rc.temp = abs(as.vector(rc.temp)) + plot(rc.temp,ylim=c(0,0.4)) + + diff(range(rc.temp)) + sd(rc.temp) + + + #-------------------------------------------------------------------------- + # Construct ERC Equal-Risk-Contribution Portfolio + #-------------------------------------------------------------------------- + temp = find.erc.portfolio.simple(ia, constraints) + temp = temp / sum(temp) + rc.temp = portfolio.risk.contribution(temp, ia) + rc.temp = abs(as.vector(rc.temp)) + plot(rc.temp,ylim=c(0,0.4)) + + diff(range(rc.temp)) + sd(rc.temp) + + #-------------------------------------------------------------------------- + # Construct ERC Equal-Risk-Contribution Portfolio + #-------------------------------------------------------------------------- + temp = equal.risk.contribution.portfolio(ia, constraints) + temp = temp / sum(temp) + rc.temp = portfolio.risk.contribution(temp, ia) + rc.temp = abs(as.vector(rc.temp)) + plot(rc.temp,ylim=c(0,0.4)) + + diff(range(rc.temp)) + sd(rc.temp) + +} + + +############################################################################### +# portfolio.risk.contribution - (w * V %*% w) / (w %*% V %*% w) +# Unproxying weight constraints by Pat Burns +# http://www.portfolioprobe.com/2011/04/13/unproxying-weight-constraints/ +#' @export +############################################################################### +portfolio.risk.contribution <- function +( + weight, # weight + ia # input assumptions +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + weight = weight[, 1:ia$n, drop=F] + cov = ia$cov[1:ia$n, 1:ia$n] + + out = weight + out[] = t(apply( weight, 1, function(x) (x * (cov %*% x)) / (t(x) %*% cov %*% x)[1] )) + return(out) +} + + + + + + + + + + + + +############################################################################### +# Create efficient frontier +#' @export +############################################################################### +portopt <- function +( + ia, # Input Assumptions + constraints = NULL, # Constraints + nportfolios = 50, # Number of portfolios + name = 'Risk', # Name + min.risk.fn = min.risk.portfolio, # Risk Measure + equally.spaced.risk = F # Add extra portfolios so that portfolios on efficient frontier + # are equally spaced on risk axis +) +{ + # load / check required packages + load.packages('quadprog,corpcor,lpSolve,kernlab') + + # set up constraints + if( is.null(constraints) ) { + constraints = new.constraints(rep(0, ia$n), 0, type = '>=') + } + + # set up solve.QP + ia$risk = iif(ia$risk == 0, 0.000001, ia$risk) + if( is.null(ia$cov) ) ia$cov = ia$correlation * (ia$risk %*% t(ia$risk)) + + # setup covariance matrix used in solve.QP + ia$cov.temp = ia$cov + + # check if there are dummy variables + n0 = ia$n + n = nrow(constraints$A) + + if( n != nrow(ia$cov.temp) ) { + temp = matrix(0, n, n) + temp[1:n0, 1:n0] = ia$cov.temp[1:n0, 1:n0] + ia$cov.temp = temp + } + + if(!is.positive.definite(ia$cov.temp, method = 'chol')) { + ia$cov.temp <- make.positive.definite(ia$cov.temp, 0.000000001) + } + + + + # set up output + if(nportfolios<2) nportfolios = 2 + out = list(weight = matrix(NA, nportfolios, nrow(constraints$A))) + colnames(out$weight) = rep('', ncol(out$weight)) + colnames(out$weight)[1:ia$n] = ia$symbols + + + # find maximum return portfolio + out$weight[nportfolios, ] = max.return.portfolio(ia, constraints) + + # find minimum risk portfolio + out$weight[1, ] = match.fun(min.risk.fn)(ia, constraints) + constraints$x0 = out$weight[1, ] + + if(nportfolios > 2) { + # find points on efficient frontier + out$return = portfolio.return(out$weight, ia) + target = seq(out$return[1], out$return[nportfolios], length.out = nportfolios) + + constraints = add.constraints(c(ia$expected.return, rep(0, nrow(constraints$A) - ia$n)), + target[1], type = '>=', constraints) + + for(i in 2:(nportfolios - 1) ) { + constraints$b[ len(constraints$b) ] = target[i] + out$weight[i, ] = match.fun(min.risk.fn)(ia, constraints) + constraints$x0 = out$weight[i, ] + +#cat(i, '\n') + + } + + if( equally.spaced.risk ) { + out$risk = portfolio.risk(out$weight, ia) + + temp = diff(out$risk) + index = which(temp >= median(temp) + mad(temp)) + + if( len(index) > 0 ) { + index = min(index) + + proper.spacing = ceiling((out$risk[nportfolios] - out$risk[index])/temp[(index-1)])-1 + nportfolios1 = proper.spacing + 2 + + if(nportfolios1 > 2) { + out$return = portfolio.return(out$weight, ia) + out$risk = portfolio.risk(out$weight, ia) + temp = spline(out$risk, out$return, n = nportfolios, method = 'natural') + + target = temp$y[ which(temp$y > out$return[index] & temp$y < out$return[nportfolios] & + temp$x > out$risk[index] & temp$x < out$risk[nportfolios])] + target = c(out$return[index], target, out$return[nportfolios]) + nportfolios1 = len(target) + + out1 = list(weight = matrix(NA, nportfolios1, nrow(constraints$A))) + out1$weight[1, ] = out$weight[index, ] + out1$weight[nportfolios1, ] = out$weight[nportfolios, ] + + constraints$x0 = out1$weight[1, ] + for(i in 2:(nportfolios1 - 1) ) { + constraints$b[ len(constraints$b) ] = target[i] + out1$weight[i, ] = match.fun(min.risk.fn)(ia, constraints) + constraints$x0 = out1$weight[i, ] + } + + out$weight = rbind(out$weight[-c(index:nportfolios),], out1$weight) + } + + + } + + } + } + + # remove empty solutions + rm.index = is.na(rowSums(out$weight)) + if(any(rm.index)) out$weight = out$weight[!rm.index,] + + # compute risk / return + out$return = portfolio.return(out$weight, ia) + out$risk = portfolio.risk(out$weight, ia) + out$name = name + + + return(out) +} + + + + + + +############################################################################### +# Visualize input assumptions +#' @export +############################################################################### +plot.ia <- function +( + ia, # input assumptions + layout = NULL # flag to idicate if layout is already set +) +{ + # create a table with summary statistics + if( is.null(layout) ) layout(matrix(1:2, nr=1)) + temp = cbind(ia$expected.return, ia$risk) + temp[] = plota.format(100 * temp[], 1, '', '%') + colnames(temp) = spl('Return,Risk') + plot.table(temp, 'Symbol') + + # visualize correlation matrix + temp = ia$correlation + temp[lower.tri(temp, TRUE)] = NA + temp = temp[-ia$n, -1] + temp[] = plota.format(100 * temp[], 1, '', '%') + plot.table(temp, highlight = TRUE, colorbar = TRUE) +} + +############################################################################### +# Plot efficient fontier(s) and transitopn map +#' @export +############################################################################### +plot.ef <- function +( + ia, # input assumption + efs, # efficient fontier(s) + portfolio.risk.fn = portfolio.risk, # risk measure + transition.map = TRUE, # flag to plot transitopn map + layout = NULL # flag to idicate if layout is already set +) +{ + # extract name of risk measure + risk.label = as.character(substitute(portfolio.risk.fn)) + + # prepare plot data + n = ia$n + x = match.fun(portfolio.risk.fn)(diag(n), ia) + y = ia$expected.return + + # prepare plot ranges + xlim = range(c(0, x, + max( sapply(efs, function(x) max(match.fun(portfolio.risk.fn)(x$weight,ia))) ) + ), na.rm = T) + + ylim = range(c(0, y, + min( sapply(efs, function(x) min(portfolio.return(x$weight,ia))) ), + max( sapply(efs, function(x) max(portfolio.return(x$weight,ia))) ) + ), na.rm = T) + + # convert x and y to percentages + x = 100 * x + y = 100 * y + xlim = 100 * xlim + ylim = 100 * ylim + + # plot + if( !transition.map ) layout = T + if( is.null(layout) ) layout(1:2) + + par(mar = c(4,3,2,1), cex = 0.8) + plot(x, y, xlim = xlim, ylim = ylim, + xlab='', ylab='', main=paste(risk.label, 'vs Return'), col='black') + mtext('Return', side = 2,line = 2, cex = par('cex')) + mtext(risk.label, side = 1,line = 2, cex = par('cex')) + grid(); + text(x, y, ia$symbols, col = 'blue', adj = c(1,1), cex = 0.8) + + # plot fontiers + for(i in len(efs):1) { + ef = efs[[ i ]] + + x = 100 * match.fun(portfolio.risk.fn)(ef$weight, ia) + y = 100 * ef$return + + lines(x, y, col=i) + } + plota.legend(sapply(efs, function(x) x$name), 1:len(efs)) + + + # Transition Map plot + if(transition.map) { + plot.transition.map(efs[[i]]$weight, x, risk.label, efs[[i]]$name) + } +} + +# Add portfolios to plot +#' @export +plot.add.portfolios = function(ia, portfolio.risk.fn = portfolio.risk, ...) { + portfolios = lst(...) + + col = plota.colors(portfolios) + + for(i in 1:len(portfolios)) + points(100 * portfolio.risk.fn(portfolios[[i]],ia), 100 * portfolio.return(portfolios[[i]],ia), pch=15, col=col[i]) + + plota.legend(names(portfolios), col, x='bottomright') +} + + +############################################################################### +# Plot Transition Map +#' @export +############################################################################### +plot.transitopn.map <- function(x,y,xlab = 'Risk',name = '',type=c('s','l')) { + plot.transition.map(x,y,xlab,name,type) +} + +#' @export +plot.transition.map <- function +( + y, # weights + x, # x data + xlab = 'Risk', # x label + name = '', # name + type=c('s','l'),# type + col = NA # colors + +) +{ + if( is.list(y) ) { + name = y$name + x = 100 * y$risk + y = y$weight + } + + y[is.na(y)] = 0 + + par(mar = c(4,3,2,1), cex = 0.8) + plota.stacked(x, y, xlab = xlab, main = paste('Transition Map for', name), + type=type[1], col=ifna(col, plota.colors(ncol(y))) ) +} + + + + + +############################################################################### +# Helper functions from the following paper: +# On the property of equally-weighted risk contributions portfolios by S. Maillard, +# T. Roncalli and J. Teiletche (2008), page 22 +# http://www.thierry-roncalli.com/download/erc.pdf +#' @export +############################################################################### +portfolio.turnover <- function +( + weight # weight +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + out = weight[,1] * NA + out[] = rowSums( abs(weight - mlag(weight)) ) / 2 + return(out) +} + +# Herfindahl Index of portfolio weights +# http://en.wikipedia.org/wiki/Herfindahl_index +#' @export +portfolio.concentration.herfindahl.index <- function +( + weight # weight +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + one.over.n = 1/ rowSums(!is.na(weight)) + out = weight[,1] * NA + out[] = (rowSums(weight^2, na.rm=T) - one.over.n) / (1 - one.over.n) + return(out) + + + one.over.n = 1/ncol(weight) + out = weight[,1] * NA + out[] = (rowSums(weight^2) - one.over.n) / (1 - one.over.n) + return(out) +} + +# Gini Coefficient of portfolio weights +# Gini is designed to work with positive numbers!!! +# http://en.wikipedia.org/wiki/Gini_coefficient +# http://en.wikipedia.org/wiki/Mean_difference +#' @export +portfolio.concentration.gini.coefficient <- function +( + weight # weight +) +{ + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + n = ncol(weight) + + + # The mean difference formula + # weight = rep(1/n,n) + # 1/2 * (sum(outer(weight, weight, function(x,y) abs(x-y))) / (n*(n-1))) / sum(abs(weight)/n) + + # Gini formula by Angus Deaton, more efficient + #(n+1)/(n-1) - 2 * sum(weight * rank(-weight)) /(n*(n-1)* mean(weight)) + #(n+1)/(n-1) - 2 * sum(abs(weight) * rank(-abs(weight))) /(n*(n-1)* sum(abs(weight)/n)) + + # same formula, but faster + #temp = sort(weight, decreasing = T) + #(n+1)/(n-1) - 2 * sum(temp * (1:n)) /(n*(n-1)* mean(temp)) + + one.to.n = 1:n + out = weight[,1] * NA + + + for(i in 1:nrow(weight)) { + x = coredata(weight[i,]) + index = !is.na(x) + n1 = sum(index) + if( n1 > 0 ) { + temp = sort(x[index], decreasing = T) + + # make sure all weights are positive + if(temp[n1] < 0) temp = temp - temp[n1] + + out[i] = (n1+1)/(n1-1) - 2 * sum(temp * one.to.n[1:n1]) /(n1*(n1-1)* sum(temp) / n1) + } + } + return(out) + + + out[] = apply( weight, 1, function(x) { + temp = sort(x, decreasing = T) + sum(temp * one.to.n) + } ) + out = (n+1)/(n-1) - 2 * out /(n*(n-1)* apply(weight, 1, mean)) + return(out) +} + diff --git a/R/aa.test.r b/R/aa.test.r new file mode 100644 index 0000000..e8e6e6b --- /dev/null +++ b/R/aa.test.r @@ -0,0 +1,2225 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Test cases for Asset Allocation Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Test AA functions, introduction +############################################################################### +aa.test <- function() +{ + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + + ia = aa.test.create.ia() + +png(filename = 'plot1.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # visualize input assumptions + plot.ia(ia) + +dev.off() + +png(filename = 'plot2.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + + # display each asset in the Risk - Return plot + layout(1) + par(mar = c(4,4,2,1), cex = 0.8) + x = 100 * ia$risk + y = 100 * ia$expected.return + + plot(x, y, xlim = range(c(0, x)), ylim = range(c(0, y)), + xlab='Risk', ylab='Return', main='Risk vs Return', col='black') + grid(); + text(x, y, ia$symbols, col = 'blue', adj = c(1,1), cex = 0.8) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier + ef = portopt(ia, constraints, 50, 'Efficient Frontier') + + + + +png(filename = 'plot3.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plot.ef(ia, list(ef)) + +dev.off() + + #-------------------------------------------------------------------------- + # Plot multiple Efficient Frontiers + #-------------------------------------------------------------------------- + + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.maxloss = portopt(ia, constraints, 50, 'Max Loss', min.maxloss.portfolio) + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad), portfolio.mad, F) + +dev.off() +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.transition.map(ef.risk) + plot.transition.map(ef.maxloss) + plot.transition.map(ef.mad) + +dev.off() + + +} + +############################################################################### +# Test AA functions, long/short 130:30 +############################################################################### +# Workingimplementation of 130:30 +# Asset Allocation and Risk Assessment with Gross Exposure Constraints for Vast Portfolios by J. Fan, Zhang J., Yu K. (2008) +# http://papers.ssrn.com/sol3/papers.cfm?abstract_id=1307423 +# +# Note 3 on Page 8 +# To get 130 long, 30 short +#-------------------------------------------- +# One alternative +# -v.i <= x.i <= v.i, v.i>0, SUM(v.i) = 1.6 +# +# Transfrom the covariance Q into +# | Q 0*Q | +# | 0*Q 0*Q | +#-------------------------------------------- +# Another alternative +# Split x into x.long and x.short, x_long and x_short >= 0 +# SUM(x.long) - SUM(x.short) = 1.6 +# +# Transfrom the covariance Q into +# | Q -Q | +# |-Q Q | +#-------------------------------------------- +# The problem is that 1.6 is not always inforced because +# minimum variance can be achived at a lower leverage +############################################################################### +aa.long.short.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # -0.5 <= x.i <= 0.8 + constraints = new.constraints(n, lb = -0.5, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + #-------------------------------------------------------------------------- + # Create 130:30 + # -v.i <= x.i <= v.i, v.i>0, SUM(v.i) = 1.6 + #-------------------------------------------------------------------------- + + # -0.5 <= x.i <= 0.8 + constraints = new.constraints(n, lb = -0.5, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # adjust prior constraints, add v.i + constraints = add.variables(n, constraints) + + # -v.i <= x.i <= v.i + # x.i + v.i >= 0 + constraints = add.constraints(rbind(diag(n), diag(n)), rep(0, n), type = '>=', constraints) + # x.i - v.i <= 0 + constraints = add.constraints(rbind(diag(n), -diag(n)), rep(0, n), type = '<=', constraints) + + # SUM(v.i) = 1.6 + constraints = add.constraints(c(rep(0, n), rep(1, n)), 1.6, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + # keep only portfolio weights + ef.risk$weight = ef.risk$weight[,(1:n)] + + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[,(1:n)] + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + #-------------------------------------------------------------------------- + # Create 130:30 + # Split x into x.long and x.short, x_long and x_short >= 0 + # SUM(x.long) - SUM(x.short) = 1.6 + #-------------------------------------------------------------------------- + ia.ls = aa.test.ia.add.short(ia) + + # x.long and x.short >= 0 + # x.long <= 0.8 + # x.short <= 0.5 + constraints = new.constraints(2*n, lb = 0, ub = c(rep(0.8,n),rep(0.5,n))) + + # SUM (x.long - x.short) = 1 + constraints = add.constraints(c(rep(1,n), -rep(1,n)), 1, type = '=', constraints) + + # SUM (x.long + x.short) = 1.6 + constraints = add.constraints(c(rep(1,n), rep(1,n)), 1.6, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia.ls, constraints, 50, 'Risk') + # compute x + ef.risk$weight = ef.risk$weight[, 1:n] - ef.risk$weight[, (n+1):(2*n)] + + ef.mad = portopt(ia.ls, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[, 1:n] - ef.mad$weight[, (n+1):(2*n)] + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + + #-------------------------------------------------------------------------- + # Create 200:100 + # Split x into x.long and x.short, x_long and x_short >= 0 + # SUM(x.long) - SUM(x.short) = 3 + # + # The problem is that 3 is not always inforced because + # minimum variance can be achived at a lower leverage + #-------------------------------------------------------------------------- + + # x.long and x.short >= 0 + # x.long <= 0.8 + # x.short <= 0.5 + constraints = new.constraints(2*n, lb = 0, ub = c(rep(0.8,n),rep(0.5,n))) + + # SUM (x.long - x.short) = 1 + constraints = add.constraints(c(rep(1,n), -rep(1,n)), 1, type = '=', constraints) + + # SUM (x.long + x.short) = 3 + constraints = add.constraints(c(rep(1,n), rep(1,n)), 3, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia.ls, constraints, 50, 'Risk') + # compute x + ef.risk$weight = ef.risk$weight[, 1:n] - ef.risk$weight[, (n+1):(2*n)] + + ef.mad = portopt(ia.ls, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[, 1:n] - ef.mad$weight[, (n+1):(2*n)] + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + #-------------------------------------------------------------------------- + # Create 200:100 using binary[0/1] variables and Branch and Bound algorithm + # Split x into x.long and x.short, x_long and x_short >= 0 + # SUM(x.long) - SUM(x.short) = 3 + # + # Solve using branch and bound: add a binary var b1:bn, xL < b, xS < (1-b) + #-------------------------------------------------------------------------- + + # x.long and x.short >= 0 + # x.long <= 0.8 + # x.short <= 0.5 + constraints = new.constraints(2*n, lb = 0, ub = c(rep(0.8,n),rep(0.5,n))) + + # SUM (x.long - x.short) = 1 + constraints = add.constraints(c(rep(1,n), -rep(1,n)), 1, type = '=', constraints) + + # SUM (x.long + x.short) = 3 + constraints = add.constraints(c(rep(1,n), rep(1,n)), 3, type = '=', constraints) + + # new add binary constraint + # adjust prior constraints: add b.i + constraints = add.variables(n, constraints) + + # index of binary variables b.i + constraints$binary.index = (2*n+1):(3*n) + + # binary variable b.i : x.long < b, x.short < (1 - b) + # x.long < b + constraints = add.constraints(rbind(diag(n), 0*diag(n), -diag(n)), rep(0, n), type = '<=', constraints) + + # x.short < (1 - b) + constraints = add.constraints(rbind(0*diag(n), diag(n), diag(n)), rep(1, n), type = '<=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia.ls, constraints, 50, 'Risk') + # compute x + ef.risk$weight = ef.risk$weight[, 1:n] - ef.risk$weight[, (n+1):(2*n)] + + ef.mad = portopt(ia.ls, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[, 1:n] - ef.mad$weight[, (n+1):(2*n)] + + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + +} + +############################################################################### +# Test AA functions, Cardinality Constraints +############################################################################### +# Minimum Invesment Constraint +# Pre-determined Number of Asstes Constraint +############################################################################### +aa.cardinality.test <- function() +{ + + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.plot.ef.summary.test <- function(ef) + { + layout(1:2) + par(mar = c(4,4,2,1), cex = 0.8) + y = iif(ef$weight > 0.000001, ef$weight, NA) + plot(as.vector(sort(100 * y)), pch=20, xaxt='n', ylim = c(0, 80), + xlab='', ylab='Weight', main='Portfolio Weights') + abline(h=0, col = 'red') + abline(h=10, col = 'red') + + plot(100* ef$risk, rowSums(!is.na(y), na.rm = T), pch=20, type='b', + xlab='Risk', ylab='Number of Assets', main='Number of Assets') + + } + + aa.plot.ef.summary.test(ef.risk) + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + + #-------------------------------------------------------------------------- + # Minimum Investment Constraint is 10% + # Add binary[0/1] variables + # 0.1 * b <= x.i <= 0.8 * b + #-------------------------------------------------------------------------- + + # SUM x.i = 1 + constraints = new.constraints(n,rep(1, n), 1, type = '=') + + # new add binary constraint + # adjust prior constraints: add b.i + constraints = add.variables(n, constraints) + + # index of binary variables b.i + constraints$binary.index = (n+1):(2*n) + + # 0.1 * b <= x.i <= 0.8 * b + # x.i >= 0.1 * b + constraints = add.constraints(rbind(diag(n), -0.1 * diag(n)), rep(0, n), type = '>=', constraints) + + # x.i <= 0.8 * b + constraints = add.constraints(rbind(diag(n), -0.8 * diag(n)), rep(0, n), type = '<=', constraints) + + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.risk$weight = ef.risk$weight[, 1:n] + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[, 1:n] + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.plot.ef.summary.test(ef.risk) + +dev.off() +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + + + #-------------------------------------------------------------------------- + # Limit number of assets to 3 + # Add binary[0/1] variables + # 0.00001 * b <= x.i <= 0.8 * b + # SUM b.i = 3 + #-------------------------------------------------------------------------- + + # SUM x.i = 1 + constraints = new.constraints(n, rep(1, n), 1, type = '=') + + # new add binary constraint + # adjust prior constraints: add b.i + constraints = add.variables(n, constraints) + + # index of binary variables b.i + constraints$binary.index = (n+1):(2*n) + + # 0.00001 * b <= x.i <= 0.8 * b + # x.i >= 0.00001 * b + constraints = add.constraints(rbind(diag(n), -0.00001 * diag(n)), rep(0, n), type = '>=', constraints) + + # x.i <= 0.8 * b + constraints = add.constraints(rbind(diag(n), -0.8 * diag(n)), rep(0, n), type = '<=', constraints) + + # SUM b = 3 + constraints = add.constraints(c(rep(0,n), rep(1,n)), 3, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.risk$weight = ef.risk$weight[, 1:n] + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad$weight = ef.mad$weight[, 1:n] + + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.plot.ef.summary.test(ef.risk) + +dev.off() +png(filename = 'plot6.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.mad) + +dev.off() + +} + + +############################################################################### +# Test AA functions, Average Correlation +# Forecast-Free Algorithms: A New Benchmark For Tactical Strategies +# http://cssanalytics.wordpress.com/2011/08/09/forecast-free-algorithms-a-new-benchmark-for-tactical-strategies/ +# +# Follow up FAQ: Forecast-Free Algorithms and Minimum Correlation Algorithm +# http://cssanalytics.wordpress.com/2011/08/15/follow-up-faq-forecast-free-algorithms-and-minimum-correlation-algorithm/ +############################################################################### +aa.avg.cor.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.cor.insteadof.cov = portopt(ia, constraints, 50, 'Cor instead of Cov', min.cor.insteadof.cov.portfolio) + ef.avgcor = portopt(ia, constraints, 50, 'AvgCor', min.avgcor.portfolio) + + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(1:2) + plot.ef(ia, list(ef.risk, ef.avgcor, ef.cor.insteadof.cov), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.avgcor, ef.cor.insteadof.cov), portfolio.avgcor, F) + +dev.off() +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.transition.map(ef.risk) + plot.transition.map(ef.avgcor) + plot.transition.map(ef.cor.insteadof.cov) + +dev.off() +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # visualize input assumptions + plot.ia(ia) + +dev.off() + + + #-------------------------------------------------------------------------- + # Double check that NonLinear Optimization finds global maximums by + # creating random portfolios that satisfy constraints. + # Plot Average Correlation Efficient Frontier and random portfolios, check + # that all portfolios lie below the efficient frontier. + #-------------------------------------------------------------------------- + # Generate random portfolios + ef.random = list() + ef.random$name = 'Random' + ef.random$weight = randfixedsum(1000000, n, 1, 0, 0.8) + + ef.random$risk = portfolio.avgcor(ef.random$weight, ia) + ef.random$return = portfolio.return(ef.random$weight, ia) + + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot Average Correlation and random portfolios + layout(1) + plot(100*ef.random$risk, 100*ef.random$return, type='p', pch=20, + xlim = 100*range(0, ef.random$risk, ef.avgcor$risk), + ylim = 100*range(0, ef.random$return, ef.avgcor$return), + main = 'Average Correlation Efficient Frontier vs Random Portfolios', + xlab = 'portfolio.avgcor', + ylab = 'Return' + ) + lines(100*portfolio.avgcor(ef.avgcor$weight, ia), 100*ef.avgcor$return, type='l', lwd=2,col = 'red') + +dev.off() + + + +} + + + +############################################################################### +# Test AA functions, Equal-Risk-Contribution (ERC) Portfolio +# +# Unproxying weight constraints by Pat Burns +# http://www.portfolioprobe.com/2011/04/13/unproxying-weight-constraints/ +# +# Analytical Solution for the Equal-Risk-Contribution Portfolio +# http://www.wilmott.com/messageview.cfm?catid=34&threadid=38497 +# +# Equally-weighted risk contributions: a new method to build risk balanced diversified portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008) +# http://www.thierry-roncalli.com/download/erc-slides.pdf +# +# On the property of equally-weighted risk contributions portfolios by S. Maillard, T. Roncalli and J. Teiletche (2008) +# http://www.thierry-roncalli.com/download/erc.pdf +# +# Matlab code for Equal Risk Contribution Portfolio by Farid Moussaoui +# http://mfquant.net/erc_portfolio.html +############################################################################### +aa.erc.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier + ef.risk = portopt(ia, constraints, 50, 'Risk') + + # plot + layout( 1:3 ) + plot.ef(ia, list(ef.risk), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(portfolio.risk.contribution(ef.risk$weight, ia), + ef.risk$risk, name='Risk Contribution') + + #-------------------------------------------------------------------------- + # Look at some portfolios + #-------------------------------------------------------------------------- + # 1/n + x = rep(1/ia$n,ia$n) + round(100*portfolio.risk.contribution(x, ia),1) + + # construct ERC Equal-Risk-Contribution Portfolio + x = find.erc.portfolio(ia, constraints) + round(100*portfolio.risk.contribution(x, ia),1) + + #-------------------------------------------------------------------------- + # Replicate some examples from erc-slides.pdf + #-------------------------------------------------------------------------- + s = (c(1,2,3,4)/10) + cor = 0.5 + 0*diag(4) + diag(cor) = 1 + cov = cor * (s %*% t(s)) + + weight = rep(1/4,4) + weight = c(100,0,0,0)/100 + weight = c(48,24,16,12)/100 + + ia$n = 4 + ia$cov=cov + round(100*portfolio.risk(weight, ia),1) + round(100*portfolio.risk.contribution(weight, ia),1) + + + s = c(12,10,11,13,12)/100 + cor = 0.6 + 0*diag(5) + diag(cor) = 1 + cov = cor * (s %*% t(s)) + + weight = c(23.96,6.43,16.92,28.73,23.96)/100 + weight = c(19.2,23,20.8,17.7,19.2)/100 + + ia$n = 5 + ia$cov=cov + round(100*portfolio.risk(weight, ia),1) + round(100*portfolio.risk.contribution(weight, ia),1) +} + + +############################################################################### +# Test AA functions, Gini mean difference Efficient Frontier +# +# Gini mean difference +# The mean difference is also known as the absolute mean difference and the Gini mean difference +# http://en.wikipedia.org/wiki/Mean_difference +# +# The Generation of Mean Gini Efficient Sets by J. Okunev (1991) +# Can be made more efficient by solving for dual +############################################################################### +aa.gini.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia.rebal() + ia$risk = apply(coredata(ia$hist.returns),2,sd) + ia$correlation = cor(coredata(ia$hist.returns), use='complete.obs',method='pearson') + ia$cov = ia$correlation * (ia$risk %*% t(ia$risk)) + + + n = ia$n + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + + #x = min.gini.portfolio(ia, constraints) + #portfolio.gini.coefficient(x, ia) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.gini = portopt(ia, constraints, 50, 'GINI', min.gini.portfolio) + + + #-------------------------------------------------------------------------- + # Create Plots + #-------------------------------------------------------------------------- + +png(filename = 'plot1g.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.gini), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.gini), portfolio.gini.coefficient, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.gini) + +dev.off() + + + + #require(fBasics) + #col = seqPalette(n, 'Greys') + #plot.transition.map(ef.risk, col=col) + + + + + + ia = list() + ia$n = 3 + ia$hist.returns = matrix(0,3,3) + ia$hist.returns[1,] = c(10,9,6)/100 + ia$hist.returns[2,] = c(15,8,12)/100 + ia$hist.returns[3,] = c(12,7,15)/100 + +} + + + + + +############################################################################### +# Test AA functions, CVaR Efficient Frontier +############################################################################### +aa.cvar.test <- function() +{ + + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + +# Expected shortfall (CVaR) +# http://www.investopedia.com/articles/04/092904.asp +ia$parameters.alpha = 0.95 + + + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.maxloss = portopt(ia, constraints, 50, 'MaxLoss', min.maxloss.portfolio) + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.cvar = portopt(ia, constraints, 50, 'CVaR', min.cvar.portfolio) + ef.cdar = portopt(ia, constraints, 50, 'CDaR', min.cdar.portfolio) + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.cvar, ef.cdar), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.cvar, ef.cdar), portfolio.cvar, F) + plot.ef(ia, list(ef.risk, ef.cvar, ef.cdar), portfolio.cdar, F) + +dev.off() +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.transition.map(ef.risk) + plot.transition.map(ef.cvar) + plot.transition.map(ef.cdar) + +dev.off() + + return() + + + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad, ef.cvar, ef.cdar), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad, ef.cvar, ef.cdar), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad, ef.cvar, ef.cdar), portfolio.cvar, F) + plot.ef(ia, list(ef.risk, ef.maxloss, ef.mad, ef.cvar, ef.cdar), portfolio.cdar, F) + + + layout( matrix(1:4, nrow = 2) ) + plot.transition.map(ef.maxloss) + plot.transition.map(ef.mad) + plot.transition.map(ef.cvar) + plot.transition.map(ef.cdar) + + +} + +############################################################################### +# Test AA functions, Omega Efficient Frontier +############################################################################### +aa.omega.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # Omega - http://en.wikipedia.org/wiki/Omega_ratio + ia$parameters.omega = 13/100 + ia$parameters.omega = 12/100 + # convert annual to monthly + ia$parameters.omega = ia$parameters.omega / 12 + + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot Omega Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2, byrow=T) ) + + # weights + rownames(ef.risk$weight) = paste('Risk','weight',1:50,sep='_') + plot.omega(ef.risk$weight[c(1,10,40,50), ], ia) + + # assets + temp = diag(n) + rownames(temp) = ia$symbols + plot.omega(temp, ia) + + # portfolio + plot.ef(ia, list(ef.risk), portfolio.omega, T, T) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Efficient Frontier in Omega Ratio framework + #-------------------------------------------------------------------------- + + # Create maximum Omega Efficient Frontier + ef.omega = portopt.omega(ia, constraints, 50, 'Omega') + + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot Omega Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2, byrow=T) ) + + # weights + plot.omega(ef.risk$weight[c(1,10,40,50), ], ia) + + # weights + rownames(ef.omega$weight) = paste('Omega','weight',1:50,sep='_') + plot.omega(ef.omega$weight[c(1,10,40,50), ], ia) + + # portfolio + plot.ef(ia, list(ef.omega, ef.risk), portfolio.omega, T, T) + +dev.off() +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk,ef.omega), portfolio.risk, F) + plot.ef(ia, list(ef.risk,ef.omega), portfolio.omega, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.omega) + +dev.off() + +} + + +############################################################################### +# Test AA functions, Downside Risk +############################################################################### +aa.downside.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # Set target return (or Minimum Acceptable Returns (MAR)) + # and consider only returns that are less than the target + ia$parameters.mar = 0/100 + # convert annual to monthly + ia$parameters.mar = ia$parameters.mar / 12 + + + # create efficient frontier(s) + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.mad.downside = portopt(ia, constraints, 50, 'S-MAD', min.mad.downside.portfolio) + + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.risk.downside = portopt(ia, constraints, 50, 'S-Risk', min.risk.downside.portfolio) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.mad.downside, ef.mad), portfolio.mad, F) + plot.ef(ia, list(ef.mad.downside, ef.mad), portfolio.mad.downside, F) + + plot.transition.map(ef.mad) + plot.transition.map(ef.mad.downside) + +dev.off() +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.downside, ef.risk), portfolio.risk, F) + plot.ef(ia, list(ef.risk.downside, ef.risk), portfolio.risk.downside, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.downside) + +dev.off() +} + + +############################################################################### +# Test AA functions, Multiple Risk Measures Efficient Frontier +############################################################################### +aa.multiple.risk.measures.test <- function() +{ + # Following linear risk constraints are implemented + # add.constraint.maxloss + # add.constraint.mad + # add.constraint.cvar + # add.constraint.cdar + + + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia() + n = ia$n + + # 0 <= x.i <= 0.8 + constraints = new.constraints(n, lb = 0, ub = 0.8) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.maxloss = portopt(ia, constraints, 50, 'MaxLoss', min.maxloss.portfolio) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.maxloss), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.maxloss), portfolio.maxloss, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.maxloss) + +dev.off() + + #-------------------------------------------------------------------------- + # Add MaxLoss <= 12 constraint + #-------------------------------------------------------------------------- + + constraints = add.constraint.maxloss(ia, 12/100, '<=', constraints) + + ef.risk.maxloss = portopt(ia, constraints, 50, 'Risk+MaxLoss') + ef.risk.maxloss$weight = ef.risk.maxloss$weight[, 1:n] + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.maxloss, ef.risk, ef.maxloss), portfolio.risk, F) + plot.ef(ia, list(ef.risk.maxloss, ef.risk, ef.maxloss), portfolio.maxloss, F) + + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.maxloss) + +dev.off() + + return() + + + + #-------------------------------------------------------------------------- + # Other Examples + #-------------------------------------------------------------------------- + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # Alpha for CVaR and DVar + ia$parameters.alpha = 0.95 + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk') + ef.maxloss = portopt(ia, constraints, 50, 'MaxLoss', min.maxloss.portfolio) + ef.mad = portopt(ia, constraints, 50, 'MAD', min.mad.portfolio) + ef.cvar = portopt(ia, constraints, 50, 'CVaR', min.cvar.portfolio) + ef.cdar = portopt(ia, constraints, 50, 'CDaR', min.cdar.portfolio) + + + #-------------------------------------------------------------------------- + # Limit Max Loss + #-------------------------------------------------------------------------- + layout(1) + plot.ef(ia, list(ef.risk, ef.maxloss), portfolio.maxloss, F) + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + constraints = add.constraint.maxloss(ia, 15/100, '<=', constraints) + + ef.risk.new = portopt(ia, constraints, 50, 'Risk+') + ef.risk.new$weight = ef.risk.new$weight[, 1:n] + + # 3. compare new ef + layout(1:2) + plot.ef(ia, list(ef.risk), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk.new), portfolio.maxloss, F) + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.new, ef.risk,ef.maxloss), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.maxloss), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.new) + + #-------------------------------------------------------------------------- + # Limit MAD + #-------------------------------------------------------------------------- + layout(1) + plot.ef(ia, list(ef.risk, ef.mad), portfolio.mad, F) + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + constraints = add.constraint.mad(ia, 2.9/100, '<=', constraints) + + ef.risk.new = portopt(ia, constraints, 50, 'Risk+') + ef.risk.new$weight = ef.risk.new$weight[, 1:n] + + # 3. compare new ef + layout(1:2) + plot.ef(ia, list(ef.risk), portfolio.mad, F) + plot.ef(ia, list(ef.risk.new), portfolio.mad, F) + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.new, ef.risk,ef.mad), portfolio.mad, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.mad), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.new) + + #-------------------------------------------------------------------------- + # Limit CVaR + #-------------------------------------------------------------------------- + layout(1) + plot.ef(ia, list(ef.risk, ef.cvar), portfolio.cvar, F) + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + constraints = add.constraint.cvar(ia, 8/100, '<=', constraints) + + ef.risk.new = portopt(ia, constraints, 50, 'Risk+') + ef.risk.new$weight = ef.risk.new$weight[, 1:n] + + # 3. compare new ef + layout(1:2) + plot.ef(ia, list(ef.risk), portfolio.cvar, F) + plot.ef(ia, list(ef.risk.new), portfolio.cvar, F) + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.new, ef.risk,ef.cvar), portfolio.cvar, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.cvar), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.new) + + #-------------------------------------------------------------------------- + # Limit CVaR + #-------------------------------------------------------------------------- + layout(1) + plot.ef(ia, list(ef.risk, ef.cdar), portfolio.cdar, F) + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + constraints = add.constraint.cdar(ia, 15/100, '<=', constraints) + + ef.risk.new = portopt(ia, constraints, 50, 'Risk+') + ef.risk.new$weight = ef.risk.new$weight[, 1:n] + + # 3. compare new ef + layout(1:2) + plot.ef(ia, list(ef.risk), portfolio.cdar, F) + plot.ef(ia, list(ef.risk.new), portfolio.cdar, F) + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.new, ef.risk,ef.cdar), portfolio.cdar, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.cdar), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.new) + + + #-------------------------------------------------------------------------- + # Limit both Max Loss and CDaR + #-------------------------------------------------------------------------- + layout(1:2) + plot.ef(ia, list(ef.risk, ef.maxloss), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk, ef.cdar), portfolio.cdar, F) + + # constraints + constraints = new.constraints(n, lb = 0, ub = 0.8) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + constraints = add.constraint.maxloss(ia, 15/100, '<=', constraints) + constraints = add.constraint.cdar(ia, 15/100, '<=', constraints) + + ef.risk.new = portopt(ia, constraints, 50, 'Risk+') + ef.risk.new$weight = ef.risk.new$weight[, 1:n] + + # 3. compare new ef + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk.new), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk), portfolio.cdar, F) + plot.ef(ia, list(ef.risk.new), portfolio.cdar, F) + + + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.maxloss, ef.cdar), portfolio.maxloss, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.maxloss, ef.cdar), portfolio.cdar, F) + plot.ef(ia, list(ef.risk.new, ef.risk, ef.maxloss, ef.cdar), portfolio.risk, F) + + layout( matrix(1:4, nrow = 2) ) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.new) + plot.transition.map(ef.maxloss) + plot.transition.map(ef.cdar) + + +} + + +############################################################################### +# Test AA functions to control risk and return at the same time +############################################################################### +aa.control.risk.return.test <- function() +{ + #***************************************************************** + # Load data + #****************************************************************** + tickers = spl('EEM,EFA,GLD,IWM,IYR,QQQ,SPY,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2012:12::') + + #***************************************************************** + # Create Input Assumptions + #****************************************************************** + prices = data$prices + n=ncol(prices) + + # make sure that there is no na's in returns; othwerwise MAD will complain + ret = na.omit(prices/mlag(prices)-1) + ia = create.historical.ia(ret,252) + + #***************************************************************** + # Create Efficient Frontier + #****************************************************************** + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + constraints = add.constraints(diag(n), type='>=', b=0, constraints) + constraints = add.constraints(diag(n), type='<=', b=1, constraints) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier + ef = portopt(ia, constraints, 50, 'Efficient Frontier') + + # plot + risk.fn = portfolio.risk + plot.ef(ia, list(ef), risk.fn, transition.map=F) + + #***************************************************************** + # Plot example portfolios + #****************************************************************** + weight = min.var.portfolio(ia,constraints) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='red') + + weight = max.sharpe.portfolio()(ia,constraints) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='orange') + + weight = max.return.portfolio(ia,constraints) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='green') + + weight = risk.parity.portfolio()(ia,constraints) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='green') + + #***************************************************************** + # Find portfolio for given return + #****************************************************************** + target.return = 24/100 + constraints1 = add.constraints(ia$expected.return,type='>=', b=target.return, constraints) + weight = min.var.portfolio(ia,constraints1) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='orange') + + #***************************************************************** + # Find portfolio for given risk + #****************************************************************** + # map between risk and mad + # plot(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia)) + # approx(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia), 10/100, method='linear')$y + target.risk = 12/100 + target.mad = approx(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia), target.risk, method='linear')$y + + constraints1 = add.constraint.mad(ia, type='<=', value=target.mad, constraints) + weight = max.return.portfolio(ia,constraints1) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='orange') + + #***************************************************************** + # Find portfolio for given return and given risk + #****************************************************************** + target.return = 24/100 + target.risk = 12/100 + # map between risk and mad + # plot(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia)) + # approx(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia), 10/100, method='linear')$y + # this is not very precise, so extra adjusment might be necessary + target.mad = approx(portfolio.risk(ef$weight,ia), portfolio.mad(ef$weight,ia), target.risk, method='linear')$y + target.mad = target.mad # - 0.0002 + + constraints1 = add.constraints(ia$expected.return,type='>=', b=target.return, constraints) + constraints1 = add.constraint.mad(ia, type='>=', value=target.mad, constraints1) + + f.obj.return = c(ia$expected.return, rep(0, nrow(constraints1$A) - ia$n)) + f.obj.mad = constraints1$A[, ncol(constraints1$A)] + weight = lp.obj.portfolio(ia, constraints1, f.obj.return + f.obj.mad ) + points(100 * risk.fn(weight,ia), 100 * portfolio.return(weight,ia), pch=15, col='orange') + + + # diagnostics + 100 * portfolio.mad(weight, ia) + 100 * target.mad + 100 * portfolio.risk(weight, ia) + 100 * portfolio.return(weight, ia) +} + + + +############################################################################### +# Test AA functions: Solutions to Instability of mean-variance efficient portfolios +# Resampling and Shrinkage +############################################################################### +aa.solutions2instability.test <- function() +{ + #-------------------------------------------------------------------------- + # All methods provide: + # 1. Better Diversification + # 2. Efficient Portfolios are immune to small changes in input assumptions + #-------------------------------------------------------------------------- + + #-------------------------------------------------------------------------- + # Create Resampled Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia.rebal() + n = ia$n + + # -1 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Risk', equally.spaced.risk = T) + ef.risk.resampled = portopt.resampled(ia, constraints, 50, 'Risk Resampled', + nsamples = 200, sample.len= 10) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(c(1,1,2,3), nrow = 2, byrow=T) ) + plot.ef(ia, list(ef.risk, ef.risk.resampled), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.resampled) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Efficient Frontier using Ledoit-Wolf Covariance Shrinkage Estimator from tawny package + #-------------------------------------------------------------------------- + + # load / check required packages + load.packages('tawny') + + ia.original = ia + + ia$cov = tawny::cov.shrink(ia$hist.returns) + ef.risk.cov.shrink = portopt(ia, constraints, 50, 'Risk Ledoit-Wolf', equally.spaced.risk = T) + + ia = ia.original + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(c(1,1,2,3), nrow = 2, byrow=T) ) + plot.ef(ia, list(ef.risk, ef.risk.cov.shrink), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.cov.shrink) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Resampled Efficient Frontier(using Ledoit-Wolf Covariance Shrinkage Estimator) + # As described on page 8 of + # Resampling vs. Shrinkage for Benchmarked Managers by M. Wolf (2006) + #-------------------------------------------------------------------------- + + ef.risk.resampled.shrink = portopt.resampled(ia, constraints, 50, 'Risk Ledoit-Wolf+Resampled', + nsamples = 200, sample.len= 10, shrinkage.fn=tawny::cov.shrink) + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(c(1:4), nrow = 2, byrow=T) ) + plot.ef(ia, list(ef.risk, ef.risk.resampled, ef.risk.resampled.shrink), portfolio.risk, F) + plot.transition.map(ef.risk) + plot.transition.map(ef.risk.resampled) + plot.transition.map(ef.risk.resampled.shrink) + +dev.off() + +} + +############################################################################### +# Test AA functions, Arithmetic vs Geometric Efficient Frontier +############################################################################### +aa.arithmetic.geometric.test <- function() +{ + #-------------------------------------------------------------------------- + # Create Efficient Frontier + #-------------------------------------------------------------------------- + ia = aa.test.create.ia.rebal() + n = ia$n + + # -1 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Arithmetic', equally.spaced.risk = T) + + # compute historical geometrical returns + ef.risk.geometric = ef.risk + ef.risk.geometric$name = 'Geometric' + ef.risk.geometric$return = portfolio.geometric.return(ef.risk$weight, ia) + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + plot.ef(ia, list(ef.risk, ef.risk.geometric), portfolio.risk, T) + +dev.off() + + + + #-------------------------------------------------------------------------- + # Following DIVERSIFICATION, REBALANCING, AND THE GEOMETRIC MEAN FRONTIER by W. Bernstein and D. Wilkinson (1997) + # paper's notation : A(1,0) and A(1,1) page 8, 14 + #-------------------------------------------------------------------------- + # A(1,0) + ef.risk.A10 = ef.risk + ef.risk.A10$name = 'A(1;0)' + ef.risk.A10$return = apply( cbind(ef.risk$return, ef.risk$risk), 1, + function(x) aritm2geom(x[1], x[2], 1, 0) ) + # A(1,1) + ef.risk.A11 = ef.risk + ef.risk.A11$name = 'A(1;1)' + ef.risk.A11$return = apply( cbind(ef.risk$return, ef.risk$risk), 1, + function(x) aritm2geom(x[1], x[2], 1, 1) ) + + # G(1,0) + ia.G = ia + ia.G$expected.return = apply( cbind(ia$geometric.return, ia$risk), 1, + function(x) geom2aritm(x[1], x[2], 1, 0) ) + ef.risk.G10 = portopt(ia.G, constraints, 50, 'G(1;0)',equally.spaced.risk = T) + ef.risk.G10$return = apply( cbind(ef.risk.G10$return, ef.risk.G10$risk), 1, + function(x) aritm2geom(x[1], x[2], 1, 0) ) + # G(1,1) + ia.G$expected.return = apply( cbind(ia$geometric.return, ia$risk), 1, + function(x) geom2aritm(x[1], x[2], 1, 1) ) + ef.risk.G11 = portopt(ia.G, constraints, 50, 'G(1;1)',equally.spaced.risk = T) + ef.risk.G11$return = apply( cbind(ef.risk.G11$return, ef.risk.G11$risk), 1, + function(x) aritm2geom(x[1], x[2], 1, 1) ) + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.A10), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.A11), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.G10), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.G11), portfolio.risk, F) + +dev.off() + + #-------------------------------------------------------------------------- + # Use A4 method to convert between Arithmetic and Geometric means + #-------------------------------------------------------------------------- + # A + ef.risk.A4 = ef.risk + ef.risk.A4$name = 'Risk A4' + ef.risk.A4$return = apply( cbind(ef.risk$return, ef.risk$risk), 1, + function(x) aritm2geom4(x[1], x[2]) ) + + # G + ia.G = ia + ia.G$expected.return = apply( cbind(ia$geometric.return, ia$risk), 1, + function(x) geom2aritm4(x[1], x[2]) ) + ef.risk.G4 = portopt(ia.G, constraints, 50, 'Risk G4',equally.spaced.risk = T) + ef.risk.G4$return = apply( cbind(ef.risk.G4$return, ef.risk.G4$risk), 1, + function(x) aritm2geom4(x[1], x[2]) ) + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers + layout( matrix(1:2, nrow = 2) ) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.A4), portfolio.risk, F) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.G4), portfolio.risk, F) + +dev.off() + + #-------------------------------------------------------------------------- + # Create True Geometric Efficient Frontier + #-------------------------------------------------------------------------- + ef.true.geometric = ef.risk + ef.true.geometric$name = 'True Geometric' + constraints$x0 = ef.risk$weight[1,] + + for(i in 1:len(ef.risk$risk)) { + cat('i =', i, '\n') + ef.true.geometric$weight[i,] = max.geometric.return.portfolio(ia, constraints, ef.risk$risk[i], ef.risk$risk[i]) + constraints$x0 = ef.true.geometric$weight[i,] + } + + ef.true.geometric$return = portfolio.geometric.return(ef.true.geometric$weight, ia) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk.geometric, ef.risk, ef.true.geometric), portfolio.risk, T, T) + plot.ef(ia, list(ef.true.geometric, ef.risk, ef.risk.geometric), portfolio.risk, T, T) + +dev.off() + + #-------------------------------------------------------------------------- + # Double check that NonLinear Optimization finds global maximums by + # creating random portfolios that satisfy constraints. + # Plot True Geometric Efficient Frontier and random portfolios, check + # that all portfolios lie below the efficient frontier. + #-------------------------------------------------------------------------- + # Generate random portfolios + ef.random = list() + ef.random$name = 'Random' + ef.random$weight = randfixedsum(100000, n, 1, 0, 1) + + ef.random$risk = portfolio.risk(ef.random$weight, ia) + ef.random$return = portfolio.geometric.return(ef.random$weight, ia) + + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot True Geometric Efficient Frontier and random portfolios + layout(1) + plot(100*ef.random$risk, 100*ef.random$return, type='p', pch=20, + xlim = 100*range(ef.random$risk, ef.true.geometric$risk), + ylim = 100*range(ef.random$return, ef.true.geometric$return), + main = 'True Geometric Efficient Frontier vs Random Portfolios', + xlab = 'portfolio.risk', + ylab = 'Return' + ) + lines(100*ef.true.geometric$risk, 100*ef.true.geometric$return, type='l', lwd=2,col = 'red') + +dev.off() + + return() + + + # compute Unrebalanced returns + ef.risk.unrebalanced = ef.risk + ef.risk.unrebalanced$name = 'Unrebalanced' + ef.risk.unrebalanced$return = portfolio.unrebalanced.return(ef.risk$weight, ia) + plot.ef(ia, list(ef.risk, ef.risk.geometric, ef.risk.unrebalanced), portfolio.risk, T) + + + # To check that Geometric returns are not additive, feed geometric.returns to optimizer + # and observe resulting frontier below the True Geometric frontier + ia.G = ia + ia.G$expected.return = ia$geometric.return + ef.risk.geometric1 = portopt(ia.G, constraints, 50, 'Geometric1',equally.spaced.risk = T) + plot.ef(ia, list(ef.risk, ef.risk.geometric,ef.risk.geometric1), portfolio.risk, T) + + + # Find maximum Geometric Mean portfolio + x=max.geometric.return.portfolio(ia, constraints, 0, 1) + lines( portfolio.risk(t(x), ia), portfolio.geometric.return(t(x), ia), type='p', pch=20, col = 'blue') +} + +############################################################################### +# Test AA functions, Periodic table +# Construct Periodic table, like in Single Country Index Returns +# http://us.ishares.com/content/stream.jsp?url=/content/en_us/repository/resource/single_country_periodic_table.pdf&mimeType=application/pdf +############################################################################### +aa.periodic.table.test <- function() +{ + #-------------------------------------------------------------------------- + # Get Historical Data + #-------------------------------------------------------------------------- + # Country IA are based on monthly data + ia = aa.test.create.ia.country('1990::') + hist.returns = ia$hist.returns + + # convert returns to prices + hist.prices = cumprod(1 + hist.returns) + + # extract annual prices + period.ends = endpoints(hist.prices, 'years') + hist.prices = hist.prices[period.ends, ] + + # compute simple returns + hist.returns = na.omit( ROC(hist.prices, type = 'discrete') ) + hist.returns = hist.returns['2000::'] + + + #-------------------------------------------------------------------------- + # Create Periodic table + #-------------------------------------------------------------------------- + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plot.periodic.table1(hist.returns) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Periodic table, another version + #-------------------------------------------------------------------------- + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plot.periodic.table2(hist.returns) + +dev.off() + +} + +############################################################################### +# Test AA functions, Decompose Manager's Style +############################################################################### +#-------------------------------------------------------------------------- +# Style Summary Plot +#-------------------------------------------------------------------------- +aa.style.summary.plot <- function(name, style.weights, style.r.squared, window.len) +{ + layout( matrix(c(1,2,2,3,3,3), nrow=2, byrow=T) ) + + #Latest weights + weight = last(style.weights) + plot.table(t(round(100*weight))) + + # R2 + plota(100*style.r.squared, type='l', LeftMargin = 3, main=paste(window.len, 'months window Linear Least Squares Regression R^2')) + + # Style History + plot.transition.map(style.weights, index(style.weights), xlab='', name=name) +} + + +aa.style.test <- function() +{ + + #-------------------------------------------------------------------------- + # Get Historical Data + #-------------------------------------------------------------------------- + load.packages('quantmod') + + # load historical prices from Yahoo Finance + symbols = spl('FMILX,EWA,EWC,EWQ,EWG,EWJ,EWU,SPY') + symbols = spl('FWWFX,EWA,EWC,EWQ,EWG,EWJ,EWU,SPY') + + symbol.names = spl('Fund,Australia,Canada,France,Germany,Japan,UK,USA') + + getSymbols(symbols, from = '1980-01-01', auto.assign = TRUE) + + # align dates for all symbols & convert to frequency + hist.prices = merge(FWWFX,EWA,EWC,EWQ,EWG,EWJ,EWU,SPY) + period.ends = endpoints(hist.prices, 'months') + hist.prices = Ad(hist.prices)[period.ends, ] + + index(hist.prices) = as.Date(paste('1/', format(index(hist.prices), '%m/%Y'), sep=''), '%d/%m/%Y') + colnames(hist.prices) = symbol.names + + # remove any missing data + hist.prices = na.omit(hist.prices['1990::2010']) + + # compute simple returns + hist.returns = na.omit( ROC(hist.prices, type = 'discrete') ) + + #load 3-Month Treasury Bill from FRED + TB3M = quantmod::getSymbols('TB3MS', src='FRED', auto.assign = FALSE) + TB3M = processTBill(TB3M, timetomaturity = 1/4) + index(TB3M) = as.Date(paste('1/', format(index(TB3M), '%m/%Y'), sep=''), '%d/%m/%Y') + TB3M = ROC(Ad(TB3M), type = 'discrete') + colnames(TB3M) = 'Cash' + + hist.returns = na.omit( merge(hist.returns, TB3M) ) + + #-------------------------------------------------------------------------- + # Style Regression over 36 Month window, unconstrainted + #-------------------------------------------------------------------------- + # setup + ndates = nrow(hist.returns) + n = ncol(hist.returns)-1 + window.len = 36 + + style.weights = hist.returns[, -1] + style.weights[] = NA + style.r.squared = hist.returns[, 1] + style.r.squared[] = NA + + # main loop + for( i in window.len:ndates ) { + window.index = (i - window.len + 1) : i + + fit = lm.constraint( hist.returns[window.index, -1], hist.returns[window.index, 1] ) + style.weights[i,] = fit$coefficients + style.r.squared[i,] = fit$r.squared + } + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.style.summary.plot('Style UnConstrained', style.weights, style.r.squared, window.len) + +dev.off() + + + #-------------------------------------------------------------------------- + # Style Regression over Window, constrainted + #-------------------------------------------------------------------------- + # setup + load.packages('quadprog') + + style.weights[] = NA + style.r.squared[] = NA + + # Setup constraints + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # main loop + for( i in window.len:ndates ) { + window.index = (i - window.len + 1) : i + + fit = lm.constraint( hist.returns[window.index, -1], hist.returns[window.index, 1], constraints ) + style.weights[i,] = fit$coefficients + style.r.squared[i,] = fit$r.squared + } + + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.style.summary.plot('Style Constrained', style.weights, style.r.squared, window.len) + +dev.off() + + #-------------------------------------------------------------------------- + # Style Regression over Window, constrained + limits on allocation + #-------------------------------------------------------------------------- + # setup + style.weights[] = NA + style.r.squared[] = NA + + # Setup constraints + temp = rep(0, n) + names(temp) = colnames(hist.returns)[-1] + lb = temp + ub = temp + ub[] = 1 + + lb['Australia'] = 0 + ub['Australia'] = 5 + + lb['Canada'] = 0 + ub['Canada'] = 5 + + lb['France'] = 0 + ub['France'] = 15 + + lb['Germany'] = 0 + ub['Germany'] = 15 + + lb['Japan'] = 0 + ub['Japan'] = 15 + + lb['UK'] = 0 + ub['UK'] = 25 + + lb['USA'] = 30 + ub['USA'] = 100 + + lb['Cash'] = 2 + ub['Cash'] = 15 + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = lb/100, ub = ub/100) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # main loop + for( i in window.len:ndates ) { + window.index = (i - window.len + 1) : i + + fit = lm.constraint( hist.returns[window.index, -1], hist.returns[window.index, 1], constraints ) + style.weights[i,] = fit$coefficients + style.r.squared[i,] = fit$r.squared + } + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + aa.style.summary.plot('Style Constrained+Limits', style.weights, style.r.squared, window.len) + +dev.off() + + #-------------------------------------------------------------------------- + # Look at Manager's Tracking Error + #-------------------------------------------------------------------------- + manager.returns = hist.returns[, 1] + manager.returns = manager.returns[window.len:ndates,] + implied.returns = as.xts( rowSums(style.weights * hist.returns[, -1]), index(hist.returns)) + implied.returns = implied.returns[window.len:ndates,] + + tracking.error = manager.returns - implied.returns + alpha = 12*mean(tracking.error) + covar.alpha = 12* cov(tracking.error) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(1:2) + plota(cumprod(1+manager.returns), type='l') + plota.lines(cumprod(1+implied.returns), col='red') + plota.legend('Fund,Style', 'black,red') + + par(mar = c(4,4,2,1)) + hist(100*tracking.error, xlab='Monthly Tracking Error', + main= paste('Annualized Alpha =', round(100*alpha,1), 'Std Dev =', round(100*sqrt(covar.alpha),1)) + ) + +dev.off() + + + # Biulding Managers IA to create Efficient Frontier + # For error calculations we can either use most recent window or full sample + # error = managers.hist.returns - style %*% t(assets.hist.returns) + # managers.alpha = 12 * mean(error) + # managers.covar.alpha = 12 * cov(error) + # + # Long-term component + Short-term component + # managers.expected.return = style %*% t(assets.expected.return) + managers.alpha + # managers.cov = style %*% assets.covar %*% t(style) + managers.covar.alpha + +} + + +############################################################################### +# Test AA functions, Black-Litterman model +############################################################################### +aa.black.litterman.test <- function() +{ + #-------------------------------------------------------------------------- + # Visualize Market Capitalization History + #-------------------------------------------------------------------------- + + hist.caps = aa.test.hist.capitalization() + hist.caps.weight = hist.caps/rowSums(hist.caps) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plot.transition.map(hist.caps.weight, index(hist.caps.weight), xlab='', name='Market Capitalization Weight History') + +dev.off() +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(1:9, nrow = 3, byrow=T) ) + col = plota.colors(ncol(hist.caps)) + for(i in 1:ncol(hist.caps)) { + plota(hist.caps[,i], type='l', lwd=5, col=col[i], main=colnames(hist.caps)[i]) + } + +dev.off() + + + + #-------------------------------------------------------------------------- + # Compute Risk Aversion, prepare Black-Litterman input assumptions + #-------------------------------------------------------------------------- + ia = aa.test.create.ia.country() + + ir = get.fedfunds.rate() + period = join( format(range(index(ia$hist.returns)), '%Y:%m'), '::') + + # The implied risk aversion coefficient can be estimated by dividing + # the expected excess return by the variance of the portfolio + risk.aversion = bl.compute.risk.aversion( ia$hist.returns$USA, ir[period]/ia$annual.factor ) + risk.aversion = bl.compute.risk.aversion( ia$hist.returns$USA ) + + # the latest weights + cap.weight = last(hist.caps.weight) + + ia.bl = ia + ia.bl$expected.return = bl.compute.eqret( risk.aversion, ia$cov, cap.weight, last(ir[period]) ) + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout( matrix(c(1,1,2,3), nrow=2, byrow=T) ) + pie(coredata(cap.weight), paste(colnames(cap.weight), round(100*cap.weight), '%'), + main = paste('Country Market Capitalization Weights for', format(last(index(ia$hist.returns)),'%b %Y')) + , col=plota.colors(ia$n)) + + plot.ia(ia.bl, T) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Efficient Frontier(s) + #-------------------------------------------------------------------------- + n = ia$n + + # -1 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create efficient frontier(s) + ef.risk = portopt(ia, constraints, 50, 'Historical', equally.spaced.risk = T) + ef.risk.bl = portopt(ia.bl, constraints, 50, 'Black-Litterman', equally.spaced.risk = T) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia, list(ef.risk), portfolio.risk, T, T) + plot.ef(ia.bl, list(ef.risk.bl), portfolio.risk, T, T) + +dev.off() + + #-------------------------------------------------------------------------- + # Create Views + #-------------------------------------------------------------------------- + temp = matrix(rep(0, n), nrow = 1) + colnames(temp) = ia$symbols + + # Relative View + # Japan will outperform UK by 2% + temp[,'Japan'] = 1 + temp[,'UK'] = -1 + + pmat = temp + qmat = c(0.02) + + # Absolute View + # Australia's expected return is 12% + temp[] = 0 + temp[,'Australia'] = 1 + + pmat = rbind(pmat, temp) + qmat = c(qmat, 0.12) + + # compute posterior distribution parameters + post = bl.compute.posterior(ia.bl$expected.return, ia$cov, pmat, qmat, tau = 0.025 ) + #bl.compute.optimal(risk.aversion, post$expected.return, post$cov) + + # create Black-Litterman input assumptions with Views + ia.bl.view = ia.bl + ia.bl.view$expected.return = post$expected.return + ia.bl.view$cov = post$cov + ia.bl.view$risk = sqrt(diag(ia.bl.view$cov)) + + # create efficient frontier(s) + ef.risk.bl.view = portopt(ia.bl.view, constraints, 50, 'Black-Litterman + View(s)', equally.spaced.risk = T) + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot multiple Efficient Frontiers and Transition Maps + layout( matrix(1:4, nrow = 2) ) + plot.ef(ia.bl, list(ef.risk.bl), portfolio.risk, T, T) + plot.ef(ia.bl.view, list(ef.risk.bl.view), portfolio.risk, T, T) + +dev.off() + +} + + +############################################################################### +# Historical Country Capitalizations from worldbank.org +# Select Countries, Series. Type in "capitalization" and select Years +# http://databank.worldbank.org/ddp/home.do?Step=12&id=4&CNO=2 +# +# Alternative Source : "World Federation of Exchanges" +# http://www.world-exchanges.org/statistics/time-series +# +# How to invest in the world with a few ETFs _ Decision Science News +# http://www.decisionsciencenews.com/2011/12/29/youve-got-the-whole-world-in-your-portfolio/ +############################################################################### +aa.test.hist.capitalization <- function() +{ + symbols = spl('Australia Canada France Germany Japan United Kingdom United States', '\t') + + # Market capitalization of listed companies (current US$) in 1,000,000,000 + data = +'1988 138.0 242.0 245.0 252.0 3910.0 771.0 2790.0 +1989 141.0 291.0 365.0 365.0 4390.0 827.0 3510.0 +1990 109.0 242.0 314.0 355.0 2920.0 849.0 3060.0 +1991 149.0 267.0 348.0 393.0 3130.0 988.0 4090.0 +1992 145.0 243.0 351.0 348.0 2400.0 927.0 4490.0 +1993 204.9 326.5 456.1 463.5 2999.8 1151.6 5136.2 +1994 218.9 315.0 451.3 470.5 3719.9 1210.2 5067.0 +1995 245.2 366.3 522.1 577.4 3667.3 1407.7 6857.6 +1996 312.0 486.3 591.1 671.0 3088.9 1740.2 8484.4 +1997 295.8 567.6 674.4 825.2 2216.7 1996.2 11308.8 +1998 328.9 543.4 991.5 1094.0 2495.8 2374.3 13451.4 +1999 427.7 800.9 1475.5 1432.2 4546.9 2933.3 16635.1 +2000 372.8 841.4 1446.6 1270.2 3157.2 2577.0 15104.0 +2001 375.1 700.8 1174.4 1071.7 2251.8 2164.7 13854.6 +2002 378.8 575.3 967.0 691.1 2126.1 1864.3 11098.1 +2003 585.5 894.0 1355.9 1079.0 3040.7 2460.1 14266.3 +2004 776.4 1177.5 1559.1 1194.5 3678.3 2815.9 16323.7 +2005 804.1 1480.9 1758.7 1221.3 4736.5 3058.2 16970.9 +2006 1095.9 1700.7 2428.6 1637.8 4726.3 3794.3 19425.9 +2007 1298.4 2186.6 2771.2 2105.5 4453.5 3858.5 19947.3 +2008 675.6 1002.2 1492.3 1108.0 3220.5 1852.0 11737.6 +2009 1258.5 1681.0 1972.0 1297.6 3377.9 2796.4 15077.3 +2010 1454.5 2160.2 1926.5 1429.7 4099.6 3107.0 17139.0' + + hist.caps = matrix( as.double(spl( gsub('\n', '\t', data), '\t')), + nrow = len(spl(data, '\n')), byrow=TRUE) + + + load.packages('quantmod') + symbol.names = symbols + + hist.caps = as.xts( hist.caps[,-1] , + as.Date(paste('1/1/', hist.caps[,1], sep=''), '%d/%m/%Y') + ) + colnames(hist.caps) = symbols + + return(hist.caps) + +} + + +# Get Monthly Federal funds rate from http://www.federalreserve.gov/releases/h15/data.htm +get.fedfunds.rate <- function() +{ + # download Monthly History of Fed Funds rates + url = 'http://www.federalreserve.gov/datadownload/Output.aspx?rel=H15&series=40afb80a445c5903ca2c4888e40f3f1f&lastObs=&from=&to=&filetype=csv&label=include&layout=seriescolumn' + txt = readLines(url) + + txt = txt[-c(1 : grep('Time Period', txt))] + hist.returns = matrix( spl(txt), nrow = len(txt), byrow=TRUE) + + load.packages('quantmod') + + hist.returns = as.xts( as.double(hist.returns[,-1]) / 100, + as.Date(paste(hist.returns[,1], '-1', sep=''), '%Y-%m-%d') + ) + + return(hist.returns) +} + + + +aa.test.create.ia.country <- function(dates = '1990::2010') +{ + #-------------------------------------------------------------------------- + # Load historical prices and compute simple returns + #-------------------------------------------------------------------------- + load.packages('quantmod,quadprog') + + # load historical prices from Yahoo Finance + symbols = spl('EWA,EWC,EWQ,EWG,EWJ,EWU,SPY') + symbol.names = spl('Australia,Canada,France,Germany,Japan,UK,USA') + + getSymbols(symbols, from = '1980-01-01', auto.assign = TRUE) + + # align dates for all symbols & convert to frequency + hist.prices = merge(EWA,EWC,EWQ,EWG,EWJ,EWU,SPY) + period.ends = endpoints(hist.prices, 'months') + hist.prices = Ad(hist.prices)[period.ends, ] + colnames(hist.prices) = symbol.names + annual.factor = 12 + + # remove any missing data + hist.prices = na.omit(hist.prices[dates]) + + # compute simple returns + hist.returns = na.omit( ROC(hist.prices, type = 'discrete') ) + + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + ia = create.historical.ia(hist.returns, annual.factor) + + return(ia) +} + + + + +############################################################################### +# Create Input Assumptions used in +# DIVERSIFICATION, REBALANCING, AND THE GEOMETRIC MEAN FRONTIER by W. Bernstein and D. Wilkinson (1997) +# www.effisols.com/basics/rebal.pdf +############################################################################### +aa.test.create.ia.rebal <- function() +{ + symbols = spl('SP500 SmallUS Europe Pacific Japan Gold 20Y_Treas 5Y_Treas TBills', '\t') + symbols = trim(symbols) + + data = +'1970 0.0403 -0.1743 -0.0935 -0.13 -0.156 0.0871 0.121 0.1685 0.0652 +1971 0.1432 0.165 0.2803 0.1082 0.6107 -0.0373 0.1324 0.0874 0.0439 +1972 0.1898 0.0443 0.1582 0.6678 1.1447 0.602 0.0567 0.0517 0.0384 +1973 -0.1466 -0.309 -0.0773 -0.2392 -0.1595 0.9184 -0.011 0.0461 0.0693 +1974 -0.2647 -0.1995 -0.2277 -0.4059 -0.1392 0.1094 0.0435 0.0568 0.0801 +1975 0.372 0.5282 0.439 0.6342 0.1723 -0.2407 0.0919 0.0782 0.058 +1976 0.2384 0.5738 -0.0637 0.0572 0.2637 -0.3258 0.1676 0.1288 0.0508 +1977 -0.0718 0.2538 0.2392 0.0334 0.1722 0.3549 -0.0065 0.014 0.0513 +1978 0.0656 0.2346 0.243 0.2397 0.5182 0.0934 -0.0118 0.0349 0.072 +1979 0.1844 0.4346 0.1467 0.5216 -0.1461 1.6133 -0.0121 0.041 0.1038 +1980 0.3242 0.3988 0.1452 0.6149 0.2939 0.6427 -0.0396 0.039 0.1126 +1981 -0.0491 0.1388 -0.1045 -0.1547 0.1041 -0.2514 0.0186 0.0944 0.1472 +1982 0.2141 0.2801 0.0569 -0.2818 -0.0023 0.4786 0.4037 0.291 0.1053 +1983 0.2251 0.3967 0.2238 0.3421 0.2779 0.0259 0.0069 0.0741 0.088 +1984 0.0623 -0.0667 0.0126 -0.0724 0.1701 0.2922 0.1554 0.1403 0.0978 +1985 0.3216 0.2466 0.7979 0.1729 0.4413 -0.0887 0.3096 0.2034 0.0773 +1986 0.1847 0.0685 0.4446 0.4839 0.9185 0.3593 0.2445 0.1513 0.0615 +1987 0.0523 -0.093 0.041 0.042 0.4187 0.3753 -0.027 0.029 0.0546 +1988 0.1681 0.2287 0.1635 0.3056 0.3534 -0.1846 0.0968 0.0609 0.0636 +1989 0.3149 0.1018 0.2906 0.1585 0.0217 0.2538 0.181 0.1327 0.0838 +1990 -0.0317 -0.2156 -0.0337 -0.1015 -0.3618 -0.2373 0.062 0.0974 0.0782 +1991 0.3055 0.4463 0.1366 0.3661 0.0882 -0.042 0.1926 0.1531 0.056 +1992 0.0766 0.2335 -0.0425 0.0701 -0.2111 -0.1598 0.0941 0.072 0.0351 +1993 0.099 0.21 0.2979 0.8035 0.2505 0.8287 0.1824 0.1124 0.029 +1994 0.012 0.031 0.0266 -0.141 0.2217 -0.1193 -0.0778 -0.0513 0.0391 +1995 0.3753 0.3448 0.2213 0.1295 0.0069 0.0191 0.3069 0.1905 0.0551 +1996 0.2295 0.1765 0.2895 0.2054 -0.155 0.0706 -0.0127 0.0661 0.0502' + + hist.returns = matrix( as.double(spl( gsub('\n', '\t', data), '\t')), + nrow = len(spl(data, '\n')), byrow=TRUE) + + + load.packages('quantmod') + + hist.returns = as.xts( hist.returns[,-1] , + as.Date(paste('1/1/', hist.returns[,1], sep=''), '%d/%m/%Y') + ) + colnames(hist.returns) = symbols + + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + ia = create.historical.ia(hist.returns, 1, symbols) + + return(ia) +} + + + +############################################################################### +# Create Input Assumptions used in aa.test functions +############################################################################### +aa.test.create.ia <- function() +{ + #-------------------------------------------------------------------------- + # Load historical prices and compute simple returns + #-------------------------------------------------------------------------- + load.packages('quantmod,quadprog') + + # load historical prices from Yahoo Finance + symbols = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + symbol.names = spl('S&P 500,Nasdaq 100,Emerging Markets,Russell 2000,EAFE,20 Year Treasury,U.S. Real Estate,Gold') + + getSymbols(symbols, from = '1980-01-01', auto.assign = TRUE) + + # align dates for all symbols & convert to monthly + hist.prices = merge(SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD) + month.ends = endpoints(hist.prices, 'months') + hist.prices = Ad(hist.prices)[month.ends, ] + colnames(hist.prices) = symbols + + # remove any missing data + hist.prices = na.omit(hist.prices['1995::2010']) + + # compute simple returns + hist.returns = na.omit( ROC(hist.prices, type = 'discrete') ) + + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + ia = create.historical.ia(hist.returns, 12, symbols, symbol.names) + + return(ia) +} + + +############################################################################### +# Create Historical Input Assumptions given symbols and dates +############################################################################### +aa.test.create.ia.custom <- function(symbols, symbol.names = symbols, dates = NULL) +{ + #-------------------------------------------------------------------------- + # Load historical prices and compute simple returns + #-------------------------------------------------------------------------- + load.packages('quantmod,quadprog') + + data <- new.env() + getSymbols(symbols, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates=dates) + + # convert to monthly frequency + hist.prices = data$prices + period.ends = endpoints(hist.prices, 'months') + hist.prices = hist.prices[period.ends, ] + colnames(hist.prices) = symbol.names + annual.factor = 12 + + # compute simple returns + hist.returns = na.omit( ROC(hist.prices, type = 'discrete') ) + + #-------------------------------------------------------------------------- + # Create historical input assumptions + #-------------------------------------------------------------------------- + ia = create.historical.ia(hist.returns, annual.factor, symbol.names, symbol.names) + + return(ia) +} + + + + +############################################################################### +# Add short (negative copy) input assumptions to given ia +############################################################################### +aa.test.ia.add.short <- function(ia) +{ + ia$symbols = c(ia$symbols,ia$symbols) + ia$n = 2*ia$n + ia$hist.returns = cbind(ia$hist.returns, -ia$hist.returns) + + ia$expected.return = c(ia$expected.return, -ia$expected.return) + ia$risk = c(ia$risk, ia$risk) + + # Transfrom correlation & covariance + # | cov -cov | + # |-cov cov | + ia$correlation = cbind( rbind(ia$correlation, -ia$correlation), rbind(-ia$correlation, ia$correlation) ) + ia$cov = cbind( rbind(ia$cov, -ia$cov), rbind(-ia$cov, ia$cov) ) + + return(ia) +} + + + \ No newline at end of file diff --git a/R/branchbound.r b/R/branchbound.r new file mode 100644 index 0000000..5809e9d --- /dev/null +++ b/R/branchbound.r @@ -0,0 +1,309 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Binary Branch and Bound and it's adaption for QP problem +# Copyright (C) 1998-2000 Alberto Bemporad, Domenico Mignone - author's of the original Matlab version +# Copyright (C) 2011 Michael Kapler - adapted code to R +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Binary Branch and Bound algorithm adpated from +# miqp.m, a Matlab function for solving Mixed Integer Quadratic Programs +# by Alberto Bemporad, Domenico Mignone +# The routine was modified to work with large set of optimization problems. +# +# http://www.aut.ee.ethz.ch/~hybrid/miqp/ +#' @export +############################################################################### +binary_branch_bound <- function +( + index_binvar, # index of binary[0/1] variables + bbb_data, # data used for solving problems + bbb_solve, # bbb_solve(bbb_data, binvar_lb, binvar_ub) - function to solve problems + control = bbb_control() # control the behavior of binary_branch_bound +) +{ +# Output: +# xmin: minimizer of the cost function +# fmin: minimum value of the cost function +# counter: number of executions +# flag: integer flag characterizing the result, where: +# if flag = 1 there exists a feasible solution +# if flag = 5 the solution is not integer feasible +# if flag = 7 no feasible solution exists + + fbest = Inf + xbest = 0 * bbb_data$x0 + counter = 0 + nbinvar = length(index_binvar) + flag = 7 # by default it is infeasible + + # The Variable STACK will contain the subproblems + stack = new.env() + stack$data = list() + stack$cost = c() + stack$pointer = c() + stack$data[[1]] = list(lb = bbb_data$lb, + ub = bbb_data$ub, + var = 1:nbinvar, + path = rep(0,nbinvar), + level = 0, + fval = Inf) + stack$cost = 0 # Array storing the cost of the problems, ordered in decreasing fashion (cost(1)=largest value) + stack$pointer = 1 # pointer stores the order of the list + + control$proborder.selected = control$proborder + + if(F) { + lb = bbb_data$lb + ub = bbb_data$ub + + # presolve two default cases + for( i in 0:1 ) { + lb[] = i + ub[] = i + sol = match.fun(bbb_solve)(bbb_data, lb, ub) + + if( sol$ok ) { + x = sol$x + fval = sol$fval + xi = x[index_binvar] # binary variables + + # found solution + if ( max(abs( round(xi,0) - xi )) < control$bineps ) { + fbest = fval + xbest = x + flag = 1 + if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n'); + } + } + } + } + + # Main Loop + while ( length(stack$data) > 0 ) { + # Get the next subproblem from the STACK + subprob = bbb_pop(stack) + + if( !control$silent ) { + cat('-----------------------------------------------------', '\n') + if( max(subprob$path) > 0 ) { + temp.index = order(-subprob$path)[1 : sum(subprob$path > 0)] + cat('\t', + paste('b', temp.index, ' = ', subprob$lb[temp.index],sep='') + , '\n') + } else { + cat(counter, '\t', 'FIRST NODE', '\n') + } + + cat(counter, '\t', subprob$lb, '\t', subprob$var, '\t', subprob$fval, '\t', fbest, '\n') + cat('\t', subprob$ub, '\n') + cat('stack size =', len(stack$pointer), '\n') + } + + if( is.finite( subprob$fval ) & is.finite( fbest ) & fbest <= subprob$fval ) { + # skip this problem because fbest is alredy smaller + if( !control$silent ) cat('SKIP this problem because a solution with lower FVAL already found\n') + } else { + + # Solve the qp + counter = counter + 1 + sol = match.fun(bbb_solve)(bbb_data, subprob$lb, subprob$ub) + + + if( !sol$ok ) { + if( !control$silent ) cat('NO SOLUTION EXISTS\n\n'); + } else { + x = sol$x + fval = sol$fval + + if( !control$silent ) { + cat('SOLUTION OK', '\t', sol$fval, '\n') + cat('\t', round(x[index_binvar[subprob$var]],3), '\n\n') + } + + + if ( flag !=1 ) flag=5 + + # Check if value function is better than the value so far + if ( fval <= fbest ) { + if ( length(subprob$var ) == 0 ) { + # found solution + fbest = fval + xbest = x + flag = 1 + if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n'); + } else { + xi = x[index_binvar[subprob$var]] # binary variables + + # found solution + if ( max(abs( round(xi,0) - xi )) < control$bineps ) { + fbest = fval + xbest = x + flag = 1 + if( !control$silent ) cat('FOUND SOLUTION =', fbest, '\n'); + } else { + # split problem in 0/1 subproblems + branchvar = bbb_decision(xi,control) + probs = bbb_separate(subprob, branchvar, fval) + p0 = probs$p0 + p1 = probs$p1 + + if( !control$silent ) cat('Branch on =', subprob$var[branchvar], '\n'); + + + + if( control$searchdir == 0 ) { + cost=1/(subprob$level+1) # Depth first + } else if( control$searchdir == 1 ) { + cost=subprob$level+1 # Breadth first + } else if( control$searchdir == 2 ) { + cost=fval # Best-first. This tends to go breadth-first + } else if( control$searchdir == 3 ) { + cost=fval/(subprob$level+1) # This privilegiates deep nodes + } + + if( control$proborder == 2 ) { + control$proborder.selected = round(xi[branchvar],0) + } + + if( control$proborder.selected == 0 ) { + bbb_push(stack, p1, p0, cost) + } else { + bbb_push(stack, p0, p1, cost) + } + } + } + } + } + + # verbose + if( F ) { + cat('counter =', counter, '\n') + cat('fbest =', fbest, '\n') + cat('stack$pointer =', stack$pointer, '\n') + cat('\n') + } + } + } #end while + rm(list=ls(stack,all=TRUE), envir=stack) + + #xbest[index_binvar] = round(xbest[index_binvar],0) # ROUNDOFF binary solution + return(list(xmin = xbest, fmin = fbest, counter = counter, flag = flag)) +} + +############################################################################### +# Decision: find next branching variable +############################################################################### +bbb_decision <- function +( + xi, # x for binary variables + control # control the behavior of binary_branch_bound +) +{ + if( control$branchvar == 0 ) { + # first free variable is chosen as branching variable + branchvar = 1 + } else if( control$branchvar == 1 ) { + # variable with max frac part is chosen as branching variable + branchvar = which.max( abs(xi-round(xi,0)) ) #pick up the first of with max value + } else if( control$branchvar == 2 ) { + # variable with min frac part is chosen as branching variable + branchvar = which.min( abs(xi-round(xi,0)) ) #pick up the first of with min value + } else { + branchvar = 1 + } + return(branchvar) +} + +############################################################################### +# Pop: returns top element of the STACK and eliminate the element from the stack +############################################################################### +bbb_pop <- function(stack) +{ + i = stack$pointer[ length(stack$data) ] + subprob = stack$data[[i]] + + stack$pointer[ stack$pointer > i ] = stack$pointer[ stack$pointer > i ] - 1 + + # remove last + stack$data[[i]] = NULL + length(stack$cost) = length(stack$data) + length(stack$pointer) = length(stack$data) + + return(subprob) +} + +############################################################################### +# Push: puts a subproblem onto the STACK +############################################################################### +bbb_push <- function +( + stack, # stack structure + element1, # element to push on stack + element2, # element to push on stack + cost # cost +) +{ + n = length(stack$data) + + # Determine position in STACK where problem is inserted, according to a best first strategy + i = match(TRUE, stack$cost <= cost) # EX: STACKCOST=[100 80 33 22 ^ 5 3 2], cost=10 + if( is.na(i) ) i = n else i = i - 1 + + stack$data[[ (n+1) ]] = element1 + stack$data[[ (n+2) ]] = element2 + + if(i == 0) { + stack$pointer=c((n+1),(n+2), stack$pointer) + stack$cost=c(cost,cost, stack$cost) + } else { + stack$pointer=c(stack$pointer[1:i], (n+1),(n+2), stack$pointer[-c(1:i)]) + stack$cost=c(stack$cost[1:i], cost, cost, stack$cost[-c(1:i)]) + } +} + +############################################################################### +# Separate: generates 2 new suproblems from a given problem +############################################################################### +bbb_separate <- function +( + prob, # QP parent problem + branchvar, # branching variable + fval # fval for parent problem +) +{ + if(length(prob$var) >= 1) { + p0 = prob + p0$fval = fval + p0$level = prob$level + 1 + p0$var = prob$var[-branchvar] + p0$path[ prob$var[branchvar] ] = 1 + max(p0$path) + p1 = p0 + + p0$lb[ prob$var[branchvar] ] = 0 + p0$ub[ prob$var[branchvar] ] = 0 + + p1$lb[ prob$var[branchvar] ] = 1 + p1$ub[ prob$var[branchvar] ] = 1 + } else { + stop('no more integer variables to branch on') + } + return( list(p0 = p0, p1 = p1) ) +} + diff --git a/R/bt.r b/R/bt.r new file mode 100644 index 0000000..2c28f9a --- /dev/null +++ b/R/bt.r @@ -0,0 +1,2194 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Backtest Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +# Align dates, faster version of merge function +#' @export +############################################################################### +bt.merge <- function +( + b, # enviroment with symbols time series + align = c('keep.all', 'remove.na'), # alignment type + dates = NULL # subset of dates +) +{ + align = align[1] + symbolnames = b$symbolnames + nsymbols = len(symbolnames) + + # count all series + ncount = sapply(symbolnames, function(i) nrow(b[[i]])) + all.dates = double(sum(ncount)) + + # put all dates into one large vector + itemp = 1 + for( i in 1:nsymbols ) { + all.dates[itemp : (itemp + ncount[i] -1)] = attr(b[[ symbolnames[i] ]], 'index') + itemp = itemp + ncount[i] + } + + # find unique + temp = sort(all.dates) + unique.dates = c(temp[1], temp[-1][diff(temp)!=0]) + + # trim if date is supplied + if(!is.null(dates)) { + class(unique.dates) = c('POSIXct', 'POSIXt') + temp = make.xts(integer(len(unique.dates)), unique.dates) + unique.dates = attr(temp[dates], 'index') + } + + # date map + date.map = matrix(NA, nr = len(unique.dates), nsymbols) + itemp = 1 + for( i in 1:nsymbols ) { + index = match(all.dates[itemp : (itemp + ncount[i] -1)], unique.dates) + sub.index = which(!is.na(index)) + date.map[ index[sub.index], i] = sub.index + itemp = itemp + ncount[i] + } + + # trim logic + index = c() + if( align == 'remove.na' ) { + index = which(count(date.map, side=1) < nsymbols ) + } + # keep all +# else { +# index = which(count(date.map, side=1) < max(1, 0.1 * nsymbols) ) +# } + + if(len(index) > 0) { + date.map = date.map[-index,, drop = FALSE] + unique.dates = unique.dates[-index] + } + + class(unique.dates) = c('POSIXct', 'POSIXt') + return( list(all.dates = unique.dates, date.map = date.map)) +} + + +############################################################################### +# Prepare backtest data enviroment +# +# it usually contains: +# * b$symbolnames +# * b$universe +# * b$prices +# * b - asset hist data +# +#' @export +############################################################################### +bt.prep <- function +( + b, # enviroment with symbols time series + align = c('keep.all', 'remove.na'), # alignment type + dates = NULL, # subset of dates + fill.gaps = F, # fill gaps introduced by merging + basic = F # control if xts object are created +) +{ + # setup + if( !exists('symbolnames', b, inherits = F) ) b$symbolnames = ls(b) + symbolnames = b$symbolnames + nsymbols = len(symbolnames) + + if( nsymbols > 1 ) { + # merge + out = bt.merge(b, align, dates) + + for( i in 1:nsymbols ) { + temp = coredata( b[[ symbolnames[i] ]] )[ out$date.map[,i],, drop = FALSE] + b[[ symbolnames[i] ]] = iif(basic, temp, make.xts( temp, out$all.dates)) + + # fill gaps logic + map.col = find.names('Close,Volume,Open,High,Low,Adjusted', b[[ symbolnames[i] ]]) + if(fill.gaps & !is.na(map.col$Close)) { + close = coredata(b[[ symbolnames[i] ]][,map.col$Close]) + n = len(close) + last.n = max(which(!is.na(close))) + close = ifna.prev(close) + if(last.n + 5 < n) close[last.n : n] = NA + b[[ symbolnames[i] ]][, map.col$Close] = close + index = !is.na(close) + + if(!is.na(map.col$Volume)) { + index1 = is.na(b[[ symbolnames[i] ]][, map.col$Volume]) & index + b[[ symbolnames[i] ]][index1, map.col$Volume] = 0 + } + + #for(j in colnames(b[[ symbolnames[i] ]])) { + for(field in spl('Open,High,Low')) { + j = map.col[[field]] + if(!is.null(j)) { + index1 = is.na(b[[ symbolnames[i] ]][,j]) & index + b[[ symbolnames[i] ]][index1, j] = close[index1] + }} + + j = map.col$Adjusted + if(!is.null(j)) { + b[[ symbolnames[i] ]][index, j] = ifna.prev(b[[ symbolnames[i] ]][index, j]) + } + + + #for(j in setdiff(1:ncol( b[[ symbolnames[i] ]] ), unlist(map.col))) { + # b[[ symbolnames[i] ]][index, j] = ifna.prev(b[[ symbolnames[i] ]][index, j]) + #} + } + } + } else { + if(!is.null(dates)) b[[ symbolnames[1] ]] = b[[ symbolnames[1] ]][dates,] + out = list(all.dates = index.xts(b[[ symbolnames[1] ]]) ) + if(basic) b[[ symbolnames[1] ]] = coredata( b[[ symbolnames[1] ]] ) + } + + # dates + b$dates = out$all.dates + + # empty matrix + dummy.mat = matrix(double(), len(out$all.dates), nsymbols) + colnames(dummy.mat) = symbolnames + if(!basic) dummy.mat = make.xts(dummy.mat, out$all.dates) + + # weight matrix holds signal and weight information + b$weight = dummy.mat + + # execution price, if null use Close + b$execution.price = dummy.mat + + # populate prices matrix + for( i in 1:nsymbols ) { + if( has.Cl( b[[ symbolnames[i] ]] ) ) { + dummy.mat[,i] = Cl( b[[ symbolnames[i] ]] ); + } + } + b$prices = dummy.mat +} + + + + +# matrix form +#' @export +bt.prep.matrix <- function +( + b, # enviroment with symbols time series + align = c('keep.all', 'remove.na'), # alignment type + dates = NULL, # subset of dates + basic = F # control if xts object are created +) +{ + align = align[1] + nsymbols = len(b$symbolnames) + + # merge + if(!is.null(dates)) { + temp = make.xts(1:len(b$dates), b$dates) + temp = temp[dates] + index = as.vector(temp) + + for(i in b$fields) b[[ i ]] = b[[ i ]][index,, drop = FALSE] + + b$dates = b$dates[index] + } + + if( align == 'remove.na' ) { + index = which(count(b$Cl, side=1) < nsymbols ) + } else { + index = which(count(b$Cl,side=1) < max(1,0.1 * nsymbols) ) + } + + if(len(index) > 0) { + for(i in b$fields) b[[ i ]] = b[[ i ]][-index,, drop = FALSE] + + b$dates = b$dates[-index] + } + + # empty matrix + dummy.mat = iif(basic, b$Cl, make.xts(b$Cl, b$dates)) + + # weight matrix holds signal and weight information + b$weight = NA * dummy.mat + + b$execution.price = NA * dummy.mat + + b$prices = dummy.mat +} + + +bt.prep.matrix.test <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + # example csv file holds returns + # Date ,A,B + # Jan-70,0.01,0.02 + returns = read.xts('Example.csv', date.fn=function(x) paste('1',x), format='%d %b-%y') + prices = bt.apply.matrix(1 + returns, cumprod) + + data <- new.env() + data$symbolnames = colnames(prices) + data$dates = index(prices) + data$fields = 'Cl' + data$Cl = prices + + bt.prep.matrix(data) + + #***************************************************************** + # Code Strategies + #****************************************************************** + # Buy & Hold + data$weight[] = NA + data$weight[] = 1 + buy.hold = bt.run.share(data) + + #***************************************************************** + # Create Report + #****************************************************************** + plotbt(buy.hold, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +} + +############################################################################### +# Remove symbols from enviroment +#' @export +############################################################################### +bt.prep.remove.symbols.min.history <- function +( + b, # enviroment with symbols time series + min.history = 1000 # minmum number of observations +) +{ + bt.prep.remove.symbols(b, which( count(b$prices, side=2) < min.history )) +} + + +#' @export +bt.prep.remove.symbols <- function +( + b, # enviroment with symbols time series + index # index of symbols to remove +) +{ + if( len(index) > 0 ) { + if( is.character(index) ) index = match(index, b$symbolnames) + + b$prices = b$prices[, -index] + b$weight = b$weight[, -index] + b$execution.price = b$execution.price[, -index] + + env.rm(b$symbolnames[index], b) + b$symbolnames = b$symbolnames[ -index] + } +} + + +############################################################################### +#' Trim data enviroment +#' +#' This function will remove weights that are smaller than given threshold +#' +#' @param b original enviroment with symbols time series +#' @param dates dates to keep from original enviroment +#' +#' @return updated enviroment with symbols time series +#' +#' @examples +#' \dontrun{ +#' bt.prep.trim(data, endpoints(data$prices, 'months')) +#' bt.prep.trim(data, '2006::') +#' } +#' @export +bt.prep.trim <- function +( + b, # enviroment with symbols time series + dates = NULL # subset of dates +) +{ + if(is.null(dates)) return(b) + + # convert dates to dates.index + dates.index = dates2index(b$prices, dates) + + data.copy <- new.env() + for(s in b$symbolnames) data.copy[[s]] = b[[s]][dates.index,,drop=F] + + data.copy$symbolnames = b$symbolnames + data.copy$dates = b$dates[dates.index] + + data.copy$prices = b$prices[dates.index,,drop=F] + data.copy$weight = b$weight[dates.index,,drop=F] + data.copy$execution.price = b$execution.price[dates.index,,drop=F] + return(data.copy) +} + + +############################################################################### +# Helper function to backtest for type='share' +#' @export +############################################################################### +bt.run.share <- function +( + b, # enviroment with symbols time series + prices = b$prices, # prices + clean.signal = T, # flag to remove excessive signal + + trade.summary = F, # flag to create trade summary + do.lag = 1, # lag signal + do.CarryLastObservationForwardIfNA = TRUE, + silent = F, + capital = 100000, + commission = 0, + weight = b$weight, + dates = 1:nrow(b$prices) +) +{ + # make sure that prices are available, assume that + # weights account for missing prices i.e. no price means no allocation + prices[] = bt.apply.matrix(coredata(prices), ifna.prev) + + + weight = mlag(weight, do.lag - 1) + do.lag = 1 + + if(clean.signal) + weight[] = bt.exrem(weight) + weight = (capital / prices) * weight + + + bt.run(b, + trade.summary = trade.summary, + do.lag = do.lag, + do.CarryLastObservationForwardIfNA = do.CarryLastObservationForwardIfNA, + type='share', + silent = silent, + capital = capital, + commission = commission, + weight = weight, + dates = dates) +} + + +############################################################################### +# Run backtest +# +# Inputs are assumed as if they were computed at point in time (i.e. no lags) +# +# For 'weight' back-test, the default action is to lage weights by one day, +# because weights are derived using all the information avalaible today, +# so we can only implement these weights tomorrow: +# portfolio.returns = lag(weights,1) * returns = weights * ( p / lag(p,1) - 1 ) +# user can specify a different lag for weights, by changing the do.lag parameter. +# +# For example, for the end of the month strategy: if we open position at the close +# on the 30th, hold position on the 31st and sell it at the close on the 1st. If our +# weights have 0 on the 30th, 1 on the 31st, 1 on the 1st, and 0 on the 2nd, we +# can specify do.lag = 0 to get correct portfolio.returns +# +# Alternatively, if our weights have 0 on the 29th, 1 on the 30st, 1 on the 31st, and 0 on the 1nd, we +# can leave do.lag = 1 to get correct portfolio.returns +# +# For 'share' back-test, the portfolio returns: +# portfolio.returns = lag(shares,1) * ( p - lag(p,1) ) / ( lag(shares,1) * lag(p,1) ) +# +############################################################################### +# some operators do not work well on xts +# weight[] = apply(coredata(weight), 2, ifna_prev) +#' @export +############################################################################### +bt.run <- function +( + b, # enviroment with symbols time series + trade.summary = F, # flag to create trade summary + do.lag = 1, # lag signal + do.CarryLastObservationForwardIfNA = TRUE, + type = c('weight', 'share'), + silent = F, + capital = 100000, + commission = 0, + weight = b$weight, + dates = 1:nrow(b$prices) +) +{ + # convert dates to dates.index + dates.index = dates2index(b$prices, dates) + + # setup + type = type[1] + + # create signal + weight[] = ifna(weight, NA) + + # lag + if(do.lag > 0) + weight = mlag(weight, do.lag) # Note k=1 implies a move *forward* + + # backfill + if(do.CarryLastObservationForwardIfNA) + weight[] = apply(coredata(weight), 2, ifna.prev) + + weight[is.na(weight)] = 0 + + # find trades + weight1 = mlag(weight, -1) + tstart = weight != weight1 & weight1 != 0 + tend = weight != 0 & weight != weight1 + trade = ifna(tstart | tend, FALSE) + + # prices + prices = b$prices + + # execution.price logic + if( sum(trade) > 0 ) { + execution.price = coredata(b$execution.price) + prices1 = coredata(b$prices) + + prices1[trade] = iif( is.na(execution.price[trade]), prices1[trade], execution.price[trade] ) + prices[] = prices1 + } + + # type of backtest + if( type == 'weight') { + ret = prices / mlag(prices) - 1 + ret[] = ifna(ret, NA) + ret[is.na(ret)] = 0 + } else { # shares, hence provide prices + ret = prices + } + + #weight = make.xts(weight, b$dates) + temp = b$weight + temp[] = weight + weight = temp + + + # prepare output + bt = bt.summary(weight, ret, type, b$prices, capital, commission) + bt$dates.index = dates.index + bt = bt.run.trim.helper(bt, dates.index) + + if( trade.summary ) bt$trade.summary = bt.trade.summary(b, bt) + + if( !silent ) { + # print last signal / weight observation + cat('Latest weights :\n') + print(round(100*last(bt$weight),2)) + cat('\n') + + cat('Performance summary :\n') + cat('', spl('CAGR,Best,Worst'), '\n', sep = '\t') + cat('', sapply(cbind(bt$cagr, bt$best, bt$worst), function(x) round(100*x,1)), '\n', sep = '\t') + cat('\n') + } + + return(bt) +} + +# trim bt object, used internally +#' @export +bt.run.trim.helper = function(bt, dates.index) { + n.dates = len(dates.index) + for(n in ls(bt)) { + if( !is.null(dim(bt[[n]])) ) { + if( nrow(bt[[n]]) > n.dates ) + bt[[n]] = bt[[n]][dates.index,,drop=F] + } else if( len(bt[[n]]) > n.dates ) + bt[[n]] = bt[[n]][dates.index] + } + + bt$equity = bt$equity / as.double(bt$equity[1]) + bt$best = max(bt$ret) + bt$worst = min(bt$ret) + bt$cagr = compute.cagr(bt$equity) + + bt +} + + +############################################################################### +#tic(11) +#for(j in 1:10) +# a = as.vector(prices) +#toc(11) +# +#tic(11) +#for(j in 1:10) +# a = coredata(prices) +#toc(11) +# Interestingly coredata is a lot faster +# +############################################################################### +# Backtest summary +#' @export +############################################################################### +bt.summary <- function +( + weight, # signal / weights matrix + ret, # returns for type='weight' and prices for type='share' + type = c('weight', 'share'), + close.prices, + capital = 100000, + commission = 0 # cents / share commission +) +{ + # cents / share commission + # trade cost = abs(share - mlag(share)) * commission$cps + # fixed commission per trade to more effectively to penalize for turnover + # trade cost = sign(abs(share - mlag(share))) * commission$fixed + # percentage commission + # trade cost = price * abs(share - mlag(share)) * commission$percentage + + # Todo + # - ability to set different commissions at start/end of the trade + # - add percentage.fixed, same logic as fixed, but applied to capital + # trade cost = sign(abs(share - mlag(share))) * + # price * abs(pmax(share, mlag(share))) * commission$percentage.fixed + # - ability to set commissions for each asset; hence modeling different tax + # rates for stock and equities; these special commissions/taxes should + # only be applied at the year end and depend on asset and holding period + # only for trades that were completed in the given year => probably a separate function + + + if( !is.list(commission) ) { + if( type == 'weight') + commission = list(cps = 0.0, fixed = 0.0, percentage = commission) + else + commission = list(cps = commission, fixed = 0.0, percentage = 0.0) + } + + type = type[1] + n = nrow(ret) + + bt = list() + bt$weight = weight + bt$type = type + + # for commission calculations, un lag the signal + com.weight = mlag(weight,-1) + + if( type == 'weight') { + temp = ret[,1] + temp[] = rowSums(ret * weight) - + rowSums(abs(com.weight - mlag(com.weight)) * commission$percentage, na.rm=T) + - rowSums(sign(abs(com.weight - mlag(com.weight))) * commission$fixed, na.rm=T) + bt$ret = temp + #bt$ret = make.xts(rowSums(ret * weight) - rowSums(abs(weight - mlag(weight))*commission, na.rm=T), index.xts(ret)) + #bt$ret = make.xts(rowSums(ret * weight), index.xts(ret)) + } else { + bt$share = weight + bt$capital = capital + prices = ret + + # backfill prices + #prices1 = coredata(prices) + #prices1[is.na(prices1)] = ifna(mlag(prices1), NA)[is.na(prices1)] + #prices[] = prices1 + prices[] = bt.apply.matrix(coredata(prices), ifna.prev) + close.prices[] = bt.apply.matrix(coredata(close.prices), ifna.prev) + + # new logic + #cash = capital - rowSums(bt$share * mlag(prices), na.rm=T) + cash = capital - rowSums(bt$share * mlag(close.prices), na.rm=T) + + # find trade dates + share.nextday = mlag(bt$share, -1) + tstart = bt$share != share.nextday & share.nextday != 0 + tend = bt$share != 0 & bt$share != share.nextday + trade = ifna(tstart | tend, FALSE) + tstart = trade + + index = mlag(apply(tstart, 1, any)) + index = ifna(index, FALSE) +index[1] = T + + totalcash = NA * cash + totalcash[index] = cash[index] + totalcash = ifna.prev(totalcash) + totalcash = ifna(totalcash,0) # check this + + + # We can introduce transaction cost to portfolio returns as + # abs(bt$share - mlag(bt$share)) * 0.01 + + portfolio.ret = (totalcash + rowSums(bt$share * prices, na.rm=T) + - rowSums(abs(com.weight - mlag(com.weight)) * commission$cps, na.rm=T) + - rowSums(sign(abs(com.weight - mlag(com.weight))) * commission$fixed, na.rm=T) + - rowSums(prices * abs(com.weight - mlag(com.weight)) * commission$percentage, na.rm=T) + ) / (totalcash + rowSums(bt$share * mlag(prices), na.rm=T) ) - 1 + + #portfolio.ret = (totalcash + rowSums(bt$share * prices, na.rm=T) ) / (totalcash + rowSums(bt$share * mlag(prices), na.rm=T) ) - 1 + + bt$weight = bt$share * mlag(prices) / (totalcash + rowSums(bt$share * mlag(prices), na.rm=T) ) + + + + bt$weight[is.na(bt$weight)] = 0 + #bt$ret = make.xts(ifna(portfolio.ret,0), index.xts(ret)) + temp = ret[,1] + temp[] = ifna(portfolio.ret,0) +temp[1] = 0 + bt$ret = temp + + } + + bt$best = max(bt$ret) + bt$worst = min(bt$ret) + + bankrupt = which(bt$ret <= -1) + if(len(bankrupt) > 0) bt$ret[bankrupt[1]:n] = -1 + + bt$equity = cumprod(1 + bt$ret) + bt$cagr = compute.cagr(bt$equity) + + return(bt) +} + +bt.summary.test <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + data <- new.env() + getSymbols('EEM', src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + + bt.prep(data, align='keep.all', dates='2013:08::2013:08:10') + buy.date = '2013:08:05' + sell.date = '2013:08:06' + + #***************************************************************** + # Code Strategies + #****************************************************************** + # set dummy prices + coredata(data$prices) <-c(10,20,40,60,20,160,60) + prices = data$prices + + # weight back-test + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = list(cps = 0.0, fixed = 0.0, percentage = 1/100) + model3 = bt.run(data, commission = commission, silent = T) + + model3$ret + #There is 1% drop on 5th due to buying stock, and on the 6th return is 0.49 = 0.5 - 0.01 (commission) + + + # share back-test + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = list(cps = 0.0, fixed = 0.0, percentage = 1/100) + model3 = bt.run.share(data, commission = commission, capital = 100000, silent = T) + + model3$ret + #There is 1% drop on 5th due to buying stock, and on the 6th return is + #0.485 = (2500 * 60 - 2500 * 60 * 0.01) / (2500 * 40) - 1 + #i.e. return = (share * price + cash - total.commission) / (share * mlag(price) + cash) - 1 + +} + +############################################################################### +# Remove all leading NAs in model equity +#' @export +############################################################################### +bt.trim <- function +( + ..., + dates = '::' +) +{ + models = variable.number.arguments( ... ) + + for( i in 1:len(models) ) { + bt = models[[i]] + + n = len(bt$equity) + first = which.max(!is.na(bt$equity) & bt$equity != 1) + if(first > 1 && !is.na(bt$equity[(first-1)])) + first = first - 1 + if (first < n) { + index = first:n + + dates.range = range(dates2index(bt$equity[index],dates)) + index = index[dates.range[1]] : index[dates.range[2]] + + bt$dates.index = bt$dates.index[index] + bt$equity = bt$equity[index] + bt$equity = bt$equity / as.double(bt$equity[1]) + bt$ret = bt$ret[index] + bt$weight = bt$weight[index,,drop=F] + if (!is.null(bt$share)) bt$share = bt$share[index,,drop=F] + + bt$best = max(bt$ret) + bt$worst = min(bt$ret) + bt$cagr = compute.cagr(bt$equity) + } + + models[[i]] = bt + } + return (models) +} + + +bt.trim.test <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + data <- new.env() + getSymbols(spl('SPY,GLD'), src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all') + + #***************************************************************** + # Code Strategies + #****************************************************************** + models = list() + + data$weight[] = NA + data$weight$SPY[] = 1 + models$SPY = bt.run.share(data, clean.signal=F) + + data$weight[] = NA + data$weight$GLD[] = 1 + models$GLD = bt.run.share(data, clean.signal=F) + + + strategy.performance.snapshoot(bt.trim(models), T) +} + + +# bt.run - really fast with no bells or whisles +# working directly with xts is alot slower, so use coredata +#' @export +bt.run.weight.fast <- function +( + b, # enviroment with symbols time series + do.lag = 1, # lag signal + do.CarryLastObservationForwardIfNA = TRUE +) +{ + # Signal => weight + weight = ifna(coredata(b$weight), NA) + + # lag + if(do.lag > 0) weight = mlag(weight, do.lag) # Note k=1 implies a move *forward* + + # backfill + if(do.CarryLastObservationForwardIfNA) weight[] = apply(coredata(weight), 2, ifna.prev) + + weight[is.na(weight)] = 0 + + # returns + prices = coredata(b$prices) + ret = prices / mlag(prices) - 1 + ret[] = ifna(ret, 0) + ret = rowSums(ret * weight) + + # prepare output + list(weight = weight, ret = ret, equity = cumprod(1 + ret)) +} + +############################################################################### +# Portfolio turnover +# http://wiki.fool.com/Portfolio_turnover +# sales or purchases and dividing it by the average monthly value of the fund's assets +#' @export +############################################################################### +compute.turnover <- function +( + bt, # backtest object + b, # environment with symbols time series + exclude.first.trade = T # first trade is the reason for 100% turnover + # i.e. going from cash to fully invested +) +{ + year.ends = unique(c(endpoints(bt$weight, 'years'), nrow(bt$weight))) + year.ends = year.ends[year.ends>0] + nr = len(year.ends) + period.index = c(1, year.ends) + + # find first investment date + first = which.max(!is.na(bt$equity) & bt$equity != 1) + if(first > 1 && !is.na(bt$equity[(first-1)])) + first = first - 1 + + + if( bt$type == 'weight') { + portfolio.value = rowSums(abs(bt$weight), na.rm=T) + portfolio.turnover = rowSums( abs(bt$weight - mlag(bt$weight)), na.rm=T) + portfolio.turnover[ rowSums( !is.na(bt$weight) & !is.na(mlag(bt$weight)) ) == 0 ] = NA + } else { + prices = mlag(b$prices[bt$dates.index,,drop=F]) + + if( is.null(bt$cash) ) { + # logic from bt.summary function + cash = bt$capital - rowSums(bt$share * prices, na.rm=T) + + # find trade dates + share.nextday = mlag(bt$share, -1) + tstart = bt$share != share.nextday & share.nextday != 0 + + index = mlag(apply(tstart, 1, any)) + index = ifna(index, FALSE) + + totalcash = NA * cash + totalcash[index] = cash[index] + totalcash = ifna.prev(totalcash) + } else + totalcash = bt$cash + + portfolio.value = totalcash + rowSums(bt$share * prices, na.rm=T) + + portfolio.turnover = rowSums( prices * abs(bt$share - mlag(bt$share)), na.rm=T) + portfolio.turnover[ rowSums( !is.na(bt$share) & !is.na(mlag(bt$share)) & !is.na(prices) ) == 0 ] = NA + } + + if(exclude.first.trade) portfolio.turnover[first] = 0 + + portfolio.turnover[1:2] = 0 + temp = NA * period.index + for(iyear in 2:len(period.index)) { + temp[iyear] = sum( portfolio.turnover[ (1+period.index[iyear-1]) : period.index[iyear] ], na.rm=T) / + mean( portfolio.value[ (1+period.index[iyear-1]) : period.index[iyear] ], na.rm=T) + } + + if(exclude.first.trade) + turnover = mean(temp[period.index > first], na.rm=T) + else + turnover = mean(temp[period.index >= first], na.rm=T) + + ifna(turnover,0) +} + + + +# debug +# write.xts(make.xts(bt$cash, index(bt$weight)), 'cash.csv') +# write.xts(make.xts(bt$share, index(bt$weight)), 'share.csv') +# write.xts(prices, 'price.csv') +# +# portfolio.value = make.xts(portfolio.value,index(prices)) +# portfolio.turnover = make.xts(portfolio.turnover,index(prices)) +# iyear='1998' +# mean(portfolio.value[iyear]) +# sum(portfolio.turnover[iyear]) +# sum(portfolio.turnover[iyear]) / mean(portfolio.value[iyear]) + + + +############################################################################### +# Compute Portfolio Maximum Deviation +#' @export +############################################################################### +compute.max.deviation <- function +( + bt, + target.allocation +) +{ + weight = bt$weight[-1,] + max(abs(weight - repmat(target.allocation, nrow(weight), 1))) +} + + +############################################################################### +# Backtest Trade summary +#' @export +############################################################################### +bt.trade.summary <- function +( + b, # enviroment with symbols time series + bt # backtest object +) +{ + if( bt$type == 'weight') weight = bt$weight else weight = bt$share + + out = NULL + + # find trades + weight1 = mlag(weight, -1) + tstart = weight != weight1 & weight1 != 0 + tend = weight != 0 & weight != weight1 + tstart[1, weight[1,] != 0] = T + n = nrow(weight) + tend[n, weight[n,] != 0] = T + #tend[1, ] = F + trade = ifna(tstart | tend, FALSE) + + # prices + prices = b$prices[bt$dates.index,,drop=F] + + # execution price logic + if( sum(trade) > 0 ) { + execution.price = coredata(b$execution.price[bt$dates.index,,drop=F]) + prices1 = coredata(b$prices[bt$dates.index,,drop=F]) + + prices1[trade] = iif( is.na(execution.price[trade]), prices1[trade], execution.price[trade] ) + + # backfill pricess + prices1[is.na(prices1)] = ifna(mlag(prices1), NA)[is.na(prices1)] + prices[] = prices1 + + # get actual weights + weight = bt$weight + + # extract trades + symbolnames = b$symbolnames + nsymbols = len(symbolnames) + + ntrades = max(sum(tstart,na.rm=T), sum(tend,na.rm=T)) + trades = matrix(NA,nr=ntrades,nc=7) + colnames(trades) = spl('date,symbol,weight,entry.date,exit.date,entry.price,exit.price') + itrade = 1 + for( i in 1:nsymbols ) { + tstarti = which(tstart[,i]) + tendi = which(tend[,i]) + +#cat(colnames(data$prices)[i], len(tstarti), len(tendi), '\n') + + if( len(tstarti) > 0 ) { + #if( len(tendi) < len(tstarti) ) tendi = c(tendi, nrow(weight)) + if( len(tendi) > len(tstarti) ) tstarti = c(1, tstarti) + + ntrade = len(tstarti) + ntrade.index = itrade:(itrade+ntrade-1) + trades[ntrade.index,] = + cbind((tstarti+1), i, coredata(weight[(tstarti+1), i]), + tstarti, tendi, + coredata(prices[tstarti, i]), coredata(prices[tendi,i]) + ) + itrade = itrade + ntrade + } + } + + + # prepare output + out = list() + out$stats = cbind( + bt.trade.summary.helper(trades), + bt.trade.summary.helper(trades[trades[, 'weight'] >= 0, ]), + bt.trade.summary.helper(trades[trades[, 'weight'] <0, ]) + ) + colnames(out$stats) = spl('All,Long,Short') + + dates = index(weight) + dates0 = format(dates, '%Y-%m-%d') + index = order(dates[trades[,'entry.date']]) + + temp = matrix('',nr=nrow(trades),nc=8) + colnames(temp)=spl('symbol,weight,entry.date,exit.date,nhold,entry.price,exit.price,return') + temp[,'symbol'] = symbolnames[trades[index,'symbol']] + temp[,'weight'] = round(100*trades[index,'weight'],1) + temp[,'entry.date'] = dates0[trades[index,'entry.date']] + temp[,'exit.date'] = dates0[trades[index,'exit.date']] + temp[,'nhold'] = as.numeric(dates[trades[index,'exit.date']] - dates[trades[index,'entry.date']]) + temp[,'entry.price'] = round(trades[index,'entry.price'], 2) + temp[,'exit.price'] = round(trades[index,'exit.price'], 2) + temp[,'return'] = round(100*trades[index,'weight'] * (trades[index,'exit.price']/trades[index,'entry.price'] - 1),2) + + out$trades = temp + } + + return(out) +} + + + +############################################################################### +# Backtest Trade summary +#' @export +############################################################################### +bt.trade.summary.old <- function +( + b, # enviroment with symbols time series + bt # backtest object +) +{ + if( bt$type == 'weight') weight = bt$weight else weight = bt$share + + out = NULL + + # find trades + weight1 = mlag(weight, -1) + tstart = weight != weight1 & weight1 != 0 + tend = weight != 0 & weight != weight1 + tstart[1, weight[1,] != 0] = T + n = nrow(weight) + tend[n, weight[n,] != 0] = T + #tend[1, ] = F + trade = ifna(tstart | tend, FALSE) + + # prices + prices = b$prices[bt$dates.index,,drop=F] + + # execution price logic + if( sum(trade) > 0 ) { + execution.price = coredata(b$execution.price[bt$dates.index,,drop=F]) + prices1 = coredata(b$prices[bt$dates.index,,drop=F]) + + prices1[trade] = iif( is.na(execution.price[trade]), prices1[trade], execution.price[trade] ) + + # backfill pricess + prices1[is.na(prices1)] = ifna(mlag(prices1), NA)[is.na(prices1)] + prices[] = prices1 + + # get actual weights + weight = bt$weight + + # extract trades + symbolnames = b$symbolnames + nsymbols = len(symbolnames) + + trades = c() + for( i in 1:nsymbols ) { + tstarti = which(tstart[,i]) + tendi = which(tend[,i]) + +#cat(colnames(data$prices)[i], len(tstarti), len(tendi), '\n') + + if( len(tstarti) > 0 ) { + #if( len(tendi) < len(tstarti) ) tendi = c(tendi, nrow(weight)) + if( len(tendi) > len(tstarti) ) tstarti = c(1, tstarti) + + trades = rbind(trades, + cbind(i, weight[(tstarti+1), i], + tstarti, tendi, tendi-tstarti, + coredata(prices[tstarti, i]), coredata(prices[tendi,i]) + ) + ) + } + } + colnames(trades) = spl('symbol,weight,entry.date,exit.date,nhold,entry.price,exit.price') + + + # prepare output + out = list() + out$stats = cbind( + bt.trade.summary.helper(trades), + bt.trade.summary.helper(trades[trades[, 'weight'] >= 0, ]), + bt.trade.summary.helper(trades[trades[, 'weight'] <0, ]) + ) + colnames(out$stats) = spl('All,Long,Short') + + temp.x = index.xts(weight) + + trades = data.frame(coredata(trades)) + trades$symbol = symbolnames[trades$symbol] + trades$nhold = as.numeric(temp.x[trades$exit.date] - temp.x[trades$entry.date]) + trades$entry.date = temp.x[trades$entry.date] + trades$exit.date = temp.x[trades$exit.date] + trades$return = round(100*(trades$weight) * (trades$exit.price/trades$entry.price - 1),2) + trades$entry.price = round(trades$entry.price, 2) + trades$exit.price = round(trades$exit.price, 2) + trades$weight = round(100*(trades$weight),1) + + out$trades = as.matrix(trades) + } + + return(out) +} + + +bt.trade.summary.test <- function() { +test = list( + weight1 = matrix(c(0,0,0,1),nc=1), + weight2 = matrix(c(0,1,0,0),nc=1), + weight3 = matrix(c(1,1,1,1),nc=1), + weight4 = matrix(c(1,0,0,0),nc=1), + weight5 = matrix(c(1,2,0,1,2),nc=1) +) + + for(i in 1:len(test)) { + + weight = test[[i]] + + # find trades + weight1 = mlag(weight, -1) + tstart = weight != weight1 & weight1 != 0 + tend = weight != 0 & weight != weight1 + #tstart[1, weight[1,] != 0] = T + n = nrow(weight) + tend[n, weight[n,] != 0] = T + tend[1, ] = NA + + trade = ifna(tstart | tend, FALSE) + + tstarti = which(tstart) + tendi = which(tend) + + if( len(tendi) > len(tstarti) ) tstarti = c(1, tstarti) + + cat(len(tstarti), len(tendi), '\n') + + #data.frame(weight, weight1, tstart, tend) + } + +} + + +# helper function +# [Why Every Trader Should Know and Understand This Formula](http://www.priceactionlab.com/Blog/2015/02/why-every-trader-should-know-and-understand-this-formula/) +#' @export +bt.trade.summary.helper <- function(trades) +{ + if(nrow(trades) <= 0) return(NA) + + out = list() + tpnl = trades[, 'weight'] * (trades[, 'exit.price'] / trades[,'entry.price'] - 1) + tlen = trades[, 'exit.date'] - trades[, 'entry.date'] + + out$ntrades = nrow(trades) + out$avg.pnl = mean(tpnl) + out$len = mean(tlen) + + out$win.prob = len(which( tpnl > 0 )) / out$ntrades + out$win.avg.pnl = mean( tpnl[ tpnl > 0 ]) + out$win.len = mean( tlen[ tpnl > 0 ]) + + out$loss.prob = 1 - out$win.prob + out$loss.avg.pnl = mean( tpnl[ tpnl < 0 ]) + out$loss.len = mean( tlen[ tpnl < 0 ]) + + #Van Tharp : Expectancy = (PWin * AvgWin) - (PLoss * AvgLoss) + out$expectancy = (out$win.prob * out$win.avg.pnl + out$loss.prob * out$loss.avg.pnl)/100 + + # Profit Factor is computed as follows: (PWin * AvgWin) / (PLoss * AvgLoss) + out$profitfactor = -(out$win.prob * out$win.avg.pnl) / (out$loss.prob * out$loss.avg.pnl) + + return(as.matrix(unlist(out))) +} + +############################################################################### +# Change data periodicity in the given bt enviroment +# +# example of mapping to first day of the month +# date.map.fn = function(x) as.Date(format(x, '%Y-%m-1'),'%Y-%m-%d') +# +#' @export +############################################################################### +bt.change.periodicity <- function +( + b, # enviroment with symbols time series + + # convert data to given periodicity + periodicity = 'months', + period.ends = NULL, + date.map.fn = NULL +) +{ + require(xts) + b1 = env() + for(n in ls(b)) + if( is.xts( b[[n]] ) ) { + if(!is.null(periodicity)) + period.ends = endpoints(b[[n]], periodicity) + + temp = b[[n]][period.ends,] + + if(!is.null(date.map.fn)) + index(temp) = date.map.fn(index(temp)) + + colnames(temp) = colnames(b[[n]]) + b1[[n]] = temp + } else + b1[[n]] = b[[n]] + + if(!is.null(b$dates)) + b1$dates = index(b1$prices) + b1 +} + +############################################################################### +# Apply given function to bt enviroment +# for example, to compute 10 month moving average each quater +# bt.apply.matrix(prices, function(x) mean(last(x,10)), periodicity='months', apply.periodicity='quarters') +# +# Make sure not to use a rolling window functions if apply.periodicity is given +# +############################################################################### +#' @export +bt.apply <- function +( + b, # enviroment with symbols time series + xfun=Cl, # user specified function + ... # other parameters +) +{ + out = b$weight + out[] = NA + + symbolnames = b$symbolnames + nsymbols = length(symbolnames) + xfun = match.fun(xfun) + + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[[ symbolnames[i] ]]),... ) , silent=TRUE) + if (class(msg)[1] == 'try-error') + warning(i, msg, '\n') + else + out[,i] = msg + } + return(out) +} + +#' @export +bt.apply.matrix <- function +( + b, # matrix + xfun=Cl, # user specified function + ... # other parameters +) +{ + out = b + out[] = NA + nsymbols = ncol(b) + xfun = match.fun(xfun) + + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[,i]),... ) , silent=TRUE) + if (class(msg)[1] == 'try-error') + warning(i, msg, '\n') + else + out[,i] = msg + + } + return(out) +} + + + + + +# following function can handle different periodicity and apply.periodicity +# make sure not to use a rolling window functions if apply.periodicity is given!!! +#' @export +bt.apply.ex <- function +( + b, # enviroment with symbols time series + xfun=Cl, # user specified function + ..., # other parameters + + # convert data to given periodicity before applying xfun + periodicity = NULL, + period.ends = NULL, + + # apply xfun only on selected periodicity + apply.periodicity = NULL, + apply.period.ends = NULL, + + fill.gaps = F # fill gaps introduced by having different periodicity +) +{ + temp = bt.apply.setup.helper(b$weight, xfun, periodicity, period.ends, apply.periodicity, apply.period.ends) + period.ends = temp$period.ends + apply.period.ends = temp$apply.period.ends + map = temp$map + + out = b$weight + out[] = NA + + symbolnames = b$symbolnames + nsymbols = length(symbolnames) + xfun = match.fun(xfun) + + # check how many results xfun returns + +if(is.null(apply.period.ends)) { + if(is.null(period.ends)) + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[[ symbolnames[i] ]]),... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[,i] = msg + else + warning(i, msg, '\n') + } + else + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[[ symbolnames[i] ]][period.ends,]),... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[period.ends,i] = msg + else + warning(i, msg, '\n') + } +} else { + if(is.null(period.ends)) + for( i in 1:nsymbols ) { + x = coredata(b[[ symbolnames[i] ]]) + for( j in apply.period.ends ) { + msg = try( xfun( x[1:j,,drop=F],... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[j,i] = msg + else + warning(i, msg, '\n') + } + } + else # i.e. run quaterly on the monthly data + for( i in 1:nsymbols ) { + x = coredata(b[[ symbolnames[i] ]][period.ends,]) + for( j in apply.period.ends ) { + msg = try( xfun( x[1:map[j]],... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[j,i] = msg + else + warning(i, msg, '\n') + } + } +} + if(fill.gaps) bt.apply.matrix(out, ifna.prev) else out +} + +# make sure not to use a rolling window functions if apply.periodicity is given!!! +#' @export +bt.apply.matrix.ex <- function +( + b, # matrix + xfun=Cl, # user specified function + ..., # other parameters + + # convert data to given periodicity before applying xfun + periodicity = NULL, + period.ends = NULL, + + # apply xfun only on selected periodicity + apply.periodicity = NULL, + apply.period.ends = NULL, + + fill.gaps = F # fill gaps introduced by having different periodicity +) +{ + temp = bt.apply.setup.helper(b, xfun, periodicity, period.ends, apply.periodicity, apply.period.ends) + period.ends = temp$period.ends + apply.period.ends = temp$apply.period.ends + map = temp$map + + out = b + out[] = NA + nsymbols = ncol(b) + xfun = match.fun(xfun) + +if(is.null(apply.period.ends)) { + if(is.null(period.ends)) + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[,i]),... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[,i] = msg + else + warning(i, msg, '\n') + } + else + for( i in 1:nsymbols ) { + msg = try( xfun( coredata(b[period.ends,i]),... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[period.ends,i] = msg + else + warning(i, msg, '\n') + } +} else { + if(is.null(period.ends)) + for( i in 1:nsymbols ) { + x = coredata(b[,i]) + for( j in apply.period.ends ) { + msg = try( xfun( x[1:j],... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[j,i] = msg + else + warning(i, msg, '\n') + } + } + else # i.e. run quaterly on the monthly data + for( i in 1:nsymbols ) { + x = coredata(b[period.ends,i]) + for( j in apply.period.ends ) { + msg = try( xfun( x[1:map[j]],... ) , silent=TRUE) + if (class(msg)[1] != 'try-error') + out[j,i] = msg + else + warning(i, msg, '\n') + } + } +} + if(fill.gaps) bt.apply.matrix(out, ifna.prev) else out +} + + + +bt.apply.setup.helper <- function(m, xfun, periodicity, period.ends, apply.periodicity, apply.period.ends) { + if(!is.null(periodicity) && is.null(period.ends)) + period.ends = endpoints(m, periodicity) + if(!is.null(apply.periodicity) && is.null(apply.period.ends)) + apply.period.ends = endpoints(m, apply.periodicity) + + if(!is.null(apply.period.ends)) + apply.period.ends = apply.period.ends[apply.period.ends > 0] + if(!is.null(period.ends)) + period.ends = period.ends[period.ends > 0] + + map = NULL + if(!is.null(apply.period.ends) && !is.null(period.ends)) { + map = array(NA, nrow(m)) + map[period.ends] = 1:len(period.ends) + map = ifna.prev(map) + map = ifna(map,1) + } + + list(period.ends = period.ends, apply.period.ends = apply.period.ends, map = map) +} + + + + +# following function can handle multiple return arrays. i.e. ATR +# make sure not to use a rolling window functions if apply.periodicity is given!!! +#' @export +bt.apply.ex2 <- function +( + b, # enviroment with symbols time series + xfun=Cl, # user specified function + ..., # other parameters + + # convert data to given periodicity before applying xfun + periodicity = NULL, + period.ends = NULL, + + # apply xfun only on selected periodicity + apply.periodicity = NULL, + apply.period.ends = NULL, + + fill.gaps = F # fill gaps introduced by having different periodicity +) +{ + temp = bt.apply.setup.helper(b$weight, xfun, periodicity, period.ends, apply.periodicity, apply.period.ends) + period.ends = temp$period.ends + apply.period.ends = temp$apply.period.ends + map = temp$map + + temp = b$weight + temp[] = NA + out = env(out = temp, n=1, name='out') + index = 1:nrow(temp) + + symbolnames = b$symbolnames + nsymbols = length(symbolnames) + xfun = match.fun(xfun) + + if(is.null(apply.period.ends)) { + for( i in 1:nsymbols ) + if(is.null(period.ends)) + set.result.helper(b[[ symbolnames[i] ]], index, xfun, out, i, ...) + else + set.result.helper(b[[ symbolnames[i] ]][period.ends,], period.ends, xfun, out, i, ...) + } else { + for( i in 1:nsymbols ) { + x = coredata(iif(is.null(period.ends), b[[ symbolnames[i] ]], b[[ symbolnames[i] ]][period.ends,])) + for( j in apply.period.ends ) + if(is.null(period.ends)) + set.result.helper(x[1:j,,drop=F], j, xfun, out, i, ...) + else # i.e. run quaterly on the monthly data + set.result.helper(x[1:map[j],,drop=F], j, xfun, out, i, ...) + } + } + + bt.apply.fill.gaps.helper(out, fill.gaps) +} + + + +# out = bt.apply2(data, function(x) ATR(HLC(x))) +# out$atr +# make sure not to use a rolling window functions if apply.periodicity is given!!! +#' @export +bt.apply.matrix.ex2 <- function +( + b, # matrix + xfun=Cl, # user specified function + ..., # other parameters + + # convert data to given periodicity before applying xfun + periodicity = NULL, + period.ends = NULL, + + # apply xfun only on selected periodicity + apply.periodicity = NULL, + apply.period.ends = NULL, + + fill.gaps = F # fill gaps introduced by having different periodicity +) +{ + temp = bt.apply.setup.helper(b, xfun, periodicity, period.ends, apply.periodicity, apply.period.ends) + period.ends = temp$period.ends + apply.period.ends = temp$apply.period.ends + map = temp$map + + temp = b + temp[] = NA + out = env(out = temp, n=1, name='out') + index = 1:nrow(temp) + + nsymbols = ncol(b) + xfun = match.fun(xfun) + + if(is.null(apply.period.ends)) { + for( i in 1:nsymbols ) + if(is.null(period.ends)) + set.result.helper(b[,i], index, xfun, out, i, ...) + else + set.result.helper(b[period.ends,i], period.ends, xfun, out, i, ...) + } else { + for( i in 1:nsymbols ) { + x = coredata(iif(is.null(period.ends), b[,i], b[period.ends,i])) + for( j in apply.period.ends ) + if(is.null(period.ends)) { + set.result.helper(x[1:j], j, xfun, out, i, ...) + } else # i.e. run quaterly on the monthly data + set.result.helper(x[1:map[j]], j, xfun, out, i, ...) + } + } + + bt.apply.fill.gaps.helper(out, fill.gaps) +} + +set.result.helper = function(x, j, xfun, out, i, ...) { + msg = try( xfun( iif(is.xts(x), coredata(x), x), ... ) , silent=TRUE) + if (class(msg)[1] == 'try-error') + warning(i, msg, '\n') + else { + nresult = iif(is.null(dim(msg)), 1, ncol(msg)) + if(nresult != out$n) { + temp = out[[ out$name[1] ]] + rm(list = out$name, envir = out) + out$name = iif(is.null(dim(msg)), names(msg), colnames(msg)) + out$n = nresult + for(result.name in out$name) + out[[result.name]] = temp + } + + if(out$n == 1) + out$out[j,i] = msg + else + for(result.name in out$name) + out[[result.name]][j,i] = iif(len(j) == 1, msg[result.name], msg[,result.name]) + } +} + +bt.apply.fill.gaps.helper = function(out, fill.gaps) { + if(out$n == 1) { + if(fill.gaps) + bt.apply.matrix(out$out, ifna.prev) + else + out$out + } else { + if(fill.gaps) + for(result.name in out$name) + out[[result.name]] = bt.apply.matrix(out[[result.name]], ifna.prev) + rm(list = c('n','name'), envir = out) + out + } +} + + +# test for bt.apply functions +bt.apply.test = function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod,quadprog,corpcor,lpSolve') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data = env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1990::') + + t2 = bt.apply.ex2(data, function(x) ATR(HLC(x))) + #t2$atr + #ls(t2) + + + + prices = data$prices + + t01 = bt.apply.matrix(prices, SMA, 100) + t02 = bt.apply(data, function(x) SMA(Cl(x),100)) + t11 = bt.apply.matrix.ex(prices, SMA, 100) + t12 = bt.apply.ex(data, function(x) SMA(Cl(x),100)) + t21 = bt.apply.matrix.ex2(prices, SMA, 100) + t22 = bt.apply.ex2(data, function(x) SMA(Cl(x),100)) + print(all.equal(t01, t02)) + print(all.equal(t01, t11)) + print(all.equal(t01, t12)) + print(all.equal(t01, t21)) + print(all.equal(t01, t22)) + + t11 = bt.apply.matrix.ex(prices, SMA, 10, periodicity='months') + t12 = bt.apply.ex(data, function(x) SMA(Cl(x),10), periodicity='months') + t21 = bt.apply.matrix.ex2(prices, SMA, 10, periodicity='months') + t22 = bt.apply.ex2(data, function(x) SMA(Cl(x),10), periodicity='months') + print(all.equal(t11, t12)) + print(all.equal(t11, t21)) + print(all.equal(t11, t22)) + + + # Make sure not to use a rolling window functions if apply.periodicity is given + # bt.apply.matrix(prices, function(x) mean(mlast(x,10)), periodicity='months', apply.periodicity='quarters') + t11 = bt.apply.matrix.ex(prices, function(x) mean(mlast(x,100)), apply.periodicity='quarters') + t12 = bt.apply.ex(data, function(x) mean(mlast(Cl(x),100)), apply.periodicity='quarters') + t21 = bt.apply.matrix.ex2(prices, function(x) mean(mlast(x,100)), apply.periodicity='quarters') + t22 = bt.apply.ex2(data, function(x) mean(mlast(Cl(x),100)), apply.periodicity='quarters') + print(all.equal(t11, t12)) + print(all.equal(t11, t21)) + print(all.equal(t11, t22)) + + + t11 = bt.apply.matrix.ex(prices, function(x) mean(mlast(x,10)), periodicity='months', apply.periodicity='quarters') + t12 = bt.apply.ex(data, function(x) mean(mlast(Cl(x),10)), periodicity='months', apply.periodicity='quarters') + t21 = bt.apply.matrix.ex2(prices, function(x) mean(mlast(x,10)), periodicity='months', apply.periodicity='quarters') + t22 = bt.apply.ex2(data, function(x) mean(mlast(Cl(x),10)), periodicity='months', apply.periodicity='quarters') + print(all.equal(t11, t12)) + print(all.equal(t11, t21)) + print(all.equal(t11, t22)) + + + + load.packages('rbenchmark') + + test01 = function() { t01 = bt.apply.matrix(prices, SMA, 100) } + test02 = function() { t02 = bt.apply(data, function(x) SMA(Cl(x),100)) } + test11 = function() { t11 = bt.apply.matrix.ex(prices, SMA, 100) } + test12 = function() { t12 = bt.apply.ex(data, function(x) SMA(Cl(x),100)) } + test21 = function() { t21 = bt.apply.matrix.ex2(prices, SMA, 100) } + test22 = function() { t22 = bt.apply.ex2(data, function(x) SMA(Cl(x),100)) } + + + library(rbenchmark) + benchmark( + test01(), + test02(), + test11(), + test12(), + test21(), + test22(), + columns = c("test", "replications", "elapsed", "relative"), + order = "relative", + replications = 50 + ) + +} + + +############################################################################### +# Remove excessive signal +# http://www.amibroker.com/guide/afl/exrem.html +#' @export +############################################################################### +exrem <- function(x) { + temp = c(0, ifna(ifna.prev(x),0)) + itemp = which(temp != mlag(temp)) + x[] = NA + x[(itemp-1)] = temp[itemp] + return(x) +} + +exrem.test <- function() { + exrem(c(NA,1,1,0,1,1,NA,0)) +} + +#' @export +bt.exrem <- function(weight) +{ + bt.apply.matrix(weight, exrem) +} + + +############################################################################### +# Backtest Test function +############################################################################### +bt.test <- function() +{ + load.packages('quantmod') + + #***************************************************************** + # Load historical data + #****************************************************************** + + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + + prices = data$prices + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + # MA Cross + sma = bt.apply(data, function(x) { SMA(Cl(x), 200) } ) + data$weight[] = NA + data$weight[] = iif(prices >= sma, 1, 0) + sma.cross = bt.run(data, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( sma.cross, buy.hold) +dev.off() + + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2( sma.cross, buy.hold) +dev.off() + + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3( sma.cross, buy.hold) +dev.off() + + + + + # put all reports into one pdf file + pdf(file = 'report.pdf', width=8.5, height=11) + plotbt.custom.report(sma.cross, buy.hold, trade.summary=T) + dev.off() + + #***************************************************************** + # Code Strategies + #****************************************************************** + + data$weight[] = NA + data$weight$SPY = 1 + temp = bt.run(data) + + data$weight[] = NA + data$weight$SPY = 2 + temp = bt.run(data) + + data$weight[] = NA + data$weight$SPY = 1 + capital = 100000 + data$weight[] = (capital / prices) * data$weight + temp = bt.run(data, type='share', capital=capital) + + data$weight[] = NA + data$weight$SPY = 2 + capital = 100000 + data$weight[] = (capital / prices) * data$weight + temp = bt.run(data, type='share', capital=capital) + +} + +############################################################################### +# Analytics Functions +############################################################################### +# CAGR - geometric return +#' @export +############################################################################### +compute.cagr <- function(equity, nyears = NA) +{ + if(is.numeric(nyears)) + as.double( last(equity,1)^(1/nyears) - 1 ) + else + as.double( last(equity,1)^(1/compute.nyears(equity)) - 1 ) +} + +#' @export +compute.nyears <- function(x) +{ + as.double(diff(as.Date(range(index.xts(x)))))/365 +} + +#' @export +compute.raw.annual.factor = function(x) { + round( nrow(x) / compute.nyears(x) ) +} + +# 252 - days, 52 - weeks, 26 - biweeks, 12-months, 6,4,3,2,1 +#' @export +compute.annual.factor = function(x) { + possible.values = c(252,52,26,13,12,6,4,3,2,1) + index = which.min(abs( compute.raw.annual.factor(x) - possible.values )) + round( possible.values[index] ) +} + +#' @export +compute.sharpe <- function(x) +{ + temp = compute.annual.factor(x) + x = as.vector(coredata(x)) + return(sqrt(temp) * mean(x)/sd(x) ) +} + +# http://alumnus.caltech.edu/~amir/mdd-risk.pdf +# The Calmar Ratio is equal to the compounded annual growth rate divided by the maximum drawdown. +# The maximum drawdown is typically measured over a three year period. +# Calmar Ratio = CAGR / MAXDD +#' @export +compute.calmar <- function(x) +{ + compute.cagr(x) / compute.max.drawdown(x) +} + +# R2 equals the square of the correlation coefficient +#' @export +compute.R2 <- function(equity) +{ + x = as.double(index.xts(equity)) + y = equity + #summary(lm(y~x)) + return( cor(y,x)^2 ) +} + +# http://cssanalytics.wordpress.com/2009/10/15/ft-portfolio-with-dynamic-hedging/ +# DVR is the Sharpe Ratio times the R-squared of the equity curve +#' @export +compute.DVR <- function(bt) +{ + return( compute.sharpe(bt$ret) * compute.R2(bt$equity) ) +} + +#' @export +compute.risk <- function(x) +{ + temp = compute.annual.factor(x) + x = as.vector(coredata(x)) + return( sqrt(temp)*sd(x) ) +} + +#' @export +compute.drawdown <- function(x) +{ + return(x / cummax(c(1,x))[-1] - 1) +} + +#' @export +compute.max.drawdown <- function(x) +{ + as.double( min(compute.drawdown(x)) ) +} + +#' @export +compute.avg.drawdown <- function(x) +{ + drawdown = c( 0, compute.drawdown(coredata(x)), 0 ) + dstart = which( drawdown == 0 & mlag(drawdown, -1) != 0 ) + dend = which(drawdown == 0 & mlag(drawdown, 1) != 0 ) + drawdowns = apply( cbind(dstart, dend), 1, function(x) min(drawdown[ x[1]:x[2] ], na.rm=T) ) + mean(drawdowns) +} + +#' @export +compute.cdar <- function(x, probs=0.05) +{ + drawdown = c( 0, compute.drawdown(coredata(x)), 0 ) + dstart = which( drawdown == 0 & mlag(drawdown, -1) != 0 ) + dend = which(drawdown == 0 & mlag(drawdown, 1) != 0 ) + drawdowns = apply( cbind(dstart, dend), 1, function(x) min(drawdown[ x[1]:x[2] ], na.rm=T) ) + if(len(drawdowns)>2) + mean( drawdowns[ drawdowns < quantile(drawdowns, probs=probs) ] ) + else + min(drawdowns) +} + +#' @export +compute.exposure <- function(weight) +{ + sum( apply(weight, 1, function(x) sum(x != 0) ) != 0 ) / nrow(weight) +} + +#' @export +compute.var <- function(x, probs=0.05) +{ + quantile( coredata(x), probs=probs) +} + +#' @export +compute.cvar <- function(x, probs=0.05) +{ + x = coredata(x) + mean( x[ x < quantile(x, probs=probs) ] ) +} + +#' @export +compute.stats <- function(data, fns, do.na.omit = T) +{ + out = matrix(double(), len(fns), len(data)) + colnames(out) = names(data) + rownames(out) = names(fns) +if( do.na.omit ) + for(c in 1:len(data)) { + for(r in 1:len(fns)) { + out[r,c] = match.fun(fns[[r]])( fast.na.omit(data[[c]]) ) + } + } +else + for(c in 1:len(data)) { + for(r in 1:len(fns)) { + out[r,c] = match.fun(fns[[r]])( data[[c]] ) + } + } + + return(out) +} + +############################################################################### +# Example to illustrate a simeple backtest +#' @export +############################################################################### +bt.simple <- function(data, signal, silent = F) +{ + # lag singal + signal = Lag(signal, 1) + + # back fill + signal = na.locf(signal, na.rm = FALSE) + signal[is.na(signal)] = 0 + + # calculate Close-to-Close returns + ret = ROC(Cl(data), type='discrete') + ret[1] = 0 + + # compute stats + n = nrow(ret) + bt <- list() + bt$ret = ret * signal + bt$best = max(bt$ret) + bt$worst = min(bt$ret) + bt$equity = cumprod(1 + bt$ret) + bt$cagr = bt$equity[n] ^ (1/nyears(data)) - 1 + + # print + if( !silent) { + cat('', spl('CAGR,Best,Worst'), '\n', sep = '\t') + cat('', sapply(cbind(bt$cagr, bt$best, bt$worst), function(x) round(100*x,1)), '\n', sep = '\t') + } + + return(bt) +} + +bt.simple.test <- function() +{ + load.packages('quantmod') + + # load historical prices from Yahoo Finance + data = getSymbols('SPY', src = 'yahoo', from = '1980-01-01', auto.assign = F) + + # Buy & Hold + signal = rep(1, nrow(data)) + buy.hold = bt.simple(data, signal) + + # MA Cross + sma = SMA(Cl(data),200) + signal = ifelse(Cl(data) > sma, 1, 0) + sma.cross = bt.simple(data, signal) + + # Create a chart showing the strategies perfromance in 2000:2009 + dates = '2000::2009' + buy.hold.equity <- buy.hold$equity[dates] / as.double(buy.hold$equity[dates][1]) + sma.cross.equity <- sma.cross$equity[dates] / as.double(sma.cross$equity[dates][1]) + + chartSeries(buy.hold.equity, TA=c(addTA(sma.cross.equity, on=1, col='red')), + theme ='white', yrange = range(buy.hold.equity, sma.cross.equity) ) +} + +############################################################################### +#' Remove small weights +#' +#' This function will remove weights that are smaller than given threshold +#' +#' @param weight weight matrix +#' @param long.min.weight minimum weight for long positions, \strong{defaults to 0.1 } +#' @param short.min.weight minimum weight for short positions, \strong{defaults to long.min.weight } +#' +#' @return updated weight matrix +#' +#' @examples +#' \dontrun{ +#' weight = c(0.1, 0.6, 0.2, 0.1, 0, -0.1, -0.6, -0.2, -0.1, 0) +#' weight = matrix(weight, nrow=2, byrow=TRUE) +#' print(bt.apply.min.weight(weight, 0.1)) +#' } +#' @author Ivan Popivanov and Michael Kapler +#' @export +############################################################################### +# Possible use +# if(!missing(min.weight)) { +# for(i in names(obj$weights)) { +# obj$weights[[i]] = apply.min.weight(obj$weights[[i]], min.weight) +# } +# } +############################################################################### +bt.apply.min.weight <- function +( + weight, + long.min.weight = 0.1, + short.min.weight = long.min.weight +) +{ + # make sure weight is a matrix + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + # in each row, compute total pos/neg weights + pos = apply(weight, 1, function(row) sum(row[row > 0])) + neg = rowSums(weight) - pos + + # setup + pos.mat = iif(weight >= long.min.weight, weight, 0) + neg.mat = iif(weight <= -short.min.weight, weight, 0) + + # re-scale + pos.mat = pos.mat * ifna(pos / rowSums(pos.mat), 1) + neg.mat = neg.mat * ifna(neg / rowSums(neg.mat), 1) + + return(pos.mat + neg.mat) +} + +test.bt.apply.min.weight <- function() +{ + data = c(0.1, 0.6, 0.2, 0.1, 0, -0.1, -0.6, -0.2, -0.1, 0) + mm = matrix(data=data, nrow=2, byrow=TRUE) + print(bt.apply.min.weight(mm, 0.1)) + print(bt.apply.min.weight(mm, 0.2)) + + data = c(0.1, 0.6, 0.2, 0.1, 0, -0.1, -0.6, -0.2, -0.1, 0) + mm = matrix(data=data, nrow=1, byrow=TRUE) + print(bt.apply.min.weight(mm, 0.1)) + print(bt.apply.min.weight(mm, 0.2)) + + data = c(0.1, 0.6, 0.2, 0.1, 0, -0.2, -0.5, -0.3, -0.1, 0) + mm = matrix(data=data, nrow=1, byrow=TRUE) + print(bt.apply.min.weight(mm, 0.1)) + print(bt.apply.min.weight(mm, 0.2)) +} + +############################################################################### +#' Round weights +#' +#' Similar idea to bt.apply.min.weight +#' +#' @export +############################################################################### +bt.apply.round.weight <- function +( + weight, + long.round.weight = 5/100, + short.round.weight = long.round.weight +) +{ + # make sure weight is a matrix + if(is.null(dim(weight))) dim(weight) = c(1, len(weight)) + + # in each row, compute total pos/neg weights + pos = apply(weight, 1, function(row) sum(row[row > 0])) + neg = rowSums(weight) - pos + + # setup + pos.mat = iif(weight >= 0, round(weight / long.round.weight) * long.round.weight, 0) + neg.mat = iif(weight <= 0, round(weight / short.round.weight) * short.round.weight, 0) + + # re-scale + pos.mat = pos.mat * ifna(pos / rowSums(pos.mat), 1) + neg.mat = neg.mat * ifna(neg / rowSums(neg.mat), 1) + + return(pos.mat + neg.mat) +} + +############################################################################### +#' Print starting dates for time series +#' +#' @export +############################################################################### +bt.start.dates <- function +( + b # enviroment with symbols time series +) +{ + temp = lapply(b, function(x) index(x[1]) ) + temp$dates = NULL + temp$prices = NULL + temp$weight = NULL + temp$execution.price = NULL + temp$symbolnames = NULL + temp = temp[order( sapply(temp, function(x) x) )] + + out = t(t( sapply(temp, function(x) as.character(x)) )) + colnames(out) = 'Start' + out +} + +#' @export +bt.end.dates <- function +( + b # enviroment with symbols time series +) +{ + temp = lapply(b, function(x) index(last(x)) ) + temp$dates = NULL + temp$prices = NULL + temp$weight = NULL + temp$execution.price = NULL + temp$symbolnames = NULL + temp = temp[order( sapply(temp, function(x) x) )] + + out = t(t( sapply(temp, function(x) as.character(x)) )) + colnames(out) = 'Start' + out +} + + +############################################################################### +#' Append today's quotes +#' +#' data.today = getQuote.yahoo.today(ls(data)) +#' print(data.today) +#' bt.append.today(data, data.today) +#' +#' @export +############################################################################### +bt.append.today <- function(b, data.today) { + date.column = find.names('Date',data.today) + valid.index = which(!is.na(data.today[,date.column,with=F])) + data.today = data.today[valid.index] + + data = make.stock.xts(read.xts(data.today, date.column=date.column,format='%m/%d/%Y', decreasing=NULL)) + tickers = data.today$Symbol + Yesterday = data.today$Yesterday + + # todo, better logic for merging Intraday and EOD data + for(i in 1:len(tickers)) { + if(is.null(b[[ tickers[i] ]])) next + if( last(index(data[i,])) > last(index(b[[ tickers[i] ]])) ) + b[[ tickers[i] ]] = rbind(data[i,], b[[ tickers[i] ]]) + #b[[ tickers[i] ]] = extend.data(env[[ s ]], data[[ gsub('\\^', '', map[[ s ]][i]) ]], scale=T) + } +} diff --git a/R/bt.share.r b/R/bt.share.r new file mode 100644 index 0000000..7e291e4 --- /dev/null +++ b/R/bt.share.r @@ -0,0 +1,3010 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Backtest Functions +# Copyright (C) 2015 Systematic Investor +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + +############################################################################### +#' New Share Back Test functionality to properly capture portfolio changes. +#' This is an event driven back test that updates portfolio at every trade event +#' +#' Summary: +#' * store actual positions and cash at the end of the day, +#' hence if we are rebalacing on T, the positions will be shown on T +#' * for weights, use weights from T-1, to properly reflect weights throughout day +#' +#' If UnAdjusted logic is enabled, each price history is expected to have Dividend and +#' Split columns, it can be populated with bt.unadjusted.add.div.split function +#' +#' events are trades and div/splits for existing positions +#' * if div => adjust cash for +#' long = cash + share * div * (1-div.tax) +#' short = cash - share * div +#' if split => adjust share by split ratio +#' +#' @export +############################################################################### +bt.run.share.ex <- function +( + b, # enviroment with symbols time series + prices = b$prices, # prices + clean.signal = T, # flag to remove excessive signal + + trade.summary = F, # flag to create trade summary + do.lag = 1, # lag logic, to be back compatible with bt.run.share + + silent = F, + capital = 100000, + commission = 0, + weight = b$weight, + dates = 1:nrow(b$prices), + + lot.size = 0.01, + control = list( + round.lot = default.round.lot.control() + ), + + # cashflow are treated differently based on type + # the regular cashflows do not affect portfolio returns + # + # the fee.rebate cashflows affect portfolio returns + # MER,Margin Cost, Annual Taxes, can be modeled as periodic withdrawals + # these withdrawals should be included in return calculations + # because these withdrawals are fees of running portfolio vs + # regular withdrawals should not affect portfolio returns + # + cashflow.control = list( + # named list, for example + # + #monthly.income = list( + # cashflows = NULL, # xts object with cashflows, indicates both timing and amount + # invest = spl('cash,rebalance,update'), # indicates how to adjust portfolio after cashflow + # cashflow.fn = function(info, i, i.prev) round.to((info$cash[i] + sum(info$shares[i,] * prices[i,]))*(5/100), 100), # if specified, cashflows are computed as a function of total equity + # type = spl('regular,fee.rebate') + #), + # + #MER = list( + # cashflows = NULL, + # invest = spl('cash,rebalance,update'), + # cashflow.fn = function(info, i, i.prev) sum((info$cash + rowSums(info$shares * prices))[(i.prev+1):i]*(2/100 / 365)) , + # type = 'fee.rebate' + #), + # + #margin.cost = list( + # cashflows = NULL, + # invest = spl('cash,rebalance,update'), + # cashflow.fn = function(info, i, i.prev) sum(iif(info$cash < 0, -info$cash, 0)[(i.prev+1):i]*(2/100 / 365)) + # type = 'fee.rebate' + #), + # value = cash + sum(price * share) + # short = sum((price * share)[share<0]) + # long = sum((price * share)[share>0]) + # margin = iif(long > value, long - value, 0) + # + # portfolio can accure interest on (cash + short), if (cash + short) > 0 + # portfolio can accure short rebate on -short i.e. short rebate = FED rate - borrow rate + # this can turn negative + # + #taxes = list( + # cashflows = NULL, + # invest = spl('cash,rebalance,update'), + # cashflow.fn = NULL, # function need to access gain/loss information + # type = 'fee.rebate' + #) + ), + + adjusted = T, + + # following functionality only works for unadjusted data + dividend.control = list( + foreign.withholding.tax = NULL, + # http://canadiancouchpotato.com/2012/09/17/foreign-withholding-tax-explained/ + + invest = spl('cash,rebalance,update') + # invest can take following values: + # cash - put dividend to cash + # rebalance - force full rebalance + # update - minimally update portfolio to allocate dividend + # only add new positions, such that abs(shares) only increases + ), + + tax.control = NULL + #tax.control = default.tax.control() +) +{ + #--------------------------------------------------------- + # check inputs + #--------------------------------------------------------- + default.dividend.control = list( + foreign.withholding.tax = NULL, + # http://canadiancouchpotato.com/2012/09/17/foreign-withholding-tax-explained/ + + invest = spl('cash,rebalance,update') + # invest can take following values: + # cash - put dividend to cash + # rebalance - force full rebalance + # update - minimally update portfolio to allocate dividend + # only add new positions, such that abs(shares) only increases + ) + + dividend.control = verify.control('dividend.control', default.dividend.control, dividend.control) + + #--------------------------------------------------------- + # defs + #--------------------------------------------------------- + invest.type.def = list(none=0, cash=1, rebalance=2, update=3) + cashflow.type.def = list(regular=0, fee.rebate=1) + + #--------------------------------------------------------- + # process cashflows + #--------------------------------------------------------- + dummy = NA * prices[,1,drop=F] + cashflows = list( + n = len(cashflow.control), + cash = dummy + ) + + if( cashflows$n > 0 ) { + cashflows$last.index = rep(0, cashflows$n) + + cashflows$type = rep('', cashflows$n) + for(i in 1:cashflows$n) cashflows$type[i] = ifnull(cashflow.control[[i]]$type, 'regular')[1] + cashflows$type = cashflow.type.def[[ tolower(cashflows$type) ]] + + cashflows$invest = rep('', cashflows$n) + for(i in 1:cashflows$n) cashflows$invest[i] = ifnull(cashflow.control[[i]]$invest, 'cash')[1] + cashflows$invest = invest.type.def[[ tolower(cashflows$invest) ]] + + cashflows$fn = lapply(cashflow.control, function(x) iif(is.null(x$cashflow.fn), x$cashflow.fn, match.fun(x$cashflow.fn))) + + cashflows$cash = matrix(NA, nrow(prices), cashflows$n) + colnames(cashflows$cash) = names(cashflow.control) + for(i in 1:cashflows$n) + if( !is.null(cashflow.control[[i]]$cashflows) ) { + dummy[] = NA + dummy[index(cashflow.control[[i]]$cashflows)] = cashflow.control[[i]]$cashflows + cashflows$cash[,i] = dummy + } + } + cashflows$cash = coredata(ifna(cashflows$cash, 0)) + + #--------------------------------------------------------- + # process weight + #--------------------------------------------------------- + # make sure we don't have any abnormal weights + weight[is.nan(weight) | is.infinite(weight)] = NA + weight[!is.na(weight) & is.na(prices)] = 0 + + # lag logic, to be back compatible with bt.run.share + # default logic is to use current weights to trade at close i.e. no lag + weight = iif( do.lag == 1, weight, mlag(weight, do.lag - 1) ) + + weight = coredata(weight) + temp = bt.exrem(weight) + + if(clean.signal) { + weight = temp + } else { # always clean up 0's + index = ifna(weight == 0, F) + weight[index] = temp[index] + } + + #--------------------------------------------------------- + # process prices + #--------------------------------------------------------- + check.non.positive.prices = function(p, name) { + if(any(p<=0, na.rm=T)) { + index = lookup.index(open, which(p <= 0)) + stop('bt.run.share.ex detected non positive ', name, ' for ' , join(colnames(p)[index$icol], ' , ')) + } + } + + + check.non.positive.prices(prices,'prices') + + prices = coredata(prices) + n = ncol(prices) + + # execution.price logic + trade = !is.na(weight) + if( sum(trade) > 0 ) { + execution.price = coredata(b$execution.price) + prices[trade] = iif( is.na(execution.price[trade]), prices[trade], execution.price[trade] ) + } + + check.non.positive.prices(prices,'execution.prices') + + # make sure that prices are available, assume that + # weights account for missing prices i.e. no price means no allocation + prices[] = ifna( bt.apply.matrix(prices, ifna.prev), 1) + + #--------------------------------------------------------- + # validate + #--------------------------------------------------------- + if( !is.list(commission) ) + commission = list(cps = commission, fixed = 0.0, percentage = 0.0) + + lot.size = map2vector(lot.size, colnames(prices), 0.01) + + + + + + + dividend.control$foreign.withholding.tax = map2vector(dividend.control$foreign.withholding.tax, colnames(prices), 0) + dividend.control$invest = ifnull(dividend.control$invest, 'cash') + dividend.control$invest = invest.type.def[[ tolower(dividend.control$invest[1]) ]] + + #--------------------------------------------------------- + # execute internal version of bt.run.share.ex + #--------------------------------------------------------- + bt = bt.run.share.ex.internal(b, prices, capital, commission, weight, + lot.size, control, cashflows, adjusted, dividend.control, tax.control) + + #--------------------------------------------------------- + # process results + #--------------------------------------------------------- + # make ret -> equity, weight xts + bt$ret = make.xts(bt$ret, index(b$prices)) + bt$weight = make.xts(bt$weight, index(b$prices)) + + + bankrupt = which(bt$ret <= -1) + if(len(bankrupt) > 0) bt$ret[bankrupt[1]:n] = -1 + + + bt$equity = cumprod(1 + bt$ret) + + + # convert dates to dates.index + bt$dates.index = dates2index(b$prices, dates) + # prepare output + bt = bt.run.trim.helper(bt, bt$dates.index) + + + if( trade.summary ) bt$trade.summary = bt.trade.summary(b, bt) + + if( !silent ) { + # print last signal / weight observation + cat('Latest weights :\n') + print(round(100*last(bt$weight),2)) + cat('\n') + + cat('Performance summary :\n') + cat('', spl('CAGR,Best,Worst'), '\n', sep = '\t') + cat('', sapply(cbind(bt$cagr, bt$best, bt$worst), function(x) round(100*x,1)), '\n', sep = '\t') + cat('\n') + } + + bt +} + + +############################################################################### +#' verify.control +#' @export +############################################################################### +verify.control = function(name, control, inputs) { + default.names = ls(control, all.names=T) + input.names = ls(inputs, all.names=T) + + missing = setdiff(input.names, default.names) + if(len(missing) > 0) + warning(paste(name, + '\n\nOnly following variables are supported:\n', join(default.names,'\n '), + '\n\nFollowing variables were provided:\n', join(missing,'\n '), '\nbut not supported.'), str(control)) + + common = intersect(input.names, default.names) + for(n in common) + control[[n]] = inputs[[n]] + + control +} + + +############################################################################### +#' default.tax.control +#' @export +############################################################################### +default.tax.control = function(nonqualified = c()) { + list( + capital.gain = list( + short.term.tax = 35/100, + long.term.tax = 15/100, + #wash.sale.min.holding.period = 30, # 30 days + wash.sale.min.holding.period = NA, # skip wash sale logic + long.term.min.holding.period = 365 # one year + ), + + dividend = list( + qualified.tax = 15/100, + qualified.min.holding.period = 60, # 60 days + nonqualified.tax = 35/100, + nonqualified = nonqualified # tickers of stocks that do not qualify for preferential tax rate + ) + ) +} + + +# internal version, all inputs are assumed preprocessed +bt.run.share.ex.internal <- function(b, prices, capital, commission, weight, + lot.size, control, cashflows, adjusted, dividend.control, tax.control +) +{ + #--------------------------------------------------------- + # defs + #--------------------------------------------------------- + invest.type.def = list(none=0, cash=1, rebalance=2, update=3) + cashflow.type.def = list(regular=0, fee.rebate=1) + + #--------------------------------------------------------- + # setup + #--------------------------------------------------------- + # back filled weights + weight1 = ifna( bt.apply.matrix(weight, ifna.prev), 0) + + + # find cashflows + trade.cashflow = rowSums(cashflows$cash != 0) > 0 + + + # find trades + trade = !is.na(weight) + trade.index = rowSums(trade) > 0 + + #--------------------------------------------------------- + # unadjusted logic + #--------------------------------------------------------- + if(!adjusted) { + dividends = coredata(bt.apply(b, function(x) x[,'Dividend'])) + dividends[is.na(dividends)] = 0 + splits = coredata(bt.apply(b, function(x) x[,'Split'])) + splits[is.na(splits)] = 0 + + trade.dividend = rowSums(mlag(weight1) != 0 & dividends > 0, na.rm=T) > 0 + trade.split = rowSums(mlag(weight1) != 0 & splits > 0, na.rm=T) > 0 + + event.index = which(trade.index | trade.cashflow | trade.dividend | trade.split) + } else + event.index = which(trade.index | trade.cashflow) + + + + nperiods = nrow(prices) + n = ncol(prices) + + + #--------------------------------------------------------- + # taxes + #--------------------------------------------------------- + if( !is.null(tax.control) ) { + # should interact with foreign dividend tax + holdings = env( + n.trades = rep(0, n), + # start with 100 rows, if goes above 100, increase by 100 + share = matrix(0, 100, n), # fifo vector of trades for each assset + date = matrix(0, 100, n), # index / date of each trade + price = matrix(0, 100, n) # entry price each trade + ) + + wash.sale = env( + n.trades = rep(0, n), + date = matrix(0, 100, n), + share = matrix(0, 100, n), + loss.per.share = matrix(0, 100, n), + long.term = matrix(T, 100, n) + ) + + tax = env( + long.term.cap = rep(0, nperiods), + short.term.cap = rep(0, nperiods), + qualified.div = rep(0, nperiods), + non.qualified.div = rep(0, nperiods) + ) + + tax.control$dividend$nonqualified = map2vector(tax.control$dividend$nonqualified, colnames(prices), F) + } + + #--------------------------------------------------------- + # setup event driven back test loop + #--------------------------------------------------------- + + cash.wt = rep(capital, nperiods) + event.type = div = com = cashflow = fee.rebate = rep(0, nperiods) + event.type.def = list(none=0, trade=1, split=2, dividend=3, cashflow=4) + share.wt = matrix(0, nperiods, n) + colnames(share.wt) = colnames(prices) + + + info = env( + cash = cash.wt, + share = share.wt + ) + if( !is.null(tax.control) ) { + info$dates = b$dates + info$tax = tax + info$tax.control = tax.control + info$holdings = holdings + } + + + last.trade = 0 + weight.last = weight1[1,] + + # need to speed up code for dividends invested in cash + # i.e. just put dividends to cash and go forward + + for(i in event.index) { + trade.invest.type = iif(trade.index[i], invest.type.def$rebalance, invest.type.def$none) + trade.today = trade.index[i] + + + + + + if(last.trade > 0) { + # copy from last trade + index = (last.trade + 1) : i + n.index = len(index) + share.wt[index,] = rep.row(info$share[last.trade,], n.index) + info$share[index,] = rep.row(info$share[last.trade,], n.index) + cash.wt[index] = info$cash[last.trade] + info$cash[index] = info$cash[last.trade] + + weight.last = weight1[i-1,] + } + + + + # unadjusted logic + if(!adjusted) { + if( trade.dividend[i] ) { + if( !is.null(tax.control) ) { + tax.update.dividends(tax.control, dividend.control, holdings, tax, info$share[i,], dividends[i,], i, b$dates) + } + + # for(a in which(info$share[i,] !=0 & dividends[i,] > 0)) + asset.cashflow = sum(info$share[i,] * dividends[i,] * + iif(info$share[i,] < 0, 1, 1 - dividend.control$foreign.withholding.tax) + ) + + info$cash[i] = info$cash[i] + asset.cashflow + cash.wt[i] = cash.wt[i] + asset.cashflow + div[i] = asset.cashflow + event.type[i] = event.type.def$dividend + + if(dividend.control$invest == invest.type.def$rebalance | dividend.control$invest == invest.type.def$update) { + trade.index[i] = T + if(trade.invest.type == invest.type.def$none) trade.invest.type = dividend.control$invest + } + } + + + + # check what happens if dividend and split are on the same day + if( trade.split[i] ) { + for(a in which(info$share[i,] !=0 & splits[i,] > 0)) + info$share[i,a] = share.wt[i,a] = info$share[i,a] / splits[i,a] + event.type[i] = event.type.def$split + + if( !is.null(tax.control) ) { + for(a in which(info$share[i,] !=0 & splits[i,] > 0)) { + holdings.split(holdings, a, splits[i,a]) + + n.trades = 1:holdings$n.trades[a] + holdings$price[n.trades,a] = holdings$price[n.trades,a] * splits[i,a] + } + + for(a in which(wash.sale$n.trades > 0 & splits[i,] > 0)) { + holdings.split(wash.sale, a, splits[i,a]) + + n.trades = 1:wash.sale$n.trades[a] + wash.sale$loss.per.share[n.trades,a] = wash.sale$loss.per.share[n.trades,a] * splits[i,a] + } + } + } + } + + # need to be completed / tested + if( trade.cashflow[i] ) { + + for(c in (1:cashflows$n)[cashflows$cash[i,] != 0]) { + if( !is.null(cashflows$fn[[c]]) ) { + cashflows$cash[i,c] = cashflows$fn[[c]](info, i, cashflows$last.index[c]) + } + + info$cash[i] = info$cash[i] + cashflows$cash[i,c] + + if(cashflows$type[c] == cashflow.type.def$regular) + cashflow[i] = cashflow[i] + cashflows$cash[i,c] + else + fee.rebate[i] = fee.rebate[i] + cashflows$cash[i,c] + + event.type[i] = event.type.def$cashflow + + cashflows$last.index[c] = i + + if(cashflows$invest[c] == invest.type.def$rebalance | cashflows$invest[c] == invest.type.def$update) { + trade.index[i] = T + if(trade.invest.type == invest.type.def$none) trade.invest.type = cashflows$invest[c] + } + } + } + + + # update share[i,] and cash[i] + if( trade.index[i] ) { + # if there is a big cashflow, we might want to override weight.change.index + # to set all to TRUE to work with full portfolio instead of subset + + weight.change.index = iif(trade.today, !is.na(weight[i,]), rep(T,n)) + + if(trade.invest.type == invest.type.def$rebalance) + out = bt.run.share.ex.allocate(weight.new = weight1[i,], weight.prev = weight.last, + weight.change.index = weight.change.index, + price = prices[i,], share = info$share[i,], cash = info$cash[i], + commission, lot.size, control = control$round.lot, + cashflow = cashflow[i] + fee.rebate[i] + div[i]) + + # update - minimally update portfolio to allocate cash + # only add new positions, such that abs(shares) only increases + if(trade.invest.type == invest.type.def$update) { + + + out = bt.run.share.ex.invest(weight.new = weight1[i,], weight.prev = weight.last, + weight.change.index = weight.change.index, + price = prices[i,], share = info$share[i,], cash = info$cash[i], + cashflow = cashflow[i] + fee.rebate[i] + div[i], + commission, lot.size, control = control$round.lot) + } + + if( !is.null(tax.control) && sum(info$share[i,] != out$share) > 0 ) { + + if( any(!equal.check(info$share[i,], sapply(1:n, function(a) sum(iif(holdings$n.trades[a] > 0, holdings$share[1:holdings$n.trades[a],a], 0)) )) ) ) + { + cat('Wrong Holdings', info$share[i,][5], '\n') + + + } + tax.update.holdings(tax.control, holdings, tax, wash.sale, + info$share[i,], out$share, prices[i,], i, b$dates) + } + + # only update current ones, not the ones used for weights + info$share[i,] = out$share + info$cash[i] = out$cash + com[i] = out$com + event.type[i] = event.type.def$trade + } + last.trade = i + } + + if( last.trade > 0 & last.trade < nperiods) { + # copy from last trade + index = (last.trade + 1) : nperiods + n.index = len(index) + share.wt[index,] = rep.row(info$share[last.trade,], n.index) + info$share[index,] = rep.row(info$share[last.trade,], n.index) + cash.wt[index] = info$cash[last.trade] + info$cash[index] = info$cash[last.trade] + } + + + #--------------------------------------------------------- + # setup output structure + #--------------------------------------------------------- + bt = list( + type = 'share', + capital = capital, + share = info$share, + cash = info$cash, + value = info$cash + rowSums(info$share * prices), + com = com, + div = div, + + weight = share.wt * prices / (cash.wt + rowSums(share.wt * prices)), + + event.type = factor(event.type, as.character(unlist(event.type.def)), names(event.type.def)) + ) + + if( cashflows$n > 0 ) { + bt$cashflows = cashflows$cash + + bt$cashflow = cashflow + bt$fee.rebate = fee.rebate + } + + if( !is.null(tax.control) ) { + bt$long.term.cap = tax$long.term.cap + bt$short.term.cap = tax$short.term.cap + bt$qualified.div = tax$qualified.div + bt$non.qualified.div = tax$non.qualified.div + } + + #--------------------------------------------------------- + # compute returns + #--------------------------------------------------------- + value = c(capital, bt$value) + bt$ret = (value / mlag(value) - 1)[-1] + if(sum(abs(cashflow)) > 0) { + # special logic to compute returns in case of cashflows, external money flows + # * negative cashflow: assume money will be taken out after the close + # return = (total value[T] without cashflow[T]) / total value[T-1] + index = cashflow < 0 + bt$ret[index] = (c(capital, bt$value - cashflow) / mlag(value) - 1)[-1][index] + + # * positive cashflow: assume money were availbale a day before and just sat in account + # return = (total value[T] including cashflow) / (total value[T-1] + cashflow[T]) + index = cashflow > 0 + value1 = c(capital, bt$value + mlag(cashflow, -1)) + bt$ret[index] = (value / mlag(value1) - 1)[-1][index] + } + + bt +} + + +# +# [Numerical Error] +# http://www.burns-stat.com/documents/tutorials/impatient-r/more-r-key-objects/more-r-numbers/ +# seq(0, 1, by=.1)[4] == .3 +# +# [Rmpfr package](https://cran.r-project.org/web/packages/Rmpfr/vignettes/Rmpfr-pkg.pdf) +# sum(mpfr(c(1100, 300, 1100, 500 , 500, 2000, 500), 80)/ 0.78) == (mpfr(6000,80)/ 0.78) +# +# a = c(1100, 300, 1100, 500 , 500, 2000, 500) / 0.78 +# b = 6000/ 0.78 +# sum(a) == b +# a[1]=a[1]- (sum(a) - b) +# sum(a) == b +# +# print(sum(a)-b,digits=20) +# +holdings.split = function(holdings, a, split) { + n.trades = 1:holdings$n.trades[a] + + sum.before.split = sum(holdings$share[n.trades,a]) / split + + holdings$share[n.trades,a] = holdings$share[n.trades,a] / split + + sum.after.split = sum(holdings$share[n.trades,a]) + + holdings$share[1,a] = holdings$share[1,a] + sum.before.split - sum.after.split +} + + +bt.run.share.ex.n.days = function(index.today, index.hist, dates) { + as.numeric(dates[index.today] - dates[index.hist]) +} + + + +#download both div and splits in ome file - getSplits +#http://ichart.finance.yahoo.com/x?s=IBM&a=00&b=2&c=1962&d=09&e=6&f=2015&g=v&y=0&z=30000 +# +# update dividends and compute taxes +tax.update.dividends = function(tax.control, dividend.control, holdings, tax, share, dividend, index, dates) +{ + # NOTES: + # + # dividend.control$foreign.withholding.tax are taken out from dividend cash when dividend is paid. i.e. + # asset.cashflow = sum(info$share[i,] * dividends[i,] * + # iif(info$share[i,] < 0, 1, 1 - dividend.control$foreign.withholding.tax) + # ) + # + # these amount can be claimed back; so we assume that it used to pay taxes. i.e. + # let's assume $100 dividend is due and there is 20% foreign.withholding.tax + # so only $80 dividend is paid + # + # let's also assume that there is a 20% tax on dividends; in that case taxes already paid and dividend is not considered fo tax calculations. i.e. + # qualified.div = dividend * (1 - dividend.control$foreign.withholding.tax / tax.control$dividend$qualified.tax) + # qualified.div = dividend * (1 - 20% / 20%) = dividend * 0 = 100 * 0 = 0 + # + # another example: assume 20% foreign.withholding.tax and 40% tax on dividends; in this case another $20 in taxes are due + # at 40% tax on dividends that corresponds to $50 dividend + # qualified.div = dividend * (1 - dividend.control$foreign.withholding.tax / tax.control$dividend$qualified.tax) + # qualified.div = dividend * (1 - 20% / 40%) = dividend * 0.5 = 100 * 0.5 = 50 + # + + + # offset by foreign.withholding.tax + qualified.div = dividend * (1 - dividend.control$foreign.withholding.tax / iif(tax.control$dividend$qualified.tax == 0, 1, tax.control$dividend$qualified.tax)) + non.qualified.div = dividend * (1 - dividend.control$foreign.withholding.tax / iif(tax.control$dividend$nonqualified.tax == 0, 1, tax.control$dividend$nonqualified.tax)) + qualified.div.adj = non.qualified.div.adj = 0 + + # long position, separate between qualified and non.qualified + pos.cashflow = share > 0 & dividend > 0 + # loop over all qualified divs + for(a in which(pos.cashflow & !tax.control$dividend$nonqualified)) { + n.trades = 1:holdings$n.trades[a] + trade.days = bt.run.share.ex.n.days(index, holdings$date[n.trades,a], dates) + + # find holdings that breach qualified.min.holding.period and move them from qualified to non.qualified + nonqualified.trade.days = trade.days < tax.control$dividend$qualified.min.holding.period + if(sum(nonqualified.trade.days) == 0) next + qualified.div.adj = qualified.div.adj - qualified.div[a] * sum(holdings$share[n.trades,a][nonqualified.trade.days]) + non.qualified.div.adj = non.qualified.div.adj + non.qualified.div[a] * sum(holdings$share[n.trades,a][nonqualified.trade.days]) + } + + tax$qualified.div[index] = tax$qualified.div[index] + qualified.div.adj + sum( + (share * qualified.div)[pos.cashflow & !tax.control$dividend$nonqualified] + ) + + tax$non.qualified.div[index] = tax$non.qualified.div[index] + non.qualified.div.adj + sum( + (share * non.qualified.div)[pos.cashflow & tax.control$dividend$nonqualified] + ) + + #http://www.fool.com/personal-finance/taxes/2002/12/06/dividends-paid-on-short-sales.aspx + # short position - add to cost basis + for(a in which(share < 0 & dividend > 0)) { + n.trades = 1:holdings$n.trades[a] + holdings$price[n.trades,a] = holdings$price[n.trades,a] - dividend[a] + } +} + + +# record wash sale, called every time there is a loosing trade +record.wash.sale = function(a, n.trades, pnl, price, trigger, holdings, wash.sale, tax.control) { + if( is.na(tax.control$capital.gain$wash.sale.min.holding.period) ) return() + + wash.sale.index = pnl[n.trades] < 0 + n.wash.sale.index = sum(wash.sale.index) + + if( n.wash.sale.index > 0 ) { + # increase size of arrays by 100 if needed to store trades + if( wash.sale$n.trades[a] + n.wash.sale.index > nrow(wash.sale$share) ) { + n = ncol(wash.sale$date) + wash.sale$date = rbind(wash.sale$date, matrix(0, 100, n)) + wash.sale$share = rbind(wash.sale$share, matrix(0, 100, n)) + wash.sale$loss.per.share = rbind(wash.sale$loss.per.share, matrix(0, 100, n)) + wash.sale$long.term = rbind(wash.sale$long.term, matrix(T, 100, n)) + } + + n1 = wash.sale$n.trades[a] + 1:n.wash.sale.index + wash.sale$date[n1,a] = holdings$date[n.trades,a][wash.sale.index] + wash.sale$share[n1,a] = holdings$share[n.trades,a][wash.sale.index] + wash.sale$loss.per.share[n1,a] = (price[a] - holdings$price[n.trades,a])[wash.sale.index] + wash.sale$long.term[n1,a] = trigger[n.trades][wash.sale.index] + wash.sale$n.trades[a] = wash.sale$n.trades[a] + n.wash.sale.index + } +} + +# check if wash sale took place, only called on new trade enrty +check.wash.sale = function(a, dates, tax, tax.control, holdings, wash.sale) { + # no losses recorded + if( is.na(tax.control$capital.gain$wash.sale.min.holding.period) || wash.sale$n.trades[a] == 0) return() + + i = holdings$n.trades[a] + index = holdings$date[i,a] + + n.trades = 1:wash.sale$n.trades[a] + trade.days = bt.run.share.ex.n.days(index , wash.sale$date[n.trades,a], dates) + trigger = trade.days <= tax.control$capital.gain$wash.sale.min.holding.period + n.trigger = sum(trigger) + + # all loses are past the wash.sale.min.holding.period + if( n.trigger == 0 ) { + wash.sale$n.trades[a] = 0 + return() + } + + + # detected wash sale, the proper way is to split trade to match number of shares for each loss trade + # we are simplifying here; no trade splitting, just cost adjusment + share1 = abs(holdings$share[i,a]) + run.share = cumsum(abs(wash.sale$share[n.trades,a][trigger])) + n1 = which( run.share > share1 ) + + # entry has more shares than loss + if( len(n1) == 0 || mlast(run.share) == share1 ) { + loss = wash.sale$loss.per.share[n.trades,a][trigger]*wash.sale$share[n.trades,a][trigger] + + holdings$price[i,a] = holdings$price[i,a] - sum(loss) / holdings$share[i,a] + wash.sale$n.trades[a] = 0 + + tax$long.term.cap[index] = tax$long.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger], loss, 0) ) + tax$short.term.cap[index] = tax$short.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger], 0, loss) ) + + return() + } + + # there are suffient losses + n1 = n1[1] + trigger.index = which(trigger) + + + # matching exactly + if( run.share[n1] == share1 ) { + loss = wash.sale$loss.per.share[n.trades,a][trigger][1:n1]*wash.sale$share[n.trades,a][trigger][1:n1] + + holdings$price[i,a] = holdings$price[i,a] - sum(loss) / holdings$share[i,a] + + tax$long.term.cap[index] = tax$long.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger][1:n1], loss, 0) ) + tax$short.term.cap[index] = tax$short.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger][1:n1], 0, loss) ) + + n1 = n1 + 1 + } else { + # split trade + share.left = run.share[n1] - share1 + last.index = trigger.index[n1] + wash.sale$share[last.index,a] = wash.sale$share[last.index,a] - share.left + + loss = wash.sale$loss.per.share[n.trades,a][trigger][1:n1]*wash.sale$share[n.trades,a][trigger][1:n1] + + holdings$price[i,a] = holdings$price[i,a] - sum(loss) / holdings$share[i,a] + + tax$long.term.cap[index] = tax$long.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger][1:n1], loss, 0) ) + tax$short.term.cap[index] = tax$short.term.cap[index] - sum( iif(wash.sale$long.term[n.trades,a][trigger][1:n1], 0, loss) ) + + wash.sale$share[last.index,a] = share.left + } + + # shift arrays + if(n1 > 1) { + from.index = trigger.index[n1]:wash.sale$n.trades[a] + to.index = 1:len(from.index) + wash.sale$date[to.index,a] = wash.sale$date[from.index,a] + wash.sale$share[to.index,a] = wash.sale$share[from.index,a] + wash.sale$loss.per.share[to.index,a] = wash.sale$loss.per.share[from.index,a] + wash.sale$long.term[to.index,a] = wash.sale$long.term[from.index,a] + wash.sale$n.trades[a] = len(to.index) + } +} + + + + + + + + +# update holdings and compute taxes +tax.update.holdings = function(tax.control, holdings, tax, wash.sale, share0, share1, price, index, dates) +{ + n = len(price) + + # NOTES: + # + # n.trades = 1:holdings$n.trades[a] + # share0 = sum(holdings$share[n.trades,a]) + # + # capital gains/loses + # sum(iif(share0 > share1, (share0 - share1)*(price-holdings$price[1,]), 0)) + # tax$short.term.cap[index] + tax$long.term.cap[index] + + if( any(!equal.check(share0, sapply(1:n, function(a) sum(iif(holdings$n.trades[a] > 0, holdings$share[1:holdings$n.trades[a],a], 0)) )) ) ) + cat('Mismatch holding shares', index, '\n') + + + for(a in (1:n)[share0 != share1]) { + n.trades = 1:holdings$n.trades[a] + + # flip + if( (share0[a] * share1[a]) <= 0) { + # liquidate all + if(share0[a] != 0) { + pnl = holdings$share[n.trades,a] * (price[a] - holdings$price[n.trades,a]) + trade.days = bt.run.share.ex.n.days(index, holdings$date[n.trades,a], dates) + trigger = trade.days > tax.control$capital.gain$long.term.min.holding.period + tax$long.term.cap[index] = tax$long.term.cap[index] + sum(iif(trigger, pnl, 0)) + tax$short.term.cap[index] = tax$short.term.cap[index] + sum(iif(trigger, 0, pnl)) + + # record losses for wash sale checking + record.wash.sale(a, n.trades, pnl, price, trigger, holdings, wash.sale, tax.control) + + holdings$n.trades[a] = 0 + } + # enter new position + if(share1[a] != 0) { + holdings$share[1,a] = share1[a] + holdings$price[1,a] = price[a] + holdings$date[1,a] = index + holdings$n.trades[a] = 1 +# wash sale - check +check.wash.sale(a, dates, tax, tax.control, holdings, wash.sale) + + + } else + holdings$n.trades[a] = 0 + } else { + # add + if( abs(share1[a]) > abs(share0[a]) ) { + # increase size of arrays by 100 if needed to store trades + if( holdings$n.trades[a] + 1 > nrow(holdings$share) ) { + holdings$share = rbind(holdings$share, matrix(0, 100, n)) + holdings$price = rbind(holdings$price, matrix(0, 100, n)) + holdings$date = rbind(holdings$date, matrix(0, 100, n)) + } + n1 = holdings$n.trades[a] + 1 + holdings$share[n1,a] = share1[a] - share0[a] + holdings$price[n1,a] = price[a] + holdings$date[n1,a] = index + holdings$n.trades[a] = n1 +# wash sale - check +check.wash.sale(a, dates, tax, tax.control, holdings, wash.sale) + } + + # remove, assume FIFO - first-in first-out + if( abs(share1[a]) < abs(share0[a]) ) { + remove.share = share0[a] - share1[a] + + pnl = holdings$share[n.trades,a] * (price[a] - holdings$price[n.trades,a]) + + trade.days = bt.run.share.ex.n.days(index, holdings$date[n.trades,a], dates) + trigger = trade.days > tax.control$capital.gain$long.term.min.holding.period + + run.share = cumsum(holdings$share[n.trades,a]) + n1 = which( abs(run.share) >= abs(remove.share) )[1] + + + # matching exactly + if( run.share[n1] == remove.share ) { + tax$long.term.cap[index] = tax$long.term.cap[index] + sum(iif(trigger, pnl, 0)[1:n1]) + tax$short.term.cap[index] = tax$short.term.cap[index] + sum(iif(trigger, 0, pnl)[1:n1]) + record.wash.sale(a, 1:n1, pnl, price, trigger, holdings, wash.sale, tax.control) + n1 = n1 + 1 + } else { + # split trade + share.left = run.share[n1] - remove.share + + #pnl[n1] = pnl[n1] - (holdings$share[n1,a] - share.left) * + # (price[a] - holdings$price[n1,a]) + pnl[n1] = pnl[n1] - share.left * + (price[a] - holdings$price[n1,a]) + + tax$long.term.cap[index] = tax$long.term.cap[index] + sum(iif(trigger, pnl, 0)[1:n1]) + tax$short.term.cap[index] = tax$short.term.cap[index] + sum(iif(trigger, 0, pnl)[1:n1]) + + holdings$share[n1,a] = holdings$share[n1,a] - share.left + record.wash.sale(a, 1:n1, pnl, price, trigger, holdings, wash.sale, tax.control) + + holdings$share[n1,a] = share.left + } + + # shift arrays + if(n1 > 1) { + from.index = n1:holdings$n.trades[a] + to.index = 1:len(from.index) + holdings$share[to.index,a] = holdings$share[from.index,a] + holdings$price[to.index,a] = holdings$price[from.index,a] + holdings$date[to.index,a] = holdings$date[from.index,a] + holdings$n.trades[a] = len(to.index) + } + } + } + + + if( !equal.check(share1[a], sum(iif(holdings$n.trades[a] > 0, holdings$share[1:holdings$n.trades[a],a], 0)))) + cat('a', a, index, '\n') + } + + if( any(!equal.check(share1, sapply(1:n, function(a) sum(iif(holdings$n.trades[a] > 0, holdings$share[1:holdings$n.trades[a],a], 0)) )) ) ) + cat('Mismatch holding shares', index, '\n') + + + +} + +equal.check = function(a,b,eps=1e-10) abs(a - b) < eps + + +############################################################################### +#' default.round.lot.control +#' @export +############################################################################### +default.round.lot.control = function() { + list( + # selects allocation that has + # best.match - smallest absolute deviation from target allocation + # minimum.turnover - minimum turnover and is within diff.target abs weight from best match + select = c('best.match', 'minimum.turnover'), + diff.target = 5/100 # only used if select = 'minimum.turnover' + ) +} + + +############################################################################### +#' minimally update portfolio to allocate cashflow +#' only add new positions, such that abs(shares) only increases +#' +#' @export +############################################################################### +bt.run.share.ex.invest = function +( + weight.new, + weight.prev, + weight.change.index, + price, + share, + cash, + cashflow, + commission, + lot.size, + silent=T, + # control allocation if round lot is enabled + control = default.round.lot.control() +) { +# Basic cases, try to satisfy with cash + if(cashflow >= 0) { + # do nothing - need to be corrected!!! + return(list(share = share, cash = cash, com = 0)) + } else { + # current cash + current.cash = sum(price * share) + cash - sum(price * abs(share)) + # value - long + current.cash = (sum(price * share) + cash) - sum((price * share)[share>0]) + if(current.cash >= 0) + return(list(share = share, cash = cash, com = 0)) + # otherwise continue to satisfy the cash requirement + } + +if(F) { +# Case A, simple: allocate abs(cashflow) proportionate to weight and to existing share / cash +# does not work for negative cashflows because we need cash to pay commissions + n = len(share) + out = bt.run.share.ex.allocate(weight.new = weight.new, weight.prev = rep(0, n), + weight.change.index = rep(T, n), + price = price, share = rep(0, n), cash = abs(cashflow), + commission, lot.size, control = control) + if(cashflow >= 0) + return(list(share = share + out$share, cash = (cash - cashflow) + out$cash, com = out$com)) + else { + out = bt.run.share.ex.allocate(weight.new = weight.new, weight.prev = rep(0, n), + weight.change.index = rep(T, n), + price = price, share = rep(0, n), cash = abs(cashflow) + 5 * out$com, + commission, lot.size, control = control) + + return(list(share = share - out$share, cash = cash + sum(share*price) - (sum((share - out$share)*price) + out$com), com = out$com)) + } +} + +# Case B, better: do full rebalance, +# for cashflow(+) freeze weights that has abs(share.new) < abs(share) and repeat +# for cashflow(-) freeze weights that has abs(share.new) > abs(share) and repeat + out = bt.run.share.ex.allocate(weight.new = weight.new, weight.prev = weight.prev, + weight.change.index = weight.change.index, + price = price, share = share, cash = cash, + commission, lot.size, control = control, + cashflow = cashflow) + if(cashflow >= 0) { + if( any(abs(out$share) < abs(share)) ) { + weight.change.index[abs(out$share) < abs(share)] = F + + out = bt.run.share.ex.allocate(weight.new = weight.new, weight.prev = weight.prev, + weight.change.index = weight.change.index, + price = price, share = share, cash = cash, + commission, lot.size, control = control) + } + } else { + if( any(abs(out$share) > abs(share)) ) { + weight.change.index[abs(out$share) > abs(share)] = F + + out = bt.run.share.ex.allocate(weight.new = weight.new, weight.prev = weight.prev, + weight.change.index = weight.change.index, + price = price, share = share, cash = cash, + commission, lot.size, control = control, + cashflow = cashflow) + } + } + + out +} + +############################################################################### +#' Do one period re balance +#' +#' @export +############################################################################### +bt.run.share.ex.allocate = function +( + weight.new, + weight.prev, + weight.change.index, + price, + share, + cash, + commission, + lot.size, + silent=T, + # control allocation if round lot is enabled + control = default.round.lot.control(), + cashflow = 0 +) { + # total value, as if everything is liquidated + value = sum(price * share) + cash + + + + + # make lot size fractional over-vise run into rounding problem# i.e. + # print(762.18,digits=20) + # 762.17999999999995 + # print(76218/100,digits=20) + # 762.17999999999995 + # print(76218*0.01,digits=20) + # 762.18000000000006 + #if( len(lot.size) > 0 && all(lot.size != 0) ) + # lot.size1 = sapply(lot.size, function(x) MASS:::.rat(x)$rat) + +# helper functions +compute.commission = function(share.prev, share.new, price, commission) { + if(is.null(dim(share.new))) { + share.diff = abs(share.prev - share.new) + return( + sum(share.diff) * commission$cps + sum(sign(share.diff)) * commission$fixed + sum(price * share.diff) * commission$percentage + ) + } + + share.prev = rep.row(share.prev, nrow(share.new)) + price = rep.row(price, nrow(share.new)) + + share.diff = abs(share.prev - share.new) + rowSums(share.diff) * commission$cps + rowSums(sign(share.diff)) * commission$fixed + rowSums(price * share.diff) * commission$percentage +} + +compute.cash = function(value, share, price, com) { + if(is.null(dim(share))) + value - sum(price * share) - com + else { + price = rep.row(price, nrow(share)) + value - rowSums(price * share) - com + } +} + +compute.weight.diff = function(target, share, cash) { + if(is.null(dim(share))) + sum(abs( + target - c(share * price, cash) / (sum(price * share) + cash) + )) + else { + price = rep.row(price, nrow(share)) + target = rep.row(target, nrow(share)) + rowSums(abs( + target - cbind(share * price, cash) / (rowSums(price * share) + cash) + )) + } +} + + +#new.cash = (1 - sum(weight.new)) * value +allocate = function(value, share) { + new.total.weight = sum(abs(weight.new[weight.change.index])) + if(new.total.weight == 0) + share[weight.change.index] = 0 + else { + allocate.value = value * sum(abs(weight.new)) - sum(abs(share * price)[!weight.change.index]) + + # weight = weight * (capital / prices) + share[weight.change.index] = + allocate.value * (weight.new / price)[weight.change.index] / new.total.weight + } + share +} + + + + +allocate.lot = function(value, share, lot.size) { + if( len(lot.size) == 0 || all(lot.size == 0) ) + return(rep.row(allocate(value, share), 3)) + + new.total.weight = sum(abs(weight.new[weight.change.index])) + if(new.total.weight == 0) { + shares = rep.row(share, 2) + shares[2, weight.change.index] = 0 + } else { + allocate.value = value * sum(abs(weight.new)) - sum(abs(share * price)[!weight.change.index]) + lot.size = lot.size[weight.change.index] + w = weight.new[weight.change.index]/ new.total.weight + p = price[weight.change.index] + + shares = rep.row(share, 3) + shares[2, weight.change.index] = round.lot.basic(w, p, allocate.value, lot.size) + shares[3, weight.change.index] = round.lot.basic.base(w, p, allocate.value, lot.size) + } + shares +} + + + + + # first allocate based on total value + new.share = allocate(value, share) + + # compute commisions + com = compute.commission(share, new.share, price, commission) + + # if commisions are due, allocate second time + # asuming commisions are paid out from total value upfront + if( com > 0 || len(lot.size) > 0 ) { + # might need to set aside more, due to nonlinear nature of commisions + # i.e. fixed commision was not active during first allocation, but is active during second one + share1 = allocate.lot(value - 2 * com, share, lot.size) + + # drop current allocation from possible ones + if( cashflow < 0 ) + if( (value - sum((price * share)[share > 0])) < 0 ) + share1 = share1[-1,,drop=F] + + # create list of possible portfolios and compute commisions, cash, weight diff + com1 = compute.commission(share, share1, price, commission) + cash1 = compute.cash(value, share1, price, com1) + + target = c(weight.new, 1 - sum(weight.new)) + diff1 = compute.weight.diff(target, share1, cash1) + + # select one of the portfolios + # weight diff best match + j = which.min(diff1) + + # minimum turnover match that is within 5% abs weight diff from best match + if( control$select[1] == 'minimum.turnover' ) { + j1 = which(diff1 - diff1[j] <= control$diff.target) + j = j1[which.min(com1[j1])] + } + + # select one + new.share = share1[j,] + com = com1[j] + } + + + # assume that total value does not change i.e. + # value = sum(price * share) + cash = sum(price * new.share) + new.cash + com + new.cash = value - sum(price * new.share) - com + +if(!silent) { + # check that value before and value after are the same factoring in commisions + cat('Old[T,V,C]', sum(price * share) + cash, sum(price * share), cash, '\n', + 'New [T,V,C,COM]', sum(price * new.share) + new.cash + com, sum(price * new.share), new.cash, com, '\n') + + # check that final weights are similar to desired weights + cat('Old Weight', weight.new, '\n', + 'New Weight', price * new.share / (sum(price * new.share) + new.cash), '\n') +} + + list(share = new.share, cash = new.cash, com = com) +} + + + + + +# Tests +bt.run.share.ex.allocate.test = function() { + + # Start with Cash + commission = list(cps = 0.0, fixed = 0.0, percentage = 0.0) + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + weight.prev = c(0,0) / 10 + share = c(0, 0) + price = c(1,2) + cash = 100 + lot.size=c() + + weight.new = c(10,0) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size,F) + + weight.new = c(-10,0) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size,F) + + weight.new = c(13,-3) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size, F) + + weight.new = c(2,8) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(0,8) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(0,8) / 10 + weight.change.index = c(F, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + + weight.new = c(-10,0) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(-10,0) / 10 + weight.change.index = c(T, F) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(13,-3) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(-10,10) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(10,10) / 10 + weight.change.index = c(T, T) + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + # Start with Allocation + weight.new = c(2,8) / 10 + weight.prev = c(0,8) / 10 + weight.change.index = c(T, F) + price = c(1,2) + share = c(0, 40) + cash = 20 + + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + + weight.new = c(2,8) / 10 + weight.prev = c(0,8) / 10 + weight.change.index = c(T, T) + price = c(1,2) + share = c(0, 40) + cash = 20 + + a = bt.run.share.ex.allocate(weight.new,weight.prev,weight.change.index,price,share,cash,commission,lot.size) + +} + + + +############################################################################### +#' Round Lot +#' a helper function for round.lot.basic +#' @export +############################################################################### +round.lot = function(weight, price, capital, lot.size) { + weight = coredata(ifna(weight, 0)) + price = coredata(ifna(price, 1)) + lot.size = ifna(iif( len(lot.size) == 1, rep(lot.size, ncol(weight)), lot.size), 1) + + round.lot.basic(weight, price, capital, lot.size) +} + +############################################################################### +#' Round Lot Basic Base +#' round lot to the nearest lot.size +#' @export +############################################################################### +round.lot.basic.base = function(weight, price, capital, lot.size) { + sign(weight) * floor(abs(weight * capital / price / lot.size)) * lot.size +} + +#' @export +round.to = function(x, to) { + sign(x) * floor(abs(x) / to) * to +} + +############################################################################### +#' Round Lot Basic +#' round lot to the nearest lot.size and next try to reallocate remaining cash +#' @export +############################################################################### +round.lot.basic = function(weight, price, capital, lot.size) { + share = abs(weight * capital) / price + share1 = floor(share / lot.size) * lot.size + + discrepancy = (share - share1) * price + cash = sum(discrepancy) + + lot.cash = price * lot.size + min.lot.cash = min(lot.cash) + + # handle 0 weights, MV seems to produce very tiny NEGATIVE weights + # let's round up to one share and use it instead of weight + index = (1:len(weight))[cash >= lot.cash & floor(abs(share)) != 0] + + for(i in order(discrepancy[index], decreasing=T)) { + if(cash < min.lot.cash) break + j = index[i] + if(cash < lot.cash[j]) next + + share1[j] = share1[j] + lot.size[j] + cash = cash - lot.cash[j] + } + + sign(weight) * share1 +} + +round.lot.basic.test = function() { + weight = c(1, 1, 1, 1) / 4 + price = c(1.345, 2.4, 3.5, 4.6) + capital = 100 + lot.size = c(1, 1, 1, 1) + + w = round.lot.basic(weight, price, capital, lot.size) + w + sum(abs(w * price)) + + weight = c(1, -1, 3, -1) / 4 + + w = round.lot.basic(weight, price, capital, lot.size) + w + sum(abs(w * price)) + w = (weight * capital) / price + w + sum(abs(w * price)) +} + + +############################################################################### +#' Test for bt.run.share.ex functionality +#' @export +############################################################################### +bt.run.share.ex.test = function() { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'SPY' + tickers = 'SPY,XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU' + + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + #***************************************************************** + # Buy Hold + #****************************************************************** + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test = bt.run.share(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex.lot = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, lot.size=50) + + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex.lot.turnover = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, + lot.size=50, control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)) + ) + + # check shares + last(models$test.ex.lot$share[period.ends,], 20) + + + + #***************************************************************** + # Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + layout(1:3) + plotbt.transition.map(models$test$weight, 'BuyHold') + plotbt.transition.map(models$test.ex$weight, 'BuyHold.ex') + plotbt.transition.map(models$test.ex.lot$weight, 'BuyHold.ex') + + layout(1:3) + plot(models$test.ex.lot$value, type='l') + plot(models$test.ex.lot$cash[-c(1:20)], type='l') + plot(models$test.ex.lot$com, type='l') + + + # put all reports into one pdf file + pdf(file = 'report1.pdf', width=8.5, height=11) + + strategy.performance.snapshoot(models, data=data) + + dev.off() + + + + #***************************************************************** + # Another test + #****************************************************************** + models = list() + + commission = list(cps = 0.01, fixed = 10.0, percentage = 0.0) + + obj = portfolio.allocation.helper(data$prices, + period.ends = period.ends, lookback.len = 250, silent=T, + min.risk.fns = list( + EW=equal.weight.portfolio, + RP=risk.parity.portfolio(function(ia) ia$risk), + MV=min.var.portfolio, + Sharpe.RP=risk.parity.portfolio(function(ia) ia$risk / ia$expected.return) + ) + ) + + for(i in names(obj$weights)) { + data$weight[] = NA + data$weight[period.ends,] = obj$weights[[i]] + models[[paste0(i)]] = bt.run.share(data, clean.signal=F, silent=T, commission=commission) + + data$weight[] = NA + data$weight[period.ends,] = obj$weights[[i]] + models[[paste0(i,'.ex')]] = bt.run.share.ex(data, clean.signal=F, silent=T, commission=commission) + + data$weight[] = NA + data$weight[period.ends,] = obj$weights[[i]] + models[[paste0(i,'.ex.lot')]] = bt.run.share.ex(data, clean.signal=F, silent=T, commission=commission, lot.size=50) + + data$weight[] = NA + data$weight[period.ends,] = obj$weights[[i]] + models[[paste0(i,'.ex.lot.turnover')]] = bt.run.share.ex(data, clean.signal=F, silent=T, commission=commission, + lot.size=50, control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100))) + + } + + + # check shares + range(models$MV.ex.lot$share) + + #***************************************************************** + # Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + + # put all reports into one pdf file + pdf(file = 'report2.pdf', width=8.5, height=11) + + strategy.performance.snapshoot(models, data=data) + + dev.off() + + + + #***************************************************************** + # Example of using round lot externally + #****************************************************************** + weight = rep(1/n, n) + price = coredata(last(prices)) + share = rep(0, n) + cash = 100000 + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + lot.size = rep(100, n) + + bt.run.share.ex.allocate(weight, weight, rep(T, n), + price, share, cash, commission, lot.size) + +} + + + + +############################################################################### +#' Append dividend and split columns +#' @export +############################################################################### +bt.unadjusted.add.div.split = function( + data.raw, + yahoo.round.up.nearest.cents=F, + infer.div.split.from.adjusted=F # caution, please see example in test.implied.div.split +) { + if( !exists('symbolnames', data.raw, inherits = F) ) + tickers = ls(data.raw) + else + tickers = data.raw$symbolnames + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** + for(ticker in spl(tickers)) { + price = data.raw[[ticker]] + price$Dividend = price$Split = 0 + + if(infer.div.split.from.adjusted) { + close = coredata(Cl(price)) + adjusted = coredata(Ad(price)) + +#Determine Dividend and Split from adjusted and un-adjusted prices +#Implied Dividend: (Pt1+Dt1)/Pt0 = At1/At0 => Dt1 = Pt0 * At1/At0 - Pt1 +#Implied Split: St1 * Pt1/Pt0 = At1/At0 => St1 = Pt1/Pt0 * At0/At1 + implied.split = close / mlag(close) * mlag(adjusted) / adjusted + isplit.index = ifna(implied.split < 0.9 | implied.split > 1.2,F) + isplit = implied.split[isplit.index] + isplit = round(100 * isplit) / 100 + + implied.div = mlag(close) * adjusted / mlag(adjusted) - close + idiv.index = ifna(implied.div > 1e-3, F) & !isplit.index + idiv = implied.div[idiv.index] + idiv = round(1e3 * idiv) / 1e3 + + price$Dividend[idiv.index] = idiv + price$Split[isplit.index] = isplit + + + } else { + # need full history + dividend = getDividends(ticker, from = '1900-01-01') + split = getSplits(ticker, from = '1900-01-01') + split = split[split > 0] + dividend = dividend[dividend > 0] + +# un-adjust split, faster version of adjRatios(splits=merge(split, index(dividend)))[,1] +#split1 = split +# split1[] = rev(cumprod(rev(coredata(split)))) +#x = mlag(merge(split1, index(dividend)), -1) +#x[] = ifna(x[ifna.prevx.rev(x)],1) +##all(x == adjRatios(splits=merge(split, index(dividend)))[,1]) + + + # Please see quantmod:::adjustOHLC for more details + # un-adjust dividends for splits (Yahoo already adjusts div for splits) + if(is.xts(split) && is.xts(dividend) && nrow(split) > 0 && nrow(dividend) > 0) + dividend = dividend * 1/adjRatios(splits=merge(split, index(dividend)))[,1] + + # use unadjusted dividends to compute retruns based on Close + dividend = dividend[index(price)] + split = split[index(price)] + + # http://www.theglobeandmail.com/globe-investor/investor-education/four-dividend-dates-every-investor-needs-to-know/article19273251/ + if( is.xts(dividend) && nrow(dividend) > 0 ) + if( nrow(price[index(dividend)]) != nrow(dividend) ) + stop(paste('Missing Price date for dividend. Symbol =', ticker)) + else + price$Dividend[index(dividend)] = dividend + + if( is.xts(split) && nrow(split) > 0 ) + if( nrow(price[index(split)]) != nrow(split) ) + stop(paste('Missing Price date for split. Symbol =', ticker)) + else + price$Split[index(split)] = split + } + + # round up to the nearest cents - this is the only way to match IBM prices + if(yahoo.round.up.nearest.cents) { + map.col = unlist(find.names('Close,Open,High,Low,Adjusted', price, F)) + price[,map.col] = ceiling(100 * price[,map.col]) / 100 + } + + data.raw[[ticker]] = price + } +} + + + +#Determine Dividend and Split from adjusted and un-adjusted prices +#Implied Dividend: (Pt1+Dt1)/Pt0 = At1/At0 => Dt1 = Pt0 * At1/At0 - Pt1 +#Implied Split: St1 * Pt1/Pt0 = At1/At0 => St1 = Pt1/Pt0 * At0/At1 +test.implied.div.split = function(ticker) { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + ticker = 'IBM' + + data <- new.env() + getSymbols.extra(ticker, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + + # need full history + dividend = getDividends(ticker, from = '1900-01-01') + split = getSplits(ticker, from = '1900-01-01') + + # un-adjust dividends for splits (Yahoo already adjusts div for splits) + if(is.xts(split) && is.xts(dividend) && nrow(split) > 0 && nrow(dividend) > 0) + dividend1 = dividend * 1/adjRatios(splits=merge(split, index(dividend)))[,1] + else + dividend1 = dividend + + close = Cl(data$IBM) + adjusted = Ad(data$IBM) + + implied.split = close / mlag(close) * mlag(adjusted) / adjusted + isplit.index = implied.split < 0.8 | implied.split > 1.2 + isplit = implied.split[isplit.index] + isplit = round(100 * isplit) / 100 + + cbind(isplit['1970::'], split['1970::']) + + implied.div = mlag(close) * adjusted / mlag(adjusted) - close + idiv.index = implied.div > 1e-3 + idiv = implied.div[idiv.index & !isplit.index] + idiv = round(1e3 * idiv) / 1e3 + len(idiv['1970::']) + len(dividend1['1970::']) + + setdiff( index(dividend1['1970::']), index(idiv['1970::'])) + setdiff( index(idiv['1970::']), index(dividend1['1970::']) ) + + cbind(idiv['1970::'], dividend1['1970::']) + + #***************************************************************** + # Check DOW components + #***************************************************************** + tickers = dow.jones.components() + +for(ticker in tickers) { + + data <- new.env() + getSymbols.extra(ticker, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + + # need full history + dividend = getDividends(ticker, from = '1900-01-01') + split = getSplits(ticker, from = '1900-01-01') + split = split[split > 0] + dividend = dividend[dividend > 0] + + # un-adjust dividends for splits (Yahoo already adjusts div for splits) + if(is.xts(split) && is.xts(dividend) && nrow(split) > 0 && nrow(dividend) > 0) + dividend1 = dividend * 1/adjRatios(splits=merge(split, index(dividend)))[,1] + else + dividend1 = dividend + + close = Cl(data[[ticker]]) + adjusted = Ad(data[[ticker]]) + + implied.split = close / mlag(close) * mlag(adjusted) / adjusted + isplit.index = ifna(implied.split < 0.9 | implied.split > 1.1, F) + isplit = implied.split[isplit.index] + isplit = round(100 * isplit) / 100 + + if(len(isplit)>0) + cat(ticker, 'SPL', len(isplit['1970::']) - len(split['1970::']), max(round(isplit['1970::'],3) - round(split['1970::'],3)), '\n') + else + cat(ticker, 'SPL', len(isplit['1970::']) - len(split['1970::']), '\n') + #cbind(round(isplit['1970::'],3), round(split['1970::'],3)) + + implied.div = mlag(close) * adjusted / mlag(adjusted) - close + idiv.index = ifna(implied.div > 1e-3, F) + idiv = implied.div[idiv.index & !isplit.index] + idiv = round(1e3 * idiv) / 1e3 + len(idiv['1970::']) + len(dividend1['1970::']) + + cat(ticker, 'DIV', len(idiv['1970::']) - len(dividend1['1970::']), + len(setdiff( index(dividend1['1970::']), index(idiv['1970::']))), + len(setdiff( index(idiv['1970::']), index(dividend1['1970::']) )), + max(round(idiv['1970::'],3)- round(dividend1['1970::'],3)), '\n') + + setdiff( index(dividend1['1970::']), index(idiv['1970::'])) + setdiff( index(idiv['1970::']), index(dividend1['1970::']) ) + + #cbind(round(idiv['1970::'],3), round(dividend1['1970::'],3)) +} + +} + +#***************************************************************** +# Problems with infered div and split data +#***************************************************************** +# KO has wrong dividned, split adjusted, there is Aug 13, 2012 2: 1 Stock Split +# http://finance.yahoo.com/q/hp?s=KO&a=00&b=2&c=1962&d=09&e=14&f=2015&g=v +# Nov 28, 2001 0.09 Dividend +# Sep 12, 2001 0.18 Dividend +# Jun 13, 2001 0.09 Dividend +# +# http://www.nasdaq.com/symbol/ko/dividend-history +# 11/28/2001 Cash 0.18 -- 11/28/2001 -- +# 6/13/2001 Cash 0.18 -- 6/15/2001 -- +# 3/13/2001 Cash 0.18 -- 3/15/2001 -- +# +# implied dividend is correct +#http://finance.yahoo.com/q/hp?s=KO&a=08&b=2&c=2001&d=09&e=14&f=2001&g=d +#> idiv['2001'] +#2001-03-13 0.176 +#2001-06-13 0.180 +#2001-09-17 0.218 +#2001-11-28 0.176 +# +#============================================================ +# +# DIS split is not detected +#http://finance.yahoo.com/q/hp?s=DIS&a=00&b=2&c=1962&d=09&e=14&f=2015&g=v +#Jun 13, 2007 1014: 1000 Stock Split +# +#============================================================ +# +# DD split is not detected +#http://finance.yahoo.com/q/hp?s=DD&a=00&b=2&c=1962&d=09&e=14&f=2015&g=v +#Jul 1, 2015 1053: 1000 Stock Split +# => hence incorrect div is implied +# +#============================================================ +# +# MSFT big div is treated as split +# Nov 15, 2004 3.08 Dividend +# http://finance.yahoo.com/q/hp?s=MSFT&a=02&b=13&c=1986&d=09&e=14&f=2015&g=v +# +#============================================================ +# +# PG has split and div on the same day +#May 19, 1970 0.02188 Dividend +#May 19, 1970 2: 1 Stock Split +#http://finance.yahoo.com/q/hp?s=PG&a=00&b=2&c=1970&d=09&e=14&f=2015&g=v&z=66&y=132 +# +#============================================================ +# +# VZ missing splits -spinoffs +#Jul 2, 2010 1000000: 937889 Stock Split +#Apr 1, 2008 100000: 99537 Stock Split +#Nov 20, 2006 100000: 96334 Stock Split +# +#============================================================ + + + +############################################################################### +#' Test for bt.run.share.unadjusted functionality +#' @export +############################################################################### +bt.run.share.unadjusted.test.data = function() { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'IBM' + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + #bt.start.dates(data) + + # copy unadjusted prices + data.raw = env(data) + + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** + bt.unadjusted.add.div.split(data.raw, yahoo.round.up.nearest.cents = T) + + + #***************************************************************** + # Look at the data for IBM + #****************************************************************** + ticker = 'IBM' + # adjusted + adjusted = data.raw[[ticker]]$Adjusted / mlag(data.raw[[ticker]]$Adjusted) - 1 + adjusted = ifna(adjusted,0) + prod(1 + adjusted) + + # unadjusted + split = iif(data.raw[[ticker]]$Split > 0, 1 / data.raw[[ticker]]$Split, 1) + unadjusted = (data.raw[[ticker]]$Close * split + data.raw[[ticker]]$Dividend) / mlag(data.raw[[ticker]]$Close) - 1 + unadjusted = ifna(unadjusted,0) + prod(1 + unadjusted) + + # look at diffs + index = which(round(adjusted - unadjusted,4) != 0) + cbind(round(adjusted - unadjusted, 4), data.raw[[ticker]]$Split, data.raw[[ticker]]$Dividend)[index] + + plota.matplot(cbind(cumprod(1 + adjusted),cumprod(1 + unadjusted))) + + # look at most extreme one + index.max = which.max(abs(adjusted - unadjusted)) + cbind(adjusted, unadjusted, round(adjusted - unadjusted, 4), data.raw[[ticker]]$Split, data.raw[[ticker]]$Dividend)[index.max] + data.raw[[ticker]][(index.max-1):index.max,] + + # http://finance.yahoo.com/q/hp?s=IBM&a=10&b=4&c=1992&d=10&e=5&f=1992&g=d + (65.875 + 0.3025) / 68.250 - 1 + 12.04279 / 12.25577 - 1 + + # https://www.google.com/finance/historical?cid=18241&startdate=Nov+4+1992&enddate=Nov+5+1992 + 16.47 /17.06 -1 + + # www.quantshare.com/sa-43-10-ways-to-download-historical-stock-quotes-data-for-free + # http://www.quotemedia.com/finance/quote/?qm_page=13863&qm_symbol=IBM + #http://app.quotemedia.com/quotetools/getHistoryDownload.csv?&webmasterId=501&startDay=02&startMonth=11&startYear=1992&endDay=02&endMonth=12&endYear=1992&isRanged=false&symbol=IBM + 8.4485 / 7.8843 - 1 + + + # not working anymore + # http://moneycentral.msn.com/investor/charts/chartdl.aspx?PT=11&compsyms=&D4=1&DD=1&D5=0&DCS=2&MA0=0&MA1=0&CF=0&D7=&D6=&showtablbt=View+price+history+with+dividends%2Fsplits&symbol=IBM&nocookie=1&SZ=0 + + yhist = read.xts(hist.quotes.url('IBM', '1992-11-01', '1992-11-30', 'yahoo')) + ghist = read.xts(hist.quotes.url('IBM', '1992-11-01', '1992-11-30', 'google'), format='%d-%b-%y') + qhist = read.xts(hist.quotes.url('IBM', '1992-11-01', '1992-11-30', 'quotemedia')) + + # quantmod:::adjustOHLC + # TTR:::adjRatios + dividends = getDividends('IBM', from = '1900-01-01') + splits = getSplits('IBM', from = '1900-01-01') + +dividends['1992:11::1992:11'] + + # un-adjust dividends for splits (Yahoo already adjusts div for splits) + if(is.xts(splits) && is.xts(dividends) && nrow(splits) > 0 && nrow(dividends) > 0) + dividends = dividends * 1/adjRatios(splits=merge(splits, index(dividends)))[,1] + +dividends['1992:11::1992:11'] + + # use unadjusted dividends to compute retruns based on Close + dividend = dividends[index(yhist)] + + yhist = yhist[,spl('Close,Adj_Close')] + colnames(yhist) = spl('Yahoo.Close,Yahoo.Adjusted') + yhist$Dividend = 0 + yhist$Dividend[index(dividend)] = dividend + yhist + + ghist = ghist[,'Close'] + colnames(ghist) = spl('Google.Adjusted') + + qhist = qhist[,c('close', 'adjclose')] + colnames(qhist) = spl('Quotemedia.Close,Quotemedia.Adjusted') + + temp = cbind(yhist, ghist, qhist) + temp[,spl('Yahoo.Close,Dividend,Quotemedia.Close')] + + to.return = function(x) round(100*(x/mlag(x)-1),3) + + Yahoo.Return = to.return(temp$Yahoo.Close + temp$Dividend) + + # round up to the nearest cents - this is the only way to match IBM prices + Yahoo.Return1 = to.return(ceiling(100*temp$Yahoo.Close)/100 + temp$Dividend) + + Yahoo.Return.Adjusted = to.return(temp$Yahoo.Adjusted) + + Google.Return.Adjusted = to.return(temp$Google.Adjusted) + + Quotemedia.Return = to.return(temp$Quotemedia.Close + temp$Dividend) + Quotemedia.Return.Adjusted = to.return(temp$Quotemedia.Adjusted) + + ret = cbind(Yahoo.Return, Yahoo.Return1, Yahoo.Return.Adjusted, Google.Return.Adjusted, Quotemedia.Return, Quotemedia.Return.Adjusted) + t(apply(ret,1,range)) + t(diff(apply(ret,1,range))) + ret['1992:11:05'] + + +# https://www.ibm.com/investor/financials/ +# The dividend rate per share is the actual amount paid per share. No adjustments were made for stock splits. +# Dividend number 311 +# Rate per share 1.21 +# Payable date 12/10/92 +# Record date 11/12/92 +# +# Split +# Record date 5/10/79 +# Payment date 5/31/79 +# Stock dividend or split 4 for 1 Stock Split +# +# Prices +txt = ' +Date Open High Low Close Volume +Nov-2-1992 67.00 69.00 67.00 68.88 2,322,100 +Nov-3-1992 68.50 69.88 68.50 69.13 2,375,200 +Nov-4-1992 69.00 69.63 68.13 68.25 2,079,800 +Nov-5-1992 67.13 67.25 65.63 65.88 2,136,200 +Nov-6-1992 65.38 66.50 65.00 66.25 2,642,300 +Nov-9-1992 66.25 67.63 66.25 67.50 2,216,400 +Nov-10-1992 67.63 68.00 65.88 65.88 2,187,100 +Nov-11-1992 65.63 65.75 64.50 65.00 3,145,100 +Nov-12-1992 65.13 65.38 64.13 64.13 3,133,000 +Nov-13-1992 64.88 65.13 64.00 64.88 1,851,300 +Nov-16-1992 64.75 65.50 64.63 64.88 1,765,100 +Nov-17-1992 64.88 65.00 64.00 64.25 2,020,700 +Nov-18-1992 64.13 64.38 62.75 63.13 2,707,100 +Nov-19-1992 63.00 63.13 61.00 61.25 3,307,600 +Nov-20-1992 61.38 62.63 60.88 62.25 3,715,200 +Nov-23-1992 62.38 63.88 62.25 63.25 2,220,200 +Nov-24-1992 63.75 65.50 63.50 64.88 2,847,100 +Nov-25-1992 65.38 66.00 65.13 65.38 1,788,700 +Nov-27-1992 65.88 66.25 65.25 66.00 1,229,500 +Nov-30-1992 67.88 68.63 67.50 68.25 3,239,000 +' + +IBM = read.xts(txt,sep=' ', format='%b-%d-%Y') + IBM = IBM[,'Close'] + colnames(IBM) = spl('IBM.Close') + + IBM$Dividend = 0 + IBM$Dividend['1992:11:05'] = 1.21 + + IBM.Return = to.return(IBM$IBM.Close + IBM$Dividend) + + ret = cbind(IBM.Return, Yahoo.Return, Yahoo.Return1, Yahoo.Return.Adjusted, Google.Return.Adjusted, Quotemedia.Return, Quotemedia.Return.Adjusted) + ret['1992:11:05'] + + ret$IBM.Close - ret$Yahoo.Close.1 + + # http://www.dividend.com/dividend-stocks/technology/diversified-computer-systems/ibm-ibm-corp/ + +# looks like dividends are split adjusted by yahoo + + # all due to dividends + setdiff(index, which(data.raw[[ticker]]$Dividend > 0)) + + # remove diffs + temp.adjusted = adjusted + temp.adjusted[index] = 0 + prod(1 + temp.adjusted) + + temp.unadjusted = unadjusted + temp.unadjusted[index] = 0 + prod(1 + temp.unadjusted) + + plota.matplot(cbind(cumprod(1 + temp.adjusted),cumprod(1 + temp.unadjusted))) + +} + + +############################################################################### +#' Summarize bt.run.share.ex events +#' @export +############################################################################### +bt.make.trade.event.summary.table = function(bt, to.text=F) { + index = bt$event.type != 'none' + + # create summary table: event.type, date, shares, cash, com, div, value + out = data.frame( + Type = bt$event.type, + bt$share, + Cash=bt$cash, + Com=bt$com, + Div=bt$div, + Value=bt$value + )[index,] + rownames(out) = format(index(bt$equity)[index], '%Y-%m-%d') + + if(to.text) to.nice(out,0) + else out +} + +############################################################################### +#' Summarize bt.run.share.ex events +#' @export +############################################################################### +bt.make.cashflow.event.summary.table = function(bt, to.text=F) { + if( is.null(bt$cashflow) ) return() + + + index = rowSums(bt$cashflows != 0) > 0 + + # create summary table: event.type, date, shares, cash, com, div, value + out = data.frame( + Cashflow = bt$cashflow, + Fee.Rebate = bt$fee.rebate, + bt$cashflows + )[index,] + rownames(out) = format(index(bt$equity)[index], '%Y-%m-%d') + + if(to.text) to.nice(out,0) + else out +} + + +############################################################################### +#' Test for bt.run.share.unadjusted functionality +#' @export +############################################################################### +bt.run.share.unadjusted.test = function() { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'IBM' + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + #bt.start.dates(data) + + # copy unadjusted prices + data.raw = env(data) + data.raw1 = env(data) + + # adjusted prices + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + + #***************************************************************** + # Base SIT Back-test + #****************************************************************** + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = 1 + models$test = bt.run.share(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = 1 + models$test.ex = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, + lot.size=1) + + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** + bt.unadjusted.add.div.split(data.raw, yahoo.round.up.nearest.cents = T) + + bt.prep(data.raw, align='remove.na', fill.gaps = T) + + + #***************************************************************** + # Setup + #***************************************************************** + prices = data.raw$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data.raw$prices,'months') + + #models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + + #***************************************************************** + # New Back-test + #****************************************************************** + data.raw$weight[] = NA + #data.raw$weight[1,] = 1 + data.raw$weight[period.ends,] = 1 + models$test.unadjusted = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, adjusted = F) + + + + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** +data.raw = data.raw1 + bt.unadjusted.add.div.split(data.raw, yahoo.round.up.nearest.cents = T, infer.div.split.from.adjusted=T) + + bt.prep(data.raw, align='remove.na', fill.gaps = T) + + + #***************************************************************** + # Setup + #***************************************************************** + prices = data.raw$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data.raw$prices,'months') + + #models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + + #***************************************************************** + # New Back-test + #****************************************************************** + data.raw$weight[] = NA + #data.raw$weight[1,] = 1 + data.raw$weight[period.ends,] = 1 + models$test.unadjusted1 = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, adjusted = F) + + + + + + #***************************************************************** + # Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + layout(1:2) + plotbt.transition.map(models$test.ex$weight) + plotbt.transition.map(models$test.unadjusted$weight) + + + # create table + mlast(bt.make.trade.event.summary.table(models$test.unadjusted), 20) + + + + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'SPY' + tickers = 'SPY,XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU' + tickers = 'AAPL,IBM,VTI,IEV,EWJ,EEM,RWX,DBC,GLD,TLT,IEF,SHY' + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + #bt.start.dates(data) + + # copy unadjusted prices + data.raw = env(data) + + # adjusted prices + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + + #***************************************************************** + # Base SIT Back-test + #****************************************************************** + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test = bt.run.share(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, + lot.size=50) + + + #***************************************************************** + # Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + plotbt.transition.map(models$test.ex$weight) + +#***************************************************************** +# New Back-test +#****************************************************************** + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** + #data.raw1 = env(data.raw) + #data.raw = data.raw1 + #bt.unadjusted.add.div.split(data.raw, infer.div.split.from.adjusted=T) + bt.unadjusted.add.div.split(data.raw) + + bt.prep(data.raw, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data.raw$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data.raw$prices,'months') + + #models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + + #***************************************************************** + # New Back-test + #****************************************************************** + data.raw$weight[] = NA + data.raw$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.unadjusted = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, adjusted = F) + + data.raw$weight[] = NA + data.raw$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.unadjusted1 = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, + adjusted = F, + control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + dividend.control = list(foreign.withholding.tax = 30/100) + ) + + #***************************************************************** + # Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + layout(1:2) + plotbt.transition.map(models$test.unadjusted$weight) + plotbt.transition.map(models$test.unadjusted1$weight) + + # create table + mlast(bt.make.trade.event.summary.table(models$test.unadjusted), 20) + + + + # put all reports into one pdf file + pdf(file = 'report.u.pdf', width=8.5, height=11) + + strategy.performance.snapshoot(models, data=data) + + dev.off() + + + + +} + + + +############################################################################### +#' Test for bt.run.share.ex cashflow functionality +#' @export +############################################################################### +bt.run.share.ex.test.cashflow = function() { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'SPY' + tickers = 'SPY,XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU' + + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + #***************************************************************** + # Buy Hold + #****************************************************************** + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test = bt.run.share(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex.lot = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, lot.size=50) + + data$weight[] = NA + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$test.ex.lot.cashflow = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, + lot.size=50, + cashflow.control = list( + monthly.income = list( + cashflows = event.at(prices, 'quarter', 1000, offset=0), + invest = 'cash', + type = 'regular' + ) + ) + ) + + # info tables + mlast(bt.make.trade.event.summary.table(models$test.ex.lot.cashflow), 20) + + mlast(bt.make.cashflow.event.summary.table(models$test.ex.lot.cashflow), 20) + + matplot(cbind( + models$test.ex.lot$value, + models$test.ex.lot.cashflow$value + ), type='l') + + + #***************************************************************** + # Report + #****************************************************************** + #strategy.performance.snapshoot(models, T) + + #plotbt.transition.map(models$test.unadjusted$weight) + + # put all reports into one pdf file + pdf(file = 'report.c.pdf', width=8.5, height=11) + strategy.performance.snapshoot(models, data=data) + dev.off() +} + + + +# Tests +bt.run.share.ex.invest.test = function() { + + # Start with Cash + #commission = list(cps = 0.0, fixed = 0.0, percentage = 0.0) + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + weight.prev = c(10,0) / 10 + share = c(100, 0) + price = c(1,2) + cash = 0 + lot.size=c() + + weight.new = c(10,0) / 10 + weight.change.index = c(T, T) + cashflow = -10 + cash = cash + cashflow + + a = bt.run.share.ex.invest(weight.new,weight.prev,weight.change.index,price,share,cash,cashflow,commission,lot.size,F) + + a + + + +} + + +############################################################################### +#' Test for bt.run.share.ex tax functionality +#' @export +############################################################################### +bt.run.share.ex.test.tax = function() { + #***************************************************************** + # Load historical data + #***************************************************************** + load.packages('quantmod') + + tickers = 'SPY' + tickers = 'SPY,XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU' + tickers = 'AAPL,IBM,VTI,IEV,EWJ,EEM,RWX,DBC,GLD,TLT,IEF,SHY' + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T, set.symbolnames=T) + #bt.start.dates(data) + + # copy unadjusted prices + data.raw = env(data) + + # adjusted prices + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** +#source('../bt.share.r') + + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 1.0, percentage = 0.0) + + weights = ntop(prices[period.ends,], n) + + #***************************************************************** + # Buy Hold + #****************************************************************** + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = weights + models$test = bt.run.share(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = weights + models$test.ex = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission) + + data$weight[] = NA + #data$weight[1,] = 1 + data$weight[period.ends,] = weights + models$test.ex.lot = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, lot.size=50) + + + data$weight[] = NA + data$weight[period.ends,] = weights + models$test.ex.lot.tax = bt.run.share.ex(data, clean.signal=F, silent=F, commission=commission, + lot.size=50, + control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + + # enable taxes + tax.control = default.tax.control(), + cashflow.control = list( + taxes = list( + cashflows = event.at(prices, 'year', offset=60), + cashflow.fn = tax.cashflows, + invest = 'cash', + type = 'fee.rebate' + ) + ) + ) + + + + # info tables + mlast(bt.make.trade.event.summary.table(models$test.ex.lot.tax), 20) + + mlast(bt.make.cashflow.event.summary.table(models$test.ex.lot.tax), 20) + + + #***************************************************************** + # Report + #****************************************************************** + #strategy.performance.snapshoot(models, T) + + #plotbt.transition.map(models$test.unadjusted$weight) + + # put all reports into one pdf file + pdf(file = 'report.t.pdf', width=8.5, height=11) + + strategy.performance.snapshoot(models, data=data) + + dev.off() + + + + + + + + #***************************************************************** + # For each asset, append dividend and split columns + #****************************************************************** + bt.unadjusted.add.div.split(data.raw) + + bt.prep(data.raw, align='remove.na', fill.gaps = T) + + + #***************************************************************** + # New Back-test + #****************************************************************** + data.raw$weight[] = NA + data.raw$weight[period.ends,] = weights + models$test.unadjusted = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, adjusted = F) + + data.raw$weight[] = NA + data.raw$weight[period.ends,] = weights + models$test.unadjusted1 = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, + adjusted = F, + control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + dividend.control = list(foreign.withholding.tax = 30/100) + ) + + + + data$weight[] = NA + data$weight[period.ends,] = weights + models$test.unadjusted.tax = bt.run.share.ex(data.raw, clean.signal=F, silent=F, commission=commission, + lot.size=50, + control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + + adjusted = F, + # enable taxes + tax.control = default.tax.control(), + cashflow.control = list( + taxes = list( + cashflows = event.at(prices, 'year', offset=60), + cashflow.fn = tax.cashflows, + invest = 'cash', + type = 'fee.rebate' + ) + ) + ) + + + # info tables + mlast(bt.make.trade.event.summary.table(models$test.unadjusted.tax), 20) + + mlast(bt.make.cashflow.event.summary.table(models$test.unadjusted.tax), 20) + + + #***************************************************************** + # Dig dipper + #****************************************************************** + models$test1 = models$test.ex.lot.tax + models$test2 = models$test.unadjusted.tax + + look.at.taxes(models$test1)['2007'] + look.at.taxes(models$test2)['2007'] + + tax.summary(models$test1) + tax.summary(models$test2) + + tax.summary(models$test1, function(x) as.numeric(format(x,'%Y%m')))[1:14,] + tax.summary(models$test2, function(x) as.numeric(format(x,'%Y%m')))[1:14,] + + data$prices[period.ends,][1:14,1:3] + data.raw$prices[period.ends,][1:14,1:3] + + bt.make.trade.event.summary.table(models$test1)[1:14,] + bt.make.trade.event.summary.table(models$test2)[1:36,] + + + + + + + if(F) { + models$test.unadjusted.tax$long.term.cap + models$test.unadjusted.tax$short.term.cap + + models$test.unadjusted.tax$qualified.div + models$test.unadjusted.tax$non.qualified.div + } + + + #***************************************************************** + # Report + #****************************************************************** + # put all reports into one pdf file + pdf(file = 'report.t.u.pdf', width=8.5, height=11) + + strategy.performance.snapshoot(models, data=data) + + dev.off() + + + + +} + + +############################################################################### +#' Helper functions, subject to change +#' @export +############################################################################### +event.at = function(x, period = 'month', amount = 1, period.ends = date.ends(x,period), offset = 1) { + nperiods = nrow(x) + index = period.ends + offset + index[index > nperiods] = nperiods + index[index < 1] = 1 + cashflow = x[index,1] + cashflow[] = amount + cashflow +} + + + +#' @export +look.at.taxes = function(m) { + temp = data.frame(m[spl('long.term.cap,short.term.cap,qualified.div,non.qualified.div')]) + temp = make.xts(cbind(temp, total=rowSums(temp)), data$dates) + temp[temp$total!=0] +} + +#' @export +tax.summary = function(m, by.fn=date.year) { + temp = aggregate( + m[spl('long.term.cap,short.term.cap,qualified.div,non.qualified.div')], + list(year=by.fn(data$dates)), + sum + ) + cbind(temp, total=rowSums(temp)) +} + + +############################################################################### +#' Compute Taxes due at the end of the year +#' @export +############################################################################### +tax.cashflows = function(info, index, last.index) { + + +#gall <<- environment() +#list2vars(gall) +#if(index == 1511) +#matrix(1,1,1)[1,20] + + + + # index of last year + ii = date.year(info$dates) == date.year(info$dates[index]) - 1 + + # check if there is any data + if(sum(ii) == 0) return(0) + + # work with copy of tax environment + if( is.null(info$tax.copy) ) { + info$tax.copy = env( + long.term.cap = info$tax$long.term.cap, + short.term.cap = info$tax$short.term.cap + ) + } else { + info$tax.copy$long.term.cap[ii] = info$tax$long.term.cap[ii] + info$tax.copy$short.term.cap[ii] = info$tax$short.term.cap[ii] + } + + + # find end of last year + i = max(which(ii)) + + # get all capital gains / losses, assume we can carry indefinitely + long.term.cap = sum(info$tax.copy$long.term.cap[1:i]) + short.term.cap = sum(info$tax.copy$short.term.cap[1:i]) + + tax.cashflows.cap.helper = function(neg, pos) { + if( -neg > pos) { + neg = neg + pos + pos = 0 + } else { + pos = pos + neg + neg = 0 + } + return(list(neg = neg, pos = pos)) + } + + if(long.term.cap < 0 && short.term.cap > 0) { + temp = tax.cashflows.cap.helper(long.term.cap, short.term.cap) + long.term.cap = temp$neg + short.term.cap = temp$pos + } else if(long.term.cap > 0 && short.term.cap < 0) { + temp = tax.cashflows.cap.helper(short.term.cap, long.term.cap) + long.term.cap = temp$pos + short.term.cap = temp$neg + } + + tax = 0 + info$tax.copy$long.term.cap[1:i] = 0 + if(long.term.cap >= 0) + tax = tax + long.term.cap * info$tax.control$capital.gain$long.term.tax + else # carry over remaining loss + info$tax.copy$long.term.cap[i] = long.term.cap + + info$tax.copy$short.term.cap[1:i] = 0 + if(short.term.cap >= 0) + tax = tax + short.term.cap * info$tax.control$capital.gain$short.term.tax + else # carry over remaining loss + info$tax.copy$short.term.cap[i] = short.term.cap + + + # get all dividends + qualified.div = sum(info$tax$qualified.div[ii]) + non.qualified.div = sum(info$tax$non.qualified.div[ii]) + + tax = tax + qualified.div * info$tax.control$dividend$qualified.tax + tax = tax + non.qualified.div * info$tax.control$dividend$nonqualified.tax + +#cat('Tax', index, format(info$dates[index], '%d-%m-%Y'), tax, '\n') + + -tax +} + + + + + + + +############################################################################### +# General notes on new functionality +############################################################################### +# +# +#Using un-adjusted vs adjusted prices in after tax back-test should produce similar results, but not exact because +#============================================ +#* adjusted prices back-test assumes that dividends are automatically reinvested, +#while un-adjusted prices back-test deposits dividends into cash account that is allocated +#during next re-balance. There might be some commissions associated with deployment of dividends +#in this case. +# +# i.e. in test.ex.lot.tax we don't pay any taxes since divs are reinvested +#in test.unadjusted.tax we pay taxes on divs plus commisions costs to invest divs +# +#* the un-adjusted prices back-test compute commissions based on actual price of shares at the time, +#while the adjusted prices back-test compute commissions based on adjusted prices that might very small +#far back in the history. Hence, there might be a difference in commissions. +# + + + + +# +#bt.run.share vs bt.run.share.ex - different assumptions in calculations of shares +#========================================= +#the bt.run.share function scales number of shares to the original capital at each rebalance. +#To glance at SIT back-test logic for bt.run.share, please have a look at +# https://systematicinvestor.wordpress.com/2013/11/05/commissions/ +# +#This problem with bt.run.share function is one of the reason i'm working on +#bt.run.share.ex. bt.run.share.ex function properly tracks capital evolution +#and is not causing artificial turnover. +# +#Following simple example that should clarify the logic in bt.run.share. +#bt.run.share function computes number of shares at each rebalance using following formula, +#please note capital is fixed and never changes : +#share = weight * capital / price +# +#Following is an extreme case example: +#Let's say capital = $10, weight is 50/50 +# +#period one prices are ($1 and $1) hence share = (0.5, 0.5) * $10 / ($1, $1) = we have 5 shares and 5 shares +#period two prices are ($5 and $5) hence share = (0.5, 0.5) * $10 / ($5, $5) = we have 1 share and 1 share +#above introduces artificial turnover that you see with bt.run.share function +# + + +# Testing with stock that never distributed any dividend (GOOGL). +# +# The difference bwtn the unadjusted and the adjusted returns. +# +#Actually GOOGL had split on Apr 3, 2014 +#Hence number of shares was adjusted and on the next rebalance, shares were rounded up to closest 100's +#and commisions were paid +#Apr 3, 2014 1998: 1000 Stock Split +#http://finance.yahoo.com/q/hp?s=GOOGL&a=7&b=19&c=2004&d=9&e=14&f=2015&g=d&z=66&y=330 +# +#> mlast(bt.make.trade.event.summary.table(models$test.unadjusted.tax), 25) +# Type GOOGL Cash Com +#2014-03-31 trade 950.0 2737.991 0.000 +#2014-04-03 split 1898.1 2737.991 0.000 +#2014-04-30 trade 1900.0 1720.699 1.019 +# +# The turnover is not null because there is initial turnover when position is started. I.e. Cash -> Equity Allocation +# + + + +# ToDo it would be nice to have an option to do an incremental back-test +# i.e. append new data and only re-run the updated portion of back-test +# +# bt.run - really fast with no bells or whisles +# working directly with xts is alot slower, so use coredata +#' @export +bt.run.share.fast <- function +( + b, # enviroment with symbols time series + clean.signal = T, # flag to remove excessive signal + do.lag = 1, # lag signal + capital = 100000, + lot.size = 0.01 +) +{ + #--------------------------------------------------------- + # process weight + #--------------------------------------------------------- + # make sure we don't have any abnormal weights + weight = b$weight + weight[is.nan(weight) | is.infinite(weight)] = NA + weight[!is.na(weight) & is.na(b$prices)] = 0 + + # lag logic, to be back compatible with bt.run.share + # default logic is to use current weights to trade at close i.e. no lag + weight = iif( do.lag == 1, weight, mlag(weight, do.lag - 1) ) + + weight = coredata(weight) +if(F) { + temp = bt.exrem(weight) + + if(clean.signal) { + weight = temp + } else { # always clean up 0's + index = ifna(weight == 0, F) + weight[index] = temp[index] + } +} + #--------------------------------------------------------- + # process prices + #--------------------------------------------------------- + prices = coredata(b$prices) + n = ncol(prices) + nperiods = nrow(prices) + + # find trades + trade = !is.na(weight) + trade.index = which(rowSums(trade) > 0) + + #--------------------------------------------------------- + # setup event driven back test loop + #--------------------------------------------------------- + cash.wt = cash = rep(capital, nperiods) + share.wt = share = matrix(0, nperiods, n) + last.trade = 0 + lot.size = map2vector(lot.size, colnames(prices), 1) + lot.size = rep(1,n) + + for(i in trade.index) { + if(last.trade > 0) { + # copy from last trade + index = (last.trade + 1) : i + n.index = len(index) + share.wt[index,] = rep.row(share[last.trade,], n.index) + cash.wt[index] = cash[last.trade] + + share[index,] = rep.row(share[last.trade,], n.index) + cash[index] = cash[last.trade] + } + + p = prices[i,] + p[is.na(p)] = 1 + w = weight[i,] + w[is.na(w)] = 0 + + # update share[i,] and cash[i] + value = cash[i] + sum(p * share[i,]) + #share[i,] = value * w / p + + # not going to work for missing prices, probbaly need an index + #share[i,] = round.lot.basic.base(w, p, value, lot.size) + share[i,] = round.lot.basic(w, p, value, lot.size) + cash[i] = value - sum(share[i,] * p) + + last.trade = i + } + + if( last.trade > 0 & last.trade < nperiods) { + # copy from last trade + index = (last.trade + 1) : nperiods + n.index = len(index) + share.wt[index,] = rep.row(share[last.trade,], n.index) + cash.wt[index] = cash[last.trade] + + share[index,] = rep.row(share[last.trade,], n.index) + cash[index] = cash[last.trade] + } + + # prepare output + bt = list(type = 'share', capital = capital, share=share) + bt$value = cash + rowSums(share * prices, na.rm=T) + #bt$weight = share * prices / bt$value + bt$weight = share.wt * prices / (cash.wt + rowSums(share.wt * prices, na.rm=T)) + + + value = c(capital, bt$value) + bt$ret = (value / mlag(value) - 1)[-1] + bt$equity = cumprod(1 + bt$ret) + + bt +} + + + + + + + + diff --git a/R/bt.share.test.r b/R/bt.share.test.r new file mode 100644 index 0000000..2ab247d --- /dev/null +++ b/R/bt.share.test.r @@ -0,0 +1,163 @@ + +bt.run.share.ex.example.match.adjusted.unadjusted = function() +{ + #***************************************************************** + # To match backtest results using Adjusted data, the backtest using + # UnAdjusted data must reinvest dividends right away. i.e. + # dividend.control = list(invest = 'rebalance') + #***************************************************************** + + #***************************************************************** + # Helper function + #***************************************************************** + load.data = function(adjusted = T) { + tickers = 'SPY' + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + # clone SPY + data$SPY1 = data$SPY + + if(adjusted) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + else + bt.unadjusted.add.div.split(data, infer.div.split.from.adjusted=T) + + bt.prep(data, align='remove.na', fill.gaps = T) + data + } + + #***************************************************************** + # Adjusted + #***************************************************************** + library(SIT) + library(quantmod) + + data = load.data(T) + + period.ends = date.ends(data$prices,'years') + nperiod.ends = len(period.ends) + + models = list() + + data$weight[] = NA + data$weight[period.ends,] = matrix(c(0,1),nr=99,nc=2)[1:nperiod.ends,] + models$a.basic = bt.run.share.ex(data, clean.signal=T, silent=F, adjusted = T + ) + + #***************************************************************** + # UnAdjusted + #***************************************************************** + data = load.data(F) + + # must reinvest dividends right away to match performance of adjusted backtest + dividend.control = list(invest = 'rebalance') + + data$weight[] = NA + data$weight[period.ends,] = matrix(c(0,1),nr=99,nc=2)[1:len(period.ends),] + models$basic = bt.run.share.ex(data, clean.signal=T, silent=F, adjusted = F, + dividend.control = dividend.control) + + plotbt.strategy.sidebyside(models, make.plot=F, return.table=T) + + plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = NULL) +} + + + +bt.run.share.ex.example.commissions.adjusted.unadjusted = function() +{ + #***************************************************************** + # Commissions make a big difference when working with + # UnAdjusted data, Lot size plays small role + #***************************************************************** + + #***************************************************************** + # Helper function + #***************************************************************** + load.data = function(adjusted = T) { + tickers = 'MMM, AA, CAT, KO, HPQ' + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + if(adjusted) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + else + bt.unadjusted.add.div.split(data, infer.div.split.from.adjusted=T) + + bt.prep(data, align='remove.na', fill.gaps = T) + data + } + + #***************************************************************** + # Adjusted + #***************************************************************** + library(SIT) + library(quantmod) + + data = load.data(T) + + period.ends = date.ends(data$prices,'months') + + models = list() + + commission = list(cps = 0.01, fixed = 10.0, percentage = 0.0) + + n = ncol(data$prices) + weights = rep.row(rep(1/n, n), len(period.ends)) + + + + data$weight[] = NA + data$weight[period.ends,] = weights + models$a.base = bt.run.share.ex(data, clean.signal=F, silent=T, #commission=commission, + #lot.size=100, + #control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + adjusted = T + ) + + data$weight[] = NA + data$weight[period.ends,] = weights + models$a.base.com = bt.run.share.ex(data, clean.signal=F, silent=T, commission=commission, + #lot.size=100, + #control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + adjusted = T + ) + + #***************************************************************** + # UnAdjusted + #***************************************************************** + data = load.data(F) + + # must reinvest dividends right away to match performance of adjusted backtest + dividend.control = list(invest = 'rebalance') + dividend.control = list(invest = 'cash') + + data$weight[] = NA + data$weight[period.ends,] = weights + models$u.base = bt.run.share.ex(data, clean.signal=F, silent=T, #commission=commission, + #lot.size=100, + #control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + dividend.control = dividend.control, + adjusted = F + ) + + data$weight[] = NA + data$weight[period.ends,] = weights + models$u.base.com = bt.run.share.ex(data, clean.signal=F, silent=T, commission=commission, + #lot.size=100, + #control = list(round.lot = list(select = 'minimum.turnover', diff.target = 5/100)), + dividend.control = dividend.control, + adjusted = F + ) + + + + + + plotbt.strategy.sidebyside(models, make.plot=F, return.table=T) + + plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = NULL) +} + + \ No newline at end of file diff --git a/R/bt.stop.r b/R/bt.stop.r new file mode 100644 index 0000000..fef8c77 --- /dev/null +++ b/R/bt.stop.r @@ -0,0 +1,488 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Stop functionality for Backtests +# Copyright (C) 2013 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + +############################################################################### +# Timed Exit: exit trade after nlen bars +#' @export +############################################################################### +bt.exrem.time.exit <- function(signal, nlen, create.weight = T) { + signal[is.na(signal)] = FALSE + + signal.index = which(signal) + nsignal.index = len(signal.index) + nperiods = len(signal) + signal.index.exit = iif(signal.index + nlen - 1 > nperiods, nperiods, signal.index + nlen) + + if(!create.weight) { + for(i in 1:nsignal.index) { + if( signal[ signal.index[i] ] ) { + signal[ (signal.index[i]+1) : signal.index.exit[i] ] = FALSE + } + } + return(signal) + } else { + temp = signal * NA + + for(i in 1:nsignal.index) { + if( signal[ signal.index[i] ] ) { + signal[ (signal.index[i]+1) : signal.index.exit[i] ] = FALSE + temp[ signal.index.exit[i] ] = 0 + } + } + + temp[signal] = 1 + return(temp) + } +} + + + +############################################################################### +# Enforce minimum holding period before taking another signal +#' @export +############################################################################### +bt.min.holding.period <- function(x, nlen) { + x = coredata(x) + + enter = x != 0 + enter[is.na(enter)] = FALSE + enter.index = which(enter) + + for(t in enter.index) + if( enter[ t ] ) { + index = t + nlen + enter[ t : index ] = FALSE + x[ t : index ] = x[t] + } + return(x) +} + + +############################################################################### +# Matrix versions of time/price/time.price stops +#' @export +############################################################################### +bt.time.stop <- function(weight, nlen) +{ + # same as bt.exrem.time.exit function!!! + bt.apply.matrix(weight, bt.ts.time.stop, nlen) +} + + +# based on bt.apply.matrix +#' @export +bt.price.stop <- function(b, price, pstop) +{ + out = b + out[] = NA + nsymbols = ncol(b) + + if(is.null(dim(pstop))) pstop = rep.row(pstop, nrow(b)) + + for( i in 1:nsymbols ) + out[,i] = bt.ts.price.stop(coredata(b[,i]), coredata(price[,i]), coredata(pstop[,i])) + return(out) +} + + +# based on bt.apply.matrix +#' @export +bt.time.price.stop <- function(b, nlen, price, pstop) +{ + out = b + out[] = NA + nsymbols = ncol(b) + + if(is.null(dim(pstop))) pstop = rep.row(pstop, nrow(b)) + + for( i in 1:nsymbols ) + out[,i] = bt.ts.time.price.stop(coredata(b[,i]), nlen, coredata(price[,i]), coredata(pstop[,i])) + return(out) +} + + +############################################################################### +# enter signal: weight != 0 +# exit signal : weight == 0 or 1 to -1 flip signal +# no signal : is.na(weight) +#' @export +############################################################################### +bt.ts.trade.index <- function(x) +{ + # index of enter signals + enter = x != 0 + enter[is.na(enter)] = FALSE +# do not consider trade that happend today +enter[length(x)] = FALSE + + enter.index = which(enter) + + + # index of exit signals corresponding to enter signals + # capute both x == 0 and 1 to -1 flip signal + temp = ifna.prev(x) + temp0 = mlag(temp) + exit = temp0 != 0 & temp != temp0 + exit[ !exit ] = NA + exit = ifna.prevx.rev(exit) + + list(enter = enter, enter.index = enter.index, exit = exit) +} + + +############################################################################### +# enter signal: weight != 0 +# true/false vector, true indicating start of trade +#' @export +############################################################################### +bt.ts.enter.state <- function(x) +{ + # enter signals + enter = x != 0 + enter[is.na(enter)] = FALSE + enter +} + +############################################################################### +# Exit position if holding periods > nlen +#' @export +############################################################################### +bt.ts.time.stop <- function(x, nlen) +{ + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply stop + for(t in enter.index) + if( enter[ t ] ) + if( exit[ t ] < t + nlen ) + enter[ t : exit[ t ] ] = FALSE + else { + enter[ t : (t + nlen) ] = FALSE + x[ (t + nlen) ] = 0 + } + return(x) +} + + +time.stop.test <- function() { + bt.ts.time.stop(c(1,1,1,0,1,1,NA,1,0),2) + bt.ts.time.stop(c(1,0,1,1,1,1,1,1,1),3) +} + + +############################################################################### +# Exit long position if price.today < price.enter - stop +# Exit short position if price.today > price.enter + stop +# +# price SHOULD NOT contain any non-leading NA's!!! +# +#' @export +############################################################################### +bt.ts.price.stop <- function(x, price, pstop) +{ + price = coredata(price) + pstop = coredata(pstop) + + if(length(pstop) == 1) pstop = rep(pstop, len(x)) + + # faster which + dummy = 1:length(x) + + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply stop + for(t in enter.index) + if( enter[ t ] ) { + if( x[ t ] > 0 ) + temp = price[ t : exit[ t ] ] < price[ t ] - pstop[ t ] + else + temp = price[ t : exit[ t ] ] > price[ t ] + pstop[ t ] + + if( any(temp, na.rm=T) ) { + iexit = t - 1 + dummy[temp][1] + enter[ t : iexit ] = FALSE + x[ iexit ] = 0 + } else + enter[ t : exit[ t ] ] = FALSE + } + return(x) +} + + +price.stop.test <- function() { + bt.ts.price.stop(c(1,1,1,1,1,1,NA,1,0), + c(1,1,0.9,0.7,1,1,1,1,0), + 0.2 + ) + + bt.ts.price.stop(-c(1,1,1,1,1,1,NA,1,0), + c(1,1,0.9,1.7,1,1,1,1,0), + 0.2 + ) + +} + + +############################################################################### +# Exit position if either time stop or price stop +# +# price SHOULD NOT contain any non-leading NA's!!! +# +#' @export +############################################################################### +bt.ts.time.price.stop <- function(x, nlen, price, pstop) +{ + price = coredata(price) + pstop = coredata(pstop) + + if(length(pstop) == 1) pstop = rep(pstop, len(x)) + + # faster which + dummy = 1:length(x) + + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply time and price stop + for(t in enter.index) + if( enter[ t ] ) { + if( x[ t ] > 0 ) + temp = price[ t : exit[ t ] ] < price[ t ] - pstop[ t ] + else + temp = price[ t : exit[ t ] ] > price[ t ] + pstop[ t ] + + if( any(temp, na.rm=T) ) { + iexit = t - 1 + dummy[temp][1] + + if( iexit < t + nlen ) { + enter[ t : iexit ] = FALSE + x[ iexit ] = 0 + } else { + enter[ t : (t + nlen) ] = FALSE + x[ (t + nlen) ] = 0 + } + } else + if( exit[ t ] < t + nlen ) + enter[ t : exit[ t ] ] = FALSE + else { + enter[ t : (t + nlen) ] = FALSE + x[ (t + nlen) ] = 0 + } + } + return(x) +} + +time.price.stop.test <- function() { + bt.ts.time.price.stop(c(1,1,1,1,1,1,NA,1,0), + 4, + c(1,1,0.9,0.7,1,1,1,1,0), + 0.2 + ) + + bt.ts.time.price.stop(-c(1,1,1,1,1,1,NA,1,0), + 4, + c(1,1,0.9,1.7,1,1,1,1,0), + 0.2 + ) + +} + + + + + + + +############################################################################### +# Price stop with user defined fn +############################################################################### +# stop.fn is expected to return a boolean array of size tend - tstart + 1 +# with TRUE(s) idicating that stop was activated +# +# price SHOULD NOT contain any non-leading NA's!!! +# +# time comparison with xts is usually tricky; hence it is always wise to +# provide all inputs in after coredata +# +#' @export +custom.stop.fn <- function(x, price, stop.fn, ...) +{ + price = coredata(price) + + if(is.character(stop.fn)) stop.fn = match.fun(stop.fn) + + # faster which + dummy = 1:length(x) + + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply stop + for(t in enter.index) + if( enter[ t ] ) { + # temp = stop.fn(x[ t ], price, t, exit[ t ], ...) + temp = stop.fn(x[ t ], price, t, exit[ (t + 1) ], ...) + + if( any(temp, na.rm=T) ) { + iexit = t - 1 + dummy[temp][1] + enter[ t : iexit ] = FALSE + x[ iexit ] = 0 + } else + enter[ t : exit[ t ] ] = FALSE + } + return(x) +} + +# expect list(state - T/F vector, remove - T/F - if remove signals, value - value to set) +# +# in terms of custom.stop.fn, list(state = state, remove = T, value = 0 i.e. exit) +#' @export +custom.stop.fn.list <- function(x, price, stop.fn, ...) +{ + price = coredata(price) + + if(is.character(stop.fn)) stop.fn = match.fun(stop.fn) + + # faster which + dummy = 1:length(x) + + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply stop + for(t in enter.index) + if( enter[ t ] ) { + # temp = stop.fn(x[ t ], price, t, exit[ t ], ...) + out = stop.fn(x[ t ], price, t, exit[ (t + 1) ], ...) + temp = out$state + + if( any(temp, na.rm=T) ) { + iexit = t - 1 + dummy[temp][1] + if(out$clean.signal) enter[ t : iexit ] = FALSE + x[ iexit ] = out$value + } else + enter[ t : exit[ t ] ] = FALSE + } + return(x) +} + + + + +custom.stop.fn.full <- function(x, price, stop.fn, ...) +{ + price = coredata(price) + + if(is.character(stop.fn)) stop.fn = match.fun(stop.fn) + + # get index of trades + temp = bt.ts.trade.index(x) + enter = temp$enter + enter.index = temp$enter.index + exit = temp$exit + + + # loop over all enter signals and apply stop + for(t in enter.index) + if( enter[ t ] ) { + # temp = stop.fn(x[ t ], price, t, exit[ t ], ...) + out = stop.fn(x, price, t, exit[ (t + 1) ], ...) + x = out$x + if(out$clean.signal) enter[ t : out$tlast ] = FALSE + } + return(x) +} + + + + + + + + +# note that this is a custom function because HHV (i.e. cummax) and is path dependent +custom.trailing.stop.test <- function(weight, price, tstart, tend, sma, nstop) { + index = tstart : tend + if(weight > 0) { + # trailing stop + temp = price[ index ] < cummax(0.9 * sma[ index ]) + + # profit target + temp = temp | price[ index ] > cummax(1.1 * sma[ index ]) + } else { + temp = price[ index ] > cummax(1.1 * sma[ index ]) + } + + # time stop + if( tend - tstart > nstop ) temp[ (nstop + 1) ] = T + + return( temp ) +} + + +############################################################################### +# Tests +############################################################################### +custom.stop.fn.test <- function() { + signal = c(1,1,1,1,1,1,NA,1,0) + price = c(1,1,0.9,0.7,1,1,1,1,0) + custom.stop.fn(signal, price, + custom.trailing.stop.test, + sma = ifna(SMA(price, 2), price), + nstop = 20 + ) + + + signal = -c(1,1,1,1,1,1,NA,1,0) + price = c(1,1,0.9,1.7,1,1,1,1,0) + custom.stop.fn(signal, price, + custom.trailing.stop.test, + sma = ifna(SMA(price, 2), price), + nstop = 4 + ) + +} + + diff --git a/R/bt.stop.test.r b/R/bt.stop.test.r new file mode 100644 index 0000000..614b525 --- /dev/null +++ b/R/bt.stop.test.r @@ -0,0 +1,561 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Test for Stop functionality for Backtests +# Copyright (C) 2013 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + +############################################################################### +# Helper function to visualize signal / strategy +# +# plot strategy, highligh invested periods with green +#' @export +############################################################################### +bt.stop.strategy.plot <- function( + data, + model, + dates = '::', + main = NULL, + layout = NULL, # flag to idicate if layout is already set + extra.plot.fn = NULL, + ... +) { + # highlight logic based on weight + weight = model$weight[dates] + col = iif(weight > 0, 'green', iif(weight < 0, 'gray', 'white')) + plota.control$col.x.highlight = col.add.alpha(col, 100) + highlight = T + + if(is.null(layout)) layout(1) + + plota(data$prices[dates], type='l', x.highlight = highlight, ...) + + if(!is.null(extra.plot.fn)) match.fun(extra.plot.fn)() + + plota.legend('Long,Short,Not Invested','green,gray,white') + + if(!is.null(main)) + legend('top', legend=main, bty='n') +} + + +############################################################################### +# Tests +# http://www.optionetics.com/market/articles/2012/08/22/kaeppels-corner-the-40-week-cycle-and-theory-versus-reality +############################################################################### +bt.stop.kaeppels.40w.test <- function() +{ + load.packages('quantmod') + + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('SPY') + tickers = spl('^DJI') + tickers = spl('DIA') + tickers = spl('^GSPC') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1967-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all', dates='1967:04:21::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + + #***************************************************************** + # 40W cycle + #****************************************************************** + # start 40W - 21-04-1967 + # 280 days + # 140 days bullish + # 180 days bear + # bull 13-07-2012 + # bear 30-11-2012 + # bull 19-4-2013 + #****************************************************************** + start.cycle = as.Date("1967-04-21") + + diff = data$dates - start.cycle + diff.cyc = diff / 280 + diff.int = as.integer(diff.cyc) + + signal=iif((diff.cyc-diff.int) < 0.5, 1, 0) + # to prevent entering the same signal after the stop + signal = exrem(signal) + + data$weight[] = NA + data$weight[] = signal + models$cycle = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + + #***************************************************************** + # Stops + #****************************************************************** + fixed.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) + price[ index ] < (1 - pstop) * price[ tstart ] + else + price[ index ] > (1 + pstop) * price[ tstart ] + } + + trailing.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) { + temp = price[ index ] < (1 - pstop) * cummax(price[ index ]) + } else { + temp = price[ index ] > (1 + pstop) * cummin(price[ index ]) + } + return( temp ) + } + + #***************************************************************** + # Add 12.5% fixed stop loss + #****************************************************************** + # same as custom.fixed.stop + #data$weight[] = NA + # data$weight[] = bt.ts.price.stop(signal, prices, 8.5/100 * prices) + #models$cycle.12.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + pstop = 8.5 / 100 + + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), fixed.stop, pstop = pstop) + models$cycle.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), trailing.stop, pstop = pstop) + models$cycle.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + #***************************************************************** + # Create Report + #****************************************************************** + plotbt.custom.report.part1(models) + plotbt.custom.report.part2(models$cycle) + plotbt.strategy.sidebyside(models) + plotbt.custom.report.part3(models$cycle, trade.summary = TRUE) + + + strategy.performance.snapshoot(models, T) + + + plotbt.custom.report.part2(models$cycle.trailing.stop) + plotbt.custom.report.part3(models$cycle.trailing.stop, trade.summary = TRUE) + #models$cycle.trailing.stop$trade.summary$trades + + + + #***************************************************************** + # Create Plot + #****************************************************************** + dates = '2009:04::' + + layout(1:3) + bt.stop.strategy.plot(data, models$cycle, dates = dates, layout=T, main = '40 week cycle', plotX = F) + bt.stop.strategy.plot(data, models$cycle.fixed.stop, dates = dates, layout=T, main = '40 week cycle fixed stop', plotX = F) + bt.stop.strategy.plot(data, models$cycle.trailing.stop, dates = dates, layout=T, main = '40 week cycle trailing stop') + +} + + + + + +############################################################################### +# MA Cross strategy with various stop examples +# +# http://www.investopedia.com/articles/trading/08/trailing-stop-loss.asp +############################################################################### +bt.stop.ma.cross.test <- function() +{ + load.packages('quantmod') + + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1999::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Code Strategies : MA Cross Over + #****************************************************************** + sma.fast = SMA(prices, 20) + sma.slow = SMA(prices, 50) + + buy.signal = iif(cross.up(sma.fast, sma.slow), 1, NA) + + data$weight[] = NA + data$weight[] = iif(cross.up(sma.fast, sma.slow), 1, iif(cross.dn(sma.fast, sma.slow), 0, NA)) + models$ma.cross = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # Stops + #****************************************************************** + # fixed stop: exit trade once price falls below % from entry price + fixed.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) + price[ index ] < (1 - pstop) * price[ tstart ] + else + price[ index ] > (1 + pstop) * price[ tstart ] + } + + # trailing stop: exit trade once price falls below % from max price since start of trade + trailing.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) { + temp = price[ index ] < (1 - pstop) * cummax(price[ index ]) + } else { + temp = price[ index ] > (1 + pstop) * cummin(price[ index ]) + } + return( temp ) + } + + # trailing stop: exit trade once price either + # - falls below % from max price since start of trade OR + # - rises above % from entry price + trailing.stop.profit.target <- function(weight, price, tstart, tend, pstop, pprofit) { + index = tstart : tend + if(weight > 0) { + temp = price[ index ] < (1 - pstop) * cummax(price[ index ]) + + # profit target + temp = temp | price[ index ] > (1 + pprofit) * price[ tstart ] + } else { + temp = price[ index ] > (1 + pstop) * cummin(price[ index ]) + + # profit target + temp = temp | price[ index ] < (1 - pprofit) * price[ tstart ] + } + return( temp ) + } + + #***************************************************************** + # Exit using fixed stop + #****************************************************************** + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), fixed.stop, + pstop = 1/100) + models$ma.cross.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # Exit using trailing stop + #****************************************************************** + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), trailing.stop, + pstop = 1/100) + models$ma.cross.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # Exit using trailing stop or profit target + #****************************************************************** + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(buy.signal), coredata(prices), trailing.stop.profit.target, + pstop = 1/100, pprofit = 1.5/100) + models$ma.cross.trailing.stop.profit.target = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # Create Report + #****************************************************************** +jpeg(filename = 'plot1.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + + strategy.performance.snapshoot(models, T) + +dev.off() + #***************************************************************** + # Create Plot + #****************************************************************** + dates = '2010::2010' + # add moving averages to the strategy plot + extra.plot.fn <- function() { + plota.lines(sma.fast, col='red') + plota.lines(sma.slow, col='blue') + } + +jpeg(filename = 'plot2.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + + layout(1:4) + bt.stop.strategy.plot(data, models$ma.cross, dates = dates, layout=T, main = 'MA Cross', extra.plot.fn = extra.plot.fn, plotX = F) + bt.stop.strategy.plot(data, models$ma.cross.fixed.stop, dates = dates, layout=T, main = 'Fixed Stop', plotX = F) + bt.stop.strategy.plot(data, models$ma.cross.trailing.stop, dates = dates, layout=T, main = 'Trailing Stop', plotX = F) + bt.stop.strategy.plot(data, models$ma.cross.trailing.stop.profit.target, dates = dates, layout=T, main = 'Trailing Stop and Profit Target') + +dev.off() +} + + + +############################################################################### +# MA Cross strategy with pull-back and various stop examples +# +# http://www.investopedia.com/articles/trading/08/trailing-stop-loss.asp +############################################################################### +bt.stop.ma.cross.pullback.test <- function() +{ + load.packages('quantmod') + + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('SPY') + tickers = spl('^GSPC') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all', dates='1999::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Code Strategies + #****************************************************************** + sma.fast = SMA(prices, 50) + sma.slow = SMA(prices, 200) + + data$weight[] = NA + data$weight[] = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, sma.slow), 0, NA)) + models$ma.crossover = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + data$weight[] = NA + data$weight[] = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, 0.95 * sma.slow), 0, NA)) + models$ma.crossover.pullback = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + + #***************************************************************** + # Stops + #****************************************************************** + fixed.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) + price[ index ] < (1 - pstop) * price[ tstart ] + else + price[ index ] > (1 + pstop) * price[ tstart ] + } + + trailing.stop <- function(weight, price, tstart, tend, pstop) { + index = tstart : tend + if(weight > 0) { + temp = price[ index ] < (1 - pstop) * cummax(price[ index ]) + } else { + temp = price[ index ] > (1 + pstop) * cummin(price[ index ]) + } + return( temp ) + } + + #***************************************************************** + # Code Strategies + #****************************************************************** + signal = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, sma.slow), 0, NA)) + signal = iif(cross.up(prices, sma.slow), 1, NA) + signal = iif(cross.up(prices, sma.slow), 1, iif(cross.dn(prices, 0.95 * sma.slow), 0, NA)) + pstop = 8.5 / 100 + + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), fixed.stop, pstop = pstop) + models$cycle.fixed.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + data$weight[] = NA + data$weight[] = custom.stop.fn(coredata(signal), coredata(prices), trailing.stop, pstop = pstop) + models$cycle.trailing.stop = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # Create Report + #****************************************************************** + strategy.performance.snapshoot(models, T) + + + #***************************************************************** + # Create Plot + #****************************************************************** + dates = '::' + # add moving averages to the strategy plot + extra.plot.fn <- function() { + plota.lines(sma.slow, col='blue') + plota.lines(0.95 * sma.slow, col='red') + } + + layout(1:4) + bt.stop.strategy.plot(data, models$ma.crossover, dates = dates, layout=T, main = 'base', plotX = F) + bt.stop.strategy.plot(data, models$ma.crossover.pullback, dates = dates, layout=T, main = 'base + 5% pull-back', extra.plot.fn = extra.plot.fn, plotX = F) + bt.stop.strategy.plot(data, models$cycle.fixed.stop, dates = dates, layout=T, main = 'fixed stop', plotX = F) + bt.stop.strategy.plot(data, models$cycle.trailing.stop, dates = dates, layout=T, main = 'trailing stop') + + +} + + + + + +############################################################################### +# Dual Moving Average System +# http://www.tradingblox.com/Manuals/UsersGuideHTML/dualmovingaverage.htm +############################################################################### +bt.stop.dual.ma.strategy <- function +( + data, + short.ma.len = 50, + long.ma.len = 200, + n.atr = NA, + atr.len = 39 +) +{ + #***************************************************************** + # Stop + #****************************************************************** + atr.trailing.stop <- function(weight, price, tstart, tend, atr) { + index = tstart : tend + if(weight > 0) + price[ index ] < cummax( price[ index ] ) - atr[ index ] + else + price[ index ] > cummin( price[ index ] ) + atr[ index ] + } + + #***************************************************************** + # The MA Crossover system + #****************************************************************** + prices = data$prices + short.ma = SMA(prices, short.ma.len) + long.ma = SMA(prices, long.ma.len) + + signal = iif(cross.up(short.ma, long.ma), 1, iif(cross.dn(short.ma, long.ma), 0, NA)) + if( !is.na(n.atr) ) { + atr = bt.apply(data, function(x) ATR(HLC(x), atr.len)[,'atr']) + + signal = custom.stop.fn(coredata(signal), coredata(prices), + atr.trailing.stop, atr = coredata(n.atr * atr)) + } + + data$weight[] = NA + data$weight[] = signal + bt.run.share(data, clean.signal=T) +} + + +bt.stop.dual.ma.test <- function() +{ + load.packages('quantmod') + + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all') + + #***************************************************************** + # Code Strategies + #****************************************************************** + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Dual Moving Average System parameters + #****************************************************************** + models$ma = bt.stop.dual.ma.strategy(data, 50, 200) + + models$ma.stop = bt.stop.dual.ma.strategy(data, 50, 200, 5, 39) + + #***************************************************************** + # Create Report + #****************************************************************** + + strategy.performance.snapshoot(models, T) + + + #***************************************************************** + # Create Plot + #****************************************************************** + dates = '2010::' + # add moving averages to the strategy plot + extra.plot.fn <- function() { + short.ma.len = 50 + long.ma.len = 200 + n.atr = 5 + atr.len = 39 + + short.ma = SMA(data$prices, short.ma.len) + long.ma = SMA(data$prices, long.ma.len) + atr = bt.apply(data, function(x) ATR(HLC(x), atr.len)[,'atr']) + + plota.lines(short.ma, col='red') + plota.lines(long.ma, col='blue') + plota.lines(data$prices - n.atr * atr, col='orange') + } + + layout(1:2) + bt.stop.strategy.plot(data, models$ma, dates = dates, layout=T, main = 'MA base', extra.plot.fn=extra.plot.fn, plotX = F) + bt.stop.strategy.plot(data, models$ma.stop, dates = dates, layout=T, main = 'base + 5% pull-back', extra.plot.fn=extra.plot.fn) + + + +} + + + diff --git a/R/bt.summary.r b/R/bt.summary.r new file mode 100644 index 0000000..7e0736c --- /dev/null +++ b/R/bt.summary.r @@ -0,0 +1,603 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Backtest Summary Report Functions +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + + +############################################################################### +# Custom Backtest Report +#' @export +############################################################################### +plotbt.custom.report <- function +( + ..., + dates = NULL, + main = '', + trade.summary = FALSE, + x.highlight = NULL +) +{ + # create layout + ilayout = + '1,1 + 1,1 + 2,2 + 3,3 + 4,6 + 4,6 + 5,7 + 5,8' + plota.layout(ilayout) + + models = variable.number.arguments( ... ) + + # Main plot + plotbt(models, dates = dates, main = main, plotX = F, log = 'y', LeftMargin = 3, x.highlight = x.highlight) + mtext('Cumulative Performance', side = 2, line = 1) + + plotbt(models[1], plottype = '12M', dates = dates, plotX = F, LeftMargin = 3, x.highlight = x.highlight) + mtext('12 Month Rolling', side = 2, line = 1) + + plotbt(models[1], dates = dates, xfun = function(x) { 100 * compute.drawdown(x$equity) }, LeftMargin = 3, x.highlight = x.highlight) + mtext('Drawdown', side = 2, line = 1) + + model = models[[1]] + name=ifnull(names(models),'')[1] + + # Additional Info + plotbt.transition.map(model$weight, x.highlight = x.highlight, name=name) + temp = plotbt.monthly.table(model$equity, smain=name) + plotbt.holdings.time(model$weight, smain=name) + + if ( !is.null(model$trade.summary) ) { + plot.table( list2matrix(bt.detail.summary(model, model$trade.summary)), keep_all.same.cex = TRUE, smain=name) + } else { + plot.table( list2matrix(bt.detail.summary(model)), keep_all.same.cex = TRUE, smain=name) + } + + if( len(models) > 1 ) plotbt.strategy.sidebyside(models) + + if ( trade.summary & !is.null(model$trade.summary)) { + ntrades = min(20, nrow(model$trade.summary$trades)) + + temp = last(model$trade.summary$trades, ntrades) + if( ntrades == 1 ) temp = model$trade.summary$trades + print( temp ) + print( model$trade.summary$stats ) + + #layout(1) + layout(c(1,rep(2,10))) + + # make dummy table with name of strategy + make.table(1,1) + a = matrix(names(models)[1],1,1) + cex = plot.table.helper.auto.adjust.cex(a) + draw.cell(a[1],1,1, text.cex=cex,frame.cell=F) + + plot.table( temp ) + } +} + +# split plotbt.custom.report into 3 functions +#' @export +plotbt.custom.report.part1 <- function +( + ..., + dates = NULL, + main = '', + trade.summary = FALSE, + x.highlight = NULL +) +{ + layout(1:3) + + models = variable.number.arguments( ... ) + model = models[[1]] + + # Main plot + plotbt(models, dates = dates, main = main, plotX = F, log = 'y', LeftMargin = 3, x.highlight = x.highlight) + mtext('Cumulative Performance', side = 2, line = 1) + + plotbt(models[1], plottype = '12M', dates = dates, plotX = F, LeftMargin = 3, x.highlight = x.highlight) + mtext('12 Month Rolling', side = 2, line = 1) + + plotbt(models[1], dates = dates, xfun = function(x) { 100 * compute.drawdown(x$equity) }, LeftMargin = 3, x.highlight = x.highlight) + mtext('Drawdown', side = 2, line = 1) +} + +#' @export +plotbt.custom.report.part2 <- function +( + ..., + dates = NULL, + main = '', + trade.summary = FALSE, + x.highlight = NULL +) +{ + models = variable.number.arguments( ... ) + model = models[[1]] + name=ifnull(names(models),'')[1] + + # create layout + if( len(models) > 1 ) + ilayout = + '1,1,3,4 + 2,2,5,5 + 2,2,6,6' + else + ilayout = + '1,1,1,3 + 2,2,4,4 + 2,2,5,5' + + plota.layout(ilayout) + + + # Additional Info + plotbt.transition.map(model$weight, x.highlight = x.highlight, name=name) + temp = plotbt.monthly.table(model$equity, smain=name) + if( len(models) > 1 ) + plotbt.holdings.time(model$weight, smain=name) + + plot.table(to.percent(t(last(models[[1]]$weight))), smain=name) + + if ( !is.null(model$trade.summary) ) { + plot.table( list2matrix(bt.detail.summary(model, model$trade.summary)), keep_all.same.cex = TRUE, smain=name) + } else { + plot.table( list2matrix(bt.detail.summary(model)), keep_all.same.cex = TRUE, smain=name) + } + + if( len(models) > 1 ) + plotbt.strategy.sidebyside(models) + else + plotbt.holdings.time(model$weight, smain=name) + +} + +#' @export +plotbt.custom.report.part3 <- function +( + ..., + dates = NULL, + main = '', + trade.summary = FALSE +) +{ + + models = variable.number.arguments( ... ) + model = models[[1]] + + if ( trade.summary & !is.null(model$trade.summary)) { + ntrades = min(20, nrow(model$trade.summary$trades)) + + temp = last(model$trade.summary$trades, ntrades) + if( ntrades == 1 ) temp = model$trade.summary$trades + print( temp ) + print( model$trade.summary$stats ) + + #layout(1) + layout(c(1,rep(2,10))) + + # make dummy table with name of strategy + make.table(1,1) + a = matrix(names(models)[1],1,1) + cex = plot.table.helper.auto.adjust.cex(a) + draw.cell(a[1],1,1, text.cex=cex,frame.cell=F) + + plot.table( temp ) + } +} + +############################################################################### +# Backtest Detail summary +#' @export +############################################################################### +bt.detail.summary <- function +( + bt, # backtest object + trade.summary = NULL +) +{ + out.all = list() + + # System Section + out = list() + out$Period = join( format( range(index.xts(bt$equity)), '%b%Y'), ' - ') + + out$Cagr = compute.cagr(bt$equity) + out$Sharpe = compute.sharpe(bt$ret) / 100 + out$DVR = compute.DVR(bt) / 100 + out$Volatility = compute.risk(bt$ret) + + out$MaxDD = compute.max.drawdown(bt$equity) + out$AvgDD = compute.avg.drawdown(bt$equity) + + if( !is.null(trade.summary) ) { + out$Profit.Factor = trade.summary$stats['profitfactor', 'All'] + } + + out$VaR = compute.var(bt$ret) + out$CVaR = compute.cvar(bt$ret) + + out$Exposure = compute.exposure(bt$weight) + out.all$System = lapply(out, function(x) if(is.double(x)) round(100*x,2) else x) + + + + + + # Trade Section + if( !is.null(bt$trade.summary) ) trade.summary = bt$trade.summary + + out = list() + if( !is.null(trade.summary) ) { + out$Win.Percent = trade.summary$stats['win.prob', 'All'] + out$Avg.Trade = trade.summary$stats['avg.pnl', 'All'] + out$Avg.Win = trade.summary$stats['win.avg.pnl', 'All'] + out$Avg.Loss = trade.summary$stats['loss.avg.pnl', 'All'] + + out = lapply(out, function(x) if(is.double(x)) round(100*x,1) else x) + + out$Best.Trade = max(as.double(trade.summary$trades[, 'return'])) + out$Worst.Trade = min(as.double(trade.summary$trades[, 'return'])) + + out$WinLoss.Ratio = round( -trade.summary$stats['win.avg.pnl', 'All']/trade.summary$stats['loss.avg.pnl', 'All'] , 2) + out$Avg.Len = round(trade.summary$stats['len', 'All'],2) + out$Num.Trades = trade.summary$stats['ntrades', 'All'] + } + out.all$Trade = out + + # Period Section + out = list() + out$Win.Percent.Day = sum(bt$ret > 0, na.rm = T) / len(bt$ret) + out$Best.Day = bt$best + out$Worst.Day = bt$worst + + month.ends = endpoints(bt$equity, 'months') + mret = ROC(bt$equity[month.ends,], type = 'discrete') + out$Win.Percent.Month = sum(mret > 0, na.rm = T) / len(mret) + out$Best.Month = max(mret, na.rm = T) + out$Worst.Month = min(mret, na.rm = T) + + year.ends = endpoints(bt$equity, 'years') + mret = ROC(bt$equity[year.ends,], type = 'discrete') + out$Win.Percent.Year = sum(mret > 0, na.rm = T) / len(mret) + out$Best.Year = max(mret, na.rm = T) + out$Worst.Year = min(mret, na.rm = T) + out.all$Period = lapply(out, function(x) if(is.double(x)) round(100*x,1) else x) + + return(out.all) +} + +############################################################################### +# Rotational Trading: how to reduce trades and improve returns by Frank Hassler +# http://engineering-returns.com/2011/07/06/rotational-trading-how-to-reducing-trades-and-improve-returns/ +# Custom Summary function to replicate tables from Engineering Returns +#' @export +############################################################################### +engineering.returns.kpi <- function +( + bt, # backtest object + trade.summary = NULL +) +{ + if( !is.null(bt$trade.summary) ) trade.summary = bt$trade.summary + + out = list() + out$Period = join( format( range(index(bt$equity)), '%b%Y'), ' - ') + + out$Cagr = compute.cagr(bt$equity) + out$Sharpe = compute.sharpe(bt$ret) / 100 + out$DVR = compute.DVR(bt) / 100 + out$R2 = compute.R2(bt$equity) / 100 + + out$Volatility = compute.risk(bt$ret) + out$MaxDD = compute.max.drawdown(bt$equity) + out$Exposure = compute.exposure(bt$weight) + + if( !is.null(trade.summary) ) { + out$Win.Percent = trade.summary$stats['win.prob', 'All'] + out$Avg.Trade = trade.summary$stats['avg.pnl', 'All'] + out$Profit.Factor = trade.summary$stats['profitfactor', 'All'] / 100 + } + + + # format + out = lapply(out, function(x) if(is.double(x)) round(100*x,2) else x) + + if( !is.null(trade.summary) ) out$Num.Trades = trade.summary$stats['ntrades', 'All'] + + return( list(System=out)) +} + +############################################################################### +# Plot strategy perfromance side by side +#' @export +############################################################################### +plotbt.strategy.sidebyside <- function +( + ... , + perfromance.metric = spl('System,Trade,Period'), + perfromance.fn = 'bt.detail.summary', + return.table = FALSE, + make.plot = TRUE +) +{ + models = variable.number.arguments( ... ) + out = list() + + for( i in 1:len(models) ) { + out[[ names(models)[i] ]] = match.fun(perfromance.fn)(models[[ i ]])[[ perfromance.metric[1] ]] + } + temp = list2matrix(out, keep.names=F) + if(make.plot) plot.table( temp, smain = perfromance.metric[1] ) + + if(return.table) return(temp) +} + + +############################################################################### +# Plot equity curves for eact strategy(model) +#' @export +############################################################################### +plotbt <- function +( + ..., # variable arguments + dates = NULL, # dates subset + plottype = spl('line,12M'), + xfun=function(x) { x$equity }, + main = NULL, + plotX = T, + log = '', + x.highlight = NULL, + LeftMargin = 0 +) +{ + models = variable.number.arguments( ... ) + plottype = plottype[1] + n = length(models) + + # get data + temp = list() + for( i in 1:n ) { + msg = try( match.fun(xfun)( models[[i]] ) , silent = TRUE) + if (class(msg)[1] != 'try-error') { + temp[[i]] = msg + } + } + + + # prepare plot + #last.date = index(last(temp[[1]])) + #prev.year.last.date = last.date - 365 + #nlag = max( 1, nrow(temp[[1]]) - which.min(abs(index(temp[[1]]) - prev.year.last.date)) ) + nlag = max( 1, compute.annual.factor(temp[[1]]) ) + + # nlag = len(last(temp[[1]], '12 months')) + yrange=c(); + for( i in 1:n ) { + itemp = temp[[i]] + + if(!is.null(dates)) { + itemp = itemp[dates] + if(itemp[1] != 0) itemp = itemp / as.double(itemp[1]) + } + + if( plottype == '12M' ) { + itemp = 100 * (itemp / mlag(itemp, nlag ) - 1) + } + temp[[i]] = itemp + + yrange = range(yrange, itemp ,na.rm = T) + } + + # plot + plota(temp[[1]], main = main, plotX = plotX, type = 'l', col = 1, + ylim = yrange,log = log, LeftMargin = LeftMargin, x.highlight = x.highlight) + + if( n > 1 ) { + for( i in 2:n ) plota.lines(temp[[i]], col = i) + } + + if( plottype == '12M' ) legend('topright', legend = '12 Month Rolling', bty = 'n') + plota.legend(names(models), paste('', 1:n, sep=''), temp) +} + +############################################################################### +# Plot Transition Map +#' @export +############################################################################### +plotbt.transition.map <- function +( + weight, + name = '', + col = rainbow(ncol(weight), start=0, end=.9), + x.highlight = NULL, + sort.asssets = T +) +{ + par(mar=c(2, 4, 1, 1), cex = 0.8, cex.main=0.8,cex.sub=0.8,cex.axis=0.8,cex.lab=0.8) + + + weight[is.na(weight)] = 0 + + # arrange so that most consient holdings are at the bottom + if(sort.asssets) weight = weight[, sort.list(colSums(weight!=0), decreasing=T)] + + plota.stacked(index.xts(weight), weight, col = col, type='s', flip.legend=T, main = iif(nchar(name) > 0, paste('Transition Map for', name), ''), x.highlight = x.highlight) +} + +############################################################################### +# Plot Pie Chart for holdings +#' @export +############################################################################### +plotbt.holdings <- function +( + weight, + smain = format(index.xts(last(weight)), '%d-%b-%Y') +) +{ + par(mar=c(2, 2, 2, 2), cex = 0.8, cex.main=0.8,cex.sub=0.8,cex.axis=0.8,cex.lab=0.8) + icols=rainbow(ncol(weight), start=0, end=.9) + + # sync order of assets with plotbt.transition.map + # arrange so that most consient holdings are at the bottom + weight = weight[, sort.list(colSums(weight!=0, na.rm=T), decreasing=T), drop=F] + + temp = 100 * as.vector(last(weight)) + atemp = abs(temp) + + if(sum(atemp)>0) { + pie(atemp, labels = paste(round(temp,0), '% ', colnames(weight), sep=''), + col = icols, cex =0.8, + main = paste('Allocation for ', smain, sep='') + ) + } +} + +############################################################################### +# Plot Pie Chart for holdings throught out time +#' @export +############################################################################### +plotbt.holdings.time <- function(weight, smain='') +{ + weight = as.matrix( apply(abs(weight), 2, sum, na.rm = T) ) + if( sum(abs(weight)) > 0 ) plotbt.holdings( t(weight) / sum(abs(weight), na.rm = T), smain = paste0(smain, ' in time')) +} + + + +############################################################################### +# Plot monthly return table +#' @export +############################################################################### +plotbt.monthly.table <- function(equity, make.plot = TRUE, smain = '') +{ + equity = map2monthly(equity) + + dates = index.xts(equity) + equity = coredata(equity) + +# just keep both versions for now +if(T) { + # find period ends + month.ends = date.month.ends(dates) + year.ends = date.year.ends(dates[month.ends]) + year.ends = month.ends[year.ends] + nr = len(year.ends) + 1 + +} else { + # find period ends + month.ends = unique(c(endpoints(dates, 'months'), len(dates))) + month.ends = month.ends[month.ends>0] + year.ends = unique(c(endpoints(dates[month.ends], 'years'), len(month.ends))) + year.ends = year.ends[year.ends>0] + year.ends = month.ends[year.ends] + nr = len(year.ends) + 1 +} + + + + + # create plot matrix + temp = matrix( double(), nr, 12 + 2) + rownames(temp) = c(date.year(dates[year.ends]), 'Avg') + colnames(temp) = spl('Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec,Year,MaxDD') + + # compute yearly profit and drawdown + index = c(1, year.ends) + for(iyear in 2:len(index)) { + iequity = equity[ index[(iyear-1)] : index[iyear] ] + iequity = ifna( ifna.prev(iequity), 0) + + temp[(iyear-1), 'Year'] = last(iequity, 1) / iequity[1] -1 + temp[(iyear-1), 'MaxDD'] = min(iequity / cummax(iequity) - 1, na.rm = T) + } + + # compute monthly profit + index = month.ends + monthly.returns = c(NA, diff(equity[index]) / equity[index[-len(index)]]) + + index = date.month(range(dates[index])) + monthly.returns = c( rep(NA, index[1]-1), monthly.returns, rep(NA, 12-index[2]) ) + temp[1:(nr - 1), 1:12] = matrix(monthly.returns, ncol=12, byrow = T) + + # compute averages + temp = ifna(temp, NA) + temp[nr,] = apply(temp[-nr,], 2, mean, na.rm = T) + + if(make.plot) { + #higlight + highlight = temp + highlight[] = iif(temp > 0, 'lightgreen', iif(temp < 0, 'red', 'white')) + highlight[nr,] = iif(temp[nr,] > 0, 'green', iif(temp[nr,] < 0, 'orange', 'white')) + highlight[,13] = iif(temp[,13] > 0, 'green', iif(temp[,13] < 0, 'orange', 'white')) + highlight[,14] = 'yellow' + } + + + temp[] = plota.format(100 * temp, 1, '', '') + + # plot + if(make.plot) plot.table(temp, highlight = highlight, smain = smain) + + return(temp) +} + + + +############################################################################### +# Convert list of lists to matrix +#' @export +############################################################################### +list2matrix <- function +( + ilist, + keep.names = TRUE +) +{ + if ( is.list( ilist[[1]] ) ) { + inc = 1 + if( keep.names ) inc = 2 + + out = matrix('', nr = max(unlist(lapply(ilist, len))), nc = inc * len(ilist) ) + colnames(out) = rep('', inc * len(ilist)) + + for( i in 1:len(ilist) ) { + nr = len(ilist[[i]]) + colnames(out)[inc * i] = names(ilist)[i] + + if(nr > 0){ + if( keep.names ) { + out[1:nr,(2*i-1)] = names(ilist[[i]]) + } else { + rownames(out) = names(ilist[[i]]) + } + out[1:nr,inc*i] = unlist(ilist[[i]]) + } + } + return(out) + } else { + return( as.matrix(unlist(ilist)) ) + } +} + diff --git a/R/bt.test.r b/R/bt.test.r new file mode 100644 index 0000000..6a65696 --- /dev/null +++ b/R/bt.test.r @@ -0,0 +1,10150 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Evaluting Sample Trading Strategies using Backtesting library in +# the Systematic Investor Toolbox +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + +bt.empty.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + # Buy & Hold + data$weight[] = 0 + buy.hold = bt.run(data, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** + + plotbt.custom.report.part1( buy.hold, trade.summary =T) + plotbt.custom.report.part2( buy.hold, trade.summary =T) + plotbt.custom.report.part3( buy.hold, trade.summary =T) + +} + +############################################################################### +# How to use execution.price functionality +############################################################################### +bt.execution.price.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + + models = list() + + #***************************************************************** + # Buy & Hold + #****************************************************************** + data$weight[] = 0 + data$execution.price[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # MA cross-over strategy + #****************************************************************** + sma.fast = SMA(prices, 50) + sma.slow = SMA(prices, 200) + signal = iif(sma.fast >= sma.slow, 1, -1) + + data$weight[] = NA + data$execution.price[] = NA + data$weight[] = signal + models$ma.crossover = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + #***************************************************************** + # MA cross-over strategy, add 10c per share commission + #***************************************************************** + data$weight[] = NA + data$execution.price[] = NA + data$weight[] = signal + models$ma.crossover.com = bt.run.share(data, commission = 0.1, clean.signal=T) + + #***************************************************************** + # MA cross-over strategy: + # Exit trades at the close on the day of the signal + # Enter trades at the open the next day after the signal + #****************************************************************** + popen = bt.apply(data, Op) + signal.new = signal + trade.start = which(signal != mlag(signal) & signal != 0) + signal.new[trade.start] = 0 + trade.start = trade.start + 1 + + data$weight[] = NA + data$execution.price[] = NA + data$execution.price[trade.start,] = popen[trade.start,] + data$weight[] = signal.new + models$ma.crossover.enter.next.open = bt.run.share(data, clean.signal=T, trade.summary = TRUE) + + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'report.pdf', width=8.5, height=11) + models = rev(models) + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot perfromance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot trades + plotbt.custom.report.part3(models$ma.crossover, trade.summary = TRUE) + +dev.off() +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plotbt.custom.report.part3(models$ma.crossover.enter.next.open, trade.summary = TRUE) + +dev.off() + #dev.off() + + + + + + + + + + + + + #***************************************************************** + # Simple example showing the difference in a way commission is integrated into returns + #****************************************************************** + commission = 4 + data$weight[] = NA + data$execution.price[] = NA + data$weight[201,] = 1 + data$weight[316,] = 0 + data$execution.price[201,] = prices[201,] + commission + data$execution.price[316,] = prices[316,] - commission + models$test.com = bt.run.share(data, clean.signal=T, trade.summary=T) + + data$weight[] = NA + data$execution.price[] = NA + data$weight[201,] = 1 + data$weight[316,] = 0 + models$test.com.new = bt.run.share(data, commission=commission, trade.summary=T, clean.signal=T) + + cbind(last(models$test.com$equity), last(models$test.com.new$equity), + as.double(prices[316] - commission)/as.double(prices[201] + commission)) + + as.double(prices[202]) / as.double(prices[201] + commission)-1 + models$test.com$equity[202]-1 + + as.double(prices[202] - commission) / as.double(prices[201])-1 + models$test.com.new$equity[202]-1 + + + #plotbt.custom.report.part1(models) + + #***************************************************************** + # Example showing the difference in a way commission is integrated into returns + #****************************************************************** + commission = 0.1 + sma.fast = SMA(prices, 50) + sma.slow = SMA(prices, 200) + + weight = iif(sma.fast >= sma.slow, 1, -1) + weight[] = bt.exrem(weight) + index = which(!is.na(weight)) + trade.start = index+1 + trade.end = c(index[-1],nperiods) + trade.direction = sign(weight[index]) + + + data$weight[] = NA + data$execution.price[] = NA + data$weight[] = weight + models$test.com.new = bt.run.share(data, commission=commission, trade.summary=T, clean.signal=T) + + + data$weight[] = NA + data$execution.price[] = NA + + index = which(trade.direction > 0) + data$execution.price[trade.start[index],] = prices[trade.start[index],] + commission + data$execution.price[trade.end[index],] = prices[trade.end[index],] - commission + + index = which(trade.direction < 0) + data$execution.price[trade.start[index],] = prices[trade.start[index],] - commission + data$execution.price[trade.end[index],] = prices[trade.end[index],] + commission + + data$weight[trade.start,] = trade.direction + data$weight[trade.end,] = 0 + + models$test.com = bt.run.share(data, clean.signal=T, trade.summary=T) + + + #plotbt.custom.report.part1(models) + +} + + +############################################################################### +# How to use commission functionality +############################################################################### +bt.commission.test <- function() +{ + # cents / share commission + # trade cost = abs(share - mlag(share)) * commission$cps + # fixed commission per trade to more effectively to penalize for turnover + # trade cost = sign(abs(share - mlag(share))) * commission$fixed + # percentage commission + # trade cost = price * abs(share - mlag(share)) * commission$percentage + # + # commission = list(cps = 0.0, fixed = 0.0, percentage = 0/100) + # cps - cents per share i.e. cps = 1.5 is 1.5 cents per share commision + # fixed - fixed cost i.e. fixed = $15 is $15 per trade irrelevant of number of shares + # percentage - percentage cost i.e. percentage = 1/100 is 1% of trade value + + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('EEM') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2013:08::2013:09') + + #***************************************************************** + # Code Strategies + #****************************************************************** + buy.date = '2013:08:14' + sell.date = '2013:08:15' + day.after.sell.date = '2013:08:16' + + capital = 100000 + prices = data$prices + share = as.double(capital / prices[buy.date]) + + # helper function to compute trade return + comp.ret <- function(sell.trade.cost, buy.trade.cost) { round(100 * (as.double(sell.trade.cost) / as.double(buy.trade.cost) - 1), 2) } + + #***************************************************************** + # Zero commission + #****************************************************************** + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = 0.0 + model = bt.run.share(data, commission = commission, capital = capital, silent = T) + + comp.ret( share * prices[sell.date], share * prices[buy.date] ) + comp.ret( model$equity[day.after.sell.date], model$equity[buy.date] ) + + #***************************************************************** + # 10c cps commission + # cents / share commission + # trade cost = abs(share - mlag(share)) * commission$cps + #****************************************************************** + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = 0.1 + model = bt.run.share(data, commission = commission, capital = capital, silent = T) + + comp.ret( share * (prices[sell.date] - commission), share * (prices[buy.date] + commission) ) + comp.ret( model$equity[day.after.sell.date], model$equity[buy.date] ) + + #***************************************************************** + # $5 fixed commission + # fixed commission per trade to more effectively to penalize for turnover + # trade cost = sign(abs(share - mlag(share))) * commission$fixed + #****************************************************************** + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = list(cps = 0.0, fixed = 5.0, percentage = 0.0) + model = bt.run.share(data, commission = commission, capital = capital, silent = T) + + comp.ret( share * prices[sell.date] - commission$fixed, share * prices[buy.date] + commission$fixed ) + comp.ret( model$equity[day.after.sell.date], model$equity[buy.date] ) + + #***************************************************************** + # % commission + # percentage commission + # trade cost = price * abs(share - mlag(share)) * commission$percentage + #****************************************************************** + data$weight[] = NA + data$weight[buy.date] = 1 + data$weight[sell.date] = 0 + commission = list(cps = 0.0, fixed = 0.0, percentage = 1/100) + model = bt.run.share(data, commission = commission, capital = capital, silent = T) + + comp.ret( share * prices[sell.date] * (1 - commission$percentage), share * prices[buy.date] * (1 + commission$percentage) ) + comp.ret( model$equity[day.after.sell.date], model$equity[buy.date] ) + + return + + #***************************************************************** + # Not Used + #***************************************************************** +# comp.ret( as.double(share * prices[sell.date] - commission$fixed)*(share * prices[buy.date] -commission$fixed), share^2 * prices[buy.date]^2 ) +# as.double(share * prices[sell.date] - commission$fixed) / (share * prices[buy.date]) * +# as.double(share * prices[buy.date] -commission$fixed) / (share * prices[buy.date]) - 1 +# + # Say following is time-line 0, A, B, C, 1, 2 + # We open share position at 0 and close at 1 + # + # Proper Logic + # ret = (share * price1 - commission) / (share * price0 + commission) + # + # Current Logic + # trade start: cash = price0 * share + # retA = (share * priceA - commission) / (share * price0) + # retB = (share * priceB) / (share * priceA) + # retC = (share * priceC) / (share * priceB) + # ret1 = (share * price1 - commission) / (share * priceC) + # ret2 = (cash - commission) / (cash) + # ret = retA * retB * retC * ret1 * ret2 - 1 + + #***************************************************************** + # Code Strategies + #****************************************************************** + obj = portfolio.allocation.helper(data$prices, + periodicity = 'months', lookback.len = 60, + min.risk.fns = list(EW=equal.weight.portfolio) + ) + + commission = list(cps = 0.0, fixed = 0.0, percentage = 0/100) + models = create.strategies(obj, data, capital = capital, commission = commission )$models + + ret = models$EW$ret + + commission = list(cps = 0.0, fixed = 0.0, percentage = 4/100) + models = create.strategies(obj, data, capital = capital, commission = commission )$models + + ret = cbind(ret, models$EW$ret) + + round(100 * cbind(ret, ret[,1] - ret[,2]),2) + write.xts(cbind(ret, ret[,1] - ret[,2]), 'diff.csv') + + + + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1990::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + obj = portfolio.allocation.helper(data$prices, + periodicity = 'months', lookback.len = 60, + min.risk.fns = list( + EW=equal.weight.portfolio + ) + ) + + capital = 100000 + commission = list(cps = 0.0, fixed = 0.0, percentage = 0/100) + models = create.strategies(obj, data, capital = capital, commission = commission )$models + + + #***************************************************************** + # Create Report + #****************************************************************** + strategy.performance.snapshoot(models, T) +} + + + + +############################################################################### +# Cross Pollination from Timely Portfolio +# http://timelyportfolio.blogspot.ca/2011/08/drawdown-visualization.html +# http://timelyportfolio.blogspot.ca/2011/08/lm-system-on-nikkei-with-new-chart.html +############################################################################### +bt.timelyportfolio.visualization.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2000::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + # Strategy + ma10 = bt.apply.matrix(prices, EMA, 10) + ma50 = bt.apply.matrix(prices, EMA, 50) + ma200 = bt.apply.matrix(prices, EMA, 200) + data$weight[] = NA; + data$weight[] = iif(ma10 > ma50 & ma50 > ma200, 1, + iif(ma10 < ma50 & ma50 < ma200, -1, 0)) + strategy = bt.run.share(data, clean.signal=F) + + + #***************************************************************** + # Visualization of system Entry and Exit based on + # http://timelyportfolio.blogspot.ca/2011/08/lm-system-on-nikkei-with-new-chart.html + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(1) + plota(strategy$eq, type='l', ylim=range(buy.hold$eq,strategy$eq)) + + col = iif(strategy$weight > 0, 'green', iif(strategy$weight < 0, 'red', 'gray')) + plota.lines(buy.hold$eq, type='l', col=col) + + plota.legend('strategy,Long,Short,Not Invested','black,green,red,gray') + +dev.off() + #***************************************************************** + # Drawdown Visualization + # 10% drawdowns in yellow and 15% drawdowns in orange + # http://timelyportfolio.blogspot.ca/2011/08/drawdown-visualization.html + #***************************************************************** +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(1:2) + drawdowns = compute.drawdown(strategy$eq) + highlight = drawdowns < -0.1 + + plota.control$col.x.highlight = iif(drawdowns < -0.15, 'orange', iif(drawdowns < -0.1, 'yellow', 0)) + + plota(strategy$eq, type='l', plotX=F, x.highlight = highlight, ylim=range(buy.hold$eq,strategy$eq)) + plota.legend('strategy,10% Drawdown,15% Drawdown','black,yellow,orange') + + plota(100*drawdowns, type='l', x.highlight = highlight) + plota.legend('drawdown', 'black', x='bottomleft') + +dev.off() + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plota.control$col.x.highlight = iif(drawdowns < -0.15, 'orange', iif(drawdowns < -0.1, 'yellow', 0)) + highlight = drawdowns < -0.1 + + plotbt.custom.report.part1(strategy, buy.hold, x.highlight = highlight) + +dev.off() + + +} + + +############################################################################### +# Improving Trend-Following Strategies With Counter-Trend Entries by david varadi +# http://cssanalytics.wordpress.com/2011/07/29/improving-trend-following-strategies-with-counter-trend-entries/ +############################################################################### +bt.improving.trend.following.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + # Trend-Following strategy: Long[Close > SMA(10) ] + sma = bt.apply(data, function(x) { SMA(Cl(x), 10) } ) + data$weight[] = NA + data$weight[] = iif(prices >= sma, 1, 0) + trend.following = bt.run(data, trade.summary=T) + + # Trend-Following With Counter-Trend strategy: Long[Close > SMA(10), DVB(1) CounterTrend ] + dv = bt.apply(data, function(x) { DV(HLC(x), 1, TRUE) } ) + data$weight[] = NA + data$weight[] = iif(prices > sma & dv < 0.25, 1, data$weight) + data$weight[] = iif(prices < sma & dv > 0.75, 0, data$weight) + trend.following.dv1 = bt.run(data, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(trend.following.dv1, trend.following, buy.hold) +dev.off() + + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(trend.following.dv1, trend.following, buy.hold) +dev.off() + + + #***************************************************************** + # Sensitivity Analysis + #****************************************************************** + ma.lens = seq(10, 100, by = 10) + dv.lens = seq(1, 5, by = 1) + + # precompute indicators + mas = matrix(double(), nrow(prices), len(ma.lens)) + dvs = matrix(double(), nrow(prices), len(dv.lens)) + + for(i in 1:len(ma.lens)) { + ma.len = ma.lens[i] + mas[, i] = bt.apply(data, function(x) { SMA(Cl(x), ma.len) } ) + } + for(i in 1:len(dv.lens)) { + dv.len = dv.lens[i] + dvs[,i] = bt.apply(data, function(x) { DV(HLC(x), dv.len, TRUE) } ) + } + + # allocate matrixes to store backtest results + dummy = matrix(double(), len(ma.lens), 1+len(dv.lens)) + rownames(dummy) = paste('SMA', ma.lens) + colnames(dummy) = c('NO', paste('DV', dv.lens)) + + out = list() + out$Cagr = dummy + out$Sharpe = dummy + out$DVR = dummy + out$MaxDD = dummy + + # evaluate strategies + for(ima in 1:len(ma.lens)) { + sma = mas[, ima] + cat('SMA =', ma.lens[ima], '\n') + + for(idv in 0:len(dv.lens)) { + if( idv == 0 ) { + data$weight[] = NA + data$weight[] = iif(prices > sma, 1, 0) + } else { + dv = dvs[, idv] + + data$weight[] = NA + data$weight[] = iif(prices > sma & dv < 0.25, 1, data$weight) + data$weight[] = iif(prices < sma & dv > 0.75, 0, data$weight) + } + strategy = bt.run(data, silent=T) + + # add 1 to account for benchmark case, no counter-trend + idv = idv + 1 + out$Cagr[ima, idv] = compute.cagr(strategy$equity) + out$Sharpe[ima, idv] = compute.sharpe(strategy$ret) + out$DVR[ima, idv] = compute.DVR(strategy) + out$MaxDD[ima, idv] = compute.max.drawdown(strategy$equity) + } + } + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot3.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + + layout(matrix(1:4,nrow=2)) + for(i in names(out)) { + temp = out[[i]] + temp[] = plota.format( 100 * temp, 1, '', '' ) + plot.table(temp, smain = i, highlight = T, colorbar = F) + } + +dev.off() + +} + + +############################################################################### +# Simple, Long-Term Indicator Near to Giving Short Signal By Woodshedder +# http://ibankcoin.com/woodshedderblog/2011/08/28/simple-long-term-indicator-near-to-giving-short-signal/ +############################################################################### +bt.roc.cross.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + + # Strategy: calculate the 5 day rate of change (ROC5) and the 252 day rate of change (ROC252). + # Buy (or cover short) at the close if yesterday the ROC252 crossed above the ROC5 and today the ROC252 is still above the ROC5. + # Sell (or open short) at the close if yesterday the ROC5 crossed above the ROC252 and today the ROC5 is still above the ROC252. + roc5 = prices / mlag(prices,5) + roc252 = prices / mlag(prices,252) + + roc5.1 = mlag(roc5,1) + roc5.2 = mlag(roc5,2) + roc252.1 = mlag(roc252,1) + roc252.2 = mlag(roc252,2) + + data$weight[] = NA + data$weight$SPY[] = iif(roc252.2 < roc5.2 & roc252.1 > roc5.1 & roc252 > roc5, 1, data$weight$SPY) + data$weight$SPY[] = iif(roc252.2 > roc5.2 & roc252.1 < roc5.1 & roc252 < roc5, -1, data$weight$SPY) + roc.cross = bt.run(data, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(roc.cross, buy.hold, trade.summary=T) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(roc.cross, buy.hold, trade.summary=T) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3(roc.cross, buy.hold, trade.summary=T) +dev.off() + + + + #***************************************************************** + # Code Strategies + #****************************************************************** + + # When shorting always use type = 'share' backtest to get realistic results + # The type = 'weight' backtest assumes that we are constantly adjusting our position + # to keep all cash = shorts + data$weight[] = NA + data$weight$SPY[] = iif(roc252.2 < roc5.2 & roc252.1 > roc5.1 & roc252 > roc5, 1, data$weight$SPY) + data$weight$SPY[] = iif(roc252.2 > roc5.2 & roc252.1 < roc5.1 & roc252 < roc5, -1, data$weight$SPY) + + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + roc.cross.share = bt.run(data, type='share', trade.summary=T, capital=capital) + + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(roc.cross.share, roc.cross, buy.hold, trade.summary=T) +dev.off() + +png(filename = 'plot5.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(roc.cross.share, roc.cross, buy.hold, trade.summary=T) +dev.off() + + +} + + + +############################################################################### +# Rotational Trading Strategies : ETF Sector Strategy +# http://www.etfscreen.com/sectorstrategy.php +# http://www.etfscreen.com/intlstrategy.php +############################################################################### +bt.rotational.trading.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU,IWB,IWD,IWF,IWM,IWN,IWO,IWP,IWR,IWS,IWV,IWW,IWZ') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = len(tickers) + + # find month ends + month.ends = endpoints(prices, 'months') + month.ends = month.ends[month.ends > 0] + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + dates = '2001::' + + # Equal Weight + data$weight[] = NA + data$weight[month.ends,] = ntop(prices, n)[month.ends,] + models$equal.weight = bt.run.share(data, clean.signal=F, dates=dates) + + + # Rank on 6 month return + position.score = prices / mlag(prices, 126) + + # Select Top 2 funds + data$weight[] = NA + data$weight[month.ends,] = ntop(position.score[month.ends,], 2) + models$top2 = bt.run.share(data, trade.summary=T, dates=dates) + + # Seletop Top 2 funds, and Keep then till they are in 1:6 rank + data$weight[] = NA + data$weight[month.ends,] = ntop.keep(position.score[month.ends,], 2, 6) + models$top2.keep6 = bt.run.share(data, trade.summary=T, dates=dates) + + #***************************************************************** + # Create Report + #****************************************************************** + + strategy.performance.snapshoot(models, T) + + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') + + + # put all reports into one pdf file + pdf(file = 'report.pdf', width=8.5, height=11) + plotbt.custom.report(models, trade.summary=T) + dev.off() + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3(models, trade.summary=T) +dev.off() + + + +} + +############################################################################### +# A Quantitative Approach to Tactical Asset Allocation by M. Faber (2006) +# http://www.mebanefaber.com/timing-model/ +############################################################################### +bt.timing.model.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('VTI,VEU,IEF,VNQ,DBC') + tickers = spl('VTI,EFA,IEF,ICF,DBC,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + for(i in ls(data)) cat( i, format(index(data[[i]][1,]), '%d%b%y'), '\n') + + # extend data for Commodities + CRB = get.CRB() + index = max(which( index(CRB) < index(data$DBC[1,]) )) + scale = as.vector(Cl(data$DBC[1,])) / as.vector(Cl(CRB[(index + 1),])) + temp = CRB[1 : (index + 1),] * repmat(scale, index + 1, 6) + data$DBC = rbind( temp[1:index,], data$DBC ) + + bt.prep(data, align='remove.na', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = len(tickers) + + # ignore cash when selecting funds + position.score = prices + position.score$SHY = NA + + # find month ends + month.ends = date.month.ends(index(prices)) + + # Equal Weight + data$weight[] = NA + data$weight[month.ends,] = ntop(position.score[month.ends,], n) + capital = 100000 + data$weight[] = (capital / prices) * data$weight + equal.weight = bt.run(data, type='share', capital=capital) + + # BuyRule, price > 10 month SMA + sma = bt.apply.matrix(prices, SMA, 200) + buy.rule = prices > sma + buy.rule = ifna(buy.rule, F) + + # Strategy + weight = ntop(position.score[month.ends,], n) + # keep in cash the rest of the funds + weight[!buy.rule[month.ends,]] = 0 + weight$SHY = 1 - rowSums(weight) + + data$weight[] = NA + data$weight[month.ends,] = weight + capital = 100000 + data$weight[] = (capital / prices) * data$weight + timing = bt.run(data, type='share', trade.summary=T, capital=capital) + + #***************************************************************** + # Code Strategies : Daily + #****************************************************************** + weight = ntop(position.score, n) + # keep in cash the rest of the funds + weight[!buy.rule] = 0 + weight$SHY = 1 - rowSums(weight) + + data$weight[] = NA + data$weight[] = weight + capital = 100000 + data$weight[] = (capital / prices) * data$weight + timing.d = bt.run(data, type='share', trade.summary=T, capital=capital) + + #***************************************************************** + # Create Report + #****************************************************************** + + # put all reports into one pdf file + pdf(file = 'report.pdf', width=8.5, height=11) + plotbt.custom.report(timing, timing.d, equal.weight, trade.summary=T) + dev.off() + + #***************************************************************** + # Code Strategies : Daily with Counter-Trend Entries by david varadi + # see bt.improving.trend.following.test + #****************************************************************** + dv = bt.apply(data, function(x) { DV(HLC(x), 1, TRUE) } ) + + data$weight[] = NA + data$weight[] = iif(prices > sma & dv < 0.25, 0.2, data$weight) + data$weight[] = iif(prices < sma & dv > 0.75, 0, data$weight) + data$weight$SHY = 0 + + + data$weight = bt.apply.matrix(data$weight, ifna.prev) + data$weight$SHY = 1 - rowSums(data$weight) + + data$weight = bt.exrem(data$weight) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + timing.d1 = bt.run(data, type='share', trade.summary=T, capital=capital) + + # compute turnover + models = variable.number.arguments(timing.d1, timing.d, timing, equal.weight) + sapply(models, compute.turnover, data) + + + #***************************************************************** + # Create Report + #****************************************************************** + + plotbt.custom.report.part1(timing.d1, timing.d, timing, equal.weight) + +} + +############################################################################### +# Monthly End-of-the-Month (MEOM) by Quanting Dutchman +# http://quantingdutchman.wordpress.com/2010/06/30/strategy-2-monthly-end-of-the-month-meom/ +############################################################################### +bt.meom.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('DIA,EEM,EFA,EWH,EWJ,EWT,EWZ,FXI,GLD,GSG,IEF,ILF,IWM,IYR,QQQ,SPY,VNQ,XLB,XLE,XLF,XLI,XLP,XLU,XLV,XLY,XLK') + + # Alternatively use Dow Jones Components + # tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1995-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1995::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + # Equal Weight + data$weight[] = ntop(prices, n) + equal.weight = bt.run(data) + + + # find month ends + month.ends = endpoints(prices, 'months') + month.ends = month.ends[month.ends > 0] + month.ends2 = iif(month.ends + 2 > nperiods, nperiods, month.ends + 2) + + # Strategy MEOM - Equal Weight + data$weight[] = NA + data$weight[month.ends,] = ntop(prices, n)[month.ends,] + data$weight[month.ends2,] = 0 + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + meom.equal.weight = bt.run(data, type='share', capital=capital) + + #***************************************************************** + # Rank1 = MA( C/Ref(C,-2), 5 ) * MA( C/Ref(C,-2), 40 ) + #****************************************************************** + + # BuyRule = C > WMA(C, 89) + buy.rule = prices > bt.apply.matrix(prices, function(x) { WMA(x, 89) } ) + buy.rule = ifna(buy.rule, F) + + # 2-day returns + ret2 = ifna(prices / mlag(prices, 2), 0) + + # Rank1 = MA( C/Ref(C,-2), 5 ) * MA( C/Ref(C,-2), 40 ) + position.score = bt.apply.matrix(ret2, SMA, 5) * bt.apply.matrix(ret2, SMA, 40) + position.score[!buy.rule] = NA + + # Strategy MEOM - top 2 + data$weight[] = NA; + data$weight[month.ends,] = ntop(position.score[month.ends,], 2) + data$weight[month.ends2,] = 0 + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + meom.top2.rank1 = bt.run(data, type='share', trade.summary=T, capital=capital) + + #***************************************************************** + # Rank2 = MA( C/Ref(C,-2), 5 ) * Ref( MA( C/Ref(C,-2), 10 ), -5 ) + #****************************************************************** + + # Rank2 = MA( C/Ref(C,-2), 5 ) * Ref( MA( C/Ref(C,-2), 10 ), -5 ) + position.score = bt.apply.matrix(ret2, SMA, 5) * mlag( bt.apply.matrix(ret2, SMA, 10), 5) + position.score[!buy.rule] = NA + + # Strategy MEOM - top 2 + data$weight[] = NA + data$weight[month.ends,] = ntop(position.score[month.ends,], 2) + data$weight[month.ends2,] = 0 + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + meom.top2.rank2 = bt.run(data, type='share', trade.summary=T, capital=capital) + + #***************************************************************** + # Create Report + #****************************************************************** + + # put all reports into one pdf file + pdf(file = 'report.pdf', width=8.5, height=11) + plotbt.custom.report(meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) + dev.off() + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3(meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) +dev.off() + + #***************************************************************** + # Modify MEOM logic - maybe sell in 1 day + #****************************************************************** + + month.ends1 = iif(month.ends + 1 > nperiods, nperiods, month.ends + 1) + + # Strategy MEOM - top 2, maybe sell in 1 day + data$weight[] = NA + data$weight[month.ends,] = ntop(position.score[month.ends,], 2) + data$weight[month.ends2,] = 0 + + # Close next day if Today's Close > Today's Open + popen = bt.apply(data, Op) + data$weight[month.ends1,] = iif((prices > popen)[month.ends1,], 0, NA) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + meom.top2.rank2.hold12 = bt.run(data, type='share', trade.summary=T, capital=capital) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(meom.top2.rank2.hold12, meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) +dev.off() + +png(filename = 'plot5.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(meom.top2.rank2.hold12, meom.top2.rank2, meom.top2.rank1, meom.equal.weight, equal.weight, trade.summary=T) +dev.off() + + +} + + +############################################################################### +# Intraday Backtest +# The FX intraday free data was +# http://www.fxhistoricaldata.com/EURUSD/ +############################################################################### +bt.intraday.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + EURUSD = getSymbols.fxhistoricaldata('EURUSD', 'hour', auto.assign = F, download=F) + SPY = getSymbols('SPY', src = 'yahoo', from = '1980-01-01', auto.assign = F) + + + #***************************************************************** + # Reference intraday period + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plota(EURUSD['2012:03:06 10::2012:03:06 21'], type='candle', main='EURUSD on 2012:03:06 from 10 to 21') +dev.off() + + #***************************************************************** + # Plot hourly and daily prices on the same chart + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # two Y axis plot + dates= '2012:01:01::2012:01:11' + y = SPY[dates] + plota(y, type = 'candle', LeftMargin=3) + + y = EURUSD[dates] + plota2Y(y, ylim = range(OHLC(y), na.rm=T), las=1, col='red', col.axis = 'red') + plota.ohlc(y, col=plota.candle.col(y)) + plota.legend('SPY(rhs),EURUSD(lhs)', 'black,red', list(SPY[dates],EURUSD[dates])) + +dev.off() + + + #***************************************************************** + # Universe: Currency Majors + # http://en.wikipedia.org/wiki/Currency_pair + #****************************************************************** + tickers = spl('EURUSD,USDJPY,GBPUSD,AUDUSD,USDCHF,USDCAD') + + #***************************************************************** + # Daily Backtest + #****************************************************************** + data <- new.env() + getSymbols.fxhistoricaldata(tickers, 'day', data, download=F) + bt.prep(data, align='remove.na', dates='1990::') + + prices = data$prices + n = len(tickers) + models = list() + + # Equal Weight + data$weight[] = NA + data$weight[] = ntop(prices, n) + models$equal.weight = bt.run.share(data, clean.signal=F) + + # Timing by M. Faber + sma = bt.apply.matrix(prices, SMA, 200) + data$weight[] = NA + data$weight[] = ntop(prices, n) * (prices > sma) + models$timing = bt.run.share(data, clean.signal=F) + + # Report + models = rev(models) +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() +png(filename = 'plot4.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() + + #***************************************************************** + # Intraday Backtest + #****************************************************************** + data <- new.env() + getSymbols.fxhistoricaldata(tickers, 'hour', data, download=F) + bt.prep(data, align='remove.na', dates='1990::') + + prices = data$prices + n = len(tickers) + models = list() + + # Equal Weight + data$weight[] = NA + data$weight[] = ntop(prices, n) + models$equal.weight = bt.run.share(data, clean.signal=F) + + # Timing by M. Faber + sma = bt.apply.matrix(prices, SMA, 200) + data$weight[] = NA + data$weight[] = ntop(prices, n) * (prices > sma) + models$timing = bt.run.share(data, clean.signal=F) + + # Report + models = rev(models) +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() +png(filename = 'plot6.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() + +} + + + + + + +############################################################################### +# Forecast-Free Algorithms: A New Benchmark For Tactical Strategies +# Rebalancing was done on a weekly basis and quarterly data was used to estimate correlations. +# http://cssanalytics.wordpress.com/2011/08/09/forecast-free-algorithms-a-new-benchmark-for-tactical-strategies/ +# +# Minimum Variance Sector Rotation +# http://quantivity.wordpress.com/2011/04/20/minimum-variance-sector-rotation/ +# +# The volatility mystery continues +# http://www.portfolioprobe.com/2011/12/05/the-volatility-mystery-continues/ +############################################################################### +bt.min.var.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod,quadprog,lpSolve') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + data.weekly <- new.env() + for(i in tickers) data.weekly[[i]] = to.weekly(data[[i]], indexAt='endof') + + bt.prep(data, align='remove.na', dates='1990::') + bt.prep(data.weekly, align='remove.na', dates='1990::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + # find week ends + week.ends = endpoints(prices, 'weeks') + week.ends = week.ends[week.ends > 0] + + + # Equal Weight 1/N Benchmark + data$weight[] = NA + data$weight[week.ends,] = ntop(prices[week.ends,], n) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + equal.weight = bt.run(data, type='share', capital=capital) + + #***************************************************************** + # Create Constraints + #***************************************************************** + constraints = new.constraints(n, lb = -Inf, ub = +Inf) + #constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + + ret = prices / mlag(prices) - 1 + weight = coredata(prices) + weight[] = NA + + for( i in week.ends[week.ends >= (63 + 1)] ) { + # one quarter = 63 days + hist = ret[ (i- 63 +1):i, ] + + # create historical input assumptions + ia = create.ia(hist) + s0 = apply(coredata(hist),2,sd) + ia$cov = cor(coredata(hist), use='complete.obs',method='pearson') * (s0 %*% t(s0)) + + weight[i,] = min.risk.portfolio(ia, constraints) + } + + # Minimum Variance + data$weight[] = weight + capital = 100000 + data$weight[] = (capital / prices) * data$weight + min.var.daily = bt.run(data, type='share', capital=capital) + + #***************************************************************** + # Code Strategies: Weekly + #****************************************************************** + + retw = data.weekly$prices / mlag(data.weekly$prices) - 1 + weightw = coredata(prices) + weightw[] = NA + + for( i in week.ends[week.ends >= (63 + 1)] ) { + # map + j = which(index(ret[i,]) == index(retw)) + + # one quarter = 13 weeks + hist = retw[ (j- 13 +1):j, ] + + # create historical input assumptions + ia = create.ia(hist) + s0 = apply(coredata(hist),2,sd) + ia$cov = cor(coredata(hist), use='complete.obs',method='pearson') * (s0 %*% t(s0)) + + weightw[i,] = min.risk.portfolio(ia, constraints) + } + + data$weight[] = weightw + capital = 100000 + data$weight[] = (capital / prices) * data$weight + min.var.weekly = bt.run(data, type='share', capital=capital, trade.summary = T) + #min.var.weekly$trade.summary$trades + #***************************************************************** + # Create Report + #****************************************************************** + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(min.var.weekly, min.var.daily, equal.weight) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(min.var.weekly, min.var.daily, equal.weight) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plotbt.transition.map(min.var.daily$weight) + legend('topright', legend = 'min.var.daily', bty = 'n') + plotbt.transition.map(min.var.weekly$weight) + legend('topright', legend = 'min.var.weekly', bty = 'n') +dev.off() + +} + + +############################################################################### +# Backtest various asset allocation strategies based on the idea +# Forecast-Free Algorithms: A New Benchmark For Tactical Strategies +# http://cssanalytics.wordpress.com/2011/08/09/forecast-free-algorithms-a-new-benchmark-for-tactical-strategies/ +# +# Extension to http://systematicinvestor.wordpress.com/2011/12/13/backtesting-minimum-variance-portfolios/ +############################################################################### +bt.aa.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod,quadprog,corpcor,lpSolve') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + #tickers = dow.jones.components() + + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1990::2011') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + # find week ends + period.ends = endpoints(prices, 'weeks') + period.annual.factor = 52 + +# period.ends = endpoints(prices, 'months') +# period.annual.factor = 12 + + period.ends = period.ends[period.ends > 0] + + #***************************************************************** + # Create Constraints + #***************************************************************** + constraints = new.constraints(n, lb = 0, ub = 1) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + #***************************************************************** + # Code Strategies + #****************************************************************** + ret = prices / mlag(prices) - 1 + start.i = which(period.ends >= (63 + 1))[1] + + #min.risk.fns = spl('min.risk.portfolio,min.maxloss.portfolio,min.mad.portfolio,min.cvar.portfolio,min.cdar.portfolio,min.cor.insteadof.cov.portfolio,min.mad.downside.portfolio,min.risk.downside.portfolio,min.avgcor.portfolio,find.erc.portfolio,min.gini.portfolio') + min.risk.fns = spl('min.risk.portfolio,min.maxloss.portfolio') + + # Gini risk measure optimization takes a while, uncomment below to add Gini risk measure + # min.risk.fns = c(min.risk.fns, 'min.gini.portfolio') + + weight = NA * prices[period.ends,] + weights = list() + # Equal Weight 1/N Benchmark + weights$equal.weight = weight + weights$equal.weight[] = ntop(prices[period.ends,], n) + weights$equal.weight[1:start.i,] = NA + + for(f in min.risk.fns) weights[[ gsub('\\.portfolio', '', f) ]] = weight + + risk.contributions = list() + for(f in names(weights)) risk.contributions[[ f ]] = weight + + # construct portfolios + for( j in start.i:len(period.ends) ) { + i = period.ends[j] + + # one quarter = 63 days + hist = ret[ (i- 63 +1):i, ] + + include.index = rep(TRUE, n) +# new logic, require all assets to have full price history +#include.index = count(hist)== 63 +#hist = hist[ , include.index] + + + # create historical input assumptions + ia = create.ia(hist) + s0 = apply(coredata(hist),2,sd) + ia$correlation = cor(coredata(hist), use='complete.obs',method='pearson') + ia$cov = ia$correlation * (s0 %*% t(s0)) + + # find optimal portfolios under different risk measures + for(f in min.risk.fns) { + # set up initial solution + constraints$x0 = weights[[ gsub('\\.portfolio', '', f) ]][(j-1), include.index] + + weights[[ gsub('\\.portfolio', '', f) ]][j, include.index] = match.fun(f)(ia, constraints) + } + + + # compute risk contributions implied by portfolio weihgts + for(f in names(weights)) { + risk.contributions[[ f ]][j, include.index] = portfolio.risk.contribution(weights[[ f ]][j, include.index], ia) + } + + if( j %% 10 == 0) cat(j, '\n') + } + + #***************************************************************** + # Create strategies + #****************************************************************** + models = list() + for(i in names(weights)) { + data$weight[] = NA + data$weight[period.ends,] = weights[[i]] + models[[i]] = bt.run.share(data, clean.signal = F) + } + + #***************************************************************** + # Create Report + #****************************************************************** + models = rev(models) + weights = rev(weights) + risk.contributions = rev(risk.contributions) + +png(filename = 'plot1.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot perfromance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Statistics Side by Side + plotbt.strategy.sidebyside(models) +dev.off() + + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') +dev.off() + + + +png(filename = 'plot4.png', width = 600, height = 1600, units = 'px', pointsize = 12, bg = 'white') + # Plot transition maps + layout(1:len(models)) + for(m in names(models)) { + plotbt.transition.map(models[[m]]$weight, name=m) + legend('topright', legend = m, bty = 'n') + } +dev.off() + +png(filename = 'plot5.png', width = 600, height = 1600, units = 'px', pointsize = 12, bg = 'white') + # Plot risk contributions + layout(1:len(risk.contributions)) + for(m in names(risk.contributions)) { + plotbt.transition.map(risk.contributions[[m]], name=paste('Risk Contributions',m)) + legend('topright', legend = m, bty = 'n') + } +dev.off() + + +png(filename = 'plot6.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot portfolio concentration stats + layout(1:2) + plota.matplot(lapply(weights, portfolio.concentration.gini.coefficient), main='Gini Coefficient') + plota.matplot(lapply(weights, portfolio.concentration.herfindahl.index), main='Herfindahl Index') + #plota.matplot(lapply(weights, portfolio.turnover), main='Turnover') +dev.off() + + +png(filename = 'plot7.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Compute stats + out = compute.stats(weights, + list(Gini=function(w) mean(portfolio.concentration.gini.coefficient(w), na.rm=T), + Herfindahl=function(w) mean(portfolio.concentration.herfindahl.index(w), na.rm=T), + Turnover=function(w) period.annual.factor * mean(portfolio.turnover(w), na.rm=T) + ) + ) + + out[] = plota.format(100 * out, 1, '', '%') + plot.table(t(out)) +dev.off() + + +png(filename = 'plot8.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(weights, function(w) period.annual.factor * mean(portfolio.turnover(w), na.rm=T)), 'Average Annual Portfolio Turnover') +dev.off() + +} + +bt.aa.test.new <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod,quadprog,corpcor,lpSolve') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1990::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + cluster.group = cluster.group.kmeans.90 + + obj = portfolio.allocation.helper(data$prices, + periodicity = 'months', lookback.len = 60, + min.risk.fns = list( + EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + MD=max.div.portfolio, + + MV=min.var.portfolio, + MVE=min.var.excel.portfolio, + MV2=min.var2.portfolio, + + MC=min.corr.portfolio, + MCE=min.corr.excel.portfolio, + MC2=min.corr2.portfolio, + + MS=max.sharpe.portfolio(), + ERC = equal.risk.contribution.portfolio, + + # target retunr / risk + TRET.12 = target.return.portfolio(12/100), + TRISK.10 = target.risk.portfolio(10/100), + + # cluster + C.EW = distribute.weights(equal.weight.portfolio, cluster.group), + C.RP = distribute.weights(risk.parity.portfolio(), cluster.group), + + # rso + RSO.RP.5 = rso.portfolio(risk.parity.portfolio(), 5, 500), + + # others + MMaxLoss = min.maxloss.portfolio, + MMad = min.mad.portfolio, + MCVaR = min.cvar.portfolio, + MCDaR = min.cdar.portfolio, + MMadDown = min.mad.downside.portfolio, + MRiskDown = min.risk.downside.portfolio, + MCorCov = min.cor.insteadof.cov.portfolio + ) + ) + + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'filename.pdf', width=8.5, height=11) + +png(filename = 'plot1.png', width = 1800, height = 1800, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T, 'Backtesting Asset Allocation portfolios') +dev.off() + + + + # close pdf file + #dev.off() + + #pdf(file = 'filename.pdf', width=18.5, height=21) + # strategy.performance.snapshoot(models, title = 'Backtesting Asset Allocation portfolios', data = data) + #dev.off() + + # to see last 5 re-balances + # round(100 * last(models$MCDaR$weight[obj$period.ends[-len(obj$period.ends)]+1], 5)) +} + + + + + +############################################################################### +# Investigate Rebalancing methods: +# 1. Periodic Rebalancing: rebalance to the target mix every month, quarter, year. +# 2. Maximum Deviation Rebalancing: rebalance to the target mix when asset weights deviate more than a given percentage from the target mix. +# 3. Same as 2, but rebalance half-way to target +############################################################################### +bt.rebalancing.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1900::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + target.allocation = matrix(c(0.5, 0.5), nrow=1) + + # Buy & Hold + data$weight[] = NA + data$weight[1,] = target.allocation + capital = 100000 + data$weight[] = (capital / prices) * data$weight + buy.hold = bt.run(data, type='share', capital=capital) + + + # Rebalance periodically + models = list() + for(period in spl('months,quarters,years')) { + data$weight[] = NA + data$weight[1,] = target.allocation + + period.ends = endpoints(prices, period) + period.ends = period.ends[period.ends > 0] + data$weight[period.ends,] = repmat(target.allocation, len(period.ends), 1) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + models[[period]] = bt.run(data, type='share', capital=capital) + } + models$buy.hold = buy.hold + + # Compute Portfolio Turnover + compute.turnover(models$years, data) + + # Compute Portfolio Maximum Deviation + compute.max.deviation(models$years, target.allocation) + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + pdf(file = 'report.pdf', width=8.5, height=11) + plotbt.custom.report(models) + dev.off() + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot BuyHold and Monthly Rebalancing Weights + layout(1:2) + plotbt.transition.map(models$buy.hold$weight, 'buy.hold', spl('red,orange')) + abline(h=50) + plotbt.transition.map(models$months$weight, 'months', spl('red,orange')) + abline(h=50) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each Rebalancing method + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') +dev.off() + + #***************************************************************** + # Code Strategies that rebalance based on maximum deviation + #****************************************************************** + + # rebalance to target.allocation when portfolio weights are 5% away from target.allocation + models$smart5.all = bt.max.deviation.rebalancing(data, buy.hold, target.allocation, 5/100, 0) + + # rebalance half-way to target.allocation when portfolio weights are 5% away from target.allocation + models$smart5.half = bt.max.deviation.rebalancing(data, buy.hold, target.allocation, 5/100, 0.5) + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot4.png', width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + # Plot BuyHold, Years and Max Deviation Rebalancing Weights + layout(1:4) + plotbt.transition.map(models$buy.hold$weight, 'buy.hold', spl('red,orange')) + abline(h=50) + plotbt.transition.map(models$smart5.all$weight, 'Max Deviation 5%, All the way', spl('red,orange')) + abline(h=50) + plotbt.transition.map(models$smart5.half$weight, 'Max Deviation 5%, Half the way', spl('red,orange')) + abline(h=50) + plotbt.transition.map(models$years$weight, 'years', spl('red,orange')) + abline(h=50) +dev.off() + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each Rebalancing method + layout(1:2) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover', F) + barplot.with.labels(sapply(models, compute.max.deviation, target.allocation), 'Maximum Deviation from Target Mix') +dev.off() + +png(filename = 'plot6.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Statistics Side by Side + plotbt.strategy.sidebyside(models) +dev.off() + + #***************************************************************** + # Periodic Rebalancing Seasonality + #****************************************************************** + # maQuant annual rebalancing (september/october showed the best results) + months = spl('Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec') + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + models = list() + for(i in 1:12) { + index = which( date.month(index(prices)[period.ends]) == i ) + data$weight[] = NA + data$weight[1,] = target.allocation + data$weight[period.ends[index],] = repmat(target.allocation, len(index), 1) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + models[[ months[i] ]] = bt.run(data, type='share', capital=capital) + } + +png(filename = 'plot7.png', width = 1200, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') +} + + +# Maximum Deviation Rebalancing: rebalance to the target mix when asset weights deviate more than a given percentage from the target mix. +# Also support rebalancing.ratio, same as above, but rebalance half-way to target +#' @export +bt.max.deviation.rebalancing <- function +( + data, + model, + target.allocation, + max.deviation = 3/100, + rebalancing.ratio = 0, # 0 means rebalance all-way to target.allocation + # 0.5 means rebalance half-way to target.allocation + start.index = 1, + period.ends = 1:nrow(model$weight), + fast = T +) +{ + nperiods = nrow(model$weight) + action.index = rep(F, nperiods) + + start.index = period.ends[start.index] + start.index0 = start.index + + while(T) { + # find rows that violate max.deviation + weight = model$weight + index = apply(abs(weight - rep.row(target.allocation, nperiods)), 1, max) > max.deviation + index = which( index[period.ends] ) + + if( len(index) > 0 ) { + index = period.ends[index] + index = index[ index > start.index ] + + if( len(index) > 0 ) { + action.index[index[1]] = T + + data$weight[] = NA + data$weight[start.index0,] = target.allocation + + temp = rep.row(target.allocation, sum(action.index)) + data$weight[action.index,] = temp + + rebalancing.ratio * (weight[action.index,] - temp) + + # please note the bt.run.share.ex somehow gives slighly better results + if(fast) + model = bt.run.share.fast(data) + else + model = bt.run.share.ex(data, clean.signal=F, silent=T) + + start.index = index[1] + } else break + } else break + } + + model = bt.run.share.ex(data, clean.signal=F, silent=F) + return(model) +} + + + + + + + + + +bt.rebalancing1.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + # SHY - cash + tickers = spl('SPY,TLT,GLD,FXE,USO,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1900::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + target.allocation = matrix(rep(1/6,6), nrow=1) + + # Buy & Hold + data$weight[] = NA + data$weight[1,] = target.allocation + capital = 100000 + data$weight[] = (capital / prices) * data$weight + buy.hold = bt.run(data, type='share', capital=capital) + + + # Rebalance periodically + models = list() + for(period in spl('months,quarters,years')) { + data$weight[] = NA + data$weight[1,] = target.allocation + + period.ends = endpoints(prices, period) + period.ends = period.ends[period.ends > 0] + data$weight[period.ends,] = repmat(target.allocation, len(period.ends), 1) + + capital = 100000 + data$weight[] = (capital / prices) * data$weight + models[[period]] = bt.run(data, type='share', capital=capital) + } + models$buy.hold = buy.hold + + + #***************************************************************** + # Code Strategies that rebalance based on maximum deviation + #****************************************************************** + + # rebalance to target.allocation when portfolio weights are 3% away from target.allocation + models$smart3.all = bt.max.deviation.rebalancing(data, buy.hold, target.allocation, 3/100, 0) + + # rebalance half-way to target.allocation when portfolio weights are 3% away from target.allocation + models$smart3.half = bt.max.deviation.rebalancing(data, buy.hold, target.allocation, 3/100, 0.5) + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # Plot Portfolio Turnover for each Rebalancing method + layout(1:2) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover', F) + barplot.with.labels(sapply(models, compute.max.deviation, target.allocation), 'Maximum Deviation from Target Mix') + + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Statistics Side by Side + plotbt.strategy.sidebyside(models) +dev.off() + +} + + +############################################################################### +# Rotational Trading: how to reduce trades and improve returns by Frank Hassler +# http://engineering-returns.com/2011/07/06/rotational-trading-how-to-reducing-trades-and-improve-returns/ +############################################################################### +bt.rotational.trading.trades.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU,IWB,IWD,IWF,IWM,IWN,IWO,IWP,IWR,IWS,IWV,IWW,IWZ') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1970::2011') + + #***************************************************************** + # Code Strategies : weekly rebalancing + #****************************************************************** + prices = data$prices + n = len(tickers) + + # find week ends + week.ends = endpoints(prices, 'weeks') + week.ends = week.ends[week.ends > 0] + + + # Rank on ROC 200 + position.score = prices / mlag(prices, 200) + position.score.ma = position.score + buy.rule = T + + # Select Top 2 funds daily + data$weight[] = NA + data$weight[] = ntop(position.score, 2) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.d = bt.run(data, type='share', trade.summary=T, capital=capital) + + # Select Top 2 funds weekly + data$weight[] = NA + data$weight[week.ends,] = ntop(position.score[week.ends,], 2) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.w = bt.run(data, type='share', trade.summary=T, capital=capital) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Metrics Side by Side + plotbt.strategy.sidebyside(top2.d, top2.w, perfromance.fn = 'engineering.returns.kpi') +dev.off() + + #***************************************************************** + # Code Strategies : different entry/exit rank + #****************************************************************** + + # Select Top 2 funds, Keep till they are in 4/6 rank + data$weight[] = NA + data$weight[] = ntop.keep(position.score, 2, 4) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.d.keep4 = bt.run(data, type='share', trade.summary=T, capital=capital) + + data$weight[] = NA + data$weight[] = ntop.keep(position.score, 2, 6) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.d.keep6 = bt.run(data, type='share', trade.summary=T, capital=capital) + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Metrics Side by Side + plotbt.strategy.sidebyside(top2.d, top2.d.keep4, top2.d.keep6, perfromance.fn = 'engineering.returns.kpi') +dev.off() + + #***************************************************************** + # Code Strategies : Rank smoothing + #****************************************************************** + + models = list() + models$Bench = top2.d + for( avg in spl('SMA,EMA') ) { + for( i in c(3,5,10,20) ) { + position.score.smooth = bt.apply.matrix(position.score.ma, avg, i) + position.score.smooth[!buy.rule,] = NA + + data$weight[] = NA + data$weight[] = ntop(position.score.smooth, 2) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + models[[ paste(avg,i) ]] = bt.run(data, type='share', trade.summary=T, capital=capital) + } + } + +png(filename = 'plot3.png', width = 1200, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Metrics Side by Side + plotbt.strategy.sidebyside(models, perfromance.fn = 'engineering.returns.kpi') +dev.off() + + #***************************************************************** + # Code Strategies : Combination + #****************************************************************** + + # Select Top 2 funds daily, Keep till they are 6 rank, Smooth Rank by 10 day EMA + position.score.smooth = bt.apply.matrix(position.score.ma, 'EMA', 10) + position.score.smooth[!buy.rule,] = NA + data$weight[] = NA + data$weight[] = ntop.keep(position.score.smooth, 2, 6) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.d.keep6.EMA10 = bt.run(data, type='share', trade.summary=T, capital=capital) + + # Select Top 2 funds weekly, Keep till they are 6 rank + data$weight[] = NA + data$weight[week.ends,] = ntop.keep(position.score[week.ends,], 2, 6) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.w.keep6 = bt.run(data, type='share', trade.summary=T, capital=capital) + + # Select Top 2 funds weekly, Keep till they are 6 rank, Smooth Rank by 10 week EMA + position.score.smooth[] = NA + position.score.smooth[week.ends,] = bt.apply.matrix(position.score.ma[week.ends,], 'EMA', 10) + position.score.smooth[!buy.rule,] = NA + + data$weight[] = NA + data$weight[week.ends,] = ntop.keep(position.score.smooth[week.ends,], 2, 6) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + top2.w.keep6.EMA10 = bt.run(data, type='share', trade.summary=T, capital=capital) + + +png(filename = 'plot4.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot Strategy Metrics Side by Side + plotbt.strategy.sidebyside(top2.d, top2.d.keep6, top2.d.keep6.EMA10, top2.w, top2.w.keep6, top2.w.keep6.EMA10, perfromance.fn = 'engineering.returns.kpi') +dev.off() + + + + + + + #***************************************************************** + # Possible Improvements to reduce drawdowns + #****************************************************************** + # Equal Weight + data$weight[] = ntop(prices, n) + ew = bt.run(data) + + # Avoiding severe draw downs + # http://engineering-returns.com/2010/07/26/rotational-trading-system/ + # Only trade the system when the index is either above the 200 MA or 30 MA + # Usually these severe draw downs happen bellow the 200MA average and + # the second 30 MA average will help to get in when the recovery happens + buy.rule = (ew$equity > SMA(ew$equity,200)) | (ew$equity > SMA(ew$equity,30)) + buy.rule = (ew$equity > SMA(ew$equity,200)) + buy.rule = ifna(buy.rule, F) + + # Rank using TSI by Frank Hassler, TSI is already smoothed and slow varying, + # so SMA will filter will not very effective + #http://engineering-returns.com/tsi/ + position.score = bt.apply(data, function(x) TSI(HLC(x)) ) + position.score.ma = position.score + position.score[!buy.rule,] = NA + +} + + + +############################################################################### +# Charting the Santa Claus Rally +# http://ibankcoin.com/woodshedderblog/2011/12/15/charting-the-santa-claus-rally/ +# +# Trading Calendar +# http://www.cxoadvisory.com/trading-calendar/ +############################################################################### +bt.december.trading.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1970::2011') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = len(tickers) + ret = prices / mlag(prices) - 1 + + + # find prices in December + dates = index(prices) + years = date.year(dates) + index = which(date.month(dates) == 12) + + # rearrange data in trading days + trading.days = sapply(tapply(ret[index,], years[index], function(x) coredata(x)), function(x) x[1:22]) + + # average return each trading days, excluding current year + avg.trading.days = apply(trading.days[, -ncol(trading.days)], 1, mean, na.rm=T) + current.year = trading.days[, ncol(trading.days)] + + # cumulative + avg.trading.days = 100 * ( cumprod(1 + avg.trading.days) - 1 ) + current.year = 100 * ( cumprod(1 + current.year) - 1 ) + + #***************************************************************** + # Create Plot + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # plot + par(mar=c(4,4,1,1)) + plot(avg.trading.days, type='b', col=1, + ylim=range(avg.trading.days,current.year,na.rm=T), + xlab = 'Number of Trading Days in December', + ylab = 'Avg % Profit/Loss' + ) + lines(current.year, type='b', col=2) + grid() + plota.legend('Avg SPY,SPY Dec 2011', 1:2) +dev.off() + + #***************************************************************** + # Code Strategies + #****************************************************************** + # Buy & Hold + data$weight[] = 1 + capital = 100000 + data$weight[] = (capital / prices) * data$weight + buy.hold = bt.run(data, type='share', capital=capital) + + + # Find Last trading days in November and December + index = which(date.month(dates) == 11) + last.day.november = match(tapply(dates[index], years[index], function(x) tail(x,1)), dates) + index = which(date.month(dates) == 12) + last.day.december = match(tapply(dates[index], years[index], function(x) tail(x,1)), dates) + + # December + data$weight[] = NA + data$weight[last.day.november,] = 1 + data$weight[last.day.december,] = 0 + capital = 100000 + data$weight[] = (capital / prices) * data$weight + december = bt.run(data, type='share', capital=capital, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(december, buy.hold, trade.summary=T) +dev.off() + +png(filename = 'plot3.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(december, buy.hold, trade.summary=T) +dev.off() + +} + + +############################################################################### +# Seasonality Case Study +# Historical Seasonality Analysis: What company in DOW is likely to do well in January? +############################################################################### +bt.seasonality.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::2011') + + #***************************************************************** + # Compute monthly returns + #****************************************************************** + prices = data$prices + n = ncol(prices) + + # find month ends + month.ends = endpoints(prices, 'months') + + prices = prices[month.ends,] + ret = prices / mlag(prices) - 1 + + # keep only January + ret = ret[date.month(index(ret)) == 1, ] + + # keep last 20 years + ret = last(ret,20) + + #***************************************************************** + # Compute stats + #****************************************************************** + stats = matrix(rep(NA,2*n), nc=n) + colnames(stats) = colnames(prices) + rownames(stats) = spl('N,Positive') + + for(i in 1:n) { + stats['N',i] = sum(!is.na(ret[,i])) + stats['Positive',i] = sum(ret[,i]>0, na.rm=T) + } + sort(stats['Positive',], decreasing =T) + +png(filename = 'plot1.png', width = 600, height = 200, units = 'px', pointsize = 12, bg = 'white') + plot.table(stats[, order(stats['Positive',], decreasing =T)[1:10]]) +dev.off() + + + +} + + +############################################################################### +# Volatility Forecasting using Garch(1,1) based +# +# Regime Switching System Using Volatility Forecast by Quantum Financier +# http://quantumfinancier.wordpress.com/2010/08/27/regime-switching-system-using-volatility-forecast/ +############################################################################### +# Benchmarking Garch algorithms +# garch from tseries package is faster than garchFit from fGarch package +############################################################################### +bt.test.garch.speed <- function() +{ + load.packages('tseries,fGarch,rbenchmark') + + temp = garchSim(n=252) + + test1 <- function() { + fit1=garch(temp, order = c(1, 1), control = garch.control(trace = F)) + } + test2 <- function() { + fit2=garchFit(~ garch(1,1), data = temp, include.mean=FALSE, trace=F) + } + + benchmark( + test1(), + test2(), + columns=spl('test,replications,elapsed,relative'), + order='relative', + replications=100 + ) +} + +############################################################################### +# One day ahead forecast functions for garch (tseries) and garchFit(fGarch) +# Sigma[t]^2 = w + a* Sigma[t-1]^2 + b*r[t-1]^2 +# r.last - last return, h.last - last volatility +############################################################################### +garch.predict.one.day <- function(fit, r.last) +{ + h.last = tail( fitted(fit)[,1] ,1) + sqrt(sum( coef(fit) * c(1, r.last^2, h.last^2) )) +} + +# same as predict( fit, n.ahead=1, doplot=F)[3] +garchFit.predict.one.day <- function(fit, r.last) +{ + h.last = tail(sqrt(fit@h.t), 1) + sqrt(sum( fit@fit$matcoef[,1] * c(1, r.last^2, h.last^2) )) +} + +############################################################################### +# Forecast Volatility using Garch +# garch from tseries is fast, but does not consistently converge +# garchFit from fGarch is slower, but converges consistently +############################################################################### +bt.forecast.garch.volatility <- function(ret.log, est.period = 252) +{ + nperiods = nrow(ret.log) + garch.vol = NA * ret.log + + for( i in (est.period + 1) : nperiods ) { + temp = as.vector(ret.log[ (i - est.period + 1) : i, ]) + r.last = tail( temp, 1 ) + + fit = tryCatch( garch(temp, order = c(1, 1), control = garch.control(trace = F)), + error=function( err ) FALSE, warning=function( warn ) FALSE ) + + if( !is.logical( fit ) ) { + if( i == est.period + 1 ) garch.vol[1:est.period] = fitted(fit)[,1] + garch.vol[i] = garch.predict.one.day(fit, r.last) + } else { + fit = tryCatch( garchFit(~ garch(1,1), data = temp, include.mean=FALSE, trace=F), + error=function( err ) FALSE, warning=function( warn ) FALSE ) + + if( !is.logical( fit ) ) { + if( i == est.period + 1 ) garch.vol[1:est.period] = sqrt(fit@h.t) + garch.vol[i] = garchFit.predict.one.day(fit, r.last) + } + } + if( i %% 100 == 0) cat(i, '\n') + } + garch.vol[] = ifna.prev(coredata(garch.vol)) + return(garch.vol) +} + +############################################################################### +# Volatility Forecasting using Garch(1,1) based +############################################################################### +bt.volatility.garch <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'SPY' + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='2000::2012') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = len(tickers) + nperiods = nrow(prices) + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + + # Mean-Reversion(MR) strategy - RSI2 + rsi2 = bt.apply.matrix(prices, RSI, 2) + data$weight[] = NA + data$weight[] = iif(rsi2 < 50, 1, -1) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + mr = bt.run(data, type='share', capital=capital, trade.summary=T) + + + # Trend Following(TF) strategy - MA 50/200 crossover + sma.short = bt.apply.matrix(prices, SMA, 50) + sma.long = bt.apply.matrix(prices, SMA, 200) + data$weight[] = NA + data$weight[] = iif(sma.short > sma.long, 1, -1) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + tf = bt.run(data, type='share', capital=capital, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plotbt.custom.report.part1(mr, tf, buy.hold, trade.summary=T) + +dev.off() + #***************************************************************** + # Regime Switching Historical + #****************************************************************** + #classify current volatility by percentile using a 252 day lookback period + #The resulting series oscillate between 0 and 1, and is smoothed using a 21 day percentrankSMA (developed by David Varadi) using a 252 day lookback period. + #percentrank(MA(percentrank(Stdev( diff(log(close)) ,21),252),21),250) + + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = bt.apply.matrix(ret.log, runSD, n = 21) + vol.rank = percent.rank(SMA(percent.rank(hist.vol, 252), 21), 250) + + # Regime Switching Historical + data$weight[] = NA + data$weight[] = iif(vol.rank > 0.5, + iif(rsi2 < 50, 1, -1), + iif(sma.short > sma.long, 1, -1) + ) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + regime.switching = bt.run(data, type='share', capital=capital, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plotbt.custom.report.part1(regime.switching, mr, tf, buy.hold, trade.summary=T) + +dev.off() + + #***************************************************************** + # Regime Switching using Garch + #****************************************************************** + load.packages('tseries,fGarch') + garch.vol = bt.forecast.garch.volatility(ret.log, 252) + vol.rank = percent.rank(SMA(percent.rank(garch.vol, 252), 21), 250) + + # Regime Switching Garch + data$weight[] = NA + data$weight[] = iif(vol.rank > 0.5, + iif(rsi2 < 50, 1, -1), + iif(sma.short > sma.long, 1, -1) + ) + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + regime.switching.garch = bt.run(data, type='share', capital=capital, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plotbt.custom.report.part1(regime.switching.garch, regime.switching, buy.hold, trade.summary=T) + +dev.off() +} + + + + + +############################################################################### +# Time Series Matching +# +# Based on Jean-Robert Avettand-Fenoel - How to Accelerate Model Deployment using Rook +# http://www.londonr.org/Sep%2011%20LondonR_AvettandJR.pdf +############################################################################### +bt.matching.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'SPY' + + data = getSymbols(tickers, src = 'yahoo', from = '1950-01-01', auto.assign = F) + + #***************************************************************** + # New: logic moved to functions + #****************************************************************** + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + obj = bt.matching.find(Cl(data), plot=T) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + matches = bt.matching.overlay(obj, plot=T) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + bt.matching.overlay.table(obj, matches, plot=T) +dev.off() + + + #***************************************************************** + # Original logic: Setup search + #****************************************************************** + data = last(data, 252*10) + reference = coredata(Cl(data)) + n = len(reference) + query = reference[(n-90+1):n] + reference = reference[1:(n-90)] + + n.query = len(query) + n.reference = len(reference) + + #***************************************************************** + # Compute Distance + #****************************************************************** + dist = rep(NA, n.reference) + query.normalized = (query - mean(query)) / sd(query) + + for( i in n.query : n.reference ) { + window = reference[ (i - n.query + 1) : i] + window.normalized = (window - mean(window)) / sd(window) + dist[i] = stats:::dist(rbind(query.normalized, window.normalized)) + } + + #***************************************************************** + # Find Matches + #****************************************************************** + min.index = c() + n.match = 10 + + # only look at the minimums + temp = dist + temp[ temp > mean(dist, na.rm=T) ] = NA + + # remove n.query, points to the left/right of the minimums + for(i in 1:n.match) { + if(any(!is.na(temp))) { + index = which.min(temp) + min.index[i] = index + temp[max(0,index - 2*n.query) : min(n.reference,(index + n.query))] = NA + } + } + n.match = len(min.index) + + #***************************************************************** + # Plot Matches + #****************************************************************** + dates = index(data)[1:len(dist)] + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + par(mar=c(2, 4, 2, 2)) + plot(dates, dist, type='l',col='gray', main='Top Matches', ylab='Euclidean Distance', xlab='') + abline(h = mean(dist, na.rm=T), col='darkgray', lwd=2) + points(dates[min.index], dist[min.index], pch=22, col='red', bg='red') + text(dates[min.index], dist[min.index], 1:n.match, adj=c(1,1), col='black',xpd=TRUE) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plota(data, type='l', col='gray', main=tickers) + plota.lines(last(data,90), col='blue') + for(i in 1:n.match) { + plota.lines(data[(min.index[i]-n.query + 1):min.index[i]], col='red') + } + text(index4xts(data)[min.index - n.query/2], reference[min.index - n.query/2], 1:n.match, + adj=c(1,-1), col='black',xpd=TRUE) + plota.legend('Pattern,Match Number','blue,red') +dev.off() + + #***************************************************************** + # Overlay all Matches + #****************************************************************** + matches = matrix(NA, nr=(n.match+1), nc=3*n.query) + temp = c(rep(NA, n.query), reference, query) + for(i in 1:n.match) { + matches[i,] = temp[ (min.index[i] - n.query + 1):(min.index[i] + 2*n.query) ] + } + #reference[min.index] == matches[,(2*n.query)] + + matches[(n.match+1),] = temp[ (len(temp) - 2*n.query + 1):(len(temp) + n.query) ] + #matches[(n.match+1), (n.query+1):(2*n.query)] == query + + for(i in 1:(n.match+1)) { + matches[i,] = matches[i,] / matches[i,n.query] + } + + + #***************************************************************** + # Plot all Matches + #****************************************************************** + temp = 100 * ( t(matches[,-c(1:n.query)]) - 1) + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + par(mar=c(2, 4, 2, 2)) + matplot(temp, type='l',col='gray',lwd=2, lty='dotted', xlim=c(1,2.5*n.query), + main = paste('Pattern Prediction with', n.match, 'neighbours'),ylab='Normalized', xlab='') + lines(temp[,(n.match+1)], col='black',lwd=4) + + points(rep(2*n.query,n.match), temp[2*n.query,1:n.match], pch=21, lwd=2, col='gray', bg='gray') + + bt.plot.dot.label <- function(x, data, xfun, col='red') { + for(j in 1:len(xfun)) { + y = match.fun(xfun[[j]])(data) + points(x, y, pch=21, lwd=4, col=col, bg=col) + text(x, y, paste(names(xfun)[j], ':', round(y,1),'%'), + adj=c(-0.1,0), cex = 0.8, col=col,xpd=TRUE) + } + } + + bt.plot.dot.label(2*n.query, temp[2*n.query,1:n.match], + list(Min=min,Max=max,Median=median,'Bot 25%'=function(x) quantile(x,0.25),'Top 75%'=function(x) quantile(x,0.75))) + bt.plot.dot.label(n.query, temp[n.query,(n.match+1)], list(Current=min)) +dev.off() + + #***************************************************************** + # Table with predictions + #****************************************************************** + temp = matrix( double(), nr=(n.match+4), 6) + rownames(temp) = c(1:n.match, spl('Current,Min,Average,Max')) + colnames(temp) = spl('Start,End,Return,Week,Month,Quarter') + + # compute returns + temp[1:(n.match+1),'Return'] = matches[,2*n.query]/ matches[,n.query] + temp[1:(n.match+1),'Week'] = matches[,(2*n.query+5)]/ matches[,2*n.query] + temp[1:(n.match+1),'Month'] = matches[,(2*n.query+20)]/ matches[,2*n.query] + temp[1:(n.match+1),'Quarter'] = matches[,(2*n.query+60)]/ matches[,2*n.query] + + # compute average returns + index = spl('Return,Week,Month,Quarter') + temp['Min', index] = apply(temp[1:(n.match+1),index],2,min,na.rm=T) + temp['Average', index] = apply(temp[1:(n.match+1),index],2,mean,na.rm=T) + temp['Max', index] = apply(temp[1:(n.match+1),index],2,max,na.rm=T) + + # format + temp[] = plota.format(100*(temp-1),1,'','%') + + # enter dates + temp['Current', 'Start'] = format(index(last(data,90)[1]), '%d %b %Y') + temp['Current', 'End'] = format(index(last(data,1)[1]), '%d %b %Y') + for(i in 1:n.match) { + temp[i, 'Start'] = format(index(data[min.index[i] - n.query + 1]), '%d %b %Y') + temp[i, 'End'] = format(index(data[min.index[i]]), '%d %b %Y') + } + + # plot table +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot.table(temp, smain='Match Number') +dev.off() + +} + +############################################################################### +# Time Series Matching Backtest +# +# New weighting scheme : seight each match by its distance +############################################################################### +bt.matching.backtest.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY,^GSPC') + + data <- new.env() + quantmod:::getSymbols(tickers, src = 'yahoo', from = '1950-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all') + + # compare common part [ SPY and ^GSPC match only if not adjusted for dividends] + #temp = data$prices['1993:01:29::'] + #plot(temp[,1]/as.double(temp[1,1]) - temp[,2]/as.double(temp[1,2]), main='Diff between SPY and ^GSPC') + + # combine SPY and ^GSPC + scale = as.double( data$prices$SPY['1993:01:29'] / data$prices$GSPC['1993:01:29'] ) + hist = c(scale * data$prices$GSPC['::1993:01:28'], data$prices$SPY['1993:01:29::']) + + #***************************************************************** + # Backtest setup: + # Starting January 1994, each month search for the 10 best matches + # similar to the last 90 days in the last 10 years of history data + # + # Invest next month if distance weighted prediction is positive + # otherwise stay in cash + #****************************************************************** + # find month ends + month.ends = endpoints(hist, 'months') + month.ends = month.ends[month.ends > 0] + + start.index = which(date.year(index(hist[month.ends])) == 1994)[1] + weight = hist * NA + + for( i in start.index : len(month.ends) ) { + #obj = bt.matching.find(hist[1:month.ends[i],], n.match=10, normalize.fn = normalize.mean, plot=T) + #matches = bt.matching.overlay(obj, future=hist[(month.ends[i]+1):(month.ends[i]+22),], plot=T) + #bt.matching.overlay.table(obj, matches, weights=NA, plot=T) + + obj = bt.matching.find(hist[1:month.ends[i],], normalize.fn = normalize.first) + matches = bt.matching.overlay(obj) + + # compute prediction for next month + n.match = len(obj$min.index) + n.query = len(obj$query) + month.ahead.forecast = matches[,(2*n.query+22)]/ matches[,2*n.query] - 1 + + # Average, mean(month.ahead.forecast[1:n.match]) + weights = rep(1/n.match, n.match) + avg.direction = weighted.mean(month.ahead.forecast[1:n.match], w=weights) + + # Distance weighted average + temp = round(100*(obj$dist / obj$dist[1] - 1)) + n.weight = max(temp) + 1 + weights = (n.weight - temp) / ( n.weight * (n.weight+1) / 2) + weights = weights / sum(weights) + # barplot(weights) + avg.direction = weighted.mean(month.ahead.forecast[1:n.match], w=weights) + + # Logic + weight[month.ends[i]] = 0 + if( avg.direction > 0 ) weight[month.ends[i]] = 1 + + # print progress + if( i %% 10 == 0) cat(i, '\n') + } + + #***************************************************************** + # Code Strategies + #****************************************************************** + tickers = 'SPY' + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1950-01-01', env = data, auto.assign = T) + bt.prep(data, align='keep.all') + + prices = data$prices + + # Buy & Hold + data$weight[] = 1 + buy.hold = bt.run(data) + + # Strategy + data$weight[] = NA + data$weight[] = weight['1993:01:29::'] + capital = 100000 + data$weight[] = (capital / prices) * bt.exrem(data$weight) + test = bt.run(data, type='share', capital=capital, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plotbt.custom.report.part1(test, buy.hold, trade.summary=T) + +dev.off() + + + +} + + + +############################################################################### +# Time Series Matching helper functions +############################################################################### +# functions to normalize data +############################################################################### +normalize.mean <- function(x) { x - mean(x) } +normalize.mean.sd <- function(x) { (x - mean(x)) / sd(x) } +normalize.first <- function(x) { x/as.double(x[1]) } + +############################################################################### +# functions to compute distance +############################################################################### +dist.euclidean <- function(x) { stats:::dist(x) } + +############################################################################### +# Find historical matches similar to the given query(pattern) +############################################################################### +bt.matching.find <- function +( + data, # time series + n.query=90, # length of pattern i.e. last 90 days + n.reference=252*10, # length of history to look for pattern + n.match=10, # number of matches to find + normalize.fn = normalize.mean.sd, # function to normalize data + dist.fn = dist.euclidean, # function to compute distance + plot=FALSE, # flag to create plot + plot.dist=FALSE, # flag to create distance plot + layout = NULL, # flag to idicate if layout is already set + main = NULL # plot title +) +{ + #***************************************************************** + # Setup search + #****************************************************************** + data = last(data, n.reference) + reference = coredata(data) + n = len(reference) + query = reference[(n - n.query + 1):n] + reference = reference[1:(n - n.query)] + + main = paste(main, join(format(range(index(data)[(n - n.query + 1):n]), '%d%b%Y'), ' - ')) + + n.query = len(query) + n.reference = len(reference) + + dist.fn.name = '' + if(is.character(dist.fn)) { + dist.fn.name = paste('with',dist.fn) + dist.fn = get(dist.fn) + } + + #***************************************************************** + # Compute Distance + #****************************************************************** + dist = rep(NA, n.reference) + query.normalized = match.fun(normalize.fn)(query) + + for( i in n.query : n.reference ) { + window = reference[ (i - n.query + 1) : i] + window.normalized = match.fun(normalize.fn)(window) + dist[i] = match.fun(dist.fn)(rbind(query.normalized, window.normalized)) + + # print progress + if( i %% 100 == 0) cat(i, '\n') + } + + #***************************************************************** + # Find Matches + #****************************************************************** + min.index = c() + + # only look at the minimums + temp = dist + temp[ temp > mean(dist, na.rm=T) ] = NA + + # remove n.query, points to the left/right of the minimums + for(i in 1:n.match) { + if(any(!is.na(temp))) { + index = which.min(temp) + min.index[i] = index + temp[max(0,index - 2*n.query) : min(n.reference,(index + n.query))] = NA + } + } + n.match = len(min.index) + + + #***************************************************************** + # Plot Matches + #****************************************************************** + if(plot) { + dates = index(data)[1:len(dist)] + + if(is.null(layout)) { + if(plot.dist) layout(1:2) else layout(1) + } + par(mar=c(2, 4, 2, 2)) + + if(plot.dist) { + plot(dates, dist, type='l',col='gray', main=paste('Top Historical Matches for', main, dist.fn.name), ylab='Distance', xlab='') + abline(h = mean(dist, na.rm=T), col='darkgray', lwd=2) + points(dates[min.index], dist[min.index], pch=22, col='red', bg='red') + text(dates[min.index], dist[min.index], 1:n.match, adj=c(1,1), col='black',xpd=TRUE) + } + + plota(data, type='l', col='gray', LeftMargin = 1, + main=iif(!plot.dist, paste('Top Historical Matches for', main), NULL) + ) + plota.lines(last(data,90), col='blue') + for(i in 1:n.match) { + plota.lines(data[(min.index[i]-n.query + 1):min.index[i]], col='red') + } + text(index4xts(data)[min.index - n.query/2], reference[min.index - n.query/2], 1:n.match, + adj=c(1,-1), col='black',xpd=TRUE) + plota.legend(paste('Pattern: ', main, ',Match Number'),'blue,red') + } + + return(list(min.index=min.index, dist=dist[min.index], query=query, reference=reference, dates = index(data), main = main)) +} + + +############################################################################### +# Create matrix that overlays all matches one on top of each other +############################################################################### +# helper function to plot dots and labels +############################################################################### +bt.plot.dot.label <- function(x, data, xfun, col='red') { + for(j in 1:len(xfun)) { + y = match.fun(xfun[[j]])(data) + points(x, y, pch=21, lwd=4, col=col, bg=col) + text(x, y, paste(names(xfun)[j], ':', round(y,1),'%'), + adj=c(-0.1,0), cex = 0.8, col=col,xpd=TRUE) + } +} + +bt.matching.overlay <- function +( + obj, # object from bt.matching.find function + future=NA, # time series of future, only used for plotting + plot=FALSE, # flag to create plot + plot.index=NA, # range of data to plot + layout = NULL # flag to idicate if layout is already set +) +{ + min.index = obj$min.index + query = obj$query + reference = obj$reference + + n.match = len(min.index) + n.query = len(query) + n.reference = len(reference) + + #***************************************************************** + # Overlay all Matches + #****************************************************************** + matches = matrix(NA, nr=(n.match+1), nc=3*n.query) + temp = c(rep(NA, n.query), reference, query, future) + for(i in 1:n.match) { + matches[i,] = temp[ (min.index[i] - n.query + 1):(min.index[i] + 2*n.query) ] + } + #reference[min.index] == matches[,(2*n.query)] + + matches[(n.match+1),] = temp[ (n.reference + 1):(n.reference + 3*n.query) ] + #matches[(n.match+1), (n.query+1):(2*n.query)] == query + + for(i in 1:(n.match+1)) { + matches[i,] = matches[i,] / iif(!is.na(matches[i,n.query]), matches[i,n.query], matches[i,(n.query+1)]) + } + + #***************************************************************** + # Plot all Matches + #****************************************************************** + if(plot) { + temp = 100 * ( t(matches[,-c(1:n.query)]) - 1) + if(!is.na(plot.index[1])) temp=temp[plot.index,] + n = nrow(temp) + + if(is.null(layout)) layout(1) + #par(mar=c(4, 2, 2, 2), ...) + par(mar=c(4, 2, 2, 2)) + + matplot(temp, type='n',col='gray',lwd=2, lty='dotted', xlim=c(1, n + 0.15*n), + main = paste(obj$main,'Historical Pattern Prediction with', n.match, 'neighbours'),ylab='Normalized', xlab = 'Trading Days') + + col=adjustcolor('yellow', 0.5) + rect(0, par('usr')[3],n.query, par('usr')[4], col=col, border=col) + box() + + + matlines(temp, col='gray',lwd=2, lty='dotted') + lines(temp[,(n.match+1)], col='black',lwd=4) + + + + points(rep(n, n.match), temp[n, 1:n.match], pch=21, lwd=2, col='gray', bg='gray') + + bt.plot.dot.label(n, temp[n, 1:n.match], + list(Min=min,Max=max,Median=median,'Bot 25%'=function(x) quantile(x,0.25),'Top 75%'=function(x) quantile(x,0.75))) + bt.plot.dot.label(n.query, temp[n.query,(n.match+1)], list(Current=min)) + } + + return(matches) +} + + +############################################################################### +# Create matches summary table +############################################################################### +bt.matching.overlay.table <- function +( + obj, # object from bt.matching.find function + matches, # matches from bt.matching.overlay function + weights=NA, # weights to compute average + plot=FALSE, # flag to create plot + layout = NULL # flag to idicate if layout is already set +) +{ + min.index = obj$min.index + query = obj$query + reference = obj$reference + dates = obj$dates + + n.match = len(min.index) + n.query = len(query) + n.reference = len(reference) + + if(is.na(weights)) weights = rep(1/n.match, n.match) + + #***************************************************************** + # Table with predictions + #****************************************************************** + temp = matrix( double(), nr=(n.match + 4), 6) + rownames(temp) = c(1:n.match, spl('Current,Min,Average,Max')) + colnames(temp) = spl('Start,End,Return,Week,Month,Quarter') + + # compute returns + temp[1:(n.match+1),'Return'] = matches[,2*n.query]/ matches[,n.query] + temp[1:(n.match+1),'Week'] = matches[,(2*n.query+5)]/ matches[,2*n.query] + temp[1:(n.match+1),'Month'] = matches[,(2*n.query+20)]/ matches[,2*n.query] + temp[1:(n.match+1),'Quarter'] = matches[,(2*n.query+60)]/ matches[,2*n.query] + + # compute average returns + index = spl('Return,Week,Month,Quarter') + temp['Min', index] = apply(temp[1:(n.match+0),index],2,min,na.rm=T) + #temp['Average', index] = apply(temp[1:(n.match+0),index],2,mean,na.rm=T) + temp['Average', index] = apply(temp[1:(n.match+0),index],2,weighted.mean,w=weights,na.rm=T) + temp['Max', index] = apply(temp[1:(n.match+0),index],2,max,na.rm=T) + + # format + temp[] = plota.format(100*(temp-1),1,'','%') + + # enter dates + temp['Current', 'Start'] = format(dates[(n.reference+1)], '%d %b %Y') + temp['Current', 'End'] = format(dates[len(dates)], '%d %b %Y') + for(i in 1:n.match) { + temp[i, 'Start'] = format(dates[min.index[i] - n.query + 1], '%d %b %Y') + temp[i, 'End'] = format(dates[min.index[i]], '%d %b %Y') + } + + # plot table + if(plot) { + if(is.null(layout)) layout(1) + plot.table(temp, smain='Match Number') + } + + return(temp) +} + + + +############################################################################### +# Time Series Matching with Dynamic time warping +# +# Based on Jean-Robert Avettand-Fenoel - How to Accelerate Model Deployment using Rook +# http://www.londonr.org/Sep%2011%20LondonR_AvettandJR.pdf +############################################################################### +# functions to compute distance +############################################################################### +#dist.euclidean <- function(x) { stats:::dist(x) } +dist.MOdist <- function(x) { MOdist(t(x)) } +dist.DTW <- function(x) { dtw(x[1,], x[2,])$distance } + + +bt.matching.dtw.test <- function() +{ + #***************************************************************** + # Example of Dynamic time warping from dtw help + #****************************************************************** + load.packages('dtw') + + # A noisy sine wave as query + idx = seq(0,6.28,len=100) + query = sin(idx)+runif(100)/10 + + # A cosine is for reference; sin and cos are offset by 25 samples + reference = cos(idx) + + # map one to one, typical distance + alignment<-dtw(query, reference, keep=TRUE) + alignment$index1 = 1:100 + alignment$index2 = 1:100 + +png(filename = 'plot0.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot(alignment,main='Example of 1 to 1 mapping', type='two',off=3) +dev.off() + + # map one to many, dynamic time warping + alignment<-dtw(query, reference, keep=TRUE) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot(alignment,main='Example of 1 to many mapping (DTW)', type='two',off=3) +dev.off() + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'SPY' + + data = getSymbols(tickers, src = 'yahoo', from = '1950-01-01', auto.assign = F) + + #***************************************************************** + # Euclidean distance + #****************************************************************** + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + obj = bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.euclidean', plot=T) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + matches = bt.matching.overlay(obj, plot.index=1:90, plot=T) +dev.off() + +png(filename = 'plot4.png', width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + matches = bt.matching.overlay(obj, plot=T, layout=T) + bt.matching.overlay.table(obj, matches, plot=T, layout=T) +dev.off() + + #***************************************************************** + # Dynamic time warping distance + #****************************************************************** + # http://en.wikipedia.org/wiki/Dynamic_time_warping + # http://dtw.r-forge.r-project.org/ + #****************************************************************** + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + obj = bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.DTW', plot=T) +dev.off() + +png(filename = 'plot6.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + matches = bt.matching.overlay(obj, plot.index=1:90, plot=T) +dev.off() + + +png(filename = 'plot7.png', width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + matches = bt.matching.overlay(obj, plot=T, layout=T) + bt.matching.overlay.table(obj, matches, plot=T, layout=T) +dev.off() + + #***************************************************************** + # Dynamic time warping distance + #****************************************************************** + +png(filename = 'plot8.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + obj = bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.DTW1', plot=T) +dev.off() + +png(filename = 'plot9.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + matches = bt.matching.overlay(obj, plot.index=1:90, plot=T) +dev.off() + + +png(filename = 'plot10.png', width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + matches = bt.matching.overlay(obj, plot=T, layout=T) + bt.matching.overlay.table(obj, matches, plot=T, layout=T) +dev.off() + + + + #***************************************************************** + # Dynamic time warping distance + #****************************************************************** + +png(filename = 'plot11.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + obj = bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.DDTW', plot=T) +dev.off() + +png(filename = 'plot12.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + matches = bt.matching.overlay(obj, plot.index=1:90, plot=T) +dev.off() + + +png(filename = 'plot13.png', width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + matches = bt.matching.overlay(obj, plot=T, layout=T) + bt.matching.overlay.table(obj, matches, plot=T, layout=T) +dev.off() + + + +} + + +############################################################################### +# Derivative Dynamic Time Warping by Eamonn J. Keogh and Michael J. Pazzani +# http://www.cs.rutgers.edu/~mlittman/courses/statai03/DDTW-2001.pdf +# +# page 3 +# To align two sequences using DTW we construct an n-by-m matrix where the (ith, jth) +# element of the matrix contains the distance d(qi,cj) between the two points qi and cj +# (Typically the Euclidean distance is used, so d(qi,cj) = (qi - cj)2 ). +# +# page 6 +# With DDTW the distance measure d(qi,cj) is not Euclidean but rather the square of the +# difference of the estimated derivatives of qi and cj. +# This estimate is simply the average of the slope of the line through the point in +# question and its left neighbor, and the slope of the line through the left neighbor and the +# right neighbor. Empirically this estimate is more robust to outliers than any estimate +# considering only two datapoints. Note the estimate is not defined for the first and last +# elements of the sequence. Instead we use the estimates of the second and next-to-last +# elements respectively. +############################################################################### +derivative.est <- function(x) { + x = as.vector(x) + n = len(x) + d = (( x - mlag(x) ) + ( mlag(x,-1)- mlag(x) ) / 2) / 2 + d[1] = d[2] + d[n] = d[(n-1)] + d +} + +dist.DDTW <- function(x) { + y = x + x[1,] = derivative.est(x[1,]) + x[2,] = derivative.est(x[2,]) + + alignment = dtw(x[1,], x[2,]) + stats:::dist(rbind(y[1,alignment$index1],y[2,alignment$index2])) + #proxy::dist(y[1,alignment$index1],y[2,alignment$index2],method='Euclidean',by_rows=F) +} + +dist.DTW1 <- function(x) { + alignment = dtw(x[1,], x[2,]) + stats:::dist(rbind(x[1,alignment$index1],x[2,alignment$index2])) +} + + +bt.ddtw.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'SPY' + + data = getSymbols(tickers, src = 'yahoo', from = '1950-01-01', auto.assign = F) + + #***************************************************************** + # Setup + #****************************************************************** + load.packages('dtw') + + query = as.vector(coredata(last(Cl(data['2011::2011']), 60))) + reference = as.vector(coredata(last(Cl(data['2010::2010']), 60))) + + #***************************************************************** + # Dynamic Time Warping + #****************************************************************** + alignment = dtw(query, reference, keep=TRUE) + +png(filename = 'plot1.ddtw.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot(alignment,main='DTW Alignment', type='two',off=20) +dev.off() + + + #***************************************************************** + # Derivative Dynamic Time Warping by Eamonn J. Keogh and Michael J. Pazzani + # http://www.cs.rutgers.edu/~mlittman/courses/statai03/DDTW-2001.pdf + #****************************************************************** + derivative.est <- function(x) { + x = as.vector(x) + n = len(x) + d = (( x - mlag(x) ) + ( mlag(x,-1)- mlag(x) ) / 2) / 2 + d[1] = d[2] + d[n] = d[(n-1)] + d + } + + alignment0 = dtw(derivative.est(query), derivative.est(reference), keep=TRUE) + alignment$index1 = alignment0$index1 + alignment$index2 = alignment0$index2 + +png(filename = 'plot2.ddtw.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot(alignment,main='Derivative DTW Alignment', type='two',off=20) +dev.off() + + +} + + + + + +############################################################################### +# Position Sizing +# +# Money Management Position Sizing +# http://www.trading-plan.com/money_position_sizing.html +# +# Position Sizing is Everything +# http://www.leighdrogen.com/position-sizing-is-everything/ +############################################################################### +bt.position.sizing.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + + models = list() + + #***************************************************************** + # Buy & Hold + #****************************************************************** + data$weight[] = 0 + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Volatility Position Sizing - ATR + #****************************************************************** + atr = bt.apply(data, function(x) ATR(HLC(x),20)[,'atr']) + + # http://www.leighdrogen.com/position-sizing-is-everything/ + # position size in units = ((porfolio size * % of capital to risk)/(ATR*2)) + data$weight[] = NA + capital = 100000 + + # risk 2% of capital, assuming 2 atr stop + data$weight[] = (capital * 2/100) / (2 * atr) + + # make sure you are not commiting more than 100% + # http://www.trading-plan.com/money_position_sizing.html + max.allocation = capital / prices + data$weight[] = iif(data$weight > max.allocation, max.allocation,data$weight) + + models$buy.hold.2atr = bt.run(data, type='share', capital=capital) + + #***************************************************************** + # Create Report + #****************************************************************** + models = rev(models) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() + + +} + + + +############################################################################### +# Trading Equity Curve with Volatility Position Sizing +############################################################################### +bt.volatility.position.sizing.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'SPY' + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + + #***************************************************************** + # Buy and Hold + #****************************************************************** + models = list() + prices = data$prices + + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Buy and Hold with target 10% Volatility + #****************************************************************** + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = sqrt(252) * bt.apply.matrix(ret.log, runSD, n = 60) + + data$weight[] = 0.1 / hist.vol + models$buy.hold.volatility.weighted = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Buy and Hold with target 10% Volatility and Max Total leverage 100% + #****************************************************************** + data$weight[] = 0.1 / hist.vol + rs = rowSums(data$weight) + data$weight[] = data$weight / iif(rs > 1, rs, 1) + models$buy.hold.volatility.weighted.100 = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Same, rebalanced Monthly + #****************************************************************** + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + data$weight[] = NA + data$weight[period.ends,] = 0.1 / hist.vol[period.ends,] + rs = rowSums(data$weight[period.ends,]) + data$weight[period.ends,] = data$weight[period.ends,] / iif(rs > 1, rs, 1) + models$buy.hold.volatility.weighted.100.monthly = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot performance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +dev.off() + +png(filename = 'plot2.png', width = 1600, height = 1000, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(rev(models)) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover', plotX = F, label='both') +dev.off() + + + + #***************************************************************** + # Next let's examine other volatility measures + #****************************************************************** + models = models[c('buy.hold' ,'buy.hold.volatility.weighted.100.monthly')] + + + # TTR volatility calc types + calc = c("close", "garman.klass", "parkinson", "rogers.satchell", "gk.yz", "yang.zhang") + + ohlc = OHLC(data$SPY) + for(icalc in calc) { + vol = volatility(ohlc, calc = icalc, n = 60, N = 252) + + data$weight[] = NA + data$weight[period.ends,] = 0.1 / vol[period.ends,] + rs = rowSums(data$weight[period.ends,]) + data$weight[period.ends,] = data$weight[period.ends,] / iif(rs > 1, rs, 1) + models[[icalc]] = bt.run.share(data, clean.signal=T) + } + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot4.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot performance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +dev.off() + +png(filename = 'plot5.png', width = 1600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + + + #***************************************************************** + # Volatility Position Sizing applied to MA cross-over strategy's Equity Curve + #****************************************************************** + models = list() + + sma.fast = SMA(prices, 50) + sma.slow = SMA(prices, 200) + weight = iif(sma.fast >= sma.slow, 1, -1) + + data$weight[] = weight + models$ma.crossover = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Target 10% Volatility + #****************************************************************** + ret.log = bt.apply.matrix(models$ma.crossover$equity, ROC, type='continuous') + hist.vol = sqrt(252) * bt.apply.matrix(ret.log, runSD, n = 60) + + data$weight[] = NA + data$weight[period.ends,] = (0.1 / hist.vol[period.ends,]) * weight[period.ends,] + # limit total leverage to 100% + rs = rowSums(data$weight[period.ends,]) + data$weight[period.ends,] = data$weight[period.ends,] / iif(abs(rs) > 1, abs(rs), 1) + models$ma.crossover.volatility.weighted.100.monthly = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot6.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot performance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +dev.off() + +png(filename = 'plot7.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(rev(models)) +dev.off() + + + #***************************************************************** + # Apply Volatility Position Sizing Timing stretegy by M. Faber + #****************************************************************** + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='1994::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + models = list() + + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + #***************************************************************** + # Equal Weight + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = ntop(prices[period.ends,], n) + data$weight[1:200,] = NA + models$equal.weight = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Timing by M. Faber + #****************************************************************** + sma = bt.apply.matrix(prices, SMA, 200) + + weight = ntop(prices, n) * (prices > sma) + data$weight[] = NA + data$weight[period.ends,] = weight[period.ends,] + models$timing = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Timing with target 10% Volatility + #****************************************************************** + ret.log = bt.apply.matrix(models$timing$equity, ROC, type='continuous') + hist.vol = bt.apply.matrix(ret.log, runSD, n = 60) + hist.vol = sqrt(252) * as.vector(hist.vol) + + data$weight[] = NA + data$weight[period.ends,] = (0.1 / hist.vol[period.ends]) * weight[period.ends,] + rs = rowSums(data$weight) + data$weight[] = data$weight / iif(rs > 1, rs, 1) + data$weight[1:200,] = NA + models$timing.volatility.weighted.100.monthly = bt.run.share(data, clean.signal=T) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot8.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot performance + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) +dev.off() + +png(filename = 'plot9.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(rev(models)) +dev.off() + + +} + + + + + +############################################################################### +# Rolling Correlation +# http://www.activetradermag.com/index.php/c/Trading_Strategies/d/Trading_correlation +############################################################################### +bt.rolling.cor.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = sp500.components()$tickers + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1970::') + + spy = getSymbols('SPY', src = 'yahoo', from = '1970-01-01', auto.assign = F) + ret.spy = coredata( Cl(spy) / mlag(Cl(spy))-1 ) + + #***************************************************************** + # Code Logic + #****************************************************************** + prices = data$prices['1993:01:29::'] + nperiods = nrow(prices) + + ret = prices / mlag(prices) - 1 + ret = coredata(ret) + + # require at least 100 stocks with prices + index = which((count(t(prices)) > 100 )) + index = index[-c(1:252)] + + # average correlation among S&P 500 components + avg.cor = NA * prices[,1] + + # average correlation between the S&P 500 index (SPX) and its component stocks + avg.cor.spy = NA * prices[,1] + + for(i in index) { + hist = ret[ (i- 252 +1):i, ] + hist = hist[ , count(hist)==252, drop=F] + nleft = ncol(hist) + + correlation = cor(hist, use='complete.obs',method='pearson') + avg.cor[i,] = (sum(correlation) - nleft) / (nleft*(nleft-1)) + + avg.cor.spy[i,] = sum(cor(ret.spy[ (i- 252 +1):i, ], hist, use='complete.obs',method='pearson')) / nleft + + if( i %% 100 == 0) cat(i, 'out of', nperiods, '\n') + } + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot.sp500.cor.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + + sma50 = SMA(Cl(spy), 50) + sma200 = SMA(Cl(spy), 200) + + cols = col.add.alpha(spl('green,red'),50) + plota.control$col.x.highlight = iif(sma50 > sma200, cols[1], cols[2]) + highlight = sma50 > sma200 | sma50 < sma200 + + plota(avg.cor, type='l', ylim=range(avg.cor, avg.cor.spy, na.rm=T), x.highlight = highlight, + main='Average 252 day Pairwise Correlation for stocks in SP500') + plota.lines(avg.cor.spy, type='l', col='blue') + plota.legend('Pairwise Correlation,Correlation with SPY,SPY 50-day SMA > 200-day SMA,SPY 50-day SMA < 200-day SMA', + c('black,blue',cols)) + +dev.off() + +} + + + +############################################################################### +# Volatility Quantiles +############################################################################### +bt.volatility.quantiles.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = sp500.components()$tickers + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + #save(data, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + # remove companies with less than 5 years of data + rm.index = which( sapply(ls(data), function(x) nrow(data[[x]])) < 1000 ) + rm(list=names(rm.index), envir=data) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + + + + data.spy <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data.spy, auto.assign = T) + bt.prep(data.spy, align='keep.all', dates='1994::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + # setdiff(index(data.spy$prices), index(data$prices)) + # setdiff(index(data$prices),index(data.spy$prices)) + prices = data$prices + nperiods = nrow(prices) + n = ncol(prices) + + models = list() + + # SPY + data.spy$weight[] = NA + data.spy$weight[] = 1 + models$spy = bt.run(data.spy) + + # Equal Weight + data$weight[] = NA + data$weight[] = ntop(prices, 500) + models$equal.weight = bt.run(data) + + #***************************************************************** + # Create Quantiles based on the historical one year volatility + #****************************************************************** + # setup re-balancing periods +# period.ends = 1:nperiods + period.ends = endpoints(prices, 'weeks') +# period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + # compute historical one year volatility + p = bt.apply.matrix(coredata(prices), ifna.prev) + ret = p / mlag(p) - 1 + sd252 = bt.apply.matrix(ret, runSD, 252) + + # split stocks in the S&P 500 into Quantiles using one year historical Volatility + n.quantiles=5 + start.t = which(period.ends >= (252+2))[1] + quantiles = weights = p * NA + + for( t in start.t:len(period.ends) ) { + i = period.ends[t] + + factor = sd252[i,] + ranking = ceiling(n.quantiles * rank(factor, na.last = 'keep','first') / count(factor)) + + quantiles[i,] = ranking + weights[i,] = 1/tapply(rep(1,n), ranking, sum)[ranking] + } + + quantiles = ifna(quantiles,0) + + #***************************************************************** + # Create backtest for each Quintile + #****************************************************************** + for( i in 1:n.quantiles) { + temp = weights * NA + temp[period.ends,] = 0 + temp[quantiles == i] = weights[quantiles == i] + + data$weight[] = NA + data$weight[] = temp + models[[ paste('Q',i,sep='_') ]] = bt.run(data, silent = T) + } + rowSums(models$Q_2$weight,na.rm=T) + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'report.pdf', width=8.5, height=11) + + png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) + dev.off() + + png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) + dev.off() + + + + + # save summary + #load.packages('abind') + #out = abind(lapply(models, function(m) m$equity)) + # colnames(out) = names(models) + #write.xts(make.xts(out, index(prices)), 'report.csv') +} + + + + + +############################################################################### +# Factor Attribution & Value Quantiles +############################################################################### +bt.fa.value.quantiles.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = sp500.components()$tickers + #tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + #save(data, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + # remove companies with less than 5 years of data + rm.index = which( sapply(ls(data), function(x) nrow(data[[x]])) < 1000 ) + rm(list=names(rm.index), envir=data) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + tickers = data$symbolnames + + + data.spy <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data.spy, auto.assign = T) + bt.prep(data.spy, align='keep.all', dates='1994::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + # setdiff(index(data.spy$prices), index(data$prices)) + # setdiff(index(data$prices),index(data.spy$prices)) + prices = data$prices + nperiods = nrow(prices) + n = ncol(prices) + + models = list() + + # SPY + data.spy$weight[] = NA + data.spy$weight[] = 1 + models$spy = bt.run(data.spy) + + # Equal Weight + data$weight[] = NA + data$weight[] = ntop(prices, n) + models$equal.weight = bt.run(data) + + #***************************************************************** + # Compute Factor Attribution for each ticker + #****************************************************************** + periodicity = 'weeks' + + # load Fama/French factors + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = F, clean = F) + + period.ends = endpoints(data$prices, periodicity) + period.ends = period.ends[period.ends > 0] + + # add factors and align + data.fa <- new.env() + for(i in tickers) data.fa[[i]] = data[[i]][period.ends,] + data.fa$factors = factors$data / 100 + bt.prep(data.fa, align='remove.na') + + + index = match( index(data.fa$prices), index(data$prices) ) + measure = data$prices[ index, ] + + for(i in tickers) { + cat(i, '\n') + + # Facto Loadings Regression + obj = factor.rolling.regression(data.fa, i, 36, silent=T) + + measure[,i] = coredata(obj$fl$estimate$HML) + } + + + #***************************************************************** + # Create Value Quantiles + #****************************************************************** + n.quantiles=5 + start.t = 1+36 + quantiles = weights = coredata(measure) * NA + + for( t in start.t:nrow(weights) ) { + factor = as.vector(coredata(measure[t,])) + ranking = ceiling(n.quantiles * rank(factor, na.last = 'keep','first') / count(factor)) + #tapply(factor,ranking,sum) + + quantiles[t,] = ranking + weights[t,] = 1/tapply(rep(1,n), ranking, sum)[ranking] + } + + quantiles = ifna(quantiles,0) + + #***************************************************************** + # Create backtest for each Quintile + #****************************************************************** + for( i in 1:n.quantiles) { + temp = weights * NA + temp[] = 0 + temp[quantiles == i] = weights[quantiles == i] + + data$weight[] = NA + data$weight[index,] = temp + models[[ paste('Q',i,sep='_') ]] = bt.run(data, silent = T) + } + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'report.pdf', width=8.5, height=11) + + png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) + dev.off() + + png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) + dev.off() + +} + + +############################################################################### +# Three Factor Rolling Regression Viewer +# http://mas.xtreemhost.com/ +############################################################################### +# New fund regression calculator +# http://www.bogleheads.org/forum/viewtopic.php?t=11506&highlight=regression +# +# Factor loadings? +# http://www.bogleheads.org/forum/viewtopic.php?t=14629 +# +# Efficient Frontier: Rolling Your Own: Three-Factor Analysis +# http://www.efficientfrontier.com/ef/101/roll101.htm +# +# Kenneth R French: Data Library +# http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html +############################################################################### +# alpha: how much 'extra' return did the fund have that could not be accounted for by the model. this is almost never large or statistically significant. +# B(MKT) = market factor: most 100% stock funds have a market factor near 1.0. higher values may indicate leverage. lower values may indicate cash and or bonds. +# B(SMB) = size factor (small minus big): positive values indicate the fund's average holding is smaller than the market +# B(HML) = value factor (high minus low): positive values indicate the fund's average holding is more 'value' oriented than the market (based on book to market ratio) +# R2: measures how well the fund returns match the model (values close to 1.0 indicate a good statistical fit) +############################################################################### +factor.rolling.regression <- function( + data, + ticker = data$symbolnames[-grep('factor', data$symbolnames)], + window.len = 36, + silent = F, + custom.stats.fn = NULL +) +{ + ticker = ticker[1] + + #***************************************************************** + # Facto Loadings Regression over whole period + #****************************************************************** + prices = data$prices + nperiods = nrow(prices) + dates = index(data$prices) + + # compute simple returns + hist.returns = ROC(prices[,ticker], type = 'discrete') + hist.returns = hist.returns - data$factors$RF + yout = hist.returns + y = coredata(yout) + + xout = data$factors[, -which(names(data$factors) == 'RF')] + x = coredata(xout) + +# fit = summary(lm(y~x)) +# est = fit$coefficients[,'Estimate'] +# std.err = fit$coefficients[,'Std. Error'] +# r2 = fit$r.squared + + ok.index = !(is.na(y) | (rowSums(is.na(x)) > 0)) + fit = ols(cbind(1,x[ok.index,]),y[ok.index], T) + est = fit$coefficients + std.err = fit$seb + r2 = fit$r.squared + + + # Facto Loadings - fl + fl.all = list() + fl.all$estimate = c(est, r2) + fl.all$std.error = c(std.err, NA) + + #***************************************************************** + # Facto Loadings Regression over Month window + #****************************************************************** + colnames = c('alpha', colnames(x), 'R2') + + estimate = make.xts(matrix(NA, nr = nperiods, len(colnames)), dates) + colnames(estimate) = colnames + fl = list() + fl$estimate = estimate + fl$std.error = estimate + if( !is.null(custom.stats.fn) ) { + temp = match.fun(custom.stats.fn)(cbind(1,x), y, fit) + fl$custom = make.xts(matrix(NA, nr = nperiods, len(temp)), dates) + } + + # main loop + for( i in window.len:nperiods ) { + window.index = (i - window.len + 1) : i + + if(all(!is.na(y[window.index]))) { + xtemp = cbind(1,x[window.index,]) + ytemp = y[window.index] + fit = ols(xtemp, ytemp, T) + est = fit$coefficients + std.err = fit$seb + r2 = fit$r.squared + fl$estimate[i,] = c(est, r2) + fl$std.error[i,] = c(std.err, NA) + + if( !is.null(custom.stats.fn) ) + fl$custom[i,] = match.fun(custom.stats.fn)(xtemp, ytemp, fit) + } + + if( i %% 10 == 0) if(!silent) cat(i, '\n') + } + + return(list(fl.all = fl.all, fl = fl, window.len=window.len, + y=yout, x=xout, RF=data$factors$RF)) +} + + + +# detail plot for each factor and histogram +factor.rolling.regression.detail.plot <- function(obj) { + #setup + n = ncol(obj$fl$estimate) + dates = index(obj$fl$estimate) + + layout(matrix(1:(2*n), nc=2, byrow=T)) + + for(i in 1:n) { + #------------------------------------------------------------------------- + # Time plot + #------------------------------------------------------------------------- + est = obj$fl$estimate[,i] + est.std.error = ifna(obj$fl$std.error[,i], 0) + + plota(est, + ylim = range( c( + range(est + est.std.error, na.rm=T), + range(est - est.std.error, na.rm=T) + ))) + + polygon(c(dates,rev(dates)), + c(coredata(est + est.std.error), + rev(coredata(est - est.std.error))), + border=NA, col=col.add.alpha('red',50)) + + est = obj$fl.all$estimate[i] + est.std.error = obj$fl.all$std.error[i] + + polygon(c(range(dates),rev(range(dates))), + c(rep(est + est.std.error,2), + rep(est - est.std.error,2)), + border=NA, col=col.add.alpha('blue',50)) + + abline(h=0, col='blue', lty='dashed') + + abline(h=est, col='blue') + + plota.lines(obj$fl$estimate[,i], type='l', col='red') + + #------------------------------------------------------------------------- + # Histogram + #------------------------------------------------------------------------- + par(mar = c(4,3,2,1)) + hist(obj$fl$estimate[,i], col='red', border='gray', las=1, + xlab='', ylab='', main=colnames(obj$fl$estimate)[i]) + abline(v=obj$fl.all$estimate[i], col='blue', lwd=2) + } +} + + +# style plot for 2 given factors +factor.rolling.regression.style.plot <- function(obj, + xfactor='HML', yfactor='SMB', + xlim = c(-1.5, 1.5), ylim = c(-0.5, 1.5) +) { + # Style chart + i = which(colnames(obj$fl$estimate) == xfactor) + x = coredata(obj$fl$estimate[,i]) + x.e = ifna(coredata(obj$fl$std.error[,i]), 0) + + x.all = obj$fl.all$estimate[i] + x.all.e = obj$fl.all$std.error[i] + + xlab = colnames(obj$fl$estimate)[i] + + i = which(colnames(obj$fl$estimate) == yfactor) + y = coredata(obj$fl$estimate[,i]) + y.e = ifna(coredata(obj$fl$std.error[,i]), 0) + + y.all = obj$fl.all$estimate[i] + y.all.e = obj$fl.all$std.error[i] + + ylab = colnames(obj$fl$estimate)[i] + + # plot + layout(1) + plot(x,y, xlab=xlab, ylab = ylab, type='n', las=1, + xlim = range(c(x + x.e, x - x.e, xlim), na.rm=T), + ylim = range(c(y + y.e, y - y.e, ylim), na.rm=T), + main = paste('Style, last =', ylab, round(last(y),2), xlab, round(last(x),2)) + ) + grid() + abline(h=0) + abline(v=0) + + + col = col.add.alpha('pink',250) + rect(x - x.e, y - y.e, x + x.e, y + y.e, col=col, border=NA) + + points(x,y, col='red', pch=20) + points(last(x),last(y), col='black', pch=3) + points(x.all,y.all, col='blue', pch=15) + + legend('topleft', spl('Estimates,Last estimate,Overall estimate'), + pch = c(20,3,15), + col = spl('red,black,blue'), + pt.bg = spl('red,black,blue'), + bty='n' + ) +} + + +# re-construct historical perfromance based on factor loadings +# compare fund perfromance to the +# - re-constructed portfolio based on the regression over whole period +# - re-constructed portfolio based on the rolling window regression +factor.rolling.regression.bt.plot <- function(obj) { + # setup + ticker = colnames(obj$y) + n = ncol(obj$fl$estimate)-1 + nperiods = nrow(obj$fl$estimate) + + # fund, alpha, factors, RF + ret = cbind(obj$RF, obj$y, 1, obj$x) + colnames(ret)[1:3] = spl('RF,fund,alpha') + prices = bt.apply.matrix(1+ifna(ret,0),cumprod) + + data <- new.env() + data$symbolnames = colnames(prices) + + for(i in colnames(prices)) { + data[[i]] = prices[,i] + colnames(data[[i]]) = 'Close' + } + + bt.prep(data, align='keep.all') + + #***************************************************************** + # Code Strategies + #****************************************************************** + + # create models + models = list() + + data$weight[] = NA + data$weight$fund = 1 + data$weight$RF = 1 + data$weight[1:obj$window.len,] = NA + models[[ticker]] = bt.run.share(data, clean.signal = F) + + data$weight[] = NA + data$weight[,3:(n+2)] = t(repmat(obj$fl.all$estimate[1:n], 1, nperiods)) + data$weight$RF = 1 + data$weight[1:obj$window.len,] = NA + models$all.alpha = bt.run.share(data, clean.signal = F) + + data$weight[] = NA + data$weight[,3:(n+2)] = t(repmat(obj$fl.all$estimate[1:n], 1, nperiods)) + data$weight$RF = 1 + data$weight$alpha = NA + data$weight[1:obj$window.len,] = NA + models$all = bt.run.share(data, clean.signal = F) + + data$weight[] = NA + data$weight[,3:(n+2)] = obj$fl$estimate[,1:n] + data$weight$RF = 1 + data$weight[1:obj$window.len,] = NA + models$est.alpha = bt.run.share(data, clean.signal = F) + + data$weight[] = NA + data$weight[,3:(n+2)] = obj$fl$estimate[,1:n] + data$weight$RF = 1 + data$weight$alpha = NA + data$weight[1:obj$window.len,] = NA + models$est = bt.run.share(data, clean.signal = F) + + #***************************************************************** + # Create Report + #****************************************************************** + # Plot perfromance + layout(1) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + + + # obj$fl.all$estimate[1]*52 + # mean(obj$fl$estimate$alpha,na.rm=T) +} + + +# main function to demonstrate factor attribution +three.factor.rolling.regression <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'VISVX' + #tickers = 'IBM' + + periodicity = 'weeks' + periodicity = 'months' + + data <- new.env() + quantmod::getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) { + temp = adjustOHLC(data[[i]], use.Adjusted=T) + + period.ends = endpoints(temp, periodicity) + period.ends = period.ends[period.ends > 0] + + if(periodicity == 'months') { + # reformat date to match Fama French Data + monthly.dates = as.Date(paste(format(index(temp)[period.ends], '%Y%m'),'01',sep=''), '%Y%m%d') + data[[i]] = make.xts(coredata(temp[period.ends,]), monthly.dates) + } else + data[[i]] = temp[period.ends,] + } + data.fund = data[[tickers]] + + #***************************************************************** + # Fama/French factors + #****************************************************************** + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = T, clean = F) + + # add factors and align + data <- new.env() + data[[tickers]] = data.fund + data$factors = factors$data / 100 + bt.prep(data, align='remove.na', dates='1994::') + + #***************************************************************** + # Facto Loadings Regression + #****************************************************************** + obj = factor.rolling.regression(data, tickers, 36) + + #***************************************************************** + # Reports + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 1200, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.detail.plot(obj) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.style.plot(obj) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.bt.plot(obj) +dev.off() + + #***************************************************************** + # Fama/French factors + Momentum + #****************************************************************** + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = F, clean = F) + + factors.extra = get.fama.french.data('F-F_Momentum_Factor', periodicity = periodicity,download = T, clean = F) + factors$data = merge(factors$data, factors.extra$data) + + # add factors and align + data <- new.env() + data[[tickers]] = data.fund + data$factors = factors$data / 100 + bt.prep(data, align='remove.na', dates='1994::') + + #***************************************************************** + # Facto Loadings Regression + #****************************************************************** + obj = factor.rolling.regression(data, tickers, 36) + + #***************************************************************** + # Reports + #****************************************************************** +png(filename = 'plot4.png', width = 600, height = 1200, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.detail.plot(obj) +dev.off() + +png(filename = 'plot5.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.style.plot(obj) +dev.off() + +png(filename = 'plot6.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.style.plot(obj, xfactor='HML', yfactor='Mom') +dev.off() + +png(filename = 'plot7.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.bt.plot(obj) +dev.off() + +} + +# exmple of using your own factors in the factor attribution +your.own.factor.rolling.regression <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('EEM,SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na') + + #***************************************************************** + # Create weekly factor + #****************************************************************** + prices = data$prices + + periodicity = 'weeks' + period.ends = endpoints(prices, periodicity) + period.ends = period.ends[period.ends > 0] + + hist.returns = ROC(prices[period.ends,], type = 'discrete') + hist.returns = na.omit(hist.returns) + + #Emerging Market over US Market i.e. MSCI EM vs S&P 500 = EEM - SPY + EEM_SPY = hist.returns$EEM - hist.returns$SPY + colnames(EEM_SPY) = 'EEM_SPY' + + write.xts(EEM_SPY, 'EEM_SPY.csv') + + + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = 'VISVX' + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) { + temp = adjustOHLC(data[[i]], use.Adjusted=T) + + period.ends = endpoints(temp, periodicity) + period.ends = period.ends[period.ends > 0] + + data[[i]] = temp[period.ends,] + } + data.fund = data[[tickers]] + + + #***************************************************************** + # Fama/French factors + #****************************************************************** + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = F, clean = F) + + factors.extra = 100 * read.xts('EEM_SPY.csv') + factors$data = merge(factors$data, factors.extra, join='inner') + # add factors and align + data <- new.env() + data[[tickers]] = data.fund + data$factors = factors$data / 100 + bt.prep(data, align='remove.na') + + #***************************************************************** + # Check Correlations, make sure the new factor is NOT highly correlated + #****************************************************************** + load.packages('psych') +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + pairs.panels(coredata(data$factors)) +dev.off() + + + + + + #***************************************************************** + # Facto Loadings Regression + #****************************************************************** + obj = factor.rolling.regression(data, tickers, 36) + + #***************************************************************** + # Reports + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 1200, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.detail.plot(obj) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.style.plot(obj) +dev.off() + +png(filename = 'plot4.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.style.plot(obj, xfactor='HML', yfactor='EEM_SPY') +dev.off() + +png(filename = 'plot5.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + factor.rolling.regression.bt.plot(obj) +dev.off() + + +} + + + + + +############################################################################### +# One month reversals +############################################################################### +bt.one.month.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = sp500.components()$tickers + #tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + #save(data, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + # remove companies with less than 5 years of data + rm.index = which( sapply(ls(data), function(x) nrow(data[[x]])) < 1000 ) + rm(list=names(rm.index), envir=data) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + tickers = data$symbolnames + + + data.spy <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data.spy, auto.assign = T) + bt.prep(data.spy, align='keep.all', dates='1994::') + + + #***************************************************************** + # Load historical data + #****************************************************************** +#save(data, data.spy, tickers, file='data.sp500.components.Rdata') +#load(file='data.sp500.components.Rdata') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + #***************************************************************** + # Setup monthly periods + #****************************************************************** + periodicity = 'months' + + period.ends = endpoints(data$prices, periodicity) + period.ends = period.ends[period.ends > 0] + + prices = prices[period.ends, ] + + #***************************************************************** + # Create Benchmarks + #****************************************************************** + models = list() + n.skip = 36 + n.skip = 2 + + # SPY + data.spy$weight[] = NA + data.spy$weight[] = 1 + data.spy$weight[1:period.ends[n.skip],] = NA + models$spy = bt.run(data.spy) + + # Equal Weight + data$weight[] = NA + data$weight[period.ends,] = ntop(prices, n) + data$weight[1:period.ends[n.skip],] = NA + models$equal.weight = bt.run(data) + + #***************************************************************** + # Create Reversal Quantiles + #****************************************************************** + one.month = coredata(prices / mlag(prices)) + + models = c(models, + bt.make.quintiles(one.month, data, period.ends, start.t=1 + n.skip, prefix='M1_')) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models[spl('spy,equal.weight,spread')]) +dev.off() + +} + + + +############################################################################### +# Better one-month reversal +############################################################################### +# compute various additional stats +factor.rolling.regression.custom.stats <- function(x,y,fit) { + n = len(y) + e = y - x %*% fit$coefficients + se = sd(e) + return(c(e[n], e[n]/se)) +} + +# create quintiles +bt.make.quintiles <- function( + position.score, # position.score is a factor to form Quintiles sampled at the period.ends + data, # back-test object + period.ends, + n.quantiles = 5, + start.t = 2, # first index at which to form Quintiles + prefix = '' +) +{ + n = ncol(position.score) + #***************************************************************** + # Create Quantiles + #****************************************************************** + position.score = coredata(position.score) + quantiles = weights = position.score * NA + + for( t in start.t:nrow(weights) ) { + factor = as.vector(position.score[t,]) + ranking = ceiling(n.quantiles * rank(factor, na.last = 'keep','first') / count(factor)) + + quantiles[t,] = ranking + weights[t,] = 1/tapply(rep(1,n), ranking, sum)[ranking] + } + + quantiles = ifna(quantiles,0) + + #***************************************************************** + # Create backtest for each Quintile + #****************************************************************** + temp = weights * NA + models = list() + for( i in 1:n.quantiles) { + temp[] = 0 + temp[quantiles == i] = weights[quantiles == i] + + data$weight[] = NA + data$weight[period.ends,] = temp + models[[ paste(prefix,'Q',i,sep='') ]] = bt.run(data, silent = T) + } + + # rowSums(models$M1_Q2$weight,na.rm=T) + + #***************************************************************** + # Create Q1-QN spread + #****************************************************************** + temp[] = 0 + temp[quantiles == 1] = weights[quantiles == 1] + temp[quantiles == n.quantiles] = -weights[quantiles == n.quantiles] + + data$weight[] = NA + data$weight[period.ends,] = temp + models$spread = bt.run(data, silent = T) + + return(models) +} + + + +bt.fa.one.month.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + info = sp500.components() + tickers = info$tickers + #tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + #save(data, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + # remove companies with less than 5 years of data + rm.index = which( sapply(ls(data), function(x) nrow(data[[x]])) < 1000 ) + rm(list=names(rm.index), envir=data) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + tickers = data$symbolnames + sector = info$sector[match(tickers, info$tickers)] + + + data.spy <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data.spy, auto.assign = T) + bt.prep(data.spy, align='keep.all', dates='1994::') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + # setdiff(index(data.spy$prices), index(data$prices)) + # setdiff(index(data$prices),index(data.spy$prices)) +#save(data, data.spy, tickers, sector, file='data.sp500.components.Rdata') +#load(file='data.sp500.components.Rdata') + + + + prices = data$prices + n = ncol(prices) + + #***************************************************************** + # Setup monthly periods + #****************************************************************** + periodicity = 'months' + + period.ends = endpoints(data$prices, periodicity) + period.ends = period.ends[period.ends > 0] + + prices = prices[period.ends, ] + + #***************************************************************** + # Create Benchmarks + #****************************************************************** + models = list() + n.skip = 36 + + # SPY + data.spy$weight[] = NA + data.spy$weight[] = 1 + data.spy$weight[1:period.ends[n.skip],] = NA + models$spy = bt.run(data.spy) + + # Equal Weight + data$weight[] = NA + data$weight[period.ends,] = ntop(prices, n) + data$weight[1:period.ends[n.skip],] = NA + models$equal.weight = bt.run(data) + + #***************************************************************** + # Load factors and align them with prices + #****************************************************************** + # load Fama/French factors + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = F, clean = F) + + # align monthly dates + map = match(format(index(factors$data), '%Y%m'), format(index(prices), '%Y%m')) + dates = index(factors$data) + dates[!is.na(map)] = index(prices)[na.omit(map)] + index(factors$data) = as.Date(dates) + + + # add factors and align + data.fa <- new.env() + for(i in tickers) data.fa[[i]] = data[[i]][period.ends, ] + data.fa$factors = factors$data / 100 + bt.prep(data.fa, align='remove.na') + + + index = match( index(data.fa$prices), index(data$prices) ) + prices = data$prices[index, ] + + #***************************************************************** + # Compute Factor Attribution for each ticker + #****************************************************************** + + temp = NA * prices + factors = list() + factors$last.e = temp + factors$last.e_s = temp + + for(i in tickers) { + cat(i, '\n') + + # Facto Loadings Regression + obj = factor.rolling.regression(data.fa, i, 36, silent=T, + factor.rolling.regression.custom.stats) + + for(j in 1:len(factors)) + factors[[j]][,i] = obj$fl$custom[,j] + + } + + # add base strategy + factors$one.month = coredata(prices / mlag(prices)) + + #save(factors, file='data.ff.factors.Rdata') + load(file='data.ff.factors.Rdata') + + + #***************************************************************** + # Create Quantiles + #****************************************************************** + quantiles = list() + + for(name in names(factors)) { + cat(name, '\n') + quantiles[[name]] = bt.make.quintiles(factors[[name]], data, index, start.t = 1+36, prefix=paste(name,'_',sep='')) + } + + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'report.pdf', width=8.5, height=11) + + png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(quantiles$one.month$spread,quantiles$last.e$spread,quantiles$last.e_s$spread) + dev.off() + + png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(quantiles$one.month$spread,quantiles$last.e$spread,quantiles$last.e_s$spread) + dev.off() + + + png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles$last.e ) + dev.off() + + png(filename = 'plot4.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles$last.e_s ) + dev.off() + + +} + + + +bt.fa.sector.one.month.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + info = sp500.components() + tickers = info$tickers + #tickers = dow.jones.components() + + + data <- new.env() + #getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in tickers) try(getSymbols(i, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T), TRUE) + #save(data, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + # remove companies with less than 5 years of data + rm.index = which( sapply(ls(data), function(x) nrow(data[[x]])) < 1000 ) + rm(list=names(rm.index), envir=data) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1994::') + tickers = data$symbolnames + sector = info$sector[match(tickers, info$tickers)] + + + data.spy <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data.spy, auto.assign = T) + bt.prep(data.spy, align='keep.all', dates='1994::') + + save(data, data.spy, tickers, sector, file='data.sp500.components.Rdata') + #load(file='data.sp500.components.Rdata') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + # setdiff(index(data.spy$prices), index(data$prices)) + # setdiff(index(data$prices),index(data.spy$prices)) + + prices = data$prices + n = ncol(prices) + + #***************************************************************** + # Setup monthly periods + #****************************************************************** + periodicity = 'months' + #periodicity = 'weeks' + + period.ends = endpoints(data$prices, periodicity) + period.ends = period.ends[period.ends > 0] + + prices = prices[period.ends, ] + + #***************************************************************** + # Create Benchmarks + #****************************************************************** + models = list() + n.skip = 36 + + # SPY + data.spy$weight[] = NA + data.spy$weight[] = 1 + data.spy$weight[1:period.ends[n.skip],] = NA + models$spy = bt.run(data.spy) + + # Equal Weight + data$weight[] = NA + data$weight[period.ends,] = ntop(prices, n) + data$weight[1:period.ends[n.skip],] = NA + models$equal.weight = bt.run(data) + + #***************************************************************** + # Load factors and align them with prices + #****************************************************************** + # load Fama/French factors + factors = get.fama.french.data('F-F_Research_Data_Factors', periodicity = periodicity,download = T, clean = F) + + + # align monthly dates + if(periodicity == 'months') { + map = match(format(index(factors$data), '%Y%m'), format(index(prices), '%Y%m')) + dates = index(factors$data) + dates[!is.na(map)] = index(prices)[na.omit(map)] + index(factors$data) = as.Date(dates) + } + + # add factors and align + data.fa <- new.env() + for(i in tickers) data.fa[[i]] = data[[i]][period.ends, ] + data.fa$factors = factors$data / 100 + bt.prep(data.fa, align='remove.na') + + + index = match( index(data.fa$prices), index(data$prices) ) + prices = data$prices[index, ] + + #***************************************************************** + # Compute Factor Attribution for each ticker + #****************************************************************** + temp = NA * prices + factors = list() + factors$last.e = temp + factors$last.e_s = temp + + for(i in tickers) { + cat(i, '\n') + + # Facto Loadings Regression + obj = factor.rolling.regression(data.fa, i, 36, silent=T, + factor.rolling.regression.custom.stats) + + for(j in 1:len(factors)) + factors[[j]][,i] = obj$fl$custom[,j] + + } + + # add base strategy + nlag = iif(periodicity == 'months', 1, 4) + factors$one.month = coredata(prices / mlag(prices, nlag)) + + save(factors, file='data.ff.factors.Rdata') + #load(file='data.ff.factors.Rdata') + + + + #***************************************************************** + # Create Quantiles + #****************************************************************** + quantiles = list() + + for(name in names(factors)) { + cat(name, '\n') + quantiles[[name]] = bt.make.quintiles(factors[[name]], data, index, start.t = 1+36, prefix=paste(name,'_',sep='')) + } + + quantiles.sn = list() + for(name in names(factors)) { + cat(name, '\n') + quantiles.sn[[name]] = bt.make.quintiles.sector(sector, factors[[name]], data, index, start.t = 1+36, prefix=paste(name,'_',sep='')) + } + + save(quantiles, quantiles.sn, file='model.quantiles.Rdata') + #load(file='model.quantiles.Rdata') + + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'report.pdf', width=8.5, height=11) + + png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(quantiles$one.month$spread, + quantiles$last.e$spread, quantiles$last.e_s$spread, + quantiles.sn$one.month$spread.sn, + quantiles.sn$last.e$spread.sn, quantiles.sn$last.e_s$spread.sn) + dev.off() + + png(filename = 'plot2.png', width = 800, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(quantiles$one.month$spread, + quantiles$last.e$spread, quantiles$last.e_s$spread, + quantiles.sn$one.month$spread.sn, + quantiles.sn$last.e$spread.sn, quantiles.sn$last.e_s$spread.sn) + dev.off() + + png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles.sn$one.month ) + dev.off() + + png(filename = 'plot4.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles.sn$last.e_s ) + dev.off() + + + + #***************************************************************** + # Create Report - bt.one.month.test + #****************************************************************** + png(filename = 'plot1a.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(c(models,quantiles$one.month)) + dev.off() + + png(filename = 'plot2a.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(c(models,quantiles$one.month$spread)) + dev.off() + + #***************************************************************** + # Create Report - bt.fa.one.month.test + #****************************************************************** + png(filename = 'plot1b.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(quantiles$one.month$spread,quantiles$last.e$spread,quantiles$last.e_s$spread) + dev.off() + + png(filename = 'plot2b.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(quantiles$one.month$spread,quantiles$last.e$spread,quantiles$last.e_s$spread) + dev.off() + + + png(filename = 'plot3b.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles$last.e ) + dev.off() + + png(filename = 'plot4b.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1( quantiles$last.e_s ) + dev.off() + +} + + + + +#position.score = factors[[1]] +#period.ends = index +#n.quantiles = 5 +#start.t = 1+36 +#prefix = '' + +# create sector quintiles +bt.make.quintiles.sector <- function( + sector, # sector data + position.score, # position.score is a factor to form Quintiles sampled at the period.ends + data, # back-test object + period.ends, + n.quantiles = 5, + start.t = 2, # first index at which to form Quintiles + prefix = '' +) +{ + #***************************************************************** + # Re-organize sectors into matrix, assume that sectors are constant in time + #****************************************************************** + temp = factor(sector) + sector.names = levels(temp) + n.sectors = len(sector.names) + sectors = matrix(unclass(temp),nr=nrow(position.score),nc=ncol(position.score),byrow=T) + + #***************************************************************** + # Create Quantiles + #****************************************************************** + position.score = coredata(position.score) + quantiles = weights = position.score * NA + + for( s in 1:n.sectors) { + for( t in start.t:nrow(weights) ) { + index = sectors[t,] == s + n = sum(index) + + # require at least 3 companies in each quantile + if(n > 3*n.quantiles) { + factor = as.vector(position.score[t, index]) + ranking = ceiling(n.quantiles * rank(factor, na.last = 'keep','first') / count(factor)) + + quantiles[t, index] = ranking + weights[t, index] = 1/tapply(rep(1,n), ranking, sum)[ranking] + } + } + } + + quantiles = ifna(quantiles,0) + + #***************************************************************** + # Create Q1-QN spread for each Sector + #****************************************************************** + long = weights * NA + short = weights * NA + models = list() + + for( s in 1:n.sectors) { + long[] = 0 + long[quantiles == 1 & sectors == s] = weights[quantiles == 1 & sectors == s] + long = long / rowSums(long,na.rm=T) + + short[] = 0 + short[quantiles == n.quantiles & sectors == s] = weights[quantiles == n.quantiles & sectors == s] + short = short / rowSums(short,na.rm=T) + + data$weight[] = NA + data$weight[period.ends,] = long - short + models[[ paste(prefix,'spread.',sector.names[s], sep='') ]] = bt.run(data, silent = T) + } + +if(F) { + #***************************************************************** + # Create Basic momentum strategy + #****************************************************************** + load.packages('abind') + model.prices = abind(lapply(models, function(m) m$equity), along=2) + #model.prices = make.xts(model.prices, index(data$prices) + model.prices = model.prices[period.ends,] + model.returns = model.prices / mlag(model.prices)-1 + model.score = bt.apply.matrix(model.returns, SMA, 6) + model.vol = bt.apply.matrix(model.returns, runSD, 6) + + # select top 3 sectors based on the 6 month momentum, risk weighted + top = ntop(model.score, 3) + top = top / model.vol + top = top / rowSums(top, na.rm=T) + top = ifna(top,0) + + n = ncol(position.score) + nperiods = nrow(position.score) + + long[] = 0 + short[] = 0 + for( s in 1:n.sectors) { + score = matrix(top[,s], nr = nperiods, n) + long[quantiles == 1 & sectors == s] = (weights * score)[quantiles == 1 & sectors == s] + short[quantiles == n.quantiles & sectors == s] = (weights * score)[quantiles == n.quantiles & sectors == s] + } + long = long / rowSums(long,na.rm=T) + short = short / rowSums(short,na.rm=T) + + data$weight[] = NA + data$weight[period.ends,] = long - short + models$spread.sn.top3 = bt.run(data, silent = T) + + +#plotbt.custom.report.part1(models) +#plotbt.strategy.sidebyside(models) +} + + + #***************************************************************** + # Create Sector - Neutral Q1-QN spread + #****************************************************************** + long[] = 0 + long[quantiles == 1] = weights[quantiles == 1] + long = long / rowSums(long,na.rm=T) + + short[] = 0 + short[quantiles == n.quantiles] = weights[quantiles == n.quantiles] + short = short / rowSums(short,na.rm=T) + + data$weight[] = NA + data$weight[period.ends,] = long - short + models$spread.sn = bt.run(data, silent = T) + + return(models) +} + + + +############################################################################### +# Yet Another Forecast Dashboard +############################################################################### +# extract forecast info +forecast.helper <- function(fit, h=10, level = c(80,95)) { + out = try( forecast(fit, h=h, level=level), silent=TRUE) + if (class(out)[1] != 'try-error') { + out = data.frame(out) + } else { + temp = data.frame(predict(fit, n.ahead=h, doplot=F)) + pred = temp[,1] + se = temp[,2] + qq = qnorm(0.5 * (1 + level/100)) + out = matrix(NA, nr=h, nc=1+2*len(qq)) + out[,1] = pred + for(i in 1:len(qq)) + out[,(2*i):(2*i+1)] = c(pred - qq[i] * se, pred + qq[i] * se) + colnames(out) = c('Point.Forecast', matrix(c(paste('Lo', level, sep='.'), paste('Hi', level, sep='.')), nr=2, byrow=T)) + out = data.frame(out) + } + return(out) +} + +# compute future dates for the forecast +forecast2xts <- function(data, forecast) { + # length of the forecast + h = nrow(forecast) + dates = as.Date(index(data)) + + new.dates = seq(last(dates)+1, last(dates) + 2*365, by='day') + rm.index = date.dayofweek(new.dates) == 6 | date.dayofweek(new.dates) == 0 + new.dates = new.dates[!rm.index] + + new.dates = new.dates[1:h] + return(make.xts(forecast, new.dates)) +} + +# create forecast plot +forecast.plot <- function(data, forecast, ...) { + out = forecast2xts(data, forecast) + + # create plot + plota(c(data, out[,1]*NA), type='l', + ylim = range(data,out,na.rm=T), ...) + + # highligh sections + new.dates = index4xts(out) + temp = coredata(out) + + n = (ncol(out) %/% 2) + for(i in n : 1) { + polygon(c(new.dates,rev(new.dates)), + c(temp[,(2*i)], rev(temp[,(2*i+1)])), + border=NA, col=col.add.alpha(i+2,150)) + } + + plota.lines(out[,1], col='red') + + labels = c('Data,Forecast', paste(gsub('Lo.', '', colnames(out)[2*(1:n)]), '%', sep='')) + plota.legend(labels, fill = c('black,red',col.add.alpha((1:n)+2, 150))) +} + + +bt.forecast.dashboard <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1990-01-01', env = data, auto.assign = T) + bt.prep(data, align='remove.na') + + #***************************************************************** + # Create models + #****************************************************************** + load.packages('forecast,fGarch,fArma') + + sample = last(data$prices$SPY, 200) + ts.sample = ts(sample, frequency = 12) + + + + models = list( + # fGarch + garch = garchFit(~arma(1,15)+garch(1,1), data=sample, trace=F), + # fArma + arima = armaFit(~ arima(1, 1, 15), data=ts.sample), + + # forecast + arma = Arima(ts.sample, c(1,0,1)), + arfima = arfima(ts.sample), + auto.arima = auto.arima(ts.sample), + + bats = bats(ts.sample), + HoltWinters = HoltWinters(ts.sample), + naive = Arima(ts.sample, c(0,1,0)) + ) + + + #***************************************************************** + # Create Report + #****************************************************************** + png(filename = 'plot1.png', width = 800, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(matrix(1:9,nr=3)) + for(i in 1:len(models)) { + out = forecast.helper(models[[i]], 30, level = c(80,95)) + forecast.plot(sample, out, main = names(models)[i]) + } + dev.off() + + png(filename = 'plot2.png', width = 800, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(matrix(1:9,nr=3)) + for(i in 1:len(models)) { + out = forecast.helper(models[[i]], 30, level = c(75,85,95,97,99)) + forecast.plot(sample, out, main = names(models)[i]) + } + dev.off() + +} + + + +############################################################################### +# New 60/40 +# http://gestaltu.blogspot.ca/2012/07/youre-looking-at-wrong-number.html +############################################################################### +bt.new.60.40.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SHY,IEF,TLT,SPY') + + data.all <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1990-01-01', env = data.all, auto.assign = T) + for(i in ls(data.all)) data.all[[i]] = adjustOHLC(data.all[[i]], use.Adjusted=T) + bt.prep(data.all, align='remove.na') + + prices = data.all$prices + n = ncol(prices) + nperiods = nrow(prices) + prices = prices/ matrix(first(prices), nr=nperiods, nc=n, byrow=T) + +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plota.matplot(prices) +dev.off() + + + #***************************************************************** + # Load historical data + #****************************************************************** + data <- new.env() + data$stock = data.all$SPY + data$bond = data.all$TLT + bt.prep(data, align='remove.na') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + # all bonds began trading at 2002-07-31 + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + models = list() + + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + + #***************************************************************** + # Traditional, Dollar Weighted 40% Bonds & 60% Stock + #****************************************************************** + weight.dollar = matrix(c(0.4, 0.6), nr=nperiods, nc=n, byrow=T) + + data$weight[] = NA + data$weight[period.ends,] = weight.dollar[period.ends,] + models$dollar.w.60.40 = bt.run.share(data, clean.signal=F) + + + #***************************************************************** + # Risk Weighted 40% Bonds & 60% Stock + #****************************************************************** + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = sqrt(252) * bt.apply.matrix(ret.log, runSD, n = 21) + weight.risk = weight.dollar / hist.vol + weight.risk = weight.risk / rowSums(weight.risk) + + data$weight[] = NA + data$weight[period.ends,] = weight.risk[period.ends,] + models$risk.w.60.40 = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Scale Risk Weighted 40% Bonds & 60% Stock strategy to have 6% volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk.w.60.40, + weight.risk, 6/100, 21, 100/100)[period.ends,] + models$risk.w.60.40.target6 = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Same, plus invest cash into SHY + #****************************************************************** + weight = target.vol.strategy(models$risk.w.60.40, + weight.risk, 6/100, 21, 100/100) + data.all$weight[] = NA + data.all$weight$SPY[period.ends,] = weight$stock[period.ends,] + data.all$weight$TLT[period.ends,] = weight$bond[period.ends,] + + cash = 1-rowSums(weight) + data.all$weight$SHY[period.ends,] = cash[period.ends] + models$risk.w.60.40.target6.cash = bt.run.share(data.all, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot4.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models$risk.w.60.40.target6) +dev.off() + +png(filename = 'plot5.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models$risk.w.60.40.target6.cash) +dev.off() + + +} + + + + + +############################################################################### +# Adaptive Asset Allocation +# http://www.macquarieprivatewealth.ca/dafiles/Internet/mgl/ca/en/advice/specialist/darwin/documents/darwin-adaptive-asset-allocation.pdf +# http://cssanalytics.wordpress.com/2012/07/17/adaptive-asset-allocation-combining-momentum-with-minimum-variance/ +############################################################################### + + +#' @export +bt.aaa.combo <- function +( + data, + period.ends, + n.top = 5, # number of momentum positions + n.top.keep = n.top, # only change position if it drops from n.top.keep + n.mom = 6*22, # length of momentum look back + n.vol = 1*22 # length of volatility look back +) +{ + #***************************************************************** + # Combo: weight positions in the Momentum Portfolio according to Volatliliy + #***************************************************************** + prices = coredata(data$prices) + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = bt.apply.matrix(ret.log, runSD, n = n.vol) + adj.vol = 1/hist.vol[period.ends,] + + momentum = prices / mlag(prices, n.mom) + + weight = ntop.keep(momentum[period.ends,], n.top, n.top.keep) * adj.vol + n.skip = max(n.mom, n.vol) + + data$weight[] = NA + data$weight[period.ends,] = weight / rowSums(weight, na.rm=T) + data$weight[1 : n.skip,] = NA + bt.run.share(data, clean.signal=F, silent=T) +} + +#' @export +bt.aaa.minrisk <- function +( + data, + period.ends, + n.top = 5, # number of momentum positions + n.mom = 6*22, # length of momentum look back + n.vol = 1*22 # length of volatility look back +) +{ + #***************************************************************** + # Adaptive Asset Allocation (AAA) + # weight positions in the Momentum Portfolio according to + # the minimum variance algorithm + #***************************************************************** + prices = coredata(data$prices) + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + + momentum = prices / mlag(prices, n.mom) + + weight = NA * prices + weight[period.ends,] = ntop(momentum[period.ends,], n.top) + n.skip = max(n.mom, n.vol) + + for( i in period.ends[period.ends >= n.skip] ) { + hist = ret.log[ (i - n.vol + 1):i, ] + + # require all assets to have full price history + include.index = count(hist)== n.vol + + # also only consider assets in the Momentum Portfolio + index = ( weight[i,] > 0 ) & include.index + n = sum(index) + + if(n > 0) { + hist = hist[ , index] + + # create historical input assumptions + ia = create.ia(hist) + s0 = apply(coredata(hist),2,sd) + ia$cov = cor(coredata(hist), use='complete.obs',method='pearson') * (s0 %*% t(s0)) + + # create constraints: 0<=x<=1, sum(x) = 1 + constraints = new.constraints(n, lb = 0, ub = 1) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # compute minimum variance weights + weight[i,] = 0 + weight[i,index] = min.risk.portfolio(ia, constraints) + } + } + + # Adaptive Asset Allocation (AAA) + data$weight[] = NA + data$weight[period.ends,] = weight[period.ends,] + bt.run.share(data, clean.signal=F, silent=T) +} + + +# Sensitivity Analysis based on the bt.improving.trend.following.test() +bt.aaa.sensitivity.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY,EFA,EWJ,EEM,IYR,RWX,IEF,TLT,DBC,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2004:12::') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + models = list() + + # find period ends + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + + #***************************************************************** + # Test + #****************************************************************** + models = list() + + models$combo = bt.aaa.combo(data, period.ends, n.top = 5, + n.mom = 180, n.vol = 20) + + + models$aaa = bt.aaa.minrisk(data, period.ends, n.top = 5, + n.mom = 180, n.vol = 20) + + plotbt.custom.report.part1(models) + + + + #***************************************************************** + # Sensitivity Analysis: bt.aaa.combo / bt.aaa.minrisk + #****************************************************************** + # length of momentum look back + mom.lens = ( 1 : 12 ) * 20 + # length of volatility look back + vol.lens = ( 1 : 12 ) * 20 + + + models = list() + + # evaluate strategies + for(n.mom in mom.lens) { + cat('MOM =', n.mom, '\n') + + for(n.vol in vol.lens) { + cat('\tVOL =', n.vol, '\n') + + models[[ paste('M', n.mom, 'V', n.vol) ]] = + bt.aaa.combo(data, period.ends, n.top = 5, + n.mom = n.mom, n.vol = n.vol) + } + } + + out = plotbt.strategy.sidebyside(models, return.table=T, make.plot = F) + + #***************************************************************** + # Create Report + #****************************************************************** + # allocate matrixe to store backtest results + dummy = matrix('', len(vol.lens), len(mom.lens)) + colnames(dummy) = paste('M', mom.lens) + rownames(dummy) = paste('V', vol.lens) + + names = spl('Sharpe,Cagr,DVR,MaxDD') + +png(filename = 'plot1.png', width = 1000, height = 1000, units = 'px', pointsize = 12, bg = 'white') + + layout(matrix(1:4,nrow=2)) + for(i in names) { + dummy[] = '' + + for(n.mom in mom.lens) + for(n.vol in vol.lens) + dummy[paste('V', n.vol), paste('M', n.mom)] = + out[i, paste('M', n.mom, 'V', n.vol) ] + + plot.table(dummy, smain = i, highlight = T, colorbar = F) + + } + +dev.off() + + #***************************************************************** + # Sensitivity Analysis + #****************************************************************** + # evaluate strategies + for(n.mom in mom.lens) { + cat('MOM =', n.mom, '\n') + + for(n.vol in vol.lens) { + cat('\tVOL =', n.vol, '\n') + + models[[ paste('M', n.mom, 'V', n.vol) ]] = + bt.aaa.minrisk(data, period.ends, n.top = 5, + n.mom = n.mom, n.vol = n.vol) + } + } + + out = plotbt.strategy.sidebyside(models, return.table=T, make.plot = F) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot2.png', width = 1000, height = 1000, units = 'px', pointsize = 12, bg = 'white') + + layout(matrix(1:4,nrow=2)) + for(i in names) { + dummy[] = '' + + for(n.mom in mom.lens) + for(n.vol in vol.lens) + dummy[paste('V', n.vol), paste('M', n.mom)] = + out[i, paste('M', n.mom, 'V', n.vol) ] + + plot.table(dummy, smain = i, highlight = T, colorbar = F) + + } +dev.off() + + + +} + + +bt.aaa.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY,EFA,EWJ,EEM,IYR,RWX,IEF,TLT,DBC,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + + + # contruct another back-test enviroment with split-adjusted prices, do not include dividends + # http://www.fintools.com/wp-content/uploads/2012/02/DividendAdjustedStockPrices.pdf + # http://www.pstat.ucsb.edu/research/papers/momentum.pdf + data.price <- new.env() + for(i in ls(data)) data.price[[i]] = adjustOHLC(data[[i]], symbol.name=i, adjust='split', use.Adjusted=F) + bt.prep(data.price, align='keep.all', dates='2004:12::') + + + # create split and dividend adjusted prices + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2004:12::') + + + # flag to indicate whether to use Total(split and dividend adjusted) or Price(split adjusted) prices + use.total = FALSE + + + #***************************************************************** + # Sample Plot of Total and Price only time series + #****************************************************************** + if(F) { + y = data$prices$TLT + y.price = data.price$prices$TLT + y = y / as.double(y[1]) + y.price = y.price / as.double(y.price[1]) + + plota(y, type='l', ylim=range(y, y.price, na.rm=T)) + plota.lines(y.price, col='red') + plota.legend('Total,Price', 'black,red') + } + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + prices4mom = iif(use.total, data$prices, data.price$prices) + prices4vol = iif(use.total, data$prices, data.price$prices) + + models = list() + + # find period ends + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + # Adaptive Asset Allocation parameters + n.top = 5 # number of momentum positions + n.mom = 6*22 # length of momentum look back + n.vol = 1*22 # length of volatility look back + + #***************************************************************** + # Equal Weight + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$equal.weight = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Volatliliy Position Sizing + #****************************************************************** + ret.log = bt.apply.matrix(prices4vol, ROC, type='continuous') + hist.vol = bt.apply.matrix(ret.log, runSD, n = n.vol) + + adj.vol = 1/hist.vol[period.ends,] + + data$weight[] = NA + data$weight[period.ends,] = adj.vol / rowSums(adj.vol, na.rm=T) + models$volatility.weighted = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Momentum Portfolio + #***************************************************************** + momentum = prices4mom / mlag(prices4mom, n.mom) + + data$weight[] = NA + data$weight[period.ends,] = ntop(momentum[period.ends,], n.top) + models$momentum = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Combo: weight positions in the Momentum Portfolio according to Volatliliy + #***************************************************************** + weight = ntop(momentum[period.ends,], n.top) * adj.vol + + data$weight[] = NA + data$weight[period.ends,] = weight / rowSums(weight, na.rm=T) + models$combo = bt.run.share(data, clean.signal=F,trade.summary = TRUE) + + #***************************************************************** + # Adaptive Asset Allocation (AAA) + # weight positions in the Momentum Portfolio according to + # the minimum variance algorithm + #***************************************************************** + weight = NA * prices + weight[period.ends,] = ntop(momentum[period.ends,], n.top) + + for( i in period.ends[period.ends >= n.mom] ) { + hist = ret.log[ (i - n.vol + 1):i, ] + + # require all assets to have full price history + include.index = count(hist)== n.vol + + # also only consider assets in the Momentum Portfolio + index = ( weight[i,] > 0 ) & include.index + n = sum(index) + + if(n > 0) { + hist = hist[ , index] + + # create historical input assumptions + ia = create.ia(hist) + s0 = apply(coredata(hist),2,sd) + ia$cov = cor(coredata(hist), use='complete.obs',method='pearson') * (s0 %*% t(s0)) + + # create constraints: 0<=x<=1, sum(x) = 1 + constraints = new.constraints(n, lb = 0, ub = 1) + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # compute minimum variance weights + weight[i,] = 0 + weight[i,index] = min.risk.portfolio(ia, constraints) + } + } + + # Adaptive Asset Allocation (AAA) + data$weight[] = NA + data$weight[period.ends,] = weight[period.ends,] + models$aaa = bt.run.share(data, clean.signal=F,trade.summary = TRUE) + + + #***************************************************************** + # Create Report + #****************************************************************** + #pdf(file = 'report.pdf', width=8.5, height=11) + + models = rev(models) + +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3(models$combo, trade.summary = TRUE) +dev.off() + +png(filename = 'plot4.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part3(models$aaa, trade.summary = TRUE) +dev.off() + + +} + + +bt.aaa.test.new <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY,EFA,EWJ,EEM,IYR,RWX,IEF,TLT,DBC,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2004:12::') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + # find period ends + period.ends = endpoints(prices, 'months') + #period.ends = endpoints(prices, 'weeks') + period.ends = period.ends[period.ends > 0] + + +n.mom = 180 +n.vol = 60 +n.top = 4 + + momentum = prices / mlag(prices, n.mom) + + models$combo = bt.aaa.combo(data, period.ends, n.top = n.top, + n.mom = n.mom, n.vol = n.vol) + + # bt.aaa.minrisk is equivalent to MV=min.var.portfolio below + models$aaa = bt.aaa.minrisk(data, period.ends, n.top = n.top, + n.mom = n.mom, n.vol = n.vol) + + + obj = portfolio.allocation.helper(data$prices, period.ends=period.ends, + lookback.len = n.vol, universe = ntop(momentum[period.ends,], n.top) > 0, + min.risk.fns = list(EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + MV=min.var.portfolio, + MD=max.div.portfolio, + MC=min.corr.portfolio, + MC2=min.corr2.portfolio, + MCE=min.corr.excel.portfolio, + RSO.2 = rso.portfolio(equal.weight.portfolio, 2, 100), + MS=max.sharpe.portfolio()) + ) + + #models = c(models, create.strategies(obj, data)$models) + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** + # put all reports into one pdf file + #pdf(file = 'filename.pdf', width=8.5, height=11) + +png(filename = 'plot2.png', width = 800, height = 800, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + +png(filename = 'plot3.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models$MS) +dev.off() + + +png(filename = 'plot4.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') +dev.off() + + + + # close pdf file + #dev.off() +} + + + + +#***************************************************************** +# Random Subspace Optimization(RSO) +# https://cssanalytics.wordpress.com/2013/10/06/random-subspace-optimization-rso/ +# http://systematicedge.wordpress.com/2013/10/14/random-subspace-optimization-max-sharpe/ +#***************************************************************** +bt.rso.portfolio.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod,quadprog,corpcor,lpSolve') + tickers = spl('SPY,EEM,EFA,TLT,IWM,QQQ,GLD') + tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='1998::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + + obj = portfolio.allocation.helper(data$prices, + periodicity = 'months', lookback.len = 120, + min.risk.fns = list( + EW = equal.weight.portfolio, + # RP = risk.parity.portfolio(), + + # MV = min.var.portfolio, + # RSO.MV = rso.portfolio(min.var.portfolio, 3, 100), + + MS = max.sharpe.portfolio(), + RSO.MS.2 = rso.portfolio(max.sharpe.portfolio(), 2, 100), + RSO.MS.3 = rso.portfolio(max.sharpe.portfolio(), 3, 100), + RSO.MS.4 = rso.portfolio(max.sharpe.portfolio(), 4, 100), + RSO.MS.5 = rso.portfolio(max.sharpe.portfolio(), 5, 100), + RSO.MS.6 = rso.portfolio(max.sharpe.portfolio(), 6, 100), + RSO.MS.7 = rso.portfolio(max.sharpe.portfolio(), 7, 100) + ) + ) + + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** + strategy.performance.snapshoot(models,T) + +} + +############################################################################### +# Merging Current Stock Quotes with Historical Prices +############################################################################### +bt.current.quote.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('VTI,EFA,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data) + + + # look at the data + last(data$prices, 2) + + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('VTI,EFA,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # current quotes logic + quotes = getQuote(tickers) + for(i in ls(data)) + if( last(index(data[[i]])) < as.Date(quotes[i, 'Trade Time']) ) { + data[[i]] = rbind( data[[i]], make.xts(quotes[i, spl('Open,High,Low,Last,Volume,Last')], + as.Date(quotes[i, 'Trade Time']))) + } + + bt.prep(data) + + + # look at the data + last(data$prices, 2) +} + + +############################################################################### +# Extending Commodity time series +# with CRB Commodities Index +# http://www.jefferies.com/cositemgr.pl/html/ProductsServices/SalesTrading/Commodities/ReutersJefferiesCRB/IndexData/index.shtml +############################################################################### +bt.extend.DBC.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + CRB = get.CRB() + + tickers = spl('GSG,DBC') + getSymbols(tickers, src = 'yahoo', from = '1970-01-01') + + #***************************************************************** + # Compare different indexes + #****************************************************************** + out = na.omit(merge(Ad(CRB), Ad(GSG), Ad(DBC))) + colnames(out) = spl('CRB,GSG,DBC') + temp = out / t(repmat(as.vector(out[1,]),1,nrow(out))) + +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot side by side + layout(1:2, heights=c(4,1)) + plota(temp, ylim=range(temp)) + plota.lines(temp[,1],col=1) + plota.lines(temp[,2],col=2) + plota.lines(temp[,3],col=3) + plota.legend(colnames(temp),1:3) + + # Plot correlation table + temp = cor(temp / mlag(temp)- 1, use='complete.obs', method='pearson') + temp[] = plota.format(100 * temp, 0, '', '%') + plot.table(temp) +dev.off() + + + #***************************************************************** + # Create simple equal weight back-test + #****************************************************************** + tickers = spl('GLD,DBC,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # extend Gold and Commodity time series + data$GLD = extend.GLD(data$GLD) + data$DBC = extend.data(data$DBC, get.CRB(), scale=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + # find period ends + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + models = list() + + #***************************************************************** + # Equal Weight + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = ntop(prices[period.ends,], n) + models$equal.weight = bt.run.share(data, clean.signal=F) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot3.png', width = 1200, height = 800, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part2(models) +dev.off() +} + + +bt.extend.DBC.update.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('GSG,DBC') + data = new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # "TRJ_CRB" file was downloaded from the http://www.jefferies.com/Commodities/2cc/389 + # for "TRJ/CRB Index-Total Return" + temp = extract.table.from.webpage( join(readLines("TRJ_CRB")), 'EODValue' ) + temp = join( apply(temp, 1, join, ','), '\n' ) + data$CRB_1 = make.stock.xts( read.xts(temp, format='%m/%d/%y' ) ) + + # "prfmdata.csv" file was downloaded from the http://www.crbequityindexes.com/indexdata-form.php + # for "TR/J CRB Global Commodity Equity Index", "Total Return", "All Dates" + data$CRB_2 = make.stock.xts( read.xts("prfmdata.csv", format='%m/%d/%Y' ) ) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Compare + #****************************************************************** +png(filename = 'plot1.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plota.matplot(scale.one(data$prices)) + +dev.off() +} + + + + + +############################################################################### +# Permanent Portfolio +# http://catallacticanalysis.com/permanent-portfolio/ +# http://systematicinvestor.wordpress.com/2011/12/16/backtesting-rebalancing-methods/ +# http://en.wikipedia.org/wiki/Fail-Safe_Investing#The_Permanent_Portfolio +############################################################################### +bt.permanent.portfolio.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY,TLT,GLD,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # extend GLD with Gold.PM - London Gold afternoon fixing prices + data$GLD = extend.GLD(data$GLD) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Setup + #****************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + # annual + period.ends = endpoints(prices, 'years') + period.ends = period.ends[period.ends > 0] + period.ends.y = c(1, period.ends) + + # quarterly + period.ends = endpoints(prices, 'quarters') + period.ends = period.ends[period.ends > 0] + period.ends.q = c(1, period.ends) + + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + target.allocation = matrix(rep(1/n,n), nrow=1) + + # Buy & Hold + data$weight[] = NA + data$weight[period.ends.y[1],] = target.allocation + models$buy.hold = bt.run.share(data, clean.signal=F) + + + # Equal Weight + data$weight[] = NA + data$weight[period.ends.y,] = ntop(prices[period.ends.y,], n) + models$equal.weight.y = bt.run.share(data, clean.signal=F) + + # Rebalance only when threshold is broken + models$threshold.y = bt.max.deviation.rebalancing(data, models$buy.hold, target.allocation, 10/100, 0, period.ends = period.ends.y) + + #***************************************************************** + # Quarterly + #****************************************************************** + # Equal Weight + data$weight[] = NA + data$weight[period.ends.q,] = ntop(prices[period.ends.q,], n) + models$equal.weight.q = bt.run.share(data, clean.signal=F) + + # Rebalance only when threshold is broken + models$threshold.q = bt.max.deviation.rebalancing(data, models$buy.hold, target.allocation, 10/100, 0, period.ends = period.ends.q) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each Rebalancing method + layout(1:2) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover', F) + barplot.with.labels(sapply(models, compute.max.deviation, target.allocation), 'Maximum Deviation from Target Mix') +dev.off() + +} + + + + +############################################################################### +# Additional example for Permanent Portfolio +# that employs: +# * risk allocation +# * volatility targeting +# * makret filter (10 month SMA) +# to improve strategy perfromance +############################################################################### +bt.permanent.portfolio2.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY,TLT,GLD,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # extend GLD with Gold.PM - London Gold afternoon fixing prices + data$GLD = extend.GLD(data$GLD) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Setup + #****************************************************************** + prices = data$prices + n = ncol(prices) + + period.ends = endpoints(prices, 'quarters') + period.ends = period.ends[period.ends > 0] + period.ends = c(1, period.ends) + + + models = list() + + + #***************************************************************** + # Dollar Weighted + #****************************************************************** + target.allocation = matrix(rep(1/n,n), nrow=1) + weight.dollar = ntop(prices, n) + + data$weight[] = NA + data$weight[period.ends,] = weight.dollar[period.ends,] + models$dollar = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Dollar Weighted + 7% target volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$dollar, + weight.dollar, 7/100, 21, 100/100)[period.ends,] + models$dollar.target7 = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Risk Weighted + #****************************************************************** + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = sqrt(252) * bt.apply.matrix(ret.log, runSD, n = 21) + weight.risk = weight.dollar / hist.vol + weight.risk = weight.risk / rowSums(weight.risk) + + data$weight[] = NA + data$weight[period.ends,] = weight.risk[period.ends,] + models$risk = bt.run.share(data, clean.signal=F) + + if(F) { + # risk weighted + 7% target volatility + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk, + weight.risk, 7/100, 21, 100/100)[period.ends,] + models$risk.target7 = bt.run.share(data, clean.signal=F) + + # risk weighted + 5% target volatility + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk, + weight.risk, 5/100, 21, 100/100)[period.ends,] + models$risk.target5 = bt.run.share(data, clean.signal=F) + } + #***************************************************************** + # Market Filter (tactical): 10 month moving average + #****************************************************************** + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + period.ends = c(1, period.ends) + + sma = bt.apply.matrix(prices, SMA, 200) + weight.dollar.tactical = weight.dollar * (prices > sma) + + data$weight[] = NA + data$weight[period.ends,] = weight.dollar.tactical[period.ends,] + models$dollar.tactical = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Tactical + 7% target volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$dollar.tactical, + weight.dollar.tactical, 7/100, 21, 100/100)[period.ends,] + models$dollar.tactical.target7 = bt.run.share(data, clean.signal=F) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + +} + + + + +############################################################################### +# Additional example for Permanent Portfolio +# add transaction cost and +# RR - remove SHY from basket +############################################################################### +bt.permanent.portfolio3.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('SPY,TLT,GLD,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # extend GLD with Gold.PM - London Gold afternoon fixing prices + data$GLD = extend.GLD(data$GLD) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Setup + #****************************************************************** + prices = data$prices + n = ncol(prices) + + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + period.ends = c(1, period.ends) + + + models = list() + commission = 0.1 + + #***************************************************************** + # Dollar Weighted + #****************************************************************** + target.allocation = matrix(rep(1/n,n), nrow=1) + weight.dollar = ntop(prices, n) + + data$weight[] = NA + data$weight[period.ends,] = weight.dollar[period.ends,] + models$dollar = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Dollar Weighted + 7% target volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$dollar, + weight.dollar, 7/100, 21, 100/100)[period.ends,] + models$dollar.target7 = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Risk Weighted + #****************************************************************** + ret.log = bt.apply.matrix(prices, ROC, type='continuous') + hist.vol = sqrt(252) * bt.apply.matrix(ret.log, runSD, n = 21) + weight.risk = weight.dollar / hist.vol + weight.risk$SHY = 0 + weight.risk = weight.risk / rowSums(weight.risk) + + data$weight[] = NA + data$weight[period.ends,] = weight.risk[period.ends,] + models$risk = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Risk Weighted + 7% target volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk, + weight.risk, 7/100, 21, 100/100)[period.ends,] + models$risk.target7 = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Risk Weighted + 7% target volatility + SHY + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk, + weight.risk, 7/100, 21, 100/100)[period.ends,] + + cash = 1-rowSums(data$weight) + data$weight$SHY[period.ends,] = cash[period.ends] + models$risk.target7.shy = bt.run.share(data, commission=commission, clean.signal=F) + + + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + plotbt.strategy.sidebyside(models) +dev.off() + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot Portfolio Turnover for each strategy + layout(1) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover') +dev.off() + + + + + + + #***************************************************************** + # Market Filter (tactical): 10 month moving average + #****************************************************************** + sma = bt.apply.matrix(prices, SMA, 200) + weight.dollar.tactical = weight.dollar * (prices > sma) + + data$weight[] = NA + data$weight[period.ends,] = weight.dollar.tactical[period.ends,] + models$dollar.tactical = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Tactical + 7% target volatility + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$dollar.tactical, + weight.dollar.tactical, 7/100, 21, 100/100)[period.ends,] + models$dollar.tactical.target7 = bt.run.share(data, commission=commission, clean.signal=F) + + + + + #***************************************************************** + # Risk Weighted + Tactical + #****************************************************************** + weight.risk.tactical = weight.risk * (prices > sma) + + data$weight[] = NA + data$weight[period.ends,] = weight.risk.tactical[period.ends,] + models$risk.tactical = bt.run.share(data, commission=commission, clean.signal=F) + + #***************************************************************** + # Risk Weighted + Tactical + 7% target volatility + SHY + #****************************************************************** + data$weight[] = NA + data$weight[period.ends,] = target.vol.strategy(models$risk.tactical, + weight.risk.tactical, 7/100, 21, 100/100)[period.ends,] + cash = 1-rowSums(data$weight) + data$weight$SHY[period.ends,] = cash[period.ends] + models$risk.tactical.target7.shy = bt.run.share(data, commission=commission, clean.signal=F) + + +} + + + + +############################################################################### +# Minimum Correlation Algorithm Example +############################################################################### +bt.mca.test <- function() +{ + + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod,quadprog') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2002:08::') + + #write.xts(data$prices, 'data.csv') + + #***************************************************************** + # Code Strategies + #****************************************************************** + + obj = portfolio.allocation.helper(data$prices, periodicity = 'weeks', + min.risk.fns = list(EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + MV=min.var.portfolio, + MD=max.div.portfolio, + MC=min.corr.portfolio, + MC2=min.corr2.portfolio, + MCE=min.corr.excel.portfolio), + custom.stats.fn = 'portfolio.allocation.custom.stats' + ) + + + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + + out = plotbt.strategy.sidebyside(models, return.table=T) +dev.off() + +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + # Plot time series of components of Composite Diversification Indicator + cdi = custom.composite.diversification.indicator(obj,plot.table = F) + out = rbind(colMeans(cdi, na.rm=T), out) + rownames(out)[1] = 'Composite Diversification Indicator(CDI)' +dev.off() + + # Portfolio Turnover for each strategy + y = 100 * sapply(models, compute.turnover, data) + out = rbind(y, out) + rownames(out)[1] = 'Portfolio Turnover' + +png(filename = 'plot3.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + performance.barchart.helper(out, 'Sharpe,Cagr,DVR,MaxDD', c(T,T,T,T)) +dev.off() + +png(filename = 'plot4.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + performance.barchart.helper(out, 'Volatility,Portfolio Turnover,Composite Diversification Indicator(CDI)', c(F,F,T)) +dev.off() + + +png(filename = 'plot5.png', width = 600, height = 1000, units = 'px', pointsize = 12, bg = 'white') + # Plot transition maps + layout(1:len(models)) + for(m in names(models)) { + plotbt.transition.map(models[[m]]$weight, name=m) + legend('topright', legend = m, bty = 'n') + } +dev.off() + +png(filename = 'plot6.png', width = 600, height = 1000, units = 'px', pointsize = 12, bg = 'white') + # Plot transition maps for Risk Contributions + dates = index(data$prices)[obj$period.ends] + layout(1:len(models)) + for(m in names(models)) { + plotbt.transition.map(make.xts(obj$risk.contributions[[m]], dates), + name=paste('Risk Contributions',m)) + legend('topright', legend = m, bty = 'n') + } +dev.off() + + # plot the most recent weights + plot.table( sapply(models, function(m) round(100*last(m$weight),1)) ) + +} + + +############################################################################### +# Minimum Correlation Algorithm Speed test +############################################################################### +bt.mca.speed.test <- function() +{ + #***************************************************************** + # Setup + #***************************************************************** + load.packages('quadprog,corpcor') + + n = 100 + hist = matrix(rnorm(1000*n), nc=n) + + # 0 <= x.i <= 1 + constraints = new.constraints(n, lb = 0, ub = 1) + constraints = add.constraints(diag(n), type='>=', b=0, constraints) + constraints = add.constraints(diag(n), type='<=', b=1, constraints) + + # SUM x.i = 1 + constraints = add.constraints(rep(1, n), 1, type = '=', constraints) + + # create historical input assumptions + ia = list() + ia$n = n + ia$risk = apply(hist, 2, sd) + ia$correlation = cor(hist, use='complete.obs', method='pearson') + ia$cov = ia$correlation * (ia$risk %*% t(ia$risk)) + + ia$cov = make.positive.definite(ia$cov, 0.000000001) + ia$correlation = make.positive.definite(ia$correlation, 0.000000001) + + #***************************************************************** + # Time + #***************************************************************** + load.packages('rbenchmark') + + benchmark( + min.var.portfolio(ia, constraints), + min.corr.portfolio(ia, constraints), + min.corr2.portfolio(ia, constraints), + + + columns=c("test", "replications", "elapsed", "relative"), + order="relative", + replications=100 + ) + + + #***************************************************************** + # Check the bottle neck + #***************************************************************** + Rprof() + for(i in 1:10) + min.corr.portfolio(ia, constraints) + Rprof(NULL) + summaryRprof() + + + #ia$cov = make.positive.definite.fast(ia$cov) + #ia$correlation = make.positive.definite.fast(ia$correlation) + + #***************************************************************** + # Template for testing speed finding bottle necks + #***************************************************************** + # time it + tic(12) + for(icount in 1:10) { + + # inset your code here and adjust number of evalutaions + + } + toc(12) + + # determine bottle necks + Rprof() + for(icount in 1:10) { + + # inset your code here and adjust number of evalutaions + + } + Rprof(NULL) + summaryRprof() + +} + + +############################################################################### +# Testing Universal Portfolios - Constant Rebalanced portfolio +# http://optimallog.blogspot.ca/2012/06/universal-portfolio-part-3.html +# http://optimallog.blogspot.ca/2012/06/universal-portfolio-part-4.html +# to call internal function in logopt use logopt:::crp_bh(x) or logopt:::roll.bcrp +############################################################################### +bt.crp.test <- function() +{ + #***************************************************************** + # Example from http://optimallog.blogspot.ca/2012/06/universal-portfolio-part-3.html + #****************************************************************** + load.packages('FNN') + load.packages('logopt', 'http://R-Forge.R-project.org') + + load.packages('quantmod') + + data(nyse.cover.1962.1984) + x = nyse.cover.1962.1984 + x = x[,spl('iroqu,kinar')] + + #***************************************************************** + # Load historical data + #****************************************************************** + data <- new.env() + for(i in names(x)) { + data[[i]] = cumprod(x[,i]) + colnames(data[[i]]) = 'Close' + } + bt.prep(data, align='remove.na') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + #***************************************************************** + # Plot 1 + #****************************************************************** + plota(prices$iroqu, col='blue', type='l', ylim=range(prices), main = '"iroqu" and "kinar"', ylab='') + plota.lines(prices$kinar, col='red') + grid() + plota.legend('iroqu,kinar', 'blue,red') + + #***************************************************************** + # Compute Universal Portfolio + #****************************************************************** + universal = prices[,1] * 0 + alphas = seq(0,1,by=0.05) + crps = alphas + for (i in 1:length(crps)) { + data$weight[] = NA + data$weight[] = c(alphas[i], 1-alphas[i]) + equity = bt.run(data, silent=T)$equity + + universal = universal + equity + crps[i] = last(equity) + } + universal = universal/length(alphas) + + #***************************************************************** + # Plot 2 + #****************************************************************** + plot(alphas, crps, col="blue", type="l", ylab="", + main='20 Year Return vs. mix of "iroqu" and "kinar"', + xlab='Fraction of "iroqu" in Portfolio') + points(alphas, crps, pch=19, cex=0.5, col="red") + abline(h=mean(crps), col="green") + text(0.5,mean(crps)*1.05,labels="Return from Universal Portfolio") + grid() + + #***************************************************************** + # Plot 3 + #****************************************************************** + plota(prices$iroqu, col='blue', type='l', ylim=range(prices, universal), + main = 'Universal Portfolios with "iroqu" and "kinar"', ylab="") + plota.lines(prices$kinar, col='red') + plota.lines(universal, col='green') + grid() + plota.legend('iroqu,kinar,universal', 'blue,red,green') + + + + + + + # Constant Rebalanced portfolio + crp.portfolio <- function + ( + ia, # input assumptions + constraints # constraints + ) + { + bcrp.optim(1 + ia$hist.returns, fast.only = TRUE ) + } + + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod,quadprog') + tickers = spl('SPY,QQQ,EEM,IWM,EFA,TLT,IYR,GLD') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates='2002:08::') + + #***************************************************************** + # Code Strategies + #****************************************************************** + + obj = portfolio.allocation.helper(data$prices, periodicity = 'weeks', lookback.len = 460, + min.risk.fns = list(CRP=crp.portfolio) + ) + + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** + # quite volatlie for a short lookback.len + plotbt.custom.report.part2( models$CRP ) + + + #***************************************************************** + # Code Strategies + #****************************************************************** + + obj = portfolio.allocation.helper(data$prices, periodicity = 'weeks', + min.risk.fns = list(EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + MC=min.corr.portfolio, + MC2=min.corr2.portfolio) + ) + + models = c(models, create.strategies(obj, data)$models) + + #***************************************************************** + # Create Report + #****************************************************************** + # performance is inferior to other algos + layout(1:2) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + + out = plotbt.strategy.sidebyside(models, return.table=T) + +} + + + +############################################################################### +# Interesting that Sep/Nov perfromance changes over different time frames +# http://www.marketwatch.com/story/an-early-halloween-for-gold-traders-2012-09-26 +# An early Halloween for gold traders +# Commentary: October is worst month of calendar for gold bullion +# By Mark Hulbert +# Watch out, gold traders: Halloween is likely to come early. +############################################################################### +bt.october.gold.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + ticker = 'GLD' + + data = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F) + data = adjustOHLC(data, use.Adjusted=T) + + #***************************************************************** + # Look at the Month of the Year Seasonality + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + month.year.seasonality(data, ticker) +dev.off() + + + + #***************************************************************** + # Load long series of gold prices from Bundes Bank + #****************************************************************** + data = bundes.bank.data.gold() + + #***************************************************************** + # Look at the Month of the Year Seasonality + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + month.year.seasonality(data, 'GOLD', lookback.len = nrow(data)) +dev.off() + + + #***************************************************************** + # Create file for Seasonality Tool + #****************************************************************** + GLD = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F) + GLD = adjustOHLC(GLD, use.Adjusted=T) + + + write.xts(extend.data(GLD, data / 10), 'GOLD.csv') + + + +} + + + + +############################################################################### +# Couch Potato strategy +# http://www.moneysense.ca/2006/04/05/couch-potato-portfolio-introduction/ +############################################################################### + # helper function to model Couch Potato strategy - a fixed allocation strategy + couch.potato.strategy <- function + ( + data.all, + tickers = 'XIC.TO,XSP.TO,XBB.TO', + weights = c( 1/3, 1/3, 1/3 ), + periodicity = 'years', + dates = '1900::', + commission = 0.1 + ) + { + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl(tickers) + names(weights) = tickers + + data <- new.env() + for(s in tickers) data[[ s ]] = data.all[[ s ]] + + bt.prep(data, align='remove.na', dates=dates) + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + # find period ends + period.ends = endpoints(data$prices, periodicity) + period.ends = c(1, period.ends[period.ends > 0]) + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + for(s in tickers) data$weight[period.ends, s] = weights[s] + model = bt.run.share(data, clean.signal=F, commission=commission) + + return(model) + } + +bt.couch.potato.test <- function() +{ + #***************************************************************** + # Canadian Version + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + map = list() + map$can.eq = 'XIC.TO' + map$can.div = 'XDV.TO' + map$us.eq = 'XSP.TO' + map$us.div = 'DVY' + map$int.eq = 'XIN.TO' + map$can.bond = 'XBB.TO' + map$can.real.bond = 'XRB.TO' + map$can.re = 'XRE.TO' + map$can.it = 'XTR.TO' + map$can.gold = 'XGD.TO' + + data <- new.env() + for(s in names(map)) { + data[[ s ]] = getSymbols(map[[ s ]], src = 'yahoo', from = '1995-01-01', env = data, auto.assign = F) + data[[ s ]] = adjustOHLC(data[[ s ]], use.Adjusted=T) + } + + #***************************************************************** + # Code Strategies + #****************************************************************** + models = list() + periodicity = 'years' + dates = '2006::' + + models$classic = couch.potato.strategy(data, 'can.eq,us.eq,can.bond', rep(1/3,3), periodicity, dates) + models$global = couch.potato.strategy(data, 'can.eq,us.eq,int.eq,can.bond', c(0.2, 0.2, 0.2, 0.4), periodicity, dates) + models$yield = couch.potato.strategy(data, 'can.div,can.it,us.div,can.bond', c(0.25, 0.25, 0.25, 0.25), periodicity, dates) + models$growth = couch.potato.strategy(data, 'can.eq,us.eq,int.eq,can.bond', c(0.25, 0.25, 0.25, 0.25), periodicity, dates) + + models$complete = couch.potato.strategy(data, 'can.eq,us.eq,int.eq,can.re,can.real.bond,can.bond', c(0.2, 0.15, 0.15, 0.1, 0.1, 0.3), periodicity, dates) + + models$permanent = couch.potato.strategy(data, 'can.eq,can.gold,can.bond', c(0.25,0.25,0.5), periodicity, dates) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + + out = plotbt.strategy.sidebyside(models, return.table=T) +dev.off() + + + + #***************************************************************** + # US Version + #***************************************************************** + # Load historical data + #****************************************************************** + tickers = spl('VIPSX,VTSMX,VGTSX,SPY,TLT,GLD,SHY') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1995-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # extend GLD with Gold.PM - London Gold afternoon fixing prices + data$GLD = extend.GLD(data$GLD) + + #***************************************************************** + # Code Strategies + #****************************************************************** + models = list() + periodicity = 'years' + dates = '2003::' + + models$classic = couch.potato.strategy(data, 'VIPSX,VTSMX', rep(1/2,2), periodicity, dates) + models$margarita = couch.potato.strategy(data, 'VIPSX,VTSMX,VGTSX', rep(1/3,3), periodicity, dates) + models$permanent = couch.potato.strategy(data, 'SPY,TLT,GLD,SHY', rep(1/4,4), periodicity, dates) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 600, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3) + mtext('Cumulative Performance', side = 2, line = 1) + + out = plotbt.strategy.sidebyside(models, return.table=T) +dev.off() + +} + + + +############################################################################### +# Regime Detection +# http://blogs.mathworks.com/pick/2011/02/25/markov-regime-switching-models-in-matlab/ +############################################################################### +bt.regime.detection.test <- function() +{ + #***************************************************************** + # Generate data as in the post + #****************************************************************** + bull1 = rnorm( 100, 0.10, 0.15 ) + bear = rnorm( 100, -0.01, 0.20 ) + bull2 = rnorm( 100, 0.10, 0.15 ) + true.states = c(rep(1,100),rep(2,100),rep(1,100)) + returns = c( bull1, bear, bull2 ) + + + # find regimes + load.packages('RHmm') + + y=returns + ResFit = HMMFit(y, nStates=2) + VitPath = viterbi(ResFit, y) + # HMMGraphicDiag(VitPath, ResFit, y) + # HMMPlotSerie(y, VitPath) + + #Forward-backward procedure, compute probabilities + fb = forwardBackward(ResFit, y) + + # Plot probabilities and implied states +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plot(VitPath$states, type='s', main='Implied States', xlab='', ylab='State') + + matplot(fb$Gamma, type='l', main='Smoothed Probabilities', ylab='Probability') + legend(x='topright', c('State1','State2'), fill=1:2, bty='n') +dev.off() + + + + # http://lipas.uwasa.fi/~bepa/Markov.pdf + # Expected duration of each regime (1/(1-pii)) + #1/(1-diag(ResFit$HMM$transMat)) + + + #***************************************************************** + # Add some data and see if the model is able to identify the regimes + #****************************************************************** + bear2 = rnorm( 100, -0.01, 0.20 ) + bull3 = rnorm( 100, 0.10, 0.10 ) + bear3 = rnorm( 100, -0.01, 0.25 ) + y = c( bull1, bear, bull2, bear2, bull3, bear3 ) + VitPath = viterbi(ResFit, y)$states + + + # map states: sometimes HMMFit function does not assign states consistently + # let's use following formula to rank states + # i.e. high risk, low returns => state 2 and low risk, high returns => state 1 + map = rank(sqrt(ResFit$HMM$distribution$var) - ResFit$HMM$distribution$mean) + VitPath = map[VitPath] + + #***************************************************************** + # Plot regimes + #****************************************************************** + load.packages('quantmod') + data = xts(y, as.Date(1:len(y))) + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:3) + plota.control$col.x.highlight = col.add.alpha(true.states+1, 150) + plota(data, type='h', plotX=F, x.highlight=T) + plota.legend('Returns + True Regimes') + plota(cumprod(1+data/100), type='l', plotX=F, x.highlight=T) + plota.legend('Equity + True Regimes') + + plota.control$col.x.highlight = col.add.alpha(VitPath+1, 150) + plota(data, type='h', x.highlight=T) + plota.legend('Returns + Detected Regimes') +dev.off() + +} + + +############################################################################### +# Regime Detection Pitfalls +############################################################################### +bt.regime.detection.pitfalls.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + data <- new.env() + getSymbols('SPY', src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + data$SPY = adjustOHLC(data$SPY, use.Adjusted=T) + bt.prep(data) + + #***************************************************************** + # Setup + #****************************************************************** + nperiods = nrow(data$prices) + + models = list() + + rets = ROC(Ad(data$SPY)) + rets[1] = 0 + + # use 10 years: 1993:2002 for training + in.sample.index = '1993::2002' + out.sample.index = '2003::' + + in.sample = rets[in.sample.index] + out.sample = rets[out.sample.index] + out.sample.first.date = nrow(in.sample) + 1 + + #***************************************************************** + # Fit Model + #****************************************************************** + load.packages('RHmm') + fit = HMMFit(in.sample, nStates=2) + + # find states + states.all = rets * NA + states.all[] = viterbi(fit, rets)$states + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = iif(states.all == 1, 0, 1) + data$weight[in.sample.index] = NA + models$states.all = bt.run.share(data) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + + #***************************************************************** + # Find problem - results are too good + #****************************************************************** + # The viterbi function need to see all data to compute the most likely sequence of states + # or forward/backward probabilities + # http://en.wikipedia.org/wiki/Forward%E2%80%93backward_algorithm + # http://en.wikipedia.org/wiki/Viterbi_algorithm + + # We can use expanding window to determine the states + states.win1 = states.all * NA + for(i in out.sample.first.date:nperiods) { + states.win1[i] = last(viterbi(fit, rets[1:i])$states) + if( i %% 100 == 0) cat(i, 'out of', nperiods, '\n') + } + + # Or we can refit model over expanding window as suggested in the + # Regime Shifts: Implications for Dynamic Strategies by M. Kritzman, S. Page, D. Turkington + # Out-of-Sample Analysis, page 8 + initPoint = fit$HMM + states.win2 = states.all * NA + for(i in out.sample.first.date:nperiods) { + fit2 = HMMFit(rets[2:i], nStates=2, control=list(init='USER', initPoint = initPoint)) + initPoint = fit2$HMM + states.win2[i] = last(viterbi(fit2, rets[2:i])$states) + if( i %% 100 == 0) cat(i, 'out of', nperiods, '\n') + } + + #***************************************************************** + # Plot States + #****************************************************************** +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:3) + col = col.add.alpha('white',210) + plota(states.all[out.sample.index], type='s', plotX=F) + plota.legend('Implied States based on all data', x='center', bty='o', bg=col, box.col=col,border=col,fill=col,cex=2) + plota(states.win1[out.sample.index], type='s') + plota.legend('Implied States based on rolling window', x='center', bty='o', bg=col, box.col=col,border=col,fill=col,cex=2) + plota(states.win2[out.sample.index], type='s') + plota.legend('Implied States based on rolling window(re-fit)', x='center', bty='o', bg=col, box.col=col,border=col,fill=col,cex=2) +dev.off() + + #***************************************************************** + # Code Strategies + #****************************************************************** + data$weight[] = NA + data$weight[] = iif(states.win1 == 1, 0, 1) + data$weight[in.sample.index] = NA + models$states.win1 = bt.run.share(data) + + data$weight[] = NA + data$weight[] = iif(states.win2 == 1, 0, 1) + data$weight[in.sample.index] = NA + models$states.win2 = bt.run.share(data) + + #***************************************************************** + # Create report + #****************************************************************** +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plotbt.custom.report.part1(models) +dev.off() + +} + + + + + +############################################################################### +# Financial Turbulence Index example based on the +# Skulls, Financial Turbulence, and Risk Management by M. Kritzman, Y. Li +# http://www.cfapubs.org/doi/abs/10.2469/faj.v66.n5.3 +# +# Timely Portfolio series of posts: +# http://timelyportfolio.blogspot.ca/2011/04/great-faj-article-on-statistical.html +# http://timelyportfolio.blogspot.ca/2011/04/great-faj-article-on-statistical_26.html +# http://timelyportfolio.blogspot.ca/2011/04/great-faj-article-on-statistical_6197.html +############################################################################### +bt.financial.turbulence.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + fx = get.G10() + nperiods = nrow(fx) + + #***************************************************************** + # Rolling estimate of the Financial Turbulence for G10 Currencies + #****************************************************************** + turbulence = fx[,1] * NA + ret = coredata(fx / mlag(fx) - 1) + + look.back = 252 + + for( i in (look.back+1) : nperiods ) { + temp = ret[(i - look.back + 1):(i-1), ] + + # measures turbulence for the current observation + turbulence[i] = mahalanobis(ret[i,], colMeans(temp), cov(temp)) + + if( i %% 200 == 0) cat(i, 'out of', nperiods, '\n') + } + + #***************************************************************** + # Plot 30 day average of the Financial Turbulence for G10 Currencies + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plota(EMA( turbulence, 30), type='l', + main='30 day average of the Financial Turbulence for G10 Currencies') +dev.off() + + +} + + + +############################################################################### +# Principal component analysis (PCA) +############################################################################### +bt.pca.test <- function() +{ + #***************************************************************** + # Find Sectors for each company in DOW 30 + #****************************************************************** + tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU') + tickers.desc = spl('ConsumerCyclicals,ConsumerStaples,Energy,Financials,HealthCare,Industrials,Materials,Technology,Utilities') + + sector.map = c() + for(i in 1:len(tickers)) { + sector.map = rbind(sector.map, + cbind(sector.spdr.components(tickers[i]), tickers.desc[i]) + ) + } + colnames(sector.map) = spl('ticker,sector') + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = dow.jones.components() + + sectors = factor(sector.map[ match(tickers, sector.map[,'ticker']), 'sector']) + names(sectors) = tickers + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '2000-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='keep.all', dates='2012') + + # re-order sectors, because bt.prep can change the order of tickers + sectors = sectors[data$symbolnames] + + # save data for later examples + save(data, tickers, sectors, file='bt.pca.test.Rdata') + #load(file='bt.pca.test.Rdata') + + #***************************************************************** + # Principal component analysis (PCA), for interesting discussion + # http://machine-master.blogspot.ca/2012/08/pca-or-polluting-your-clever-analysis.html + #****************************************************************** + prices = data$prices + ret = prices / mlag(prices) - 1 + + p = princomp(na.omit(ret)) + + loadings = p$loadings[] + p.variance.explained = p$sdev^2 / sum(p$sdev^2) + + # plot percentage of variance explained for each principal component +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + barplot(100*p.variance.explained, las=2, xlab='', ylab='% Variance Explained') +dev.off() + + #***************************************************************** + # 2-D Plot + #****************************************************************** + x = loadings[,1] + y = loadings[,2] + z = loadings[,3] + cols = as.double(sectors) + + # plot all companies loadings on the first and second principal components and highlight points according to the sector they belong +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plot(x, y, type='p', pch=20, col=cols, xlab='Comp.1', ylab='Comp.2') + text(x, y, data$symbolnames, col=cols, cex=.8, pos=4) + + legend('topright', cex=.8, legend = levels(sectors), fill = 1:nlevels(sectors), merge = F, bty = 'n') +dev.off() + + #***************************************************************** + # 3-D Plot, for good examples of 3D plots + # http://statmethods.wordpress.com/2012/01/30/getting-fancy-with-3-d-scatterplots/ + #****************************************************************** + load.packages('scatterplot3d') + + # plot all companies loadings on the first, second, and third principal components and highlight points according to the sector they belong +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + s3d = scatterplot3d(x, y, z, xlab='Comp.1', ylab='Comp.2', zlab='Comp.3', color=cols, pch = 20) + + s3d.coords = s3d$xyz.convert(x, y, z) + text(s3d.coords$x, s3d.coords$y, labels=data$symbolnames, col=cols, cex=.8, pos=4) + + legend('topleft', cex=.8, legend = levels(sectors), fill = 1:nlevels(sectors), merge = F, bty = 'n') +dev.off() + + #***************************************************************** + # Next steps + #***************************************************************** + # - demonstrate clustering based on the selected Principal components + # - using PCA for spread trading + # http://matlab-trading.blogspot.ca/2012/12/using-pca-for-spread-trading.html +} + +############################################################################### +# Link between svd and eigen +# https://stat.ethz.ch/pipermail/r-help/2001-September/014982.html +# http://r.789695.n4.nabble.com/eigen-and-svd-td2550210.html +# X is a matrix of de-mean returns, cov(X) = (t(x) %*% x) / T +# (svd) X = U D V' ## D are the singular values of X +# (eigen) X'X = V D^2 V' ## D^2 are the eigenvalues of X'X +# V is the same in both factorizations. +############################################################################### + + +############################################################################### +# The "Absorption Ratio" as defined in the "Principal Components as a Measure of Systemic Risk" +# by M. Kritzman,Y. Li, S. Page, R. Rigobon paper +# http://papers.ssrn.com/sol3/papers.cfm?abstract_id=1633027 +# +# The "Absorption Ratio" is define as the fraction of the total variance explained or absorbed by +# a finite set of eigenvectors. Let’s, for example, compute the "Absorption Ratio" using +# the first 3 eigenvectors. +# sum( p$sdev[1:3]^2 ) / sum( sd(na.omit(ret))^2 ) +############################################################################### + + + + +############################################################################### +# Clustering based on the selected Principal components +############################################################################### +bt.clustering.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # load data saved in the bt.pca.test() function + load(file='bt.pca.test.Rdata') + + #***************************************************************** + # Principal component analysis (PCA), for interesting discussion + # http://machine-master.blogspot.ca/2012/08/pca-or-polluting-your-clever-analysis.html + #****************************************************************** + prices = data$prices + ret = prices / mlag(prices) - 1 + + p = princomp(na.omit(ret)) + + loadings = p$loadings[] + + x = loadings[,1] + y = loadings[,2] + z = loadings[,3] + + #***************************************************************** + # Create clusters + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # create and plot clusters based on the first and second principal components + hc = hclust(dist(cbind(x,y)), method = 'ward') + plot(hc, axes=F,xlab='', ylab='',sub ='', main='Comp 1/2') + rect.hclust(hc, k=3, border='red') +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # create and plot clusters based on the first, second, and third principal components + hc = hclust(dist(cbind(x,y,z)), method = 'ward') + plot(hc, axes=F,xlab='', ylab='',sub ='', main='Comp 1/2/3') + rect.hclust(hc, k=3, border='red') +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + # create and plot clusters based on the correlation among companies + hc = hclust(as.dist(1-cor(na.omit(ret))), method = 'ward') + plot(hc, axes=F,xlab='', ylab='',sub ='', main='Correlation') + rect.hclust(hc, k=3, border='red') +dev.off() + + # cor(ret, method="pearson") + # cor(ret, method="kendall") + # cor(ret, method="spearman") + + +} + + +############################################################################### +# Using Principal component analysis (PCA) for spread trading +# http://matlab-trading.blogspot.ca/2012/12/using-pca-for-spread-trading.html +# http://www.r-bloggers.com/cointegration-r-irish-mortgage-debt-and-property-prices/ +############################################################################### +bt.pca.trading.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + # tickers = spl('XLE,USO,XES,XOP') + tickers = dow.jones.components() + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '2009-01-01', env = data, auto.assign = T) + bt.prep(data, align='remove.na') + + #***************************************************************** + # Principal component analysis (PCA), for interesting discussion + # http://machine-master.blogspot.ca/2012/08/pca-or-polluting-your-clever-analysis.html + #****************************************************************** + prices = last(data$prices, 1000) + n = len(tickers) + ret = prices / mlag(prices) - 1 + + p = princomp(na.omit(ret[1:250,])) + + loadings = p$loadings[] + + # look at the first 4 principal components + components = loadings[,1:4] + + # normalize all selected components to have total weight = 1 + components = components / rep.row(colSums(abs(components)),len(tickers)) + + # note that first component is market, and all components are orthogonal i.e. not correlated to market + market = ret[1:250,] %*% rep(1/n,n) + temp = cbind(market, -ret[1:250,] %*% components) + colnames(temp)[1] = 'Market' + + round(cor(temp, use='complete.obs',method='pearson'),1) + + # the variance of each component is decreasing + round(100*sd(temp,na.rm=T),1) + + #***************************************************************** + # examples of stationarity ( mean-reversion ) + # p.value - small => stationary + # p.value - large => not stationary + #***************************************************************** + library(tseries) + + layout(1:2) + temp = rnorm(100) + plot(temp, type='b', main=adf.test(temp)$p.value) + plot(cumsum(temp), type='b', main=adf.test(cumsum(temp))$p.value) + + #***************************************************************** + # Find stationary components, Augmented Dickey-Fuller test + # library(fUnitRoots) + # adfTest(as.numeric(equity[,1]), type="ct")@test$p.value + #****************************************************************** + library(tseries) + equity = bt.apply.matrix(1 + ifna(-ret %*% components,0), cumprod) + equity = make.xts(equity, index(prices)) + + # test for stationarity ( mean-reversion ) + adf.test(as.numeric(equity[,1]))$p.value + adf.test(as.numeric(equity[,2]))$p.value + adf.test(as.numeric(equity[,3]))$p.value + adf.test(as.numeric(equity[,4]))$p.value + + + + #***************************************************************** + # Plot securities and components + #***************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + # add Bollinger Bands + i.comp = 4 + bbands1 = BBands(rep.col(equity[,i.comp],3), n=200, sd=1) + bbands2 = BBands(rep.col(equity[,i.comp],3), n=200, sd=2) + temp = cbind(equity[,i.comp], bbands1[,'up'], bbands1[,'dn'], bbands1[,'mavg'], + bbands2[,'up'], bbands2[,'dn']) + colnames(temp) = spl('Comp. 4,1SD Up,1SD Down,200 SMA,2SD Up,2SD Down') + + plota.matplot(temp, main=paste(i.comp, 'Principal component')) + + barplot.with.labels(sort(components[,i.comp]), 'weights') +dev.off() + + + + # http://www.wekaleamstudios.co.uk/posts/seasonal-trend-decomposition-in-r/ + ts.sample = ts(as.numeric(equity[,i.comp]), frequency = 252) + fit.stl = stl(ts.sample, s.window="periodic") + plot(fit.stl) + + + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + plota.matplot(prices, plotX=F) + plota.matplot(equity) +dev.off() + +} + + + + +############################################################################### +# Details for the Visual of Current Major Market Clusters post by David Varadi +# http://cssanalytics.wordpress.com/2013/01/10/a-visual-of-current-major-market-clusters/ +############################################################################### +bt.cluster.visual.test <- function() +{ + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Create Clusters + #****************************************************************** + # compute returns + ret = data$prices / mlag(data$prices) - 1 + ret = na.omit(ret) + + # setup period and method to compute correlations + dates = '2012::2012' + method = 'pearson' # kendall, spearman + + correlation = cor(ret[dates], method = method) + dissimilarity = 1 - (correlation) + distance = as.dist(dissimilarity) + + # find 4 clusters + xy = cmdscale(distance) + fit = kmeans(xy, 4, iter.max=100, nstart=100) + + fit$cluster + + #***************************************************************** + # Create Plot + #****************************************************************** + load.packages('cluster') +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + clusplot(xy, fit$cluster, color=TRUE, shade=TRUE, labels=3, lines=0, plotchar=F, + main = paste('Major Market Clusters over', dates), sub='') +dev.off() + + +png(filename = 'plot2.png', width = 800, height = 800, units = 'px', pointsize = 12, bg = 'white') + layout(matrix(1:8,nc=2)) + par( mar = c(2, 2, 2, 2) ) + + for(icluster in 2:8) + clusplot(xy, kmeans(xy, icluster, iter.max=100, nstart=100)$cluster, color=TRUE, shade=F, + labels=3, lines=0, plotchar=F, main=icluster, sub='') +dev.off() + +} + + + +############################################################################### +# Optimal number of clusters +# http://en.wikipedia.org/wiki/Determining_the_number_of_clusters_in_a_data_set +# +# R and Data Mining: Examples and Case Studies by Y. Zhao, Chapter 6, Clustering +# http://cran.r-project.org/doc/contrib/Zhao_R_and_data_mining.pdf +# +# http://blog.echen.me/2011/03/19/counting-clusters/ +# +# Clustergram: visualization and diagnostics for cluster analysis (R code) +# http://www.r-statistics.com/tag/parallel-coordinates/ +# +# http://tr8dr.wordpress.com/2009/12/30/equity-clusters/ +# http://www.starklab.org/members/kazmar/2012/01/09/Optimal-number-of-clusters/ +# +# Morphometrics with R By Julien Claude +# http://books.google.ca/books?id=hA9ANHMPm14C&pg=PA123&lpg=PA123&dq=optimal+number+of+clusters+elbow+method&source=bl&ots=7P2bnNf5VL&sig=GEgiSL7CfOEU8gsalSsWHbDhGVc&hl=en&sa=X&ei=wmfwUIOtM_Ls2AW2k4FY&ved=0CFQQ6AEwBg#v=onepage&q=optimal%20number%20of%20clusters%20elbow%20method&f=false +# +# Choosing the number of clusters +# http://geomblog.blogspot.ca/2010/03/this-is-part-of-occasional-series-of.html +# http://geomblog.blogspot.ca/2010/03/choosing-number-of-clusters-ii.html +############################################################################### +bt.cluster.optimal.number.test <- function() +{ + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Create Clusters + #****************************************************************** + # compute returns + ret = data$prices / mlag(data$prices) - 1 + ret = na.omit(ret) + + # setup period and method to compute correlations + dates = '2012::2012' + method = 'pearson' # kendall, spearman + + correlation = cor(ret[dates], method = method) + dissimilarity = 1 - (correlation) + distance = as.dist(dissimilarity) + + # get first 2 pricipal componenets + xy = cmdscale(distance) + + #***************************************************************** + # Determine number of clusters + #****************************************************************** + n = ncol(data$prices) + n1 = ceiling(n*2/3) + + # percentage of variance explained by clusters + p.exp = rep(0,n1) + + # minimum correlation among all components in each cluster + min.cor = matrix(1,n1,n1) + + for (i in 2:n1) { + fit = kmeans(xy, centers=i, iter.max=100, nstart=100) + p.exp[i] = 1- fit$tot.withinss / fit$totss + + for (j in 1:i) { + index = fit$cluster == j + min.cor[i,j] = min(correlation[index,index]) + } + } + + # minimum number of clusters that explain at least 90% of variance + min(which(p.exp > 0.9)) + + # minimum number of clusters such that correlation among all components in each cluster is at least 40% + # will not always work + min(which(apply(min.cor[-1,],1,min,na.rm=T) > 0.4)) + 1 + + # number of clusters based on elbow method + find.maximum.distance.point(p.exp[-1]) + 1 + + + #***************************************************************** + # Create Plot + #****************************************************************** + load.packages('cluster') +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + fit = kmeans(xy, 4, iter.max=100, nstart=100) + clusplot(xy, fit$cluster, color=TRUE, shade=TRUE, labels=3, lines=0, plotchar=F, + main = paste('Major Market Clusters over', dates, ', 4 Clusters'), sub='') +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + fit = kmeans(xy, 5, iter.max=100, nstart=100) + clusplot(xy, fit$cluster, color=TRUE, shade=TRUE, labels=3, lines=0, plotchar=F, + main = paste('Major Market Clusters over', dates, ', 5 Clusters'), sub='') +dev.off() + + +# http://en.wikibooks.org/wiki/Data_Mining_Algorithms_In_R/Clustering/Expectation_Maximization_(EM) + load.packages('mclust') + fitBIC = mclustBIC(xy) + plot(fitBIC, legendArgs = list(x = "topleft")) + + fit <- summary(fitBIC, data = xy) + mclust2Dplot(data = xy, what = "density", identify = TRUE, parameters = fit$parameters, z = fit$z) + +} + + +############################################################################### +# Historical Optimal number of clusters +# based on the bt.cluster.optimal.number.test function +############################################################################### +bt.cluster.optimal.number.historical.test <- function() +{ + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT') + dates='2007:03::' + tickers = dow.jones.components() + dates='1970::' + + tickers = sp500.components()$tickers + dates='1994::' + + + + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='keep.all', dates=dates) + + + #***************************************************************** + # Use following 3 methods to determine number of clusters + # * Minimum number of clusters that explain at least 90% of variance + # cluster.group.kmeans.90 + # * Elbow method + # cluster.group.kmeans.elbow + # * Hierarchical clustering tree cut at 1/3 height + # cluster.group.hclust + #****************************************************************** + + # helper function to compute portfolio allocation additional stats + portfolio.allocation.custom.stats.clusters <- function(x,ia) { + return(list( + ncluster.90 = max(cluster.group.kmeans.90(ia)), + ncluster.elbow = max(cluster.group.kmeans.elbow(ia)), + ncluster.hclust = max(cluster.group.hclust(ia)) + )) + } + + + #***************************************************************** + # Compute # Clusters + #****************************************************************** + periodicity = 'weeks' + lookback.len = 250 + + obj = portfolio.allocation.helper(data$prices, + periodicity = periodicity, lookback.len = lookback.len, + min.risk.fns = list(EW=equal.weight.portfolio), + custom.stats.fn = portfolio.allocation.custom.stats.clusters + ) + + #***************************************************************** + # Create Reports + #****************************************************************** + temp = list(ncluster.90 = 'Kmeans 90% variance', + ncluster.elbow = 'Kmeans Elbow', + ncluster.hclust = 'Hierarchical clustering at 1/3 height') + + for(i in 1:len(temp)) { + hist.cluster = obj[[ names(temp)[i] ]] + title = temp[[ i ]] + +png(filename = paste('plot',i,'.png',sep=''), width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + plota(hist.cluster, type='l', col='gray', main=title) + plota.lines(SMA(hist.cluster,10), type='l', col='red',lwd=5) + plota.legend('Number of Clusters,10 period moving average', 'gray,red', x = 'bottomleft') +dev.off() + } + + + +} + + + + +############################################################################### +# Seasonality Examples +# Find January's with return > 4% +# http://www.avondaleam.com/2013/02/s-annual-performance-after-big-january.html +############################################################################### +bt.seasonality.january.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + price = getSymbols('^GSPC', src = 'yahoo', from = '1900-01-01', auto.assign = F) + price = Cl(to.monthly(price, indexAt='endof')) + + ret = price / mlag(price) - 1 + + #***************************************************************** + # http://www.avondaleam.com/2013/02/s-annual-performance-after-big-january.html + # Find January's with return > 4% + #****************************************************************** + index = which( date.month(index(ret)) == 1 & ret > 4/100 ) + + temp = c(coredata(ret),rep(0,12)) + out = cbind(ret[index], sapply(index, function(i) prod(1 + temp[i:(i+11)])-1)) + colnames(out) = spl('January,Year') + + #***************************************************************** + # Create Plot + #****************************************************************** + +png(filename = 'plot1.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + col=col.add.alpha(spl('black,gray'),200) + # https://stat.ethz.ch/pipermail/r-help/2002-October/025879.html + pos = barplot(100*out, border=NA, beside=T, axisnames = F, axes = FALSE, + col=col, main='Annual Return When S&P500 Rises More than 4% in January') + axis(1, at = colMeans(pos), labels = date.year(index(out)), las=2) + axis(2, las=1) + grid(NA, NULL) + abline(h= 100*mean(out$Year), col='red', lwd=2) + plota.legend(spl('January,Annual,Average'), c(col,'red')) + + + +dev.off() +png(filename = 'plot2.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # plot table + plot.table(round(100*as.matrix(out),1)) + +dev.off() + +} + + +############################################################################### +# Example of the Cluster Portfolio Allocation method +############################################################################### +bt.cluster.portfolio.allocation.test <- function() +{ + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Setup + #****************************************************************** + # compute returns + ret = data$prices / mlag(data$prices) - 1 + + # setup period + dates = '2012::2012' + ret = ret[dates] + + #***************************************************************** + # Create Portfolio + #****************************************************************** + fn.name = 'risk.parity.portfolio' + fn.name = 'equal.weight.portfolio' + + + names = c('risk.parity.portfolio', 'equal.weight.portfolio') + +for(fn.name in names) { + fn = match.fun(fn.name) + + # create input assumptions + ia = create.ia(ret) + + # compute allocation without cluster, for comparison + weight = fn(ia) + + # create clusters + group = cluster.group.kmeans.90(ia) + ngroups = max(group) + + weight0 = rep(NA, ia$n) + + # store returns for each cluster + hist.g = NA * ia$hist.returns[,1:ngroups] + + # compute weights within each group + for(g in 1:ngroups) { + if( sum(group == g) == 1 ) { + weight0[group == g] = 1 + hist.g[,g] = ia$hist.returns[, group == g, drop=F] + } else { + # create input assumptions for the assets in this cluster + ia.temp = create.ia(ia$hist.returns[, group == g, drop=F]) + + # compute allocation within cluster + w0 = fn(ia.temp) + + # set appropriate weights + weight0[group == g] = w0 + + # compute historical returns for this cluster + hist.g[,g] = ia.temp$hist.returns %*% w0 + } + } + + # create GROUP input assumptions + ia.g = create.ia(hist.g) + + # compute allocation across clusters + group.weights = fn(ia.g) + + # mutliply out group.weights by within group weights + for(g in 1:ngroups) + weight0[group == g] = weight0[group == g] * group.weights[g] + + #***************************************************************** + # Create Report + #****************************************************************** + load.packages('RColorBrewer') + col = colorRampPalette(brewer.pal(9,'Set1'))(ia$n) + +png(filename = paste(fn.name,'.plot.png',sep=''), width = 600, height = 800, units = 'px', pointsize = 12, bg = 'white') + + layout(matrix(1:2,nr=2,nc=1)) + par(mar = c(0,0,2,0)) + index = order(group) + pie(weight[index], labels = paste(colnames(ret), round(100*weight,1),'%')[index], col=col, main=fn.name) + pie(weight0[index], labels = paste(colnames(ret), round(100*weight0,1),'%')[index], col=col, main=paste('Cluster',fn.name)) + +dev.off() + + +} + + +} + + +############################################################################### +# Example of the Cluster Portfolio Allocation method +############################################################################### +bt.cluster.portfolio.allocation.test1 <- function() +{ + #***************************************************************** + # Load historical data for ETFs + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Code Strategies + #****************************************************************** + periodicity = 'months' + lookback.len = 250 + cluster.group = cluster.group.kmeans.90 + + obj = portfolio.allocation.helper(data$prices, + periodicity = periodicity, lookback.len = lookback.len, + min.risk.fns = list( + EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + + C.EW = distribute.weights(equal.weight.portfolio, cluster.group), + C.RP=distribute.weights(risk.parity.portfolio(), cluster.group) + ) + ) + + models = create.strategies(obj, data)$models + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() + + +} + + +############################################################################### +# Examples of 4 ways to load Historical Stock Data +############################################################################### +load.hist.stock.data <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = 'MMM, AA, CAT, KO, HPQ' + tickers = trim(spl(tickers)) + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + bt.prep(data, align='remove.na', fill.gaps = T) + + #***************************************************************** + # Create test data + #****************************************************************** + + # one file per ticker + for(ticker in tickers) + write.xts(data[[ticker]], paste0(ticker, '.csv'), format='%m/%d/%Y') + + # one file + write.xts(bt.apply(data, Ad), 'adjusted.csv', format='%m/%d/%Y') + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + stock.folder = '' + + data = env() + + # load historical data, select data load method + data.load.method = 'basic' + + if(data.load.method == 'basic') { + # quantmod - getSymbols + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + }else if(data.load.method == 'basic.local') { + # if you saved yahoo historical price files localy + getSymbols.sit(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T, stock.folder = stock.folder) + }else if(data.load.method == 'custom.local') { + # custom format historical price files + for(n in tickers) { + data[[n]] = read.xts(paste(stock.folder, n, '.csv', sep=''), format='%m/%d/%Y') + } + }else if(data.load.method == 'custom.one.file') { + # read from one csv file, column headers are tickers + filename = 'adjusted.csv' + all.data = read.xts(paste(stock.folder, filename, sep=''), format='%m/%d/%Y') + + # alternatively reading xls/xlsx + #load.packages('readxl') + #all.data = read.xts(read_excel('adjusted.xls')) + + for(n in names(all.data)) { + data[[n]] = all.data[,n] + colnames(data[[n]]) = 'Close' + data[[n]]$Adjusted = data[[n]]$Open = data[[n]]$High = data[[n]]$Low = data[[n]]$Close + } + } + + + + # prepare data for back test + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na') + + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = ncol(prices) + + models = list() + + # find period ends + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + obj = portfolio.allocation.helper(data$prices, period.ends=period.ends, lookback.len = 250, + min.risk.fns = list(EW=equal.weight.portfolio, + RP=risk.parity.portfolio(), + MV=min.var.portfolio, + MC=min.corr.portfolio) + ) + + models = create.strategies(obj, data)$models + + #***************************************************************** + # Create Report + #****************************************************************** + + strategy.performance.snapshoot(models, T) + +} + + +############################################################################### +# Predictive Indicators for Effective Trading Strategies By John Ehlers +# http://www.stockspotter.com/files/PredictiveIndicators.pdf +# http://dekalogblog.blogspot.ca/2013/07/my-nn-input-tweak.html +############################################################################### +john.ehlers.custom.strategy.plot <- function( + data, + models, + name, + main = name, + dates = '::', + layout = NULL # flag to idicate if layout is already set +) { + # John Ehlers Stochastic + stoch = roofing.stochastic.indicator(data$prices) + + + # highlight logic based on weight + weight = models[[name]]$weight[dates] + col = iif(weight > 0, 'green', iif(weight < 0, 'red', 'white')) + plota.control$col.x.highlight = col.add.alpha(col, 100) + highlight = T + + if(is.null(layout)) layout(1:2) + + plota(data$prices[dates], type='l', x.highlight = highlight, plotX = F, main=main) + plota.legend('Long,Short,Not Invested','green,red,white') + + plota(stoch[dates], type='l', x.highlight = highlight, plotX = F, ylim=c(0,1)) + col = col.add.alpha('red', 100) + abline(h = 0.2, col=col, lwd=3) + abline(h = 0.8, col=col, lwd=3) + plota.legend('John Ehlers Stochastic') +} + +john.ehlers.filter.test <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('DG') + data = new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + + models = list() + + # John Ehlers Stochastic + stoch = roofing.stochastic.indicator(prices) + + # Day Stochastic + stoch14 = bt.apply(data, function(x) stoch(HLC(x),14)[,'slowD']) + + #***************************************************************** + # Create plots + #****************************************************************** + dates = '2011:10::2012:9' + +jpeg(filename = 'plot1.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:3) + + plota(prices[dates], type='l', plotX=F) + plota.legend('DG') + + plota(stoch[dates], type='l', plotX=F) + abline(h = 0.2, col='red') + abline(h = 0.8, col='red') + plota.legend('John Ehlers Stochastic') + + plota(stoch14[dates], type='l') + abline(h = 0.2, col='red') + abline(h = 0.8, col='red') + plota.legend('Stochastic') +dev.off() + + #***************************************************************** + # Code Strategies + #***************************************************************** + # Figure 6: Conventional Wisdom is to Buy When the Indicator Crosses Above 20% and + # To Sell Short when the Indicator Crosses below 80% + data$weight[] = NA + data$weight[] = iif(cross.up(stoch, 0.2), 1, iif(cross.dn(stoch, 0.8), -1, NA)) + models$post = bt.run.share(data, clean.signal=T, trade.summary=T) + + data$weight[] = NA + data$weight[] = iif(cross.up(stoch, 0.2), 1, iif(cross.dn(stoch, 0.8), 0, NA)) + models$post.L = bt.run.share(data, clean.signal=T, trade.summary=T) + + data$weight[] = NA + data$weight[] = iif(cross.up(stoch, 0.2), 0, iif(cross.dn(stoch, 0.8), -1, NA)) + models$post.S = bt.run.share(data, clean.signal=T, trade.summary=T) + + # Figure 8: Predictive Indicators Enable You to Buy When the Indicator Crosses Below 20% and + # To Sell Short when the Indicator Crosses Above 80% + data$weight[] = NA + data$weight[] = iif(cross.dn(stoch, 0.2), 1, iif(cross.up(stoch, 0.8), -1, NA)) + models$pre = bt.run.share(data, clean.signal=T, trade.summary=T) + + data$weight[] = NA + data$weight[] = iif(cross.dn(stoch, 0.2), 1, iif(cross.up(stoch, 0.8), 0, NA)) + models$pre.L = bt.run.share(data, clean.signal=T, trade.summary=T) + + data$weight[] = NA + data$weight[] = iif(cross.dn(stoch, 0.2), 0, iif(cross.up(stoch, 0.8), -1, NA)) + models$pre.S = bt.run.share(data, clean.signal=T, trade.summary=T) + + #***************************************************************** + # Create Report + #****************************************************************** +jpeg(filename = 'plot2.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + +jpeg(filename = 'plot3.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:4, heights=c(2,1,2,1)) + john.ehlers.custom.strategy.plot(data, models, 'post.L', dates = '2013::', layout=T, + main = 'post.L: Buy When the Indicator Crosses Above 20% and Sell when the Indicator Crosses Below 80%') + john.ehlers.custom.strategy.plot(data, models, 'pre.L', dates = '2013::', layout=T, + main = 'pre.L: Buy When the Indicator Crosses Below 20% and Sell when the Indicator Crosses Above 80%') +dev.off() + + + return + + + + + + + + + + + + + # Not used + x = Cl(data$DG) + dates = '2013' + + layout(1:2) + plota(x[dates], type='l') + plota(my.stochastic.indicator(x)[dates], type='l') + abline(h = 0.2, col='red') + abline(h = 0.8, col='red') + + # Draw arrows corresponding buy/sell signals + trades = last(models$pre.L$trade.summary$trades,10) + position = sign(as.double(trades[,'weight'])) + + d = index4xts(prices[dates2index(prices, trades[,'entry.date'])]) + col = col.add.alpha('green', 50) + segments(d, rep(0.2,len(d)), d, rep(0.25,len(d)), col=col, lwd=5) + points(d, rep(0.25,len(d)), pch=24, col=col, bg=col, lwd=5) + + d = index4xts(prices[dates2index(prices, trades[,'exit.date'])]) + col = col.add.alpha('red', 50) + segments(d, rep(0.8,len(d)), d, rep(0.75,len(d)), col=col, lwd=5) + points(d, rep(0.75,len(d)), pch=25, col=col, bg=col, lwd=5) + + last(models$post$trade.summary$trades,10) +} + + +############################################################################### +# Calendar-based sector strategy +# +# http://www.cxoadvisory.com/2785/calendar-effects/kaeppels-sector-seasonality-strategy/ +# http://www.optionetics.com/marketdata/article.aspx?aid=13623 +# http://www.optionetics.com/marketdata/article.aspx?aid=18343 +# +# Buy Fidelity Select Technology (FSPTX) at the October close. +# Switch from FSPTX to Fidelity Select Energy (FSENX) at the January close. +# Switch from FSENX to cash at the May close. +# Switch from cash to Fidelity Select Gold (FSAGX) at the August close. +# Switch from FSAGX to cash at the September close. +# Repeat by switching from cash to FSPTX at the October close. +# +# Benchmarks +# - Vanguard 500 Index Investor (VFINX) +# - VFINX from the October close through the May close and cash otherwise (VFINX /Cash) +############################################################################### +bt.calendar.based.sector.strategy.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('FSPTX,FSENX,FSAGX,VFINX,BIL') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + + #-------------------------------- + # BIL 30-May-2007 + # load 3-Month Treasury Bill from FRED + TB3M = quantmod::getSymbols('DTB3', src='FRED', auto.assign = FALSE) + TB3M[] = ifna.prev(TB3M) + TB3M = processTBill(TB3M, timetomaturity = 1/4, 261) + #-------------------------------- + #proxies = list(BIL = data$BIL, TB3M = TB3M) + #proxy.test(proxies) + #proxy.overlay.plot(proxies) + #bt.start.dates(data) + + + # extend + data$BIL = extend.data(data$BIL, TB3M, scale=T) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + dates = data$dates + + models = list() + + # find period ends + period.ends = endpoints(prices, 'months') + period.ends = period.ends[period.ends > 0] + + months = date.month(dates[period.ends]) + + # control back-test + dates = '::' + # we can use zero lag becuase buy/sell dates are known in advance + do.lag = 0 + + #***************************************************************** + # Code Strategies + #****************************************************************** + # Vanguard 500 Index Investor (VFINX) + data$weight[] = NA + data$weight$VFINX[] = 1 + models$VFINX = bt.run.share(data, clean.signal=F, dates=dates, do.lag=do.lag) + + + # VFINX from the October[10] close through the May[5] close and cash otherwise (VFINX /Cash) + data$weight[] = NA + data$weight$VFINX[period.ends] = iif( months >= 10 | months <= 5, 1, 0) + data$weight$BIL[period.ends] = iif( !(months >= 10 | months <= 5), 1, 0) + models$VFINX_Cash = bt.run.share(data, clean.signal=F, dates=dates, do.lag=do.lag) + + + #***************************************************************** + # Calendar-based sector strategy + #****************************************************************** + # Buy Fidelity Select Technology (FSPTX) at the October close. + # Switch from FSPTX to Fidelity Select Energy (FSENX) at the January close. + # Switch from FSENX to cash at the May close. + # Switch from cash to Fidelity Select Gold (FSAGX) at the August close. + # Switch from FSAGX to cash at the September close. + # Repeat by switching from cash to FSPTX at the October close. + data$weight[] = NA + # Buy Fidelity Select Technology (FSPTX) at the October close. + data$weight$FSPTX[period.ends] = iif( months >= 10 | months < 1, 1, 0) + + # Switch from FSPTX to Fidelity Select Energy (FSENX) at the January close. + data$weight$FSENX[period.ends] = iif( months >= 1 & months < 5, 1, 0) + + # Switch from cash to Fidelity Select Gold (FSAGX) at the August close. + data$weight$FSAGX[period.ends] = iif( months >= 8 & months < 9, 1, 0) + + # Rest time in Cash + data$weight$BIL[period.ends] = 1 - rowSums(data$weight[period.ends], na.rm = T) + models$Sector = bt.run.share(data, clean.signal=F, dates=dates, do.lag=do.lag) + + #***************************************************************** + # Create Report + #****************************************************************** +jpeg(filename = 'plot1.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + + + plotbt.custom.report.part2(models$sector, trade.summary=T) + + + return + + + + + + + + + + + + + # Not used + data$weight[] = NA + # Buy Fidelity Select Technology (FSPTX) at the October close. + data$weight$FSPTX[period.ends] = iif( months >= 10 | months < 1, 1, 0) + + # Switch from FSPTX to Fidelity Select Energy (FSENX) at the January close. + data$weight$FSENX[period.ends] = iif( months >= 1 & months < 5, 1, 0) + + # Switch from FSENX to cash at the May close. + data$weight$BIL[period.ends] = iif( months >= 5 & months < 8, 1, data$weight$BIL[period.ends]) + + # Switch from cash to Fidelity Select Gold (FSAGX) at the August close. + data$weight$FSAGX[period.ends] = iif( months >= 8 & months < 9, 1, 0) + + # Switch from FSAGX to cash at the September close. + data$weight$BIL[period.ends] = iif( months >= 9 & months < 10, 1, data$weight$BIL[period.ends]) + + # since we have multiple entries to BIL, make sure to close them + data$weight$BIL[period.ends] = ifna(data$weight$BIL[period.ends], 0) + models$sector1 = bt.run.share(data, clean.signal=F) + +} + + + + +############################################################################### +# 7Twelve strategy +# +# http://www.7twelveportfolio.com/index.html +# http://www.mebanefaber.com/2013/08/01/the-712-allocation/ +# http://seekingalpha.com/article/228664-on-israelsens-7twelve-portfolio +############################################################################### +bt.7twelve.strategy.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl('VFINX,VIMSX,NAESX,VDMIX,VEIEX,VGSIX,FNARX,QRAAX,VBMFX,VIPSX,OIBAX,BIL') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + + #-------------------------------- + # BIL 30-May-2007 + # load 3-Month Treasury Bill from FRED + TB3M = quantmod::getSymbols('DTB3', src='FRED', auto.assign = FALSE) + TB3M[] = ifna.prev(TB3M) + TB3M = processTBill(TB3M, timetomaturity = 1/4, 261) + #-------------------------------- + # extend + data$BIL = extend.data(data$BIL, TB3M, scale=T) + + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + bt.prep(data, align='remove.na') + + #***************************************************************** + # Code Strategies + #****************************************************************** + models = list() + + # Vanguard 500 Index Investor (VFINX) + data$weight[] = NA + data$weight$VFINX[] = 1 + models$VFINX = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Code Strategies + #****************************************************************** + obj = portfolio.allocation.helper(data$prices, periodicity = 'years', + min.risk.fns = list(EW=equal.weight.portfolio) + ) + models$year = create.strategies(obj, data)$models$EW + + obj = portfolio.allocation.helper(data$prices, periodicity = 'quarters', + min.risk.fns = list(EW=equal.weight.portfolio) + ) + models$quarter = create.strategies(obj, data)$models$EW + + obj = portfolio.allocation.helper(data$prices, periodicity = 'months', + min.risk.fns = list(EW=equal.weight.portfolio) + ) + models$month = create.strategies(obj, data)$models$EW + + #***************************************************************** + # Create Report + #****************************************************************** +jpeg(filename = 'plot1.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + + + return + + + + + + + + + + + + + # Not used + #http://seekingalpha.com/article/228664-on-israelsens-7twelve-portfolio + map = list( + us.eq = list( + us.large = list('VFINX', 'VTI'), + us.mid = list('VIMSX', 'VO'), + us.small = list('NAESX', 'VB') + ), + non.us.eq = list( + devel.eq = list('VDMIX', 'EFA'), # VGTSX + em.eq = list('VEIEX', 'EEM') + ), + re = list( + re = list('VGSIX', 'RWX') + ), + res = list( + nat.res = list('FNARX', 'GLD'), + com = list('QRAAX', 'DBC') # CRSAX + ), + us.bond = list( + us.bond = list('VBMFX', 'AGG'), + tips = list('VIPSX', 'TIP') + ), + non.bond = list( + int.bond = list('OIBAX', 'BWX') # BEGBX + ), + cash = list( + cash = list('BIL', 'BIL') # VFISX + ) + ) + + funds = unlist(lapply(map, function(x) lapply(x, function(y) y[[1]]))) + etfs = unlist(lapply(map, function(x) lapply(x, function(y) y[[2]]))) + + paste(funds, collapse=',') +} + + + +############################################################################### +# One of the biggest challenges for a market neutral strategy is your shorts ripping when a market +# bottoms and all of the (expensive/low momentum) stocks rip straight up. That is why most factor +# based long short portfolios rarely survive – they are long and short the wrong things at market +# bottoms. +# +# Below is french fama momentum data that shows high and low momentum stocks back to the 1920s. +# Hi mo beats both the market and low mo. One would think a market neutral portfolio would be +# really low risk, but in reality it has massive drawdowns in the 1920s and 2009. +# +# One way to rectify this situation is to simply short less the more the market goes down. +# Kind of makes sense as you think about it and is probably just prudent risk management. +# +# So the modified strategy below starts 100% market neutral, and depending on the drawdown bucket +# will reduce the shorts all the way to zero once the market has declined by 50% +# (in 20% steps for every 10% decline in stocks). +# +# http://www.mebanefaber.com/2013/10/30/the-problem-with-market-neutral-and-an-answer/ +############################################################################### +bt.mebanefaber.modified.mn.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + data = new.env() + + # load historical market returns + temp = get.fama.french.data('F-F_Research_Data_Factors', periodicity = '',download = T, clean = T) + ret = temp[[1]]$Mkt.RF + temp[[1]]$RF + price = bt.apply.matrix(ret / 100, function(x) cumprod(1 + x)) + data$SPY = make.stock.xts( price ) + + # load historical momentum returns + temp = get.fama.french.data('10_Portfolios_Prior_12_2', periodicity = '',download = T, clean = T) + ret = temp[[1]] + price = bt.apply.matrix(ret / 100, function(x) cumprod(1 + x)) + data$HI.MO = make.stock.xts( price$High ) + data$LO.MO = make.stock.xts( price$Low ) + + # align dates + bt.prep(data, align='remove.na') + + #***************************************************************** + # Create Plots + #***************************************************************** + # plota.matplot(data$prices, log = 'y') + + #***************************************************************** + # Code Strategies + #***************************************************************** + models = list() + + data$weight[] = NA + data$weight$SPY[] = 1 + models$SPY = bt.run.share(data, clean.signal=T) + + data$weight[] = NA + data$weight$HI.MO[] = 1 + models$HI.MO = bt.run.share(data, clean.signal=T) + + data$weight[] = NA + data$weight$LO.MO[] = 1 + models$LO.MO = bt.run.share(data, clean.signal=T) + + data$weight[] = NA + data$weight$HI.MO[] = 1 + data$weight$LO.MO[] = -1 + models$MKT.NEUTRAL = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Modified MN + # The modified strategy below starts 100% market neutral, and depending on the drawdown bucket + # will reduce the shorts all the way to zero once the market has declined by 50% + # (in 20% steps for every 10% decline in stocks) + #***************************************************************** + market.drawdown = -100 * compute.drawdown(data$prices$SPY) + market.drawdown.10.step = 10 * floor(market.drawdown / 10) + short.allocation = 100 - market.drawdown.10.step * 2 + short.allocation[ short.allocation < 0 ] = 0 + + # cbind(market.drawdown, market.drawdown.10.step, short.allocation) + + data$weight[] = NA + data$weight$HI.MO[] = 1 + data$weight$LO.MO[] = -1 * short.allocation / 100 + models$Modified.MN = bt.run.share(data, clean.signal=F) + + #***************************************************************** + # Create Report + #***************************************************************** +jpeg(filename = 'plot1.jpg', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + + +} + +############################################################################### +# http://www.mebanefaber.com/2013/12/04/square-root-of-f-squared/ +############################################################################### +bt.mebanefaber.f.squared.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + data = new.env() + + download = T + + # load historical market returns + temp = get.fama.french.data('F-F_Research_Data_Factors', periodicity = '',download = download, clean = T) + ret = cbind(temp[[1]]$Mkt.RF + temp[[1]]$RF, temp[[1]]$RF) + price = bt.apply.matrix(ret / 100, function(x) cumprod(1 + x)) + data$SPY = make.stock.xts( price$Mkt.RF ) + data$SHY = make.stock.xts( price$RF ) + + # load historical momentum returns + temp = get.fama.french.data('10_Industry_Portfolios', periodicity = '',download = download, clean = T) + ret = temp[[1]] + price = bt.apply.matrix(ret[,1:9] / 100, function(x) cumprod(1 + x)) + for(n in names(price)) data[[n]] = make.stock.xts( price[,n] ) + + # align dates + data$symbolnames = c(names(price), 'SHY', 'SPY') + bt.prep(data, align='remove.na', dates='2000::') + + bt.dates = '2001:04::' + + #***************************************************************** + # Setup + #****************************************************************** + prices = data$prices + n = ncol(data$prices) + + models = list() + + #***************************************************************** + # Benchmark Strategies + #****************************************************************** + data$weight[] = NA + data$weight$SPY[1] = 1 + models$SPY = bt.run.share(data, clean.signal=F, dates=bt.dates) + + weight = prices + weight$SPY = NA + weight$SHY = NA + + data$weight[] = NA + data$weight[] = ntop(weight[], n) + models$EW = bt.run.share(data, clean.signal=F, dates=bt.dates) + + #***************************************************************** + # Code Strategies + # http://www.mebanefaber.com/2013/12/04/square-root-of-f-squared/ + #****************************************************************** + sma = bt.apply.matrix(prices, SMA, 10) + + # create position score + position.score = sma + position.score[ prices < sma ] = NA + position.score$SHY = NA + position.score$SPY = NA + + # equal weight allocation + weight = ntop(position.score[], n) + + # number of invested funds + n.selected = rowSums(weight != 0) + + # cash logic + weight$SHY[n.selected == 0,] = 1 + + weight[n.selected == 1,] = 0.25 * weight[n.selected == 1,] + weight$SHY[n.selected == 1,] = 0.75 + + weight[n.selected == 2,] = 0.5 * weight[n.selected == 2,] + weight$SHY[n.selected == 2,] = 0.5 + + weight[n.selected == 3,] = 0.75 * weight[n.selected == 3,] + weight$SHY[n.selected == 3,] = 0.25 + + # cbind(round(100*weight,0), n.selected) + + data$weight[] = NA + data$weight[] = weight + models$strategy1 = bt.run.share(data, clean.signal=F, dates=bt.dates) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, one.page = T) +dev.off() + + +} + + + + +############################################################################### +# Test for Averaged Input Assumptions and Averaged Momentum created by pierre.c.chretien +############################################################################### +bt.averaged.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # 10 funds + tickers = spl('Us.Eq = VTI + VTSMX, + Eurpoe.Eq = IEV + FIEUX, + Japan.Eq = EWJ + FJPNX, + Emer.Eq = EEM + VEIEX, + Re = RWX + VNQ + VGSIX, + Com = DBC + QRAAX, + Gold = GLD + SCGDX, + Long.Tr = TLT + VUSTX, + Mid.Tr = IEF + VFITX, + Short.Tr = SHY + VFISX') + + start.date = 1998 + + dates = paste(start.date,'::',sep='') + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, set.symbolnames = T, auto.assign = T) + #bt.start.dates(data) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', dates=paste(start.date-2,':12::',sep=''), fill.gaps = T) + + #***************************************************************** + # Setup + #****************************************************************** + prices = data$prices + n = ncol(prices) + nperiods = nrow(prices) + + + periodicity = 'quarters' + periodicity = 'months' + period.ends = endpoints(prices, periodicity) + period.ends = period.ends[period.ends > 0] + + max.product.exposure = 0.6 + + #***************************************************************** + # Input Assumptions + #****************************************************************** + lookback.len = 40 + create.ia.fn = create.ia + + # input assumptions are averaged on 20, 40, 60 days using 1 day lag + ia.array = c(20,40,60) + avg.create.ia.fn = create.ia.averaged(ia.array, 1) + + #***************************************************************** + # Momentum + #****************************************************************** + universe = prices>0 + + mom.lookback.len = 120 + momentum = prices / mlag(prices, mom.lookback.len) - 1 + mom.universe = ifna(momentum > 0, F) + + # momentum is averaged on 20,60,120,250 days using 3 day lag + mom.array = c(20,60,120,250) + avg.momentum = momentum.averaged(prices, mom.array, 3) + avgmom.universe = ifna(avg.momentum > 0, F) + + #***************************************************************** + # Algos + #****************************************************************** + min.risk.fns = list( + EW = equal.weight.portfolio, + MV = min.var.portfolio, + MCE = min.corr.excel.portfolio, + + MV.RSO = rso.portfolio(min.var.portfolio, 3, 100, const.ub = max.product.exposure), + MCE.RSO = rso.portfolio(min.corr.excel.portfolio, 3, 100, const.ub = max.product.exposure) + ) + + #***************************************************************** + # Code Strategies + #****************************************************************** +make.strategy.custom <- function(name, create.ia.fn, lookback.len, universe, env) { + obj = portfolio.allocation.helper(data$prices, + periodicity = periodicity, + universe = universe, + lookback.len = lookback.len, + create.ia.fn = create.ia.fn, + const.ub = max.product.exposure, + min.risk.fns = min.risk.fns, + adjust2positive.definite = F + ) + env[[name]] = create.strategies(obj, data, prefix=paste(name,'.',sep=''))$models +} + + + models <- new.env() + make.strategy.custom('ia.none' , create.ia.fn , lookback.len, universe , models) + make.strategy.custom('ia.mom' , create.ia.fn , lookback.len, mom.universe , models) + make.strategy.custom('ia.avg_mom' , create.ia.fn , lookback.len, avgmom.universe, models) + make.strategy.custom('avg_ia.none' , avg.create.ia.fn, 252 , universe , models) + make.strategy.custom('avg_ia.mom' , avg.create.ia.fn, 252 , mom.universe , models) + make.strategy.custom('avg_ia.avg_mom' , avg.create.ia.fn, 252 , avgmom.universe, models) + + #***************************************************************** + # Create Report + #***************************************************************** +strategy.snapshot.custom <- function(models, n = 0, title = NULL) { + if (n > 0) + models = models[ as.vector(matrix(1:len(models),ncol=n, byrow=T)) ] + + layout(1:3) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = title) + mtext('Cumulative Performance', side = 2, line = 1) + plotbt.strategy.sidebyside(models) + barplot.with.labels(sapply(models, compute.turnover, data), 'Average Annual Portfolio Turnover', T) +} + +#pdf(file = paste('M.Paramless.Portfolio.Tests.pdf',sep=''), width=8.5, height=11) + +png(filename = 'plot1.png', width = 900, height = 900, units = 'px', pointsize = 12, bg = 'white') + # basic vs basic + momentum => momentum filter has better results + models.final = c(models$ia.none, models$ia.mom) + strategy.snapshot.custom(models.final, len(min.risk.fns), 'Momentum Filter') +dev.off() + +png(filename = 'plot2.png', width = 900, height = 900, units = 'px', pointsize = 12, bg = 'white') + # basic vs basic + avg ia => averaged ia reduce turnover + models.final = c(models$ia.none, models$avg_ia.none) + strategy.snapshot.custom(models.final, len(min.risk.fns), 'Averaged Input Assumptions') +dev.off() + +png(filename = 'plot3.png', width = 900, height = 900, units = 'px', pointsize = 12, bg = 'white') + # basic + momentum vs basic + avg.momentum => mixed results for averaged momentum + models.final = c(models$ia.mom, models$ia.avg_mom) + strategy.snapshot.custom(models.final, len(min.risk.fns), 'Averaged Momentum') +dev.off() + +png(filename = 'plot4.png', width = 900, height = 900, units = 'px', pointsize = 12, bg = 'white') + # basic + momentum vs avg ia + avg.momentum + models.final = c(models$ia.mom, models$avg_ia.avg_mom) + strategy.snapshot.custom(models.final, len(min.risk.fns), 'Averaged vs Base') +dev.off() + + + +} + + +############################################################################### +# Probabilistic Momentum +# http://cssanalytics.wordpress.com/2014/01/28/are-simple-momentum-strategies-too-dumb-introducing-probabilistic-momentum/ +# http://cssanalytics.wordpress.com/2014/02/12/probabilistic-momentum-spreadsheet/ +############################################################################### +bt.probabilistic.momentum.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('EQ=QQQ,FI=SHY') + tickers = spl('EQ=SPY,FI=TLT') + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', dates='::') + + + #***************************************************************** + # Setup + #****************************************************************** + lookback.len = 120 + lookback.len = 60 + confidence.level = 60/100 + + + prices = data$prices + ret = prices / mlag(prices) - 1 + #ret = log(prices / mlag(prices)) + + models = list() + + #***************************************************************** + # Simple Momentum + #****************************************************************** + momentum = prices / mlag(prices, lookback.len) + data$weight[] = NA + data$weight$EQ[] = momentum$EQ > momentum$FI + data$weight$FI[] = momentum$EQ <= momentum$FI + models$Simple = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Probabilistic Momentum + Confidence Level + # http://cssanalytics.wordpress.com/2014/01/28/are-simple-momentum-strategies-too-dumb-introducing-probabilistic-momentum/ + # http://cssanalytics.wordpress.com/2014/02/12/probabilistic-momentum-spreadsheet/ + #****************************************************************** + ir = sqrt(lookback.len) * runMean(ret$EQ - ret$FI, lookback.len) / runSD(ret$EQ - ret$FI, lookback.len) + momentum.p = pt(ir, lookback.len - 1) + + data$weight[] = NA + data$weight$EQ[] = iif(cross.up(momentum.p, confidence.level), 1, iif(cross.dn(momentum.p, (1 - confidence.level)), 0,NA)) + data$weight$FI[] = iif(cross.dn(momentum.p, (1 - confidence.level)), 1, iif(cross.up(momentum.p, confidence.level), 0,NA)) + models$Probabilistic = bt.run.share(data, clean.signal=T) + + data$weight[] = NA + data$weight$EQ[] = iif(cross.up(momentum.p, confidence.level), 1, iif(cross.up(momentum.p, (1 - confidence.level)), 0,NA)) + data$weight$FI[] = iif(cross.dn(momentum.p, (1 - confidence.level)), 1, iif(cross.up(momentum.p, confidence.level), 0,NA)) + models$Probabilistic.Leverage = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + + #***************************************************************** + # Visualize Signal + #****************************************************************** + cols = spl('steelblue,steelblue1') + prices = scale.one(data$prices) + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:3) + + plota(prices$EQ, type='l', ylim=range(prices), plotX=F, col=cols[1], lwd=2) + plota.lines(prices$FI, type='l', plotX=F, col=cols[2], lwd=2) + plota.legend('EQ,FI',cols,as.list(prices)) + + highlight = models$Probabilistic$weight$EQ > 0 + plota.control$col.x.highlight = iif(highlight, cols[1], cols[2]) + plota(models$Probabilistic$equity, type='l', plotX=F, x.highlight = highlight | T) + plota.legend('Probabilistic,EQ,FI',c('black',cols)) + + highlight = models$Simple$weight$EQ > 0 + plota.control$col.x.highlight = iif(highlight, cols[1], cols[2]) + plota(models$Simple$equity, type='l', plotX=T, x.highlight = highlight | T) + plota.legend('Simple,EQ,FI',c('black',cols)) +dev.off() + + #***************************************************************** + # Create PDF Report + #****************************************************************** +pdf(file = 'Probabilistic.Momentum.Report.pdf', width=8.5, height=11) + strategy.performance.snapshoot(bt.trim(models), data = data) +dev.off() + + + + + + + #***************************************************************** + # 60 / 40 Idea + #****************************************************************** + + #***************************************************************** + # Simple Momentum + #****************************************************************** + momentum = prices / mlag(prices, lookback.len) + + signal = momentum$EQ > momentum$FI + + data$weight[] = NA + data$weight$EQ[] = iif(signal, 60, 40) / 100 + data$weight$FI[] = iif(signal, 40, 60) / 100 + models$Simple = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Probabilistic Momentum + #****************************************************************** + ir = sqrt(lookback.len) * runMean(ret$EQ - ret$FI, lookback.len) / runSD(ret$EQ - ret$FI, lookback.len) + momentum.p = pt(ir, lookback.len - 1) + + signal = iif(cross.up(momentum.p, confidence.level), 1, iif(cross.dn(momentum.p, (1 - confidence.level)), 0,NA)) + signal = ifna.prev(signal) == 1 + + data$weight[] = NA + data$weight$EQ[] = iif(signal, 60, 40) / 100 + data$weight$FI[] = iif(signal, 40, 60) / 100 + models$Probabilistic = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + strategy.performance.snapshoot(models, T) +dev.off() + +} + + +############################################################################### +# Testing Intraday data from http://thebonnotgang.com/tbg/historical-data/ +############################################################################### +# helper function to load and optionally clean data from thebonnotgang +bt.load.thebonnotgang.data <- function(Symbols, folder, silent=F, clean=T) +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + # data from http://thebonnotgang.com/tbg/historical-data/ + + # http://stackoverflow.com/questions/14440661/dec-argument-in-data-tablefread + Sys.localeconv()["decimal_point"] + Sys.setlocale("LC_NUMERIC", "French_France.1252") + + data <- new.env() + for(s in spl(Symbols)) + data[[s]] = read.xts(paste0(folder,s,'_1m.csv'), + sep = ';', date.column = 3, format='%Y-%m-%d %H:%M:%S', index.class = c("POSIXlt", "POSIXt")) + +if(!clean)return(data) + + #***************************************************************** + # Clean data + #****************************************************************** + for(i in ls(data)) { + # remove dates with gaps over 4 min + dates = index(data[[i]]) + dates.number = as.double(dates) + factor = format(dates, '%Y%m%d') + gap = tapply(dates.number, factor, function(x) max(diff(x))) + ok.index = names(gap[gap <= 4*60]) + data[[i]] = data[[i]][ !is.na(match(factor, ok.index)) ] + +if(!silent)cat(i, 'removing due to gaps:', setdiff(factor,ok.index), '\n\n') + + + # remove dates with over 7 hours or less than 2 hours of trading + dates = index(data[[i]]) + dates.number = as.double(dates) + factor = format(dates, '%Y%m%d') + nperiods = len(dates) + day.change = which(diff(dates.number) > 5 * 60) + day.start = c(1, day.change + 1) + day.end = c(day.change, nperiods) + ok.index = which(dates.number[day.end] - dates.number[day.start] < 7*60*60 & + dates.number[day.end] - dates.number[day.start] > 2*60*60) + ok.index = factor[day.start][ok.index] + data[[i]] = data[[i]][ !is.na(match(factor, ok.index)) ] + +if(!silent)cat(i, 'removing due to trading hours:', setdiff(factor,ok.index), '\n\n') + + # align all trading to start at 9:31 + dates = index(data[[i]]) + dates.number = as.double(dates) + factor = format(dates, '%Y%m%d') + nperiods = len(dates) + day.change = which(diff(dates.number) > 5 * 60) + day.start = c(1, day.change + 1) + day.end = c(day.change, nperiods) + + add.hours = as.double(format(dates[day.start], '%H')) - 9 + for(h in which(add.hours != 0)) + dates[day.start[h]:day.end[h]] = dates[day.start[h]:day.end[h]] - add.hours[h]*60*60 + index(data[[i]]) = dates + } + + + ok.index = unique(format(index(data[[ls(data)[1]]]), '%Y%m%d')) + for(i in ls(data)) { + dates = index(data[[i]]) + factor = format(dates, '%Y%m%d') + ok.index = intersect(ok.index, unique(factor)) + } + + # remove days that are not present in both time series + for(i in ls(data)) { + dates = index(data[[i]]) + factor = format(dates, '%Y%m%d') + data[[i]] = data[[i]][ !is.na(match(factor, ok.index)) ] + +if(!silent)cat(i, 'removing due to not being common:', setdiff(factor,ok.index), '\n\n') + } + + #***************************************************************** + # Round to the next minute + #****************************************************************** + for(i in ls(data)) + index(data[[i]]) = as.POSIXct(format(index(data[[i]]) + 60, '%Y-%m-%d %H:%M'), tz = Sys.getenv('TZ'), format = '%Y-%m-%d %H:%M') + + data +} + +# helper function to extract index of day start / end in intraday data +bt.intraday.day <- function(dates) +{ + dates.number = as.double(dates) + + nperiods = len(dates) + + day.change = which(diff(dates.number) > 5 * 60) + list( + day.start = c(1, day.change + 1), + day.end = c(day.change, nperiods) + ) +} + + + +bt.intraday.thebonnotgang.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # data from http://thebonnotgang.com/tbg/historical-data/ + # please save SPY and GLD 1 min data at the given path + spath = 'c:/Desktop/' + # http://stackoverflow.com/questions/14440661/dec-argument-in-data-tablefread + Sys.localeconv()["decimal_point"] + Sys.setlocale("LC_NUMERIC", "French_France.1252") + + data <- new.env() + data$SPY = read.xts(paste0(spath,'SPY_1m.csv'), + sep = ';', date.column = 3, format='%Y-%m-%d %H:%M:%S', index.class = c("POSIXlt", "POSIXt")) + + data$GLD = read.xts(paste0(spath,'GLD_1m.csv'), + sep = ';', date.column = 3, format='%Y-%m-%d %H:%M:%S', index.class = c("POSIXlt", "POSIXt")) + + #***************************************************************** + # Create plot for Nov 1, 2012 and 2013 + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(c(1,1,2)) + plota(data$SPY['2012:11:01'], type='candle', main='SPY on Nov 1st, 2012', plotX = F) + plota(plota.scale.volume(data$SPY['2012:11:01']), type = 'volume') + +dev.off() +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(c(1,1,2)) + plota(data$SPY['2013:11:01'], type='candle', main='SPY on Nov 1st, 2013', plotX = F) + plota(plota.scale.volume(data$SPY['2013:11:01']), type = 'volume') + +dev.off() + + #***************************************************************** + # Data check for Gaps in the series Intraday + #****************************************************************** + i = 'GLD' + dates = index(data[[i]]) + factor = format(dates, '%Y%m%d') + gap = tapply(dates, factor, function(x) max(diff(x))) + + gap[names(gap[gap > 4*60])] + data[[i]]['2013:02:19'] + + i = 'SPY' + dates = index(data[[i]]) + factor = format(dates, '%Y%m%d') + gap = tapply(dates, factor, function(x) max(diff(x))) + + gap[names(gap[gap > 4*60])] + data[[i]]['2013:02:19'] + + #***************************************************************** + # Data check : compare with daily + #****************************************************************** + data.daily <- new.env() + quantmod::getSymbols(spl('SPY,GLD'), src = 'yahoo', from = '1970-01-01', env = data.daily, auto.assign = T) + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + layout(1) + plota(data$GLD, type='l', col='blue', main='GLD') + plota.lines(data.daily$GLD, type='l', col='red') + plota.legend('Intraday,Daily', 'blue,red') + +dev.off() +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plota(data$SPY, type='l', col='blue', main='SPY') + plota.lines(data.daily$SPY, type='l', col='red') + plota.legend('Intraday,Daily', 'blue,red') + +dev.off() + + #***************************************************************** + # Round to the next minute + #****************************************************************** + GLD.sample = data$GLD['2012:07:10::2012:07:10 09:35'] + SPY.sample= data$SPY['2012:07:10::2012:07:10 09:35'] + + merge( Cl(GLD.sample), Cl(SPY.sample) ) + + # round to the next minute + index(GLD.sample) = as.POSIXct(format(index(GLD.sample) + 60, '%Y-%m-%d %H:%M'), format = '%Y-%m-%d %H:%M') + index(SPY.sample) = as.POSIXct(format(index(SPY.sample) + 60, '%Y-%m-%d %H:%M'), format = '%Y-%m-%d %H:%M') + + merge( Cl(GLD.sample), Cl(SPY.sample) ) + + #***************************************************************** + # Load historical data + #****************************************************************** + data = bt.load.thebonnotgang.data('SPY,GLD', spath) + #plota(data$SPY['2013:10:11'], type='candle') + bt.prep(data, align='keep.all', fill.gaps = T) + + prices = data$prices + dates = data$dates + nperiods = nrow(prices) + + models = list() + + #***************************************************************** + # Benchmarks + #****************************************************************** + data$weight[] = NA + data$weight$SPY = 1 + models$SPY = bt.run.share(data, clean.signal=F) + + data$weight[] = NA + data$weight$GLD = 1 + models$GLD = bt.run.share(data, clean.signal=F) + + data$weight[] = NA + data$weight$SPY = 0.5 + data$weight$GLD = 0.5 + models$EW = bt.run.share(data, clean.signal=F) + + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() + +} + +############################################################################### +# Strategy Testing Intraday data from http://thebonnotgang.com/tbg/historical-data/ +############################################################################### +bt.strategy.intraday.thebonnotgang.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # data from http://thebonnotgang.com/tbg/historical-data/ + # please save SPY and GLD 1 min data at the given path + spath = 'c:/Desktop/' +spath = 'c:/Documents and Settings/mkapler/Desktop/' +spath = 'c:/Desktop/1car/1shaun/' + data = bt.load.thebonnotgang.data('SPY,GLD', spath) + + data1 <- new.env() + data1$FI = data$GLD + data1$EQ = data$SPY + data = data1 + bt.prep(data, align='keep.all', fill.gaps = T) + + + lookback.len = 120 + confidence.level = 60/100 + + prices = data$prices + ret = prices / mlag(prices) - 1 + + models = list() + + #***************************************************************** + # Simple Momentum + #****************************************************************** + momentum = prices / mlag(prices, lookback.len) + data$weight[] = NA + data$weight$EQ[] = momentum$EQ > momentum$FI + data$weight$FI[] = momentum$EQ <= momentum$FI + models$Simple = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Probabilistic Momentum + Confidence Level + # http://cssanalytics.wordpress.com/2014/01/28/are-simple-momentum-strategies-too-dumb-introducing-probabilistic-momentum/ + # http://cssanalytics.wordpress.com/2014/02/12/probabilistic-momentum-spreadsheet/ + #****************************************************************** + ir = sqrt(lookback.len) * runMean(ret$EQ - ret$FI, lookback.len) / runSD(ret$EQ - ret$FI, lookback.len) + momentum.p = pt(ir, lookback.len - 1) + + data$weight[] = NA + data$weight$EQ[] = iif(cross.up(momentum.p, confidence.level), 1, iif(cross.dn(momentum.p, (1 - confidence.level)), 0,NA)) + data$weight$FI[] = iif(cross.dn(momentum.p, (1 - confidence.level)), 1, iif(cross.up(momentum.p, confidence.level), 0,NA)) + models$Probabilistic = bt.run.share(data, clean.signal=T) + + data$weight[] = NA + data$weight$EQ[] = iif(cross.up(momentum.p, confidence.level), 1, iif(cross.up(momentum.p, (1 - confidence.level)), 0,NA)) + data$weight$FI[] = iif(cross.dn(momentum.p, (1 - confidence.level)), 1, iif(cross.up(momentum.p, confidence.level), 0,NA)) + models$Probabilistic.Leverage = bt.run.share(data, clean.signal=T) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() + + #***************************************************************** + # Hourly Performance + #****************************************************************** + strategy.name = 'Probabilistic.Leverage' + ret = models[[strategy.name]]$ret + ret.number = 100*as.double(ret) + + dates = index(ret) + factor = format(dates, '%H') + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + par(mar=c(4,4,1,1)) + boxplot(tapply(ret.number, factor, function(x) x),outline=T, main=paste(strategy.name, 'Distribution of Returns'), las=1) + barplot(tapply(ret.number, factor, function(x) sum(x)), main=paste(strategy.name, 'P&L by Hour'), las=1) +dev.off() + + #***************************************************************** + # Hourly Performance: Remove first return of the day (i.e. overnight) + #****************************************************************** + day.stat = bt.intraday.day(dates) + ret.number[day.stat$day.start] = 0 + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + layout(1:2) + par(mar=c(4,4,1,1)) + boxplot(tapply(ret.number, factor, function(x) x),outline=T, main=paste(strategy.name, 'Distribution of Returns'), las=1) + barplot(tapply(ret.number, factor, function(x) sum(x)), main=paste(strategy.name, 'P&L by Hour'), las=1) +dev.off() + +} + + +bt.pair.strategy.intraday.thebonnotgang.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # data from http://thebonnotgang.com/tbg/historical-data/ + # please save SPY and GLD 1 min data at the given path + spath = 'c:/Desktop/' +spath = 'c:/Documents and Settings/mkapler/Desktop/' + data = bt.load.thebonnotgang.data('USO,GLD', spath) + bt.prep(data, align='keep.all', fill.gaps = T) + + prices = data$prices + nperiods = nrow(prices) + dates = data$dates + day.stat = bt.intraday.day(dates) + + models = list() + + #***************************************************************** + # Construct signal + # http://systematicedge.wordpress.com/2014/02/26/energy-stat-arb/ + #****************************************************************** + lookback = 120 + + stoch = (prices - bt.apply.matrix(prices, runMin, lookback)) / (bt.apply.matrix(prices, runMax, lookback) - bt.apply.matrix(prices, runMin, lookback)) + stoch = bt.apply.matrix(stoch, ifna.prev) + + stat = stoch$USO - stoch$GLD + stat = (stat - runMean(stat,20))/runSD(stat,20) + + data$weight[] = NA + data$weight$USO = iif(stat >= 2, -1, iif(stat <= -2, 1, 0)) + data$weight$GLD = iif(stat <= -2, -1, iif(stat >= 2, 1, 0)) + + data$weight[day.stat$day.end,] = 0 + data$weight[as.vector(0:(lookback-1) + rep.row(day.stat$day.start,lookback)),] = 0 + + models$P = bt.run.share(data, clean.signal=T, do.lag = 1) + + #***************************************************************** + # Construct signal + # http://systematicedge.wordpress.com/2014/03/01/energy-stat-arb-part-2/ + # lm(y~x+0) <=> ols(x,y)$coefficients + #****************************************************************** + beta = NA * prices[,1] + temp = coredata(prices[,spl('USO,GLD')]) + for(i in lookback : nperiods) { + dummy = temp[(i- lookback +1):i,] + beta[i] = ols(dummy[, 1], dummy[, 2])$coefficients + if( i %% 1000 == 0) cat(i, nperiods, round(100*i/nperiods), '\n') + } + + stat = temp[,2] - beta * temp[,1] + stat = -(stat - runMean(stat,20))/runSD(stat,20) + + data$weight[] = NA + data$weight$USO = iif(stat >= 2, -1, iif(stat <= -2, 1, 0)) + data$weight$GLD = iif(stat <= -2, -1, iif(stat >= 2, 1, 0)) + + data$weight[day.stat$day.end,] = 0 + data$weight[as.vector(0:(lookback-1) + rep.row(day.stat$day.start,lookback)),] = 0 + + models$P1 = bt.run.share(data, clean.signal=T, do.lag = 1) + + #***************************************************************** + # Create Report + #****************************************************************** +png(filename = 'plot1a.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() + + + +} + + + +############################################################################### +# Calendar Strategy: Month End +############################################################################### +bt.calendar.strategy.month.end.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY') + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, set.symbolnames = T, auto.assign = T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + + models = list() + + universe = prices > 0 + + key.date.index = date.month.ends(data$dates, F) + key.date = NA * prices + key.date[key.date.index,] = T + + #***************************************************************** + # Strategy + #***************************************************************** + data$weight[] = NA + data$weight[] = ifna(universe & key.date, F) + models$T0 = bt.run.share(data, do.lag = 0, trade.summary=T, clean.signal=T) + + #***************************************************************** + # Add helper functions + #***************************************************************** + calendar.strategy <- function(data, signal, universe = data$prices > 0) { + data$weight[] = NA + data$weight[] = ifna(universe & signal, F) + bt.run.share(data, do.lag = 0, trade.summary=T, clean.signal=T) + } + + calendar.signal <- function(key.date, offsets = 0) { + signal = mlag(key.date, offsets[1]) + for(i in offsets) signal = signal | mlag(key.date, i) + signal + } + + # Trade on key.date + models$T0 = calendar.strategy(data, key.date) + + # Trade next day after key.date + models$N1 = calendar.strategy(data, mlag(key.date,1)) + # Trade two days next(after) key.date + models$N2 = calendar.strategy(data, mlag(key.date,2)) + + # Trade a day prior to key.date + models$P1 = calendar.strategy(data, mlag(key.date,-1)) + # Trade two days prior to key.date + models$P2 = calendar.strategy(data, mlag(key.date,-2)) + + # Trade: open 2 days before the key.date and close 2 days after the key.date + signal = key.date | mlag(key.date,-1) | mlag(key.date,-2) | mlag(key.date,1) | mlag(key.date,2) + models$P2N2 = calendar.strategy(data, signal) + + # same, but using helper function above + models$P2N2 = calendar.strategy(data, calendar.signal(key.date, -2:2)) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, control=list(comparison=T), sort.performance=F) + +dev.off() + + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + last.trades(models$P2) + +dev.off() + + + #***************************************************************** + # Using new functions + #***************************************************************** + signals = calendar.signal(key.date, T0=0, N1=1, N2=2, P1=-1, P2=-2, P2N2=-2:2) + models = calendar.strategy(data, signals, universe = universe) + + strategy.performance.snapshoot(models, control=list(main=T)) + + strategy.performance.snapshoot(models, control=list(comparison=T), sort.performance=F) + + strategy.performance.snapshoot(models["P2N2"], control=list(monthly=T)) + + strategy.performance.snapshoot(models, control=list(transition=T)) + + last.trades(models$P2) + +} + + +############################################################################### +# Calendar Strategy: Option Expiry +# +# Op-ex week in December has been the most bullish week of the year for the SPX +# Buy: December Friday prior to op-ex. +# Sell X days later: 100K/trade 1984-present +# http://quantifiableedges.blogspot.com/2011/12/mooost-wonderful-tiiiiiiime-of.html +# http://quantifiableedges.blogspot.com/2010/12/most-wonderful-tiiiime-of-yearrrrrr.html +############################################################################### +bt.calendar.strategy.option.expiry.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY') + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, set.symbolnames = T, auto.assign = T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + + dates = data$dates + + models = list() + + universe = prices > 0 + + # Find Friday before options expiration week in December + years = date.year(range(dates)) + second.friday = third.friday.month(years[1]:years[2], 12) - 7 + key.date.index = na.omit(match(second.friday, dates)) + + key.date = NA * prices + key.date[key.date.index,] = T + + #***************************************************************** + # Strategy + # + # Op-ex week in December has been the most bullish week of the year for the SPX + # Buy: December Friday prior to op-ex. + # Sell X days later: 100K/trade 1984-present + # http://quantifiableedges.blogspot.com/2011/12/mooost-wonderful-tiiiiiiime-of.html + # http://quantifiableedges.blogspot.com/2010/12/most-wonderful-tiiiime-of-yearrrrrr.html + ############################################################################### + signals = list(T0=0) + for(i in 1:15) signals[[paste0('N',i)]] = 0:i + signals = calendar.signal(key.date, signals) + models = calendar.strategy(data, signals, universe = universe) + names(models) + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T, sort.performance=F) + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # custom stats + out = sapply(models, function(x) list( + CAGR = 100*compute.cagr(x$equity), + MD = 100*compute.max.drawdown(x$equity), + Win = x$trade.summary$stats['win.prob', 'All'], + Profit = x$trade.summary$stats['profitfactor', 'All'] + )) + performance.barchart.helper(out, sort.performance = F) + +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models$N15, control=list(main=T)) + +dev.off() + + #strategy.performance.snapshoot(models['N15'], control=list(transition=T)) + + #strategy.performance.snapshoot(models['N15'], control=list(monthly=T)) + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + last.trades(models$N15) + +dev.off() + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + trades = models$N15$trade.summary$trades + trades = make.xts(parse.number(trades[,'return']), as.Date(trades[,'entry.date'])) + layout(1:2) + par(mar = c(4,3,3,1), cex = 0.8) + barplot(trades, main='Trades', las=1) + plot(cumprod(1+trades/100), type='b', main='Trades', las=1) + +dev.off() + + #plotbt.custom.report.part2(models$N15, trade.summary=F) + +} + + +############################################################################### +# Calendar Strategy: Fed Days +# +# http://quantifiableedges.blogspot.ca/search/label/Fed%20Study +############################################################################### +bt.calendar.strategy.fed.days.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY') + + data <- new.env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, set.symbolnames = T, auto.assign = T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', fill.gaps = T) + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + n = ncol(prices) + + dates = data$dates + + models = list() + + universe = prices > 0 + universe = universe & prices > SMA(prices,100) + + # Find Fed Days + info = get.FOMC.dates(F) + key.date.index = na.omit(match(info$day, dates)) + + key.date = NA * prices + key.date[key.date.index,] = T + + #***************************************************************** + # Strategy + #***************************************************************** + signals = list(T0=0) + for(i in 1:15) signals[[paste0('N',i)]] = 0:i + signals = calendar.signal(key.date, signals) + models = calendar.strategy(data, signals, universe = universe) + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T, sort.performance=F) + +dev.off() + +png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # custom stats + out = sapply(models, function(x) list( + CAGR = 100*compute.cagr(x$equity), + MD = 100*compute.max.drawdown(x$equity), + Win = x$trade.summary$stats['win.prob', 'All'], + Profit = x$trade.summary$stats['profitfactor', 'All'] + )) + performance.barchart.helper(out, sort.performance = F) + +dev.off() + +png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models$N15, control=list(main=T)) + +dev.off() + + #strategy.performance.snapshoot(models['N15'], control=list(transition=T)) + + #strategy.performance.snapshoot(models['N15'], control=list(monthly=T)) + + +png(filename = 'plot4.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + last.trades(models$N15) + +dev.off() + +png(filename = 'plot5.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + trades = models$N15$trade.summary$trades + trades = make.xts(parse.number(trades[,'return']), as.Date(trades[,'entry.date'])) + layout(1:2) + par(mar = c(4,3,3,1), cex = 0.8) + barplot(trades, main='N15 Trades', las=1) + plot(cumprod(1+trades/100), type='b', main='N15 Trades', las=1) + +dev.off() + +} + + +############################################################################### +# Adjusted Momentum by David Varadi +# +# http://cssanalytics.wordpress.com/2014/07/29/vix-adjusted-momentum/ +# http://cssanalytics.wordpress.com/2014/07/30/error-adjusted-momentum/ +# http://www.quintuitive.com/2015/06/21/trading-moving-averages-with-less-whipsaws/ +############################################################################### +bt.adjusted.momentum.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('SPY,^VIX') + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na', fill.gaps = T) + + VIX = Cl(data$VIX) + + bt.prep.remove.symbols(data, 'VIX') + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + + models = list() + + commission = list(cps = 0.01, fixed = 10.0, percentage = 0.0) + + + #***************************************************************** + # Buy and Hold + #****************************************************************** + data$weight[] = NA + data$weight[] = 1 + models$buy.hold = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + #***************************************************************** + # 200 SMA + #****************************************************************** + data$weight[] = NA + data$weight[] = iif(prices > SMA(prices, 200), 1, 0) + models$ma200 = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + #***************************************************************** + # 200 ROC + #****************************************************************** + roc = prices / mlag(prices) - 1 + + data$weight[] = NA + data$weight[] = iif(SMA(roc, 200) > 0, 1, 0) + models$roc200 = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + #***************************************************************** + # 200 VIX MOM + #****************************************************************** + data$weight[] = NA + data$weight[] = iif(SMA(roc/VIX, 200) > 0, 1, 0) + models$vix.mom = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + #***************************************************************** + # 200 ER MOM - the logic is that returns should be weighted more + # when predictability is high, and conversely weighted less when + # predictability is low. In this case, the error-adjusted moving average + # will hopefully be more robust to market noise than a standard moving average. + #****************************************************************** + forecast = SMA(roc,10) + error = roc - mlag(forecast) + mae = SMA(abs(error), 10) + sma = SMA(roc/mae, 200) + + data$weight[] = NA + data$weight[] = iif(sma > 0, 1, 0) + models$er.mom = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + # cushioned + stddev = runSD(roc/mae,200) + upper.band = 0 + lower.band = -0.05*stddev + + data$weight[] = NA + data$weight[] = iif(cross.up(sma, upper.band), 1, iif(cross.dn(sma, lower.band), 0, NA)) + models$er.mom.cushioned = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + +if(F) { + #***************************************************************** + # EA, for stdev calculatins assume 0 sample mean + # http://www.quintuitive.com/2015/06/21/trading-moving-averages-with-less-whipsaws/ + #****************************************************************** + adj.rets = roc / sqrt(runSum(roc^2,10)/9) + #adj.rets = roc / runSD(roc,10) + sma = SMA(adj.rets, 200) + stddev = sqrt(runSum(adj.rets^2,200)/199) + #stddev = runSD(adj.rets,200) + + data$weight[] = NA + data$weight[] = iif(sma > 0, 1, 0) + #upper.band = lower.band = 0 + #data$weight[] = iif(cross.up(sma, upper.band), 1, iif(cross.dn(sma, lower.band), 0, NA)) + models$ea = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) + + #***************************************************************** + # Cushioned EA + #****************************************************************** + upper.band = 0 + lower.band = -0.05*stddev + + data$weight[] = NA + data$weight[] = iif(cross.up(sma, upper.band), 1, iif(cross.dn(sma, lower.band), 0, NA)) + models$ea.cushioned = bt.run.share(data, clean.signal=T, commission=commission, trade.summary=T) +} + #***************************************************************** + # Report + #****************************************************************** + layout(1:2) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = NULL) + mtext('Cumulative Performance', side = 2, line = 1) + + plotbt.strategy.sidebyside(models, perfromance.fn=engineering.returns.kpi) + + + +png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + strategy.performance.snapshoot(models, T) + +dev.off() +} + + + +#***************************************************************** +# Example showing the signal and execution lags +#***************************************************************** +bt.signal.execution.lag.test <- function() +{ + do.lag = 2 + calc.offset = -1 + + # Load test data + data <- new.env() + date = as.Date('2015-Aug-26','%Y-%b-%d') + dates = seq(date-100, date, by=1) + data$TEST = make.stock.xts(make.xts(1:len(dates), dates)) + bt.prep(data) + + # Setup + prices = data$prices + nperiods = nrow(prices) + + period.ends = endpoints(prices, 'months') + calc.offset + period.ends = period.ends[(period.ends > 0) & (period.ends <= nperiods)] + + # Code Strategy + data$weight[] = NA + data$weight[period.ends,] = prices[period.ends,] + model = bt.run(data, do.lag = do.lag) + + last(as.xts(list(WEIGHT = model$weight, SIGNAL = prices)),20) +} + +############################################################################### +# Execution price: buy low sell high +############################################################################### +bt.execution.price.high.low.test <- function +( + symbols = 'SPY,XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU', + n.top = 4, + mom.lag = 126, + dates = '2001::' +) +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + tickers = spl(symbols) + + data <- new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='remove.na') + + #***************************************************************** + # Code Strategies + #****************************************************************** + prices = data$prices + n = len(tickers) + + # find month ends + month.ends = endpoints(prices, 'months') + month.ends = month.ends[month.ends > 0] + + models = list() + + #***************************************************************** + # Code Strategies + #****************************************************************** + + # Rank on Momentum lag return + position.score = prices / mlag(prices, mom.lag) + + frequency = month.ends + # Select Top N funds + weight = ntop(position.score, n.top) + + #***************************************************************** + # Code Strategies, please note that there is only one price per day + # so all transactions happen at selected price + # i.e. below both buys and sells take place at selected price + #****************************************************************** + for(name in spl('Cl,Op,Hi,Lo')) { + fun = match.fun(name) + + exec.prices = bt.apply(data, fun) + + data$weight[] = NA + data$execution.price[] = NA + data$execution.price[frequency,] = exec.prices[frequency,] + data$weight[frequency,] = weight[frequency,] + models[[name]] = bt.run.share(data, trade.summary=T, dates=dates, silent=T, clean.signal=F) + } + + #***************************************************************** + # Code Strategies + #****************************************************************** + low.prices = bt.apply(data, Lo) + high.prices = bt.apply(data, Hi) + + # buy at low price + execution.price = low.prices[frequency,] + + # sell(i.e. weight=0) at high price + index = (weight[frequency,])==0 + execution.price[index] = coredata(high.prices[frequency,])[index] + + data$weight[] = NA + data$execution.price[] = NA + data$execution.price[frequency,] = execution.price + data$weight[frequency,] = weight[frequency,] + models$Buy.Low.Sell.High = bt.run.share(data, trade.summary=T, dates=dates, silent=T, clean.signal=F) + + #***************************************************************** + # Code Strategies + #****************************************************************** + low.prices = bt.apply(data, Lo) + high.prices = bt.apply(data, Hi) + + # buy at high price + execution.price = high.prices[frequency,] + + # sell(i.e. weight=0) at low price + index = (weight[frequency,])==0 + execution.price[index] = coredata(low.prices[frequency,])[index] + + data$weight[] = NA + data$execution.price[] = NA + data$execution.price[frequency,] = execution.price + data$weight[frequency,] = weight[frequency,] + models$Buy.High.Sell.Low = bt.run.share(data, trade.summary=T, dates=dates, silent=T, clean.signal=F) + + #***************************************************************** + # Create Report + #****************************************************************** + #strategy.performance.snapshoot(models, T) + plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = NULL) + mtext('Cumulative Performance', side = 2, line = 1) + + m = names(models)[1] + plotbt.transition.map(models[[m]]$weight, name=m) + legend('topright', legend = m, bty = 'n') + +print('Strategy Performance:') +print(plotbt.strategy.sidebyside(models, make.plot=F, return.table=T)) + +print('Monthly Results for', m, ':') +print(plotbt.monthly.table(models[[m]]$equity, make.plot = F)) +} + + + + +############################################################################### +# Dual Momentum +# +# http://www.scottsinvestments.com/2012/12/21/dual-momentum-investing-with-mutual-funds/ +# +# http://itawealth.com/2014/11/10/dual-momentum-back-tests-part-1/ +# http://itawealth.com/2014/11/12/dual-momentum-back-tests-part-2-adding-diversification-dual-momentum-strategy/ +# http://itawealth.com/2015/04/20/deciphering-the-dual-momentum-model/ +# +############################################################################### +bt.dual.momentum.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = ' + # Equity Risk = US Equity = VTI; Equity ex US = VEA + EQ.US = VTI + EQ.EX.US = VEA + + # Credit Risk = High Yield Bonds = HYG; Credit Bonds = CIU + HI.YLD = HYG + CREDIT = CIU + + # Real Estate Risk = Equity REITs = VNQ; mortgage REITs = REM + REIT.EQ = VNQ + REIT.MTG = REM + + # Economic Stress = Gold = GLD; Long Term Treasuries =TLT + GOLD = GLD + LT.GOV = TLT + + # Cash: T-Bills (SHY) + CASH = SHY + VFISX + ' + + + data = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, set.symbolnames = T, auto.assign = T) + #print(bt.start.dates(data)) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', fill.gaps = T) + data = bt.prep.trim(data, '2006::') + + + + # define risk groups, do not define group for CASH + risk.groups = transform(data$prices[1,] * NA, + EQ.US=1, EQ.EX.US=1, + HI.YLD=2, CREDIT=2, + REIT.EQ=3, REIT.MTG=3, + GOLD=4, LT.GOV=4 + ) + risk.groups + + # plot asset history + #plota.matplot(scale.one(data$prices),main='Asset Performance') + + #***************************************************************** + # Setup + #***************************************************************** + prices = data$prices + + period.ends = date.ends(prices, 'month') + + mom = prices / mlag(prices, 252) + # Absolute momentum logic: do not allocate if momentum is below CASH momentum + mom[mom < as.vector(mom$CASH)] = NA + + #***************************************************************** + # Code Strategies + #****************************************************************** + custom.weight.portfolio <- function(mom, ntop) + { + mom = mom + ntop = ntop + function + ( + ia, # input assumptions + constraints # constraints + ) + { + ntop.helper(mom[ia$nperiod, ia$index], ntop) + } + } + + + + # setup universe + universe = !is.na(mom) + universe[,'CASH'] = F + + obj = portfolio.allocation.helper(prices, + period.ends = period.ends, + universe = universe, + min.risk.fns = list( + EW=equal.weight.portfolio, + DM=distribute.weights( + static.weight.portfolio(rep(1,4)), # there are 4 clusters + static.group(risk.groups), # predefined groups + custom.weight.portfolio(mom, 1) + ) + ), + adjust2positive.definite = F, + silent=T + ) + + # scale results such that each cluster gets 25% weight + obj$weights$DM = obj$weights$DM * 0.25 + + + + #***************************************************************** + # Sanity check + #***************************************************************** +if(T) { + risk.groups = as.vector(risk.groups) + risk.groups = ifna(risk.groups, 0) + + test = matrix(0, nr=len(period.ends),nc=ncol(prices)) + for(i in 1:nrow(test)) { + for(g in 1:4) { + index = risk.groups == g + test[i, index] = ntop.helper(mom[period.ends[i], index], 1) * 0.25 # there are 4 sectors, each one gets 1/4 + } + } + + range( coredata(obj$weights$DM) - test ) +} + + + #***************************************************************** + # Absolute momentum logic: move reaming allocation to CASH, so that portfolio is fully invested + #***************************************************************** + for(i in names(obj$weights)) + obj$weights[[i]]$CASH = obj$weights[[i]]$CASH + ( 1 - rowSums(obj$weights[[i]]) ) + + + models = create.strategies(obj, data )$models + + + strategy.performance.snapshoot(models, T) + +} + + + \ No newline at end of file diff --git a/R/cluster.r b/R/cluster.r new file mode 100644 index 0000000..2c0eff8 --- /dev/null +++ b/R/cluster.r @@ -0,0 +1,103 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Repository of Benchmark Strategies +# Copyright (C) 2014 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + + +############################################################################### +#' Helper function to setup cluster +#' +#' load.packages('parallel') +#' cl = setup.cluster({source('post.fn.r')}, 'spyRets,sma.lens,data,run.backtest',envir=environment()) +#' out = clusterApplyLB(cl, vol.lens, function(j) { run.backtest(j) } ) +#' stopCluster(cl) +#' +#' @export +############################################################################### +setup.cluster <- function(expr = NULL, varlist = NULL, envir = .GlobalEnv, cores = 1000) { + #***************************************************************** + # Setup Parallel + #***************************************************************** + load.packages('parallel') + cores = min(cores, detectCores()) + + # we don't want to execute defult settings + Sys.unsetenv("R_PROFILE_USER") + cl = makeCluster(cores) + + #***************************************************************** + # Setup Cluster + #***************************************************************** + temp = clusterEvalQ(cl, { + # set up each worker. + library(quantmod) + library(SIT) + + #con = gzcon(file('../sit', 'rb')) + # source(con) + #close(con) + + NULL + }) + + # clusterEvalQ <- function (cl = NULL, expr) clusterCall(cl, eval, substitute(expr), env = .GlobalEnv) + if(!is.null(expr)) + temp = clusterCall(cl, eval, substitute(expr), env = .GlobalEnv) + + #***************************************************************** + # Move Data to Cluster + #***************************************************************** + if(!is.null(varlist)) + clusterExport(cl=cl, trim(spl(varlist)),envir=envir) + + cl +} + + +############################################################################### +#' Parallel Helper Log functions +#' +#' @export +############################################################################### +clusterApplyLB.log <- function (cl = NULL, log = log.fn(), x, fun, ...) { + argfun <- function(i) c(list(x[[i]]), list(...)) + dynamicClusterApply.log(cl, log, fun, length(x), argfun) +} + +dynamicClusterApply.log <- function (cl = NULL, log = log.fn(), fun, n, argfun) { + cl <- parallel:::defaultCluster(cl) + p <- length(cl) + if (n > 0L && p) { + submit <- function(node, job) parallel:::sendCall(cl[[node]], fun, + argfun(job), tag = job) + for (i in 1:min(n, p)) submit(i, i) + val <- vector("list", n) + for (i in 1:n) { +log(i, percent = i / n) + d <- parallel:::recvOneResult(cl) + j <- i + min(n, p) + if (j <= n) + submit(d$node, j) + val[d$tag] <- list(d$value) + } + parallel:::checkForRemoteErrors(val) + } +} \ No newline at end of file diff --git a/R/data.proxy.r b/R/data.proxy.r new file mode 100644 index 0000000..b206b5e --- /dev/null +++ b/R/data.proxy.r @@ -0,0 +1,327 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Collection of routines to examine and compare proxies and data +# Copyright (C) 2013 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + + + +############################################################################### +#' Compute correlations +#' +#' @param data matrix with data +#' @param method method used to compute correlations, please see \code{\link{cor}} for more details +#' +#' @return correlation matrix +#' +#' @export +############################################################################### +compute.cor <- function +( + data, # matrix with data + method = c("pearson", "kendall", "spearman") +) +{ + cor(data, use='complete.obs',method=method[1]) +} + +############################################################################### +#' Plot proxies and create summary table over common period +#' +#' @param data.all list or enviroment that holds proxy time series +#' @param names names or indexs of time series, \strong{defaults to all time series} +#' @param price.fn name of price function, \strong{defaults to Ad} +#' +#' @return nothing +#' +#' @examples +#' \dontrun{ +#' tickers = spl('HYG,VWEHX') +#' data = new.env() +#' getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) +#' +#' proxy.test(data) +#' } +#' @export +############################################################################### +proxy.test <- function(data.all, names = ls(data.all), price.fn=Ad) +{ + #***************************************************************** + # Prepare data + #****************************************************************** + data = new.env() + data$symbolnames = names + for(n in data$symbolnames) + data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) ) + bt.prep(data, align='remove.na', fill.gaps=T) + + #***************************************************************** + # Prepare data + #****************************************************************** + prices = data$prices + + # Plot side by side +# layout(1:2, heights=c(4,1)) +layout(1) + plota.matplot(scale.one(prices)) + + rets = (prices/mlag(prices)-1)[-1,] + + # compute correlations + temp = cor(rets, use='complete.obs', method='pearson') + diag(temp) = NA + temp[lower.tri(temp)] = NA + #temp = temp[-nrow(temp),-1,drop=F] + temp = temp[-nrow(temp),,drop=F] + temp[] = plota.format(100 * temp, 0, '', '%') + out = temp + + # compute stats + temp = compute.stats( as.list(rets), + list( + Mean=function(x) 252*mean(x,na.rm=T), + StDev=function(x) sqrt(252)*sd(x,na.rm=T) + ) + ) + temp[] = plota.format(100 * temp, 1, '', '%') + + # plot + out = rbind(out,NA,temp) +# plot.table(out) + print(out) +} + +############################################################################### +#' Plot 12 Month Spread for 2 symbols over common period +#' +#' @param data.all list or enviroment that holds proxy time series +#' @param names names or indexs of time series, \strong{defaults to all time series} +#' @param price.fn name of price function, \strong{defaults to Ad} +#' +#' @return nothing +#' +#' @examples +#' \dontrun{ +#' tickers = spl('HYG,VWEHX') +#' data = new.env() +#' getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) +#' +#' proxy.spread(data) +#' } +#' @export +############################################################################### +plot12month.rolling.spread <- function(data.all, names = ls(data.all), price.fn=Ad) +{ + #***************************************************************** + # Prepare data + #****************************************************************** + data = new.env() + data$symbolnames = names[1:2] + for(n in data$symbolnames) + data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) ) + bt.prep(data, align='remove.na', fill.gaps=T) + + #***************************************************************** + # Prepare data + #****************************************************************** + prices = data$prices + rets.12m.rolling = 100 * (prices / mlag(prices, 252) - 1) + spread.12m.rolling = rets.12m.rolling[,1] - rets.12m.rolling[,2] + + # Plot side by side + layout(1) + plota(spread.12m.rolling, type='l', + main = paste('12 Month Rolling Returns Spread % for', names[1], 'and', names[2])) + abline(h=0, col='gray') +} + + +############################################################################### +#' Plot all proxies overlaying the longest one +#' +#' @param data.all list or enviroment that holds proxy time series +#' @param names names or indexs of time series, \strong{defaults to all time series} +#' @param price.fn name of price function, \strong{defaults to Ad} +#' +#' @return nothing +#' +#' @examples +#' \dontrun{ +#' tickers = spl('HYG,VWEHX') +#' data = new.env() +#' getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) +#' +#' proxy.overlay.plot(data) +#' } +#' @export +############################################################################### +proxy.overlay.plot <- function(data.all, names = ls(data.all), price.fn=Ad) +{ + #***************************************************************** + # Prepare data + #****************************************************************** + data = new.env() + data$symbolnames = names + for(n in data$symbolnames) + data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) ) + + bt.prep(data, align='keep.all', fill.gaps=T) + + #***************************************************************** + # Prepare data + #****************************************************************** + prices = data$prices + prices = scale.one(prices, T) + + # Plot side by side + layout(1) + plota.matplot(prices) +} + +############################################################################### +#' Plot complete history for each index for Close and Adjusted, and create summary table +#' +#' @param data list or enviroment that holds proxy time series +#' @param names names or indexs of time series, \strong{defaults to all time series} +#' +#' @return nothing +#' +#' @examples +#' \dontrun{ +#' tickers = spl('HYG,VWEHX') +#' data = new.env() +#' getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) +#' +#' proxy.prices(data) +#' } +#' @export +############################################################################### +proxy.prices <- function(data, names = ls(data)) { + n.names = len(names) + temp = list() + +# layout(1:(n.names+1)) + layout(1:n.names) + for(n in names) { + plota.matplot(cbind(Cl(data[[n]]),Ad(data[[n]])),main=n) + temp[[ paste(n, 'Price') ]] = Cl(data[[n]]) + temp[[ paste(n, 'Total') ]] = Ad(data[[n]]) + } + + # compute stats + temp = compute.stats( lapply(temp, function(x) ifna(x/mlag(x) -1,NA)), + list( + Mean=function(x) 252*mean(x,na.rm=T), + StDev=function(x) sqrt(252)*sd(x,na.rm=T) + ) + ) + + # plot + temp[] = plota.format(100 * temp, 1, '', '%') +# plot.table(temp) + print(temp) +} + +#' @export +proxy.map <- function(raw.data, tickers) +{ + #***************************************************************** + # Prepare data + #****************************************************************** + data <- new.env() + tickers = spl(tickers) + tickers = tickers[order(sapply(tickers, nchar),decreasing =T)] + + getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, raw.data = raw.data, set.symbolnames = T, auto.assign = T) + for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + bt.prep(data, align='keep.all', fill.gaps=T) + + layout(1) + plota.matplot(data$prices) +} + +proxy.example.test <- function() { + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('GSG,DBC') + data = new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + # "TRJ_CRB" file was downloaded from the http://www.jefferies.com/Commodities/2cc/389 + # for "TRJ/CRB Index-Total Return" + temp = extract.table.from.webpage( join(readLines("TRJ_CRB")), 'EODValue' ) + temp = join( apply(temp, 1, join, ','), '\n' ) + data$CRB_1 = make.stock.xts( read.xts(temp, format='%m/%d/%y' ) ) + + # "prfmdata.csv" file was downloaded from the http://www.crbequityindexes.com/indexdata-form.php + # for "TR/J CRB Global Commodity Equity Index", "Total Return", "All Dates" + data$CRB_2 = make.stock.xts( read.xts("prfmdata.csv", format='%m/%d/%Y' ) ) + + #***************************************************************** + # Compare + #****************************************************************** +jpeg(filename = 'plot1.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + proxy.test(data) +dev.off() +jpeg(filename = 'plot2.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + proxy.overlay.plot(data) +dev.off() + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + tickers = spl('IYR,VGSIX,RWO') + data = new.env() + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T) + + #***************************************************************** + # Compare + #****************************************************************** +jpeg(filename = 'plot3.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + proxy.test(data) +dev.off() +jpeg(filename = 'plot4.jpg', width = 500, height = 500, units = 'px', pointsize = 12) + proxy.overlay.plot(data) +dev.off() + +# VGSIX,VEIEX,VBMFX,VWEHX,PEBIX,VIPSX,VTSMX,VGTSX,VFISX,VUSTX +# +# Equity Market +# Vanguard Total Stock Mkt (VTSMX) +# Vanguard Total Intl Stock (VGTSX) +# Vanguard 500 Index (VFINX) +# Vanguard Emerging Mkts (VEIEX) +# Fixed Income Market +# Vanguard Short-Term Treasury (VFISX) +# Vanguard Long-Term Treasury (VUSTX) +# Vanguard Total Bond Market (VBMFX) +# Vanguard High-Yield Corporate (VWEHX) +# PIMCO Emerging Markets Bond (PEBIX) +# Vanguard Inflation-Protected (VIPSX) +# PIMCO Total Return (PTTRX) +# Vanguard REIT (VGSIX) +# +} + diff --git a/R/data.r b/R/data.r new file mode 100644 index 0000000..ed71075 --- /dev/null +++ b/R/data.r @@ -0,0 +1,2951 @@ +############################################################################### +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +############################################################################### +# Collection of routines to work with data +# Copyright (C) 2011 Michael Kapler +# +# For more information please visit my blog at www.SystematicInvestor.wordpress.com +# or drop me a line at TheSystematicInvestor at gmail +############################################################################### + +#' @export +find.tokens <- function +( + txt, # source text + marker, # key-phrase(s) to find + pos = 1, # position to start searching at + pos.start = T +) +{ + # find location of data + marker = spl(marker) + + for(i in 1:len(marker)) { + if( pos < 2 ) + pos1 = regexpr(marker[i], txt) + else + pos1 = regexpr(marker[i], substr(txt, pos, nchar(txt))) + + if( pos1 < 0 ) + return(pos1) + else { + if( pos < 2 ) pos = pos1 + else pos = pos1 + pos - 1 + } + pos = pos + attr(pos1, 'match.length') + } + if( pos.start ) pos = pos - attr(pos1, 'match.length') + + return(pos) +} + + +#' @export +extract.token <- function +( + txt, # source text + smarker, # start key-phrase(s) to find + emarker, # end key-phrase(s) to find + pos = 1, # position to start searching at + keep.marker = F +) +{ + pos1 = 1 + if (nchar(smarker) > 0) + pos1 = find.tokens(txt, smarker, pos, pos.start = keep.marker) + if( pos1 < 0 ) return("") + pos1.marker = iif(keep.marker, pos1 + nchar(last(spl(smarker))), pos1) + + pos2 = nchar(txt) + if (nchar(emarker) > 0) + pos2 = find.tokens(txt, emarker, pos1.marker, pos.start = !keep.marker) - 1 + if( pos2 < 0 ) return("") + + return(substr(txt,pos1,pos2)) +} + +#' @export +remove.tags <- function +( + temp # source text +) +{ + # remove all formating + temp = gsub(pattern = '<.*?>', replacement = '', temp, perl = TRUE) + + temp = gsub(pattern = '\r', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '\n', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '\t', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = ' ', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '&', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '»', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '%', replacement = '%', temp, perl = TRUE) + + + return(temp) +} + +#' @export +replace.token <- function +( + txt, # source text + smarker, # start key-phrase(s) to find + emarker, # end key-phrase(s) to find + replacement,# replacement token + pos = 1 # position to start searching at +) +{ + token = extract.token(txt, smarker, emarker, pos, keep.marker = T) + if(nchar(token) == 0) + txt + else + replace.token(gsub(pattern = token, replacement = replacement, txt), smarker, emarker, replacement) +} + + +#' @export +clean.table <- function +( + temp # extracted table +) +{ + temp = trim(temp) + temp[nchar(temp)==0] = NA + temp = temp[ncol(temp) > rowSums(is.na(temp)),,drop=F] + temp[,nrow(temp) > colSums(is.na(temp)),drop=F] +} + +############################################################################### +# extract.table.from.webpage +#' @export +############################################################################### +extract.table.from.webpage <- function +( + txt, # source text of webpage + marker=NA, # key-phrase(s) located in the table to extract + has.header=T,# flag if table has a header + end.marker=NA # additional end of token marker(s) +) +{ + tryCatch({ + # find location of data + pos1=1 + + if(!is.na(marker)) { + marker = spl(marker) + if(len(marker) > 0 && nchar(marker[1]) > 0) + for(i in 1:len(marker)) + pos1 = regexpr(marker[i], substr(txt, pos1, nchar(txt))) + pos1 + } + + + # find start/end of table + pos0 = tail(gregexpr('', replacement = '', temp, perl = TRUE) + + temp = gsub(pattern = '', replacement = ';row;', temp, perl = TRUE) + temp = gsub(pattern = '', replacement = ';col;', temp, perl = TRUE) + temp = gsub(pattern = '', replacement = ';col;', temp, perl = TRUE) + if(!is.na(end.marker)) { + marker = spl(end.marker) + if(len(marker) > 0 && nchar(marker[1]) > 0) + for(i in 1:len(marker)) + temp = gsub(pattern = marker[i], replacement = ';row;', temp, perl = TRUE) + } + + temp = gsub(pattern = '<.*?>', replacement = '', temp, perl = TRUE) + + temp = gsub(pattern = '\r', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '\n', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '\t', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = ' ', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '&', replacement = '', temp, perl = TRUE) + temp = gsub(pattern = '»', replacement = '', temp, perl = TRUE) + + # parse into matrix + temp = lapply( strsplit(temp, ';row;'), strsplit, ';col;') + n = max( sapply(temp[[1]], function(x) len(x)) ) + temp = t( sapply(temp[[1]], function(x) x[1:n]) ) + + if(has.header) { + colnames(temp) = trim(temp[(has.header + 0), ]) + temp = temp[-c(1:(has.header + 0)), ,drop=F] + } + + }, error = function(ex) { + temp <<- txt + }, finally = { + return(temp) + }) +} + +############################################################################### +# Test for extract.table.from.webpage function +############################################################################### +extract.table.from.webpage.test <- function() +{ + load.packages('quantmod') + + Symbol = 'IBM' + + # download Key Statistics from yahoo + url = paste('http://finance.yahoo.com/q/ks?s=', Symbol, sep = '') + txt = join(readLines(url)) + + # extract Valuation Measures table from this page + temp = extract.table.from.webpage(txt, 'Market Cap', has.header = F) + temp = rbind(c('', Symbol), temp) # add header row + + + # download IBM price history from Yahoo + data = getSymbols(Symbol, from = '1980-01-01', auto.assign = FALSE) + + # prepare IBM data for 2010:2011 and compute 50 days moving average + y = data['2010::2011'] + sma50 = SMA(Cl(y), 50) + + png(filename = 'plot1.png', width = 500, height = 500, units = 'px', pointsize = 12, bg = 'white') + + # plote candles and volume and table + layout(c(1,1,2,3,3)) + + plota(y, type = 'candle', main = Symbol, plotX = F) + plota.lines(sma50, col='blue') + plota.legend(c(Symbol,'SMA 50'), 'green,blue', list(y,sma50)) + + y = plota.scale.volume(y) + plota(y, type = 'volume') + + plot.table(temp) + + dev.off() +} + + +############################################################################### +# Pricing Zero Coupon Bond (i.e. yield to price) +# http://thinkanddone.com/finance/valuation-of-zero-coupon-bonds.html +#' @export +############################################################################### +PricingZeroCouponBond <- function +( + yield, + timetomaturity, + parvalue = 100 +) +{ + parvalue / ( 1 + yield ) ^ timetomaturity +} + +############################################################################### +# Convert Historical TBills rates to Total Returns +# http://timelyportfolio.blogspot.com/2011/04/historical-sources-of-bond-returns_17.html +# http://timelyportfolio.blogspot.ca/2012/11/cashopportunity-lost-or-opportunity.html +#' @export +############################################################################### +processTBill <- function +( + yields, + timetomaturity = 1/4, + frequency = 365 +) +{ + yield = coredata(yields) / 100 + + # price return + pr = sapply( yield, function(x) PricingZeroCouponBond(x, timetomaturity) ) + pr = ROC(pr, type='discrete') + pr[1] = 0 + + # interest return + ir = (1+mlag(yield, nlag=1))^(1 / frequency)-1 + #ir = mlag(yield, nlag=1) / frequency + ir[1] = 0 + + # total return + tr = pr + ir + + #out = as.xts( cbind(pr, ir, tr), index(yields) ) + # colnames(out) = spl('PR,IR,TR') + + + close.price = cumprod(1 + pr) + adjusted.price = cumprod(1 + tr) + + out = as.xts( cbind(close.price, adjusted.price), index(yields) ) + colnames(out) = spl('Close,Adjusted') + + return(out) +} + + +processTBill.test <- function() +{ + #***************************************************************** + # Get 1 year t-bill + #****************************************************************** + quantmod::getSymbols("GS1", src = "FRED") + ir = (1 + mlag(GS1) / 100) ^ (1/12) - 1 + ir[1] = 0 + + out = processTBill(GS1, timetomaturity = 1,12) + + plota(cumprod(1 + ir), type='l', log = 'y') + plota.lines(Ad(out), type='l', col='red') + + #***************************************************************** + # Get 3 years t-bill + #****************************************************************** + SHY = getSymbols('SHY', src='yahoo', auto.assign = FALSE) + + tbill.m = quantmod::getSymbols('GS3', src='FRED', auto.assign = FALSE) + tbill.d = quantmod::getSymbols('DGS3', src='FRED', auto.assign = FALSE) + timetomaturity = 3 + + compute.raw.annual.factor(tbill.d) + compute.raw.annual.factor(tbill.m) + + # compute returns + tbill.m = processTBill(tbill.m, timetomaturity = timetomaturity, 12) + #index(tbill.m) = as.Date(paste('1/', format(index(tbill.m), '%m/%Y'), sep=''), '%d/%m/%Y') + + tbill.d[] = ifna.prev(tbill.d) + tbill.d = processTBill(tbill.d, timetomaturity = timetomaturity,261) + + + # scale to start at 1 + dates = '2003::' + tbill.m = tbill.m[dates,2] + tbill.m = tbill.m / as.double(tbill.m[1]) + tbill.d = tbill.d[dates,2] + tbill.d = tbill.d / as.double(tbill.d[1]) + SHY = Ad(SHY[dates,]) + SHY = SHY / as.double(SHY[1]) + + # plot + plota(tbill.d, type='l') + plota.lines(tbill.m, type='s', col='blue') + plota.lines(SHY, type='l', col='red') + plota.legend('Daily 3YR T-Bills,Monthly 3YR T-Bills,SHY','black,blue,red') + +} + + +############################################################################### +# Load CRB Commodities Index +# http://www.jefferies.com/cositemgr.pl/html/ProductsServices/SalesTrading/Commodities/ReutersJefferiesCRB/IndexData/index.shtml +############################################################################### +# ... parameters for read.xls function +# i.e. CRB = get.CRB(perl = 'c:/perl/bin/perl.exe') +# +# This url is not working anymore, for updated example please see +# bt.extend.DBC.update.test in bt.test.r +#' @export +############################################################################### +get.CRB <- function(...) +{ + load.packages('gtools,gdata') + + #http://www.jefferies.com/html/ProductsServices/SalesTrading/Commodities/scripts/genExcel.pl?Index=RJCRB_Excess&StartDate=19940103&EndDate=20111202 + url = paste('http://www.jefferies.com/html/ProductsServices/SalesTrading/Commodities/scripts/genExcel.pl?Index=RJCRB_Total&StartDate=19940101&EndDate=', format(Sys.Date(), '%Y%m%d'), sep='') + temp = read.xls(url, ...) + temp = as.matrix(temp[-c(1:7),]) + + out = repmat(as.double(temp[,2]), 1, 6) + colnames(out) = spl('Open,High,Low,Close,Volume,Adjusted') + out[, 'Volume'] = 0 + #out = make.xts( out, as.Date(temp[,1], '%m/%d/%y')) + out = make.xts( out, as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%m/%d/%y')) + indexClass(out) = 'Date' + + return(out) +} + + +get.CRB.test <- function() +{ + #***************************************************************** + # Load historical data + #****************************************************************** + CRB = get.CRB() + + load.packages('quantmod') + # http://etfdb.com/ + tickers = spl('GSG,DBC') + getSymbols(tickers, src = 'yahoo', from = '1970-01-01') + + #***************************************************************** + # Compare different indexes + #****************************************************************** + out = na.omit(merge(Cl(CRB), Cl(GSG), Cl(DBC))) + colnames(out) = spl('CRB,GSG,DBC') + temp = out / t(repmat(as.vector(out[1,]),1,nrow(out))) + + layout(1:2) + plota(temp, ylim=range(temp)) + plota.lines(temp[,1],col=1) + plota.lines(temp[,2],col=2) + plota.lines(temp[,3],col=3) + plota.legend(colnames(temp),1:3) + + temp = cor(temp / mlag(temp)- 1, use='complete.obs', method='pearson') + temp[] = plota.format(100 * temp, 0, '', '%') + plot.table(temp) + + + layout(1:3) + plota.matplot(CRB[,c('Close','Adjusted')]) + plota.matplot(DBC[,c('DBC.Close','DBC.Adjusted')]) + plota.matplot(GSG[,c('GSG.Close','GSG.Adjusted')]) + + + layout(1) + comm = extend.data(DBC, CRB, scale=T) + plota(comm, type='l', col=1) + plota.lines(CRB*0.078, type='l', lwd=5, col=col.add.alpha(2,150)) + plota.lines(DBC, type='l', lwd=5, col=col.add.alpha(3,150)) + plota.lines(comm, type='l', col=1) + plota.legend('comm,CRB,DBC', 1:3, list(comm,CRB,DBC)) +} + + +############################################################################### +# Get Dow Jones Components +# http://finance.yahoo.com/q/cp?s=^DJI+Components +#' @export +############################################################################### +dow.jones.components <- function() +{ + url = 'http://money.cnn.com/data/dow30/' + txt = join(readLines(url)) + + # extract links + temp = gsub(pattern = '">', replacement = '', txt, perl = TRUE) + temp = gsub(pattern = '', replacement = '', temp, perl = TRUE) + + # extract table from this page + temp = extract.table.from.webpage(temp, 'Volume', has.header = T) + trim(temp[,'Company']) +} + +dow.jones.components.0 <- function() +{ + url = 'http://finance.yahoo.com/q/cp?s=^DJI+Components' + txt = join(readLines(url)) + + # extract table from this page + temp = extract.table.from.webpage(txt, 'Volume', has.header = T) + temp[, 'Symbol'] +} + +dow.jones.components.1 <- function() +{ + load.packages('readxl,httr') + dir.create(paste(getwd(), 'temp', sep='/'), F) + GET('http://www.djaverages.com/?go=export-components&symbol=DJI', write_disk('temp/DJI.xls', overwrite=TRUE)) + temp = read_excel('temp/DJI.xls') + temp$Ticker +} + +############################################################################### +# Get NASDAQ 100 Components +# http://www.nasdaq.com/markets/indices/nasdaq-100.aspx +#' @export +############################################################################### +nasdaq.100.components <- function() +{ + url = 'http://www.nasdaq.com/quotes/nasdaq-100-stocks.aspx?render=download' + temp = read.csv(url, header=TRUE, stringsAsFactors=F) + colnames(temp) = trim(colnames(temp)) + + tickers = temp[, 'Symbol'] + return(tickers) +} + + + +############################################################################### +# Get Sector SPDR Components +# http://www.sectorspdr.com/sectorspdr/IDCO.Client.Spdrs.Holdings/Export/ExportCsv?symbol=XLE +# tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU') +# tickers.desc = spl('ConsumerCyclicals,ConsumerStaples,Energy,Financials,HealthCare,Industrials,Materials,Technology,U +#' @export +############################################################################### +sector.spdr.components <- function(sector.etf = 'XLE') +{ + url = paste('http://www.sectorspdr.com/sectorspdr/IDCO.Client.Spdrs.Holdings/Export/ExportCsv?symbol=', sector.etf, sep='') + + # extract table from this page + temp = read.csv(url, skip=1, header=TRUE, stringsAsFactors=F) + tickers = temp[, 'Symbol'] + + return(tickers) +} + + +############################################################################### +# S&P 500 Components +# http://en.wikipedia.org/wiki/List_of_S%26P_500_companies +#' @export +############################################################################### +sp500.components <- function() +{ + url = 'http://en.wikipedia.org/wiki/List_of_S%26P_500_companies' + txt = join(readLines(url)) + + # extract table from this page + temp = extract.table.from.webpage(txt, 'Ticker', has.header = T) + tickers = temp[, 'Ticker symbol'] + sector = temp[, 'GICS Sector'] + + return(list(tickers=tickers, sector=sector)) +} + +# List of sites that keep SP500 Components +# http://www.s-p-500.com/stocks-a-b/ +#http://www.forexpros.com/indices/us-spx-500-components +#http://marketvolume.com/indexes_exchanges/sp500_components.asp +#http://en.wikipedia.org/wiki/List_of_S%26P_500_companies +#http://en.wikipedia.org/wiki/Dow_Jones_Index + + +############################################################################### +# S&P 100 Components +# http://www.barchart.com/stocks/sp100.php +#' @export +############################################################################### +sp100.components <- function() +{ + url = 'http://www.barchart.com/stocks/sp100.php' + txt = join(readLines(url)) + + # extract table from this page + temp = extract.table.from.webpage(txt, 'Components', has.header = T) + i.start = grep('Name', temp[,2]) + tickers = trim(temp[-c(1:i.start), 1]) + + return(tickers) +} + + +############################################################################### +# iShares FTSE 100 (ISF) +# http://uk.ishares.com/en/rc/products/ISF/all-holdings/ +# http://www.londonstockexchange.com/exchange/prices-and-markets/stocks/indices/constituents-indices.html?index=UKX +# Yahoo ticker for UK stocks ABF.L +#' @export +############################################################################### +ftse100.components <- function() +{ + # get holdings from uk.ishares.com + url = 'http://uk.ishares.com/en/rc/products/ISF/all-holdings/' + txt = join(readLines(url)) + + # extract table from this page + txt = gsub('%','%',txt) + temp = extract.table.from.webpage(txt, 'Security', has.header = T) + + temp = trim(temp) + colnames(temp) = temp[1,] + temp = temp[-1,] + holdings = temp + + + # get ISIN to ticker map from www.londonstockexchange.com + page.label = '' + ticker2ISIN = c() + for(i in 1:100) { + cat(i,'\n') + + # download + url = paste('http://www.londonstockexchange.com/exchange/prices-and-markets/stocks/indices/constituents-indices.html?index=UKX&page=', i, sep='') + txt = join(readLines(url)) + + # get page label + pos = regexpr('Page [0-9]+ of [0-9]+', txt, ignore.case = T) + page.label.new = substr(txt, pos, pos + attr(pos, 'match.length')-1) + + if(page.label == page.label.new) break + page.label = page.label.new + + # extract table + temp.table = extract.table.from.webpage(txt, 'Price', has.header = T) + colnames(temp.table)[1] = 'tickers' + + # extract links + temp = gsub(pattern = '', replacement = '', temp, perl = TRUE) + + temp = extract.table.from.webpage(temp, 'Price', has.header = T) + pos = regexpr('fourWayKey=', temp[,2]) + ISIN = as.vector(sapply(1:nrow(temp), function(j) + substr(temp[j,2], pos[j] + attr(pos, 'match.length')[j], pos[j] + attr(pos, 'match.length')[j] + 12 - 1) + )) + + + ticker2ISIN = rbind(ticker2ISIN, cbind(temp.table[,spl('ticker,Name,Price'), drop=F], ISIN)) + } + + ISIN = intersect(holdings[,'ISIN'],ticker2ISIN[,'ISIN']) + holdings = cbind(holdings[match(ISIN, holdings[,'ISIN']), ], + ticker2ISIN[match(ISIN, ticker2ISIN[,'ISIN']), spl('ticker,Name,Price')]) + + return(apply(holdings, 2, list)) +} + + + +############################################################################### +# Get Dow Jones Components +# http://finance.yahoo.com/q/cp?s=^DJI+Components +# us.ishares.components(date='2008-02-01') +#' @export +############################################################################### +us.ishares.components <- function(Symbol = 'DVY', date = NULL, debug = F) +{ + url = paste('http://us.ishares.com/product_info/fund/holdings/', Symbol, '.htm?periodCd=d', sep='') + if( !is.null(date) ) + url = paste('http://us.ishares.com/product_info/fund/holdings/', Symbol, '.htm?asofDt=', date.end(date), '&periodCd=m', sep='') + txt = join(readLines(url)) + + # extract date from this page + temp = remove.tags(extract.token(txt, 'Holdings Detail', 'Holdings subject to change')) + date = as.Date(spl(trim(temp),' ')[3], '%m/%d/%Y') + + # extract table from this page + temp = extract.table.from.webpage(txt, 'Symbol', has.header = T) + + colnames(temp) = trim(colnames(temp)) + temp = trim(temp) + + tickers = temp[, 'Symbol'] + keep.index = nchar(tickers)>1 + weights = as.double(temp[keep.index, '% Net Assets']) / 100 + tickers = tickers[keep.index] + + out = list(tickers = tickers, weights = weights, date = date) + if(debug) out$txt = txt + out +} + + +############################################################################### +# Get Google search results: +# https://gist.github.com/Daapii/7281439 +# --- explanation of the parameters in the query --- +# +# ie = input encoding +# oe = output encoding +# q = query (our search term) +# num = amount of search results displayed at a time +# gws_rd=cr = redirects you to your countries version of google (required if you're not in the US) +# url encode our query +# query = "https://encrypted.google.com/search?ie=utf-8&oe=utf-8&q={0}&num=100&gws_rd=cr".format(query) +# google.search("r project") +#' @export +############################################################################### +google.search <- function +( + query +) +{ + url = paste("http://google.com/search?ie=utf-8&oe=utf-8&q=", URLencode(query), "&num=10&gws_rd=cr", sep='') + txt = join(readLines(url)) + + tokens = spl(txt, '
  • ') + + if(len(tokens) < 2) return(NULL) + + records = matrix('', nrow=len(tokens)-1,nc=2) + colnames(records) = c('label','url') + for(i in 2:len(tokens)) { + token = tokens[i] + token = extract.token(token, '', keep.marker = T) + url = extract.token(token, 'url\\?q=', '&sa=U&') + label = remove.tags(token) + records[i-1,] = c(label,url) + } + + return(records) +} + + +############################################################################### +# Get the latest prices from the Google finance: +# http://digitalpbk.com/stock/google-finance-get-stock-quote-realtime +# http://finance.google.com/finance/info?client=ig&q=MSFT,AAPL,NYSE:RY +#' @export +############################################################################### +#getQuote.google(spl('MSFT,AAPL,IBM')) +getQuote.google <- function(tickers) { + url = paste('http://finance.google.com/finance/info?client=ig&q=', join(tickers,','), sep='') + txt = join(readLines(url)) + temp = gsub(':', ',', txt) + temp = scan(text = temp, what='', sep=',', quiet=T) + temp = matrix(trim(temp), nr=len(temp)/len(tickers), byrow=F) + + index = match(spl('t,l,lt'), tolower(temp[,1]))+1 + names(index) = spl('ticker,last,date') + + last = as.double(temp[index['last'],]) + date = strptime(temp[index['date'],],format=' %b %d, %H,%M') + + out = data.frame(last,date) + rownames(out) = temp[index['ticker'],] + out +} + +# an xml alternative +# http://www.jarloo.com/google-stock-api/ +# http://www.google.com/ig/api?stock=AAPL&stock=GOOG +#getQuote.google.xml(spl('MSFT,AAPL,NYSE:RY')) +#' @export +getQuote.google.xml <- function(tickers) { + url = paste('http://www.google.com/ig/api?', paste('stock=',tickers, '&', sep='', collapse=''), sep='') + txt = join(readLines(url)) + + temp = txt + temp = gsub('', '', temp, perl = TRUE) + temp = gsub('', '', temp, perl = TRUE) + temp = gsub('', '', temp, perl = TRUE) + temp = gsub('', '', temp, perl = TRUE) + temp = gsub('<\\?xml.*?>', '', temp, perl = TRUE) + temp = gsub('data=', '', temp, perl = TRUE) + temp = gsub('/><', ' ', temp) + temp = gsub('>', '', temp) + temp = gsub('<', '', temp) + temp = scan(text = temp, what='', sep=' ', quiet=T) + temp = matrix(trim(temp), nr=len(temp)/len(tickers), byrow=F) + + cnames = spl('trade_date_utc,trade_time_utc,symbol,last,high,low,volume,open,avg_volume,market_cap,y_close') + index = match(cnames, tolower(temp[,1]))+1 + names(index) = cnames + + date = strptime(paste(temp[index['trade_date_utc'],], temp[index['trade_time_utc'],]), format='%Y%m%d %H%M%S',tz='UTC') + date = as.POSIXct(date, tz = Sys.getenv('TZ')) + + out = data.frame(t(temp[index[-c(1:3)],])) + colnames(out) = cnames[-c(1:3)] + rownames(out) = temp[index['symbol'],] + out +} + +############################################################################### +# Download historical intraday prices from Google Finance +# http://www.mathworks.com/matlabcentral/fileexchange/32745-get-intraday-stock-price +# http://www.mathworks.com/matlabcentral/fileexchange/36115-volume-weighted-average-price-from-intra-daily-data +# http://www.codeproject.com/KB/IP/google_finance_downloader.aspx +# http://www.marketcalls.in/database/google-realtime-intraday-backfill-data.h +# getSymbol.intraday.google('GOOG','NASDAQ') +# getSymbol.intraday.google('.DJI','INDEXDJX') +#' @export +############################################################################### +getSymbol.intraday.google <- function +( + Symbol, + Exchange, + interval = 60, # 60 seconds + period = '1d' +) +{ + # download Key Statistics from yahoo + url = paste('http://www.google.com/finance/getprices?q=', Symbol, + '&x=', Exchange, + '&i=', interval, + '&p=', period, + '&f=', 'd,o,h,l,c,v', sep='') + + load.packages('data.table') + out = fread(url, stringsAsFactors=F) + + if(ncol(out) < 5) { + cat('Error getting data from', url, '\n') + return(NULL) + } + + setnames(out, spl('Date,Open,High,Low,Close,Volume')) + + # date logic + date = out$Date + date.index = substr(out$Date,1,1) == 'a' + date = as.double(gsub('a','',date)) + temp = NA * date + temp[date.index] = date[date.index] + temp = ifna.prev(temp) + date = temp + date * interval + date[date.index] = temp[date.index] + class(date) = c("POSIXt", "POSIXct") + + date = date - (as.double(format(date[1],'%H')) - 9)*60*60 + + make.xts(out[,-1,with=F], date) +} + + + +############################################################################### +# getSymbols interface to Yahoo today's delayed qoutes +# based on getQuote.yahoo from quantmod package +# +# http://www.financialwisdomforum.org/gummy-stuff/Yahoo-data.htm +# https://github.com/joshuaulrich/quantmod/blob/master/R/getQuote.R +# +# getQuote.yahoo.info('DJP,IEF,KIE,RHS') +# +#' @export +############################################################################### +getQuote.yahoo.info <- function(Symbols, fields = c( + Name='Name', + Symbol='Symbol', + Time='Last Trade Time', + Date='Last Trade Date', + Close='Last Trade (Price Only)', + Volume='Volume', + AvgVolume='Average Daily Volume', + Yesterday='Previous Close' + ), + load.hist = T +) { + Symbols = spl(Symbols) + out = getQuote.yahoo.today(Symbols, fields) + out = as.data.frame.matrix(out) + rownames(out) = out$Symbol + + if(!load.hist) return(out) + + data = env() + getSymbols(Symbols, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T) + + out$Start = bt.start.dates(data)[out$Symbol,] + out +} + + +#' @export +getQuote.yahoo.today <- function(Symbols, fields = c( + Name='Name', + Symbol='Symbol', + Time='Last Trade Time', + Date='Last Trade Date', + Open='Open', + High='Days High', + Low='Days Low', + Close='Last Trade (Price Only)', + Volume='Volume', + Yesterday='Previous Close' + ) +) { + require('data.table') + what = yahooQF(names = fields) + names = names(fields) + Symbols = spl(Symbols) + all.symbols = lapply(seq(1, len(Symbols), 100), function(x) na.omit(Symbols[x:(x + 99)])) + out = c() + + for(i in 1:len(all.symbols)) { + # download + url = paste('http://download.finance.yahoo.com/d/quotes.csv?s=', + join( trim(all.symbols[[i]]), ','), + '&f=', what[[1]], sep = '') + + txt = join(readLines(url),'\n') + data = fread(paste0(txt,'\n'), stringsAsFactors=F, sep=',') + setnames(data,names) + setkey(data,'Symbol') + out = rbind(out, data) + } + out +} + +############################################################################### +# extend GLD and SLV historical prices +#' @export +############################################################################### +extend.GLD <- function(GLD) { + extend.data(GLD, bundes.bank.data.gold(), scale=T) +} + +# gold = extend.GLD(data$GLD) +# comm = extend.data(data$DBC, get.CRB(), scale=T) +#' @export +extend.data <- function +( + current, + hist, + scale = F +) +{ + colnames(current) = sapply(colnames(current), function(x) last(spl(x,'\\.'))) + colnames(hist) = sapply(colnames(hist), function(x) last(spl(x,'\\.'))) + + # find Close in hist + close.index = find.names('Close', hist) + if(len(close.index)==0) close.index = 1 + adjusted.index = find.names('Adjusted', hist) + if(len(adjusted.index)==0) adjusted.index = close.index + + if(scale) { + cur.close.index = find.names('Close', current) + if(len(cur.close.index)==0) cur.close.index = 1 + cur.adjusted.index = find.names('Adjusted', current) + if(len(cur.adjusted.index)==0) cur.adjusted.index = cur.close.index + + # find first common observation in current and hist series + common = merge(current[,cur.close.index], hist[,close.index], join='inner') + + scale = as.numeric(common[1,1]) / as.numeric(common[1,2]) + + if( close.index == adjusted.index ) + hist = hist * scale + else { + hist[,-adjusted.index] = hist[,-adjusted.index] * scale + + common = merge(current[,cur.adjusted.index], hist[,adjusted.index], join='inner') + scale = as.numeric(common[1,1]) / as.numeric(common[1,2]) + hist[,adjusted.index] = hist[,adjusted.index] * scale + } + } + + # subset history before current + hist = hist[format(index(current[1])-1,'::%Y:%m:%d'),,drop=F] + + #hist = make.xts( rep.col(hist[,adjusted.index], ncol(current)), index(hist)) + if( ncol(hist) != ncol(current) ) + hist = rep.col(hist[,adjusted.index], ncol(current)) + else + hist = hist[, colnames(current)] + + colnames(hist) = colnames(current) + + rbind( hist, current ) +} + + + +# extend data from the previously saved proxies +#' @export +extend.data.proxy <- function(data, data.proxy = NULL, proxy.filename = 'data.proxy.Rdata') { + if(is.null(data.proxy) && file.exists(proxy.filename)) + load(file=proxy.filename) + + if(!is.null(data.proxy)) + for(n in ls(data.proxy)) + if( !is.null(data[[n]]) ) + data[[n]] = extend.data(data[[n]], data.proxy[[n]], scale=T) +} + +############################################################################### +# Leveraged series +############################################################################### +# Create Leveraged series with data from the unlevereged. +# +# Please use only with Adjusted time series. For example create.leveraged(data$QQQ, leverage=2) +# will produce erroneous values because QQQ had 2: 1 Stock Split on Mar 20, 2000 +# Hence at 2x leverage the value goes to zero. +# +# @example create.leveraged(tlt, 2) +# @example extend.data(data$UBT, create.leveraged(data$TLT, leverage=2), scale=T) +# @example extend.data(data$TMF, create.leveraged(data$TLT, leverage=3), scale=T) +#' @export +create.leveraged = function(hist, leverage=2) { + rets = 1 + leverage * (hist / mlag(hist) - 1) + rets[1,] = 1 + bt.apply.matrix(rets, cumprod) +} + + +create.leveraged.test = function() { + tickers = spl('TMF,UBT,TLT') + data = new.env() + + getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T) + + + test2 = extend.data(data$UBT, create.leveraged(data$TLT, leverage=2), scale=T) + test3 = extend.data(data$TMF, create.leveraged(data$TLT, leverage=3), scale=T) + proxy.test(list(TLT=data$TLT, UBT=test2, TMF=test3),price.fn=Ad) + + test0 = create.leveraged(data$TLT, leverage=2) + proxy.test(list(UBT=data$UBT, EXTEND=test0),price.fn=Ad) + + test0 = create.leveraged(data$TLT, leverage=3) + proxy.test(list(TMF=data$TMF, EXTEND=test0),price.fn=Ad) + + # please note the difference in the above extension is due to difference in the + # underlying benchmarks. I.e. + # + # http://www.proshares.com/funds/ubt.html + # ProShares Ultra 20+ Year Treasury (UBT) seeks daily investment results + # that correspond to two times (2x) the daily performance of the Barclays U.S. 20+ Year Treasury Bond Index. + # + # http://www.direxioninvestments.com/products/direxion-daily-20-year-treasury-bull-3x-etf + # Direxion Daily 20+ Yr Trsy Bull 3X ETF (TMF) seeks daily investment results + # that correspond to three times (3x) the daily performance of the NYSE 20 Year Plus Treasury Bond Index (AXTWEN). +} + +############################################################################### +# Bundes Bank - long history of gold prices +# http://www.bundesbank.de/Navigation/EN/Statistics/Time_series_databases/Macro_economic_time_series/its_list_node.html?listId=www_s331_b01015_3 +#' @export +############################################################################### +bundes.bank.data <- function(symbol) { + url = paste('http://www.bundesbank.de/cae/servlet/CsvDownload?tsId=', symbol, '&its_csvFormat=en&mode=its', sep='') + temp = read.csv(url, skip=5, header=F, stringsAsFactors=F) + + #hist = make.xts(as.double(temp[,2]), as.Date(temp[,1], '%Y-%m-%d')) + hist = make.xts(as.double(temp[,2]), as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%Y-%m-%d')) + indexClass(hist) = 'Date' + colnames(hist)='Close' + return( hist[!is.na(hist)] ) +} + +#' @export +bundes.bank.data.gold <- function() { + bundes.bank.data('BBEX3.D.XAU.USD.EA.AC.C05') +} + + +############################################################################### +# Pacific Exchange Rate Service - FX rates +# Daily data is maximum for 4 years +# http://fx.sauder.ubc.ca/data.html +# http://fx.sauder.ubc.ca/cgi/fxdata?b=USD&c=AUD&c=GBP&c=CAD&c=NOK&c=EUR&c=JPY&c=NZD&c=SEK&c=CHF&rd=&fd=1&fm=1&fy=2011&ld=31&lm=12&ly=2012&y=daily&q=volume&f=csv&o= +# +# Example +# base.cur = 'USD' +# target.curs = 'AUD,CAD,EUR' +# fx.data = rbind(fx.sauder.data(2000, 2003, base.cur, target.curs), +# fx.sauder.data(2004, 2007, base.cur, target.curs), +# fx.sauder.data(2008, 2011, base.cur, target.curs), +# fx.sauder.data(2012, 2012, base.cur, target.curs)) +#' @export +############################################################################### +fx.sauder.data <- function(start.year, end.year, base.cur, target.curs) { + url = paste('http://fx.sauder.ubc.ca/cgi/fxdata?b=', base.cur, join(paste('&c=', spl(target.curs), sep='')), '&rd=&fd=1&fm=1&fy=', start.year, '&ld=31&lm=12&ly=', end.year, '&y=daily&q=volume&f=csv&o=', sep='') + temp = read.csv(url, skip=1, header=T, stringsAsFactors=F) + + #hist = make.xts(as.matrix(temp[,-c(1:3)]), as.Date(temp[,2], '%Y/%m/%d')) + hist = make.xts(as.matrix(temp[,-c(1:3)]), as.POSIXct(temp[,2], tz = Sys.getenv('TZ'), format='%Y/%m/%d')) + indexClass(hist) = 'Date' + colnames(hist) = gsub(paste('.', base.cur, sep=''), '', colnames(hist)) + + return( hist[!is.na(hist[,1]),] ) +} + + +############################################################################### +# Download historical prices from Pi Trading - Free Market Data +# http://pitrading.com/free_market_data.htm +#' @export +############################################################################### +getSymbols.PI <- function +( + Symbols, + env = .GlobalEnv, + auto.assign = TRUE, + download = TRUE +) +{ + # setup temp folder + temp.folder = paste(getwd(), 'temp', sep='/') + dir.create(temp.folder, F) + + # read all Symbols + for (i in 1:len(Symbols)) { + if(download) { + # http://pitrading.com/free_eod_data/SPX.zip + url = paste('http://pitrading.com/free_eod_data/', Symbols[i], '.zip', sep='') + filename = paste(temp.folder, '/', Symbols[i], '.zip', sep='') + download.file(url, filename, mode = 'wb') + + # unpack + unzip(filename, exdir=temp.folder) + } + + filename = paste(temp.folder, '/', Symbols[i], '.txt', sep='') + + temp = read.delim(filename, header=TRUE, sep=',') + #out = make.xts(temp[,-1], as.Date(temp[,1],'%m/%d/%Y')) + out = make.xts(temp[,-1], as.POSIXct(temp[,1], tz = Sys.getenv('TZ'), format='%m/%d/%Y')) + indexClass(out) = 'Date' + out$Adjusted = out$Close + +cat(i, 'out of', len(Symbols), 'Reading', Symbols[i], '\n', sep='\t') + + if (auto.assign) { + assign(paste(gsub('\\^', '', Symbols[i]), sep='_'), out, env) + } + } + if (!auto.assign) { + return(out) + } else { + return(env) + } +} + + + +############################################################################### +# Download FX qoutes: end of day and hourly +# http://www.fxhistoricaldata.com/EURUSD/ +#' @export +############################################################################### +getSymbols.fxhistoricaldata <- function +( + Symbols, + type = spl('hour,day'), + env = .GlobalEnv, + auto.assign = TRUE, + download = FALSE, + name.has.type = TRUE +) +{ + type = type[1] + type0 = paste0(type,'_') + + # setup temp folder + temp.folder = paste(getwd(), 'temp', sep='/') + dir.create(temp.folder, F) + + # read all Symbols + for (i in 1:len(Symbols)) { + if(download) { + # http://www.fxhistoricaldata.com/download/EURUSD_hour.zip + url = paste('http://www.fxhistoricaldata.com/download/', Symbols[i], '_', type, '.zip', sep='') + filename = paste(temp.folder, '/', Symbols[i], '_', type, '.zip', sep='') + download.file(url, filename, mode = 'wb') + + # unpack + unzip(filename, exdir=temp.folder) + } + + filename = paste(temp.folder, '/', Symbols[i], '_', type, '.csv', sep='') + + temp = read.delim(filename, header=TRUE, sep=',') + colnames(temp) = gsub('[X\\.|\\.]', '', colnames(temp)) + out = make.xts(temp[,spl('OPEN,LOW,HIGH,CLOSE')], + strptime(paste(temp$DATE, temp$TIME), format='%Y%m%d %H:%M:%S')) + +cat(i, 'out of', len(Symbols), 'Reading', Symbols[i], '\n', sep='\t') + + if (auto.assign) { + assign(paste0(gsub('\\^', '', Symbols[i]), iif(name.has.type,type0,'')), out, env) + } + } + if (!auto.assign) { + return(out) + } else { + return(env) + } +} + + + + + + +############################################################################### +# Download historical data for G10 +# The PowerShares DB G10 Currency Harvest Fund +# http://www.invescopowershares.com/products/overview.aspx?ticker=DBV +# +# The G10 currency universe from which the Index selects currently includes +# U.S. dollars, +# euros, +# Japanese yen, +# Canadian dollars, +# Swiss francs, +# British pounds, +# Australian dollars, +# New Zealand dollars, +# Norwegian krone and +# Swedish krona +#' @export +############################################################################### +get.G10 <- function +( + type = spl('currency') +) +{ + if( type[1] != 'currency') { + cat('Warning:', type[1], 'is not yet implemented in getG10 function\n') + return() + } + + # FRED acronyms for daily FX rates +map = ' +FX FX.NAME +DEXUSAL U.S./Australia +DEXUSUK U.S./U.K. +DEXCAUS Canada/U.S. +DEXNOUS Norway/U.S. +DEXUSEU U.S./Euro +DEXJPUS Japan/U.S. +DEXUSNZ U.S./NewZealand +DEXSDUS Sweden/U.S. +DEXSZUS Switzerland/U.S. +' + + map = matrix(scan(text = map, what='', quiet=T), nc=2, byrow=T) + colnames(map) = map[1,] + map = data.frame(map[-1,], stringsAsFactors=F) + + # convert all quotes to be vs U.S. + convert.index = grep('DEXUS',map$FX, value=T) + + #***************************************************************** + # Load historical data + #****************************************************************** + load.packages('quantmod') + + # load fx from fred + data.fx <- new.env() + quantmod::getSymbols(map$FX, src = 'FRED', from = '1970-01-01', env = data.fx, auto.assign = T) + for(i in ls(data.fx)) data.fx[[i]] = na.omit(data.fx[[i]]) + for(i in convert.index) data.fx[[i]] = 1 / data.fx[[i]] + + # extract fx where all currencies are available + bt.prep(data.fx, align='remove.na') + fx = bt.apply(data.fx, '[') + + return(fx) +} + + +############################################################################### +# Download Strategic Portfolios from wealthsimple.com +# +#http://faq.wealthsimple.com/article/121-how-has-the-risk-level-1-portfolio-performed +#http://faq.wealthsimple.com/article/130-how-has-the-risk-level-10-portfolio-performed +#http://faq.wealthsimple.com/article/127-how-has-the-risk-level-7-portfolio-performed +#' @export +############################################################################### +wealthsimple.portfolio = function(portfolio.number = 10) { + # download + url = paste0('http://faq.wealthsimple.com/article/', 120+portfolio.number, '-how-has-the-risk-level-',portfolio.number,'-portfolio-performed') + txt = join(readLines(url)) + + # extract + temp = extract.table.from.webpage(txt, 'Breakdown', has.header = F) + + # parse + temp = gsub(pattern = '%', replacement = '', temp) + temp = trim(temp[,c(2,4)]) + temp = temp[!is.na(temp[,1]),] + + # create output + value = as.numeric(temp[,2]) + names(value) = temp[,1] + value +} + + +wealthsimple.portfolio.test = function() { + # create list of all portolios + portfolios = list() + for(i in 1:10) + portfolios[[i]] = wealthsimple.portfolio(i) + + portfolios = t(sapply(portfolios, identity)) + + # look at evolution of mixes + plota.stacked(1:10, portfolios/100, flip.legend = T, type='s', xaxp=c(1,10,9), las=1, + main='Wealthsimple Transition Matrix', xlab='Risk Portfolio') +} + + +############################################################################### +# getSymbols interface to tradingblox free futures and forex data +# http://www.tradingblox.com/tradingblox/free-historical-data.htm +# http://www.tradingblox.com/Data/DataOnly.zip +# Date, Open, High, Low, Close, Volume (zero for forex cash markets), +# Open Interest (futures only), Delivery Month ( YYYYMM futures only), +# Unadjusted Close (zero for forex cash markets) +#' @export +############################################################################### +getSymbols.TB <- function( + env = .GlobalEnv, + auto.assign = TRUE, + download = FALSE, + type = c('Both', 'Futures', 'Forex'), + rm.index = 'PB', # remove Pork Bellies because not traded + clean = FALSE, + custom.adjustments = TRUE +) +{ + # download zip archive + if(download) { + download.file('http://www.tradingblox.com/Data/DataOnly.zip', 'DataOnly.zip') + } + + # setup temp folder + temp.folder = paste(getwd(), 'temp', sep='/') + dir.create(temp.folder, F) + + ##***************************************************************** + ## Unzip + ##****************************************************************** + temp.folder = paste(getwd(), '/', 'temp', sep='') + + # clean temp + if(clean) shell('del /F /S /Q temp\\*.*', wait = TRUE) + + # unpack + files = unzip('DataOnly.zip', exdir=temp.folder) + + # read definitions, based on Financial Instrument Model Infrastructure for R package from http://r-forge.r-project.org/R/?group_id=316 + def1 = try(read.csv('http://www.tradingblox.com/tradingblox/CSIUA/FuturesInfo.txt',skip=1,header=FALSE, stringsAsFactors=F),TRUE) + if(inherits(def1, 'try-error')) def1 = read.csv('FuturesInfo.txt',skip=1,header=FALSE, stringsAsFactors=F) + def1 = def1[-match(rm.index, def1[,1]),] + def1[,3] = 'Futures' + + def2 = try(read.csv('http://www.tradingblox.com/tradingblox/CSIUA/ForexInfo.txt',skip=1,header=FALSE, stringsAsFactors=F),TRUE) + if(inherits(def2, 'try-error')) def2 = read.csv('ForexInfo.txt',skip=1,header=FALSE, stringsAsFactors=F) + def2[,3] = 'Forex' + + def = rbind(def1[,1:4], def2[,1:4]) + if(type[1] == 'Futures') def = def1[,1:4] + if(type[1] == 'Forex') def = def2[,1:4] + + + # read all files + for( i in 1:nrow(def) ) { + symbol = def[i,1] + + filename = paste(temp.folder, '/', def[i,3], '/', def[i,4], sep='') + if(file.exists(filename)) { + fr <- read.csv(filename, header = FALSE) + fr <- make.xts(fr[,-1], as.Date(as.character(fr[,1]),'%Y%m%d')) + colnames(fr) <- spl('Open,High,Low,Close,Volume,OpenInterest,DeliveryMonth,Unadjusted')[1:ncol(fr)] + fr$Adjusted = fr$Close + if (auto.assign) assign(symbol, fr, env) +cat(i, 'out of', nrow(def), 'Reading', symbol, format(index.xts(fr)[1],'%Y%m%d'), format(index.xts(fr)[nrow(fr)],'%Y%m%d'), '\n', sep='\t') + } else { +cat('\t\t\t Missing data for ', symbol, '\n'); + } + } + + #***************************************************************** + # Add symbolnames, symbol.descriptions, and symbol.groups + #****************************************************************** + index = match(ls(env)[ na.omit(match(def[,1], ls(env))) ], def[,1]) + + + temp = def[index,1] + names(temp) = def[index,1] + env$symbolnames = temp + + temp = def[index,2] + names(temp) = def[index,1] + env$symbol.descriptions = temp + + temp = def[index,3] + names(temp) = def[index,1] + env$symbol.groups = temp + + #***************************************************************** + # Process symbol descriptions to be more readable + #****************************************************************** + names = trim(gsub(pattern = '\\(.*?\\)', replacement = '', env$symbol.descriptions, perl = TRUE)) + names = trim(gsub('-NYMEX','',names,ignore.case =T)) + names = trim(gsub('-COMEX','',names,ignore.case =T)) + names = trim(gsub('-CBT','',names,ignore.case =T)) + names = trim(gsub('-CME-','',names,ignore.case =T)) + names = trim(gsub('-CME','',names,ignore.case =T)) + names = trim(gsub('-NYCE','',names,ignore.case =T)) + names = trim(gsub('-Globex','',names,ignore.case =T)) + names = trim(gsub('-FINEX','',names,ignore.case =T)) + names = trim(gsub('-CSCE','',names,ignore.case =T)) + names = trim(gsub(' w/Prj A','',names,ignore.case =T)) + + env$symbol.descriptions.print = names + + #***************************************************************** + # Custom adjustments + #****************************************************************** + data = env + + # fix DX time series - fixed by the Trading Blox + # if(!is.null(data$DX)) data$DX['::2007:04:04', 'Unadjusted'] = coredata(data$DX['::2007:04:04']$Unadjusted * 10) + + if( custom.adjustments ) { + #***************************************************************** + # filename = 'temp\\Futures\\LH_0_I0B.TXT' + # fr <- read.csv(filename, header = FALSE) + # fr <- make.xts(fr[,-1], as.Date(as.character(fr[,1]),'%Y%m%d')) + # colnames(fr) <- spl('Open,High,Low,Close,Volume,OpenInterest,DeliveryMonth,Unadjusted') + # LH = fr + # LH$DiffClose = LH$Close - mlag(LH$Close) + # LH$DiffUnadjusted = LH$Unadjusted - mlag(LH$Unadjusted) + # LH = LH['2000:03:08::2000:03:15',spl('Close,DeliveryMonth,Unadjusted,DiffClose,DiffUnadjusted')] + # LH + # + # Close DeliveryMonth Unadjusted DiffClose DiffUnadjusted + # 2000-03-08 187.150 200004 59.450 -0.150 -0.150 + # 2000-03-09 188.450 200004 60.750 1.300 1.300 + # 2000-03-10 189.750 200004 62.050 1.300 1.300 + # 2000-03-13 189.600 200006 71.175 -0.150 9.125 + # 2000-03-14 189.575 200006 71.150 -0.025 -0.025 + # 2000-03-15 189.325 200006 70.900 -0.250 -0.250 + # + # There is a roll 2000-03-10, we switch from contract expiring on 200004 to contract expiring on 200006 + # The returns on + # 2000-03-09: 1.300 / 59.450 + # 2000-03-10: 1.300 / 60.750 + # # for the first day after roll, let's use denominator as the price of new contract + # # because numerator is the change in price of new contract + # # the 71.175 - -0.150 is the price on new contract on 2000-03-10 + # 2000-03-13: -0.150 / (71.175 - -0.150) + # 2000-03-14: -0.025 / 71.175 + # 2000-03-15: -0.025 / 71.150 + #***************************************************************** + + #***************************************************************** + # To compute returns and backtest, recreate each futures series: + # + # (unadjusted-futures[t-1] + (back-adjusted-futures[t] - back-adjusted-futures[t-1])) + # futures-return[t] = -------------------------------------------------------------------------------------------------- - 1 + # unadjusted-futures[t-1] + #****************************************************************** + for(i in data$symbolnames[data$symbol.groups != 'Forex']) { + # find rolls; alternatively can use DeliveryMonth field + spot = as.vector(data[[i]]$Unadjusted) + dspot = spot - mlag(spot) + futures = as.vector(data[[i]]$Adjusted) + dfutures = futures - mlag(futures) + index = which(round(dspot - dfutures,4) != 0 ) + + # for return calculations set spot on the roll to the new contract price + spot.adjust.roll = spot + spot.adjust.roll[(index-1)] = spot.adjust.roll[index] - dfutures[index] + + # compute returns + reta = dfutures / mlag(spot.adjust.roll) + reta[1] = 0 + n = len(spot) + + new.series = cumprod(1 + reta) + # make new series match the last spot price + data[[i]]$Adjusted = data[[i]]$Close = spot[n] * new.series / new.series[n] + } +} + + #***************************************************************** + # Done + #****************************************************************** + if (!auto.assign) { + return(fr) + } else { + return(env) + } +} + +############################################################################### +# Data contains historical time series for both +# * Spot ( Unadjusted - unadjusted-futures ) and +# * Future ( Adjusted - back-adjusted-futures) +# +# First step, I updated Spot to include roll yield (i.e. spot.adjust.roll) +# Next, I computed returns as change in futures relative to the spot.adjust.roll level +#I.e. return is +# +# (unadjusted-futures[t-1] + (back-adjusted-futures[t] - back-adjusted-futures[t-1])) +# ------------------------------------------------------------------------------------ - 1 +# unadjusted-futures[t-1] +# +# Change in back-adjusted-futures +# = -------------------------------- +# Prior Unadjusted-futures level (which i adjusted for roll yield) +# +# http://www.automated-trading-system.com/crude-oil-contango-and-roll-yield-for-commodity-trading/ +############################################################################### +getSymbols.TB.test = function() { + filename = 'temp/Futures/CL20_I0B.TXT' + i = 'CL' + data = env() + fr <- read.csv(filename, header = FALSE) + fr <- make.xts(fr[,-1], as.Date(as.character(fr[,1]),'%Y%m%d')) + colnames(fr) <- spl('Open,High,Low,Close,Volume,OpenInterest,DeliveryMonth,Unadjusted')[1:ncol(fr)] + fr$Adjusted = fr$Close + data[[i]] = fr + + # Unadjusted is Spot (unadjusted-futures) + # Adjusted is Close is Future (back-adjusted-futures) + + # adjust spot for roll overs + spot = as.vector(data[[i]]$Unadjusted) + dspot = spot - mlag(spot) + futures = as.vector(data[[i]]$Adjusted) + dfutures = futures - mlag(futures) + index = which(round(dspot - dfutures,4) != 0 ) + + spot.adjust.roll = spot + spot.adjust.roll[(index-1)] = spot.adjust.roll[index] - dfutures[index] + + # compute returns + reta = (mlag(spot.adjust.roll) + futures - mlag(futures)) / mlag(spot.adjust.roll) + reta[1] = 1 + n = len(spot) + + new.series = cumprod(reta) + Close = spot[n] * new.series / new.series[n] + + plot.data = as.xts(list( + Unadjusted = data[[i]]$Unadjusted, + Adjusted = data[[i]]$Adjusted, + Implied.Close = make.xts(Close, index(data[[i]])) + )) + +png(filename = 'plot_CL_2009.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white') + + plota.matplot( scale.one(plot.data['2009']), main='Crude oil, CL - 2009') + +dev.off() + +} + + +############################################################################### +# Kenneth R. French - Data Library +# http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/data_library.html +############################################################################### +# http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/F-F_Research_Data_Factors.zip +# http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/F-F_Research_Data_Factors_weekly.zip +# http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/F-F_Research_Data_Factors_daily.zip +# +# data2 = get.fama.french.data('F-F_Research_Data_Factors', periodicity = 'weeks',download = F, clean = F) +# data3 = get.fama.french.data('6_Portfolios_2x3', periodicity = 'days',download = F, clean = F) +#' @export +############################################################################### +get.fama.french.data <- function( + name = c('F-F_Research_Data_Factors', 'F-F_Research_Data_Factors'), + periodicity = c('days','weeks', 'months'), + force.download = FALSE, + clean = FALSE, + file.suffix = '_TXT' +) +{ + warning('get.fama.french.data is depreciated as of Apr 25, 2016 please use data.ff function instead') + data.ff(name, periodicity, force.download, clean, file.suffix) +} + +#' @export +data.ff <- function( + name = c('F-F_Research_Data_Factors', 'F-F_Research_Data_Factors'), + periodicity = c('days','weeks', 'months'), + force.download = FALSE, + clean = FALSE, + file.suffix = '_TXT' +) +{ + # map periodicity + map = c(days = '_daily', weeks = '_weekly', months = '') + + # url + period = ifna(map[periodicity[1]], periodicity[1]) + filename.zip = paste(name[1], period, file.suffix, '.zip', sep='') + filename.txt = paste(name[1], period, '.txt', sep='') + url = paste('http://mba.tuck.dartmouth.edu/pages/faculty/ken.french/ftp/', filename.zip, sep='') + + # download zip archive + if( !file.exists(filename.zip) || force.download) + download.file(url, filename.zip) + +## download using curl !!!! + + # setup temp folder + temp.folder = paste(getwd(), 'temp', sep='/') + dir.create(temp.folder, F) + + ##***************************************************************** + ## Unzip + ##****************************************************************** + temp.folder = paste(getwd(), '/', 'temp', sep='') + + # clean temp + if(clean) shell('del /F /S /Q temp\\*.*', wait = TRUE) + + # unpack + files = unzip(filename.zip, exdir=temp.folder) + + if(len(files) == 1) { + filename = paste(temp.folder, '/', filename.txt, sep='') + return( data.ff.internal.one.file(filename) ) + } + + data = env() + library(stringr) + names = str_trim(str_match(files,'.*/(.*)\\..*')[,2]) + for(i in 1:len(files)) + data[[ names[i] ]] = data.ff.internal.one.file(files[i]) + + data +} + + +# internal helper function +data.ff.internal.one.file = function(filename) { + out = readLines(filename) + index = which(nchar(out) == 0) + + data.index = grep('^[ 0-9\\.\\+-]+$', out) + temp.index = which(diff(data.index) > 1) + data.index = matrix(data.index[sort(c(1, temp.index, temp.index+1, len(data.index)))], nc=2, byrow=T) + + # extract sections + data = list() + for(i in 1:nrow(data.index)) { + start.index = index[which( index > data.index[i,1] ) - 1][1] + 1 + if(is.na(start.index)) start.index = index[len(index)] + 1 + end.index = data.index[i,1] - 1 + n.index = end.index - start.index + 1 + + # column names + name = 'data' + colnames = scan(text = out[start.index], what='', quiet=T) + if(n.index == 2) { + name = trim(out[start.index]) + colnames = scan(text = out[end.index], what='', quiet=T) + + colnames1 = scan(text = out[end.index+1], what='', quiet=T) + if(len(colnames) > len(colnames1)) { + cindex = which(diff(gregexpr(' ',out[end.index+1])[[1]]) > 1) + cindex = c(1, gregexpr(' ',out[end.index+1])[[1]][(cindex+1)], nchar(out[end.index])+1) + colnames = rep('', len(cindex)-1) + for(j in 2:len(cindex)) + colnames[j-1] = substr(out[end.index], cindex[j-1], cindex[j]-1) + colnames = trim(colnames) + colnames = colnames[nchar(colnames) > 0] + } + + } else if(n.index > 2) { + name = trim(out[start.index]) + colnames0 = scan(text = out[(end.index-1)], what='', quiet=T) + colnames1 = scan(text = out[end.index], what='', quiet=T) + colnames = paste(rep(colnames0, each = len(colnames1) / len(colnames0)), colnames1, sep='.') + } + colnames = gsub('-', '.', colnames) + #out[start.index:end.index] + + # re-read data + temp = matrix(scan(filename, what = double(), quiet=T, + skip = (data.index[i,1]-1), + nlines = (data.index[i,2] - data.index[i,1]+1)) + , nc=len(colnames)+1, byrow=T) + + date.format = '%Y%m%d' + date.format.add = '' + date.format.n = nchar(paste(temp[1,1])) + + if( date.format.n == 6 ) { + date.format.add = '01' + } else if( date.format.n == 4 ) { + date.format.add = '0101' + } + + find.name = function(name,data, i=0) if( is.null(data[[name]]) ) name else find.name(paste(name,i+1), data, i+1) + name = find.name(name, data) + + data[[name]] = make.xts(temp[,-1], as.Date(paste(temp[,1], date.format.add, sep=''),date.format)) + colnames(data[[name]]) = colnames + } + return( data ) +} + + + + + + +############################################################################### +# CBOE Futures +#' @export +############################################################################### +download.helper <- function(url,download) { + # setup temp folder + temp.folder = paste(getwd(), 'temp', sep='/') + dir.create(temp.folder, F) + + filename = paste0(temp.folder, '/', basename(url)) + if(download || !file.exists(filename)) + try(download.file(url, filename, mode='wb'), TRUE) + filename +} + + +# Update files, download = T +#for(y in date.year(Sys.Date()):(1+date.year(Sys.Date()))) +# for(m in 1:12) { +# temp = getSymbol.CBOE('VX', m, y, T) +#' @export +getSymbol.CBOE <- function +( + Symbol, + Month, + Year, + download = FALSE +) +{ + + # month codes of the futures + m.codes = spl('F,G,H,J,K,M,N,Q,U,V,X,Z') + + url = paste0("http://cfe.cboe.com/Publish/ScheduledTask/MktData/datahouse/CFE_", + m.codes[Month], substring(Year,3,4), '_', Symbol, '.csv') + + filename = download.helper(url, download) + if(file.exists(filename) && file.info(filename)$size > 1) + read.xts(filename, format='%m/%d/%Y') + else + NULL +} + + +# SPX Volatility Term Structure +#' @export +cboe.volatility.term.structure.SPX <- function(make.plot = T) { + url = 'http://www.cboe.com/data/volatilityindexes/volatilityindexes.aspx' + txt = join(readLines(url)) + + temp.table = extract.table.from.webpage(txt, 'Trade Date', has.header = T) + colnames(temp.table) = gsub(' ','.',trim(tolower(colnames(temp.table)))) + temp.table = data.frame(temp.table) + temp.table$trade.date = as.POSIXct(temp.table$trade.date, format="%m/%d/%Y %I:%M:%S %p") + temp.table$expiration.date = as.Date(temp.table$expiration.date, "%d-%b-%y") + temp.table[,3] = as.numeric(as.character(temp.table[,3])) + temp.table[,4] = as.numeric(as.character(temp.table[,4])) + temp.table + + if(make.plot) { + plot(temp.table$expiration.date, temp.table$vix, type = 'b', + main=paste('VIX Term Structure, generated ', max(temp.table$trade.date)), + xlab = 'Expiration Month', ylab='VIX Index Level') + grid() + } + + temp.table +} + + +#' @export +load.VXX.CBOE <- function() { + # https://r-forge.r-project.org/scm/viewvc.php/pkg/qmao/R/getSymbols.cfe.R?view=markup&root=twsinstrument + index = "::2007-03-25" + fields = spl('Open,High,Low,Close,Settle') + + # days remaining before settlement, on a given date + dr <- function(index, date) sum(index>date) + + data <- new.env() + futures = list() + i = 1 + for(y in 2004:(1+date.year(Sys.Date()))) + for(m in 1:12) { + temp = getSymbol.CBOE('VX', m, y) + if(is.null(temp)) next + + temp = temp[temp$Settle > 0] + if(nrow(temp)==0) next + if(len(temp[index,1])> 0) + temp[index,fields] = temp[index,fields]/10 + + label = paste0(y*100+m) + dates = index(temp) + + futures[[ i ]] = list() + futures[[ i ]]$data = temp + futures[[ i ]]$label = label + futures[[ i ]]$index = dates + futures[[ i ]]$settle.date = last(dates) + # set roll period of each future + if(i==1) + futures[[ i ]]$dt = len(dates) + else + futures[[ i ]]$dt = dr(dates, futures[[ i-1 ]]$settle.date) + + temp$i = i + #number of business days in roll period + temp$dt = futures[[ i ]]$dt + # number of remaining dates in the first futures contract + temp$dr = (len(dates)-1):0 + data[[ label ]] = temp + + i = i + 1 + } + + bt.prep(data, align='keep.all') + + # debug + # bt.apply(data, function(x) x[,'dr'])[1150:1160,48:55] + # count(t(coredata(bt.apply(data, function(x) x[,'Settle'])))) + + data +} + +#' @export +extract.VXX.CBOE <- function(data, field, index, exact.match=T) { + map = 1:ncol(data$prices) + + temp = bt.apply(data, function(x) x[,field]) + temp = coredata(temp) + + t(apply(temp, 1, function(x) { + if(exact.match) { + pos = map[!is.na(x)][1] - 1 + x[(index + pos)] + } else { + pos = map[!is.na(x)][index] + x[pos] + } + })) +} + + + +# Reconstructing VXX from CBOE futures data +# http://tradingwithpython.blogspot.ca/2012/01/reconstructing-vxx-from-cboe-futures.html +# for VXX calculation see http://www.ipathetn.com/static/pdf/vix-prospectus.pdf +# page PS-20 +#' @export +reconstruct.VXX.CBOE <- function(exact.match=T) { + data = load.VXX.CBOE() + + dt = extract.VXX.CBOE(data, 'dt', 1, exact.match)[1,] + dr = extract.VXX.CBOE(data, 'dr', 1, exact.match)[1,] + x = extract.VXX.CBOE(data, 'Settle', 1:2, exact.match) + + # for VXX calculation see http://www.ipathetn.com/static/pdf/vix-prospectus.pdf + # page PS-20: 1/2 months + # VXX Short-Term + w = cbind(dr / dt, (dt - dr) / dt) + val.cur = rowSums(x * mlag(w)) + val.yest = rowSums(mlag(x) * mlag(w)) + ret = val.cur / val.yest - 1 + + # on roll it is simply future2's return + index = ifna(mlag(dr) == 0, F) + ret[index] = (x[,1] / mlag(x[,2]) - 1)[index] + + Close = cumprod(1+ifna(ret,0)) + VXX = make.xts(cbind(Close,x,dt,dr,ret), data$dates) + + # VXZ Mid-Term: 4,5,6,7 months + x = extract.VXX.CBOE(data, 'Settle', 4:7, exact.match) + + w = cbind(dr / dt, 1, 1, (dt - dr) / dt) + val.cur = rowSums(x * mlag(w)) + val.yest = rowSums(mlag(x) * mlag(w)) + ret = val.cur / val.yest - 1 + + index = ifna(mlag(dr) == 0, F) + ret[index] = (rowSums(x[,-4]) / mlag(rowSums(x[,-1])) - 1)[index] + + Close = cumprod(1+ifna(ret,0)) + VXZ = make.xts(cbind(Close,x,dt,dr,ret), data$dates) + + # debug + # plota(VXZ,type='l',lwd=2) + # write.xts(VXZ, file='vix-mid.txt') + + list(VXX = VXX, VXZ = VXZ) +} + + +############################################################################### +# Load Country Codes from +# http://www.nationsonline.org/oneworld/country_code_list.htm +#' @export +############################################################################### +country.code = function +( + force.download = FALSE, + data.filename = 'country.code.Rdata' +) +{ + if(!force.download && file.exists(data.filename)) { + load(file=data.filename) + return(temp) + } + + url = 'http://www.nationsonline.org/oneworld/country_code_list.htm' + + library(curl) + #curl_download(url, file,mode = 'wb',quiet=T) + #txt = join(readLines(url)) + txt = rawToChar(curl_fetch_memory(url)$content) + + temp = extract.table.from.webpage(txt, 'Country or Area Name') + temp = trim(temp[,c(2:5)]) + colnames(temp)=spl('name,code2,code3,code') + save(temp,file=data.filename) + temp +} + + +############################################################################### +# Search/Lookup tickers at http://markets.ft.com +#' +#' @examples +#' \dontrun{ +#' data.ft.search.ticker('s&p 500') +#' } +#' @export +#' @rdname DataFTFunctions +############################################################################### +data.ft.search.ticker = function +( + search.field = 'tsx', + sec.type = 'IN' +) +{ + #[search](http://markets.ft.com/Research/Markets/Company-Search?searchField=tsx&country=&secType=IN) + url = paste0('http://markets.ft.com/Research/Markets/Company-Search?searchField=', curl_escape(search.field), '&country=&secType=', sec.type) + + library(curl) + h = new_handle() + req = curl_fetch_memory(url, h) + if(req$status_code != 200) + warning('error getting data, status_code:', req$status_code, 'for url:', url, 'content:', rawToChar(req$content)) + + txt = rawToChar(req$content) + + # cat(txt, file='dump.txt') # save to analyze + # gregexpr('TSEA:TOR',txt) # find location + # substr(txt, 20400,20800) + + # extract links + temp = gsub(pattern = '', replacement = '', temp, perl = TRUE) + + temp = extract.table.from.webpage(temp, 'Symbol,Exchange,Country') + + + colnames(temp)[1:4] = spl('Name,Symbol,Exchange,Country') + temp[,1:4] +} + + +############################################################################### +# List Index Members at http://markets.ft.com +#' [sp500](http://markets.ft.com/research/Markets/Tearsheets/Constituents?s=INX:IOM) +#' [tsx](http://markets.ft.com/research/Markets/Tearsheets/Constituents?s=TSEA:TOR) +#' [ftse](http://markets.ft.com/research/Markets/Tearsheets/Constituents?s=FTSE:FSI) +#' +#' [get industry/sector information from yahoo finance](https://ca.finance.yahoo.com/q/pr?s=RY.TO) +#' +#' @examples +#' \dontrun{ +#' data.ft.index.members('TSEA:TOR') +#' } +#' @export +#' @rdname DataFTFunctions +############################################################################### +data.ft.index.members = function +( + ft.symbol = 'INX:IOM', + force.download = FALSE, + data.filename = paste0(gsub(':','_',ft.symbol),'.Rdata'), + data.keep.days = 30 +) +{ + # if NOT forced to download and file exists and file is less than 30 days old + if( !force.download && + file.exists(data.filename) && + as.numeric(Sys.Date() - as.Date(file.mtime(data.filename))) <= data.keep.days + ) { + load(file=data.filename) + return(data) + } + + #h = handle_setopt(h, useragent = "moo=moomooo", referer) + # + # Main Page + # + #[sp500](http://markets.ft.com/research/Markets/Tearsheets/Constituents?s=INX:IOM) + url = paste0('http://markets.ft.com/research/Markets/Tearsheets/Constituents?s=', ft.symbol) + + #[The curl package: a modern R interface to libcurl](https://cran.r-project.org/web/packages/curl/vignettes/intro.html) + library(curl) + h = new_handle() + txt = rawToChar(curl_fetch_memory(url, h)$content) + + # extract links + temp = gsub(pattern = '', replacement = '', temp, perl = TRUE) + + temp = extract.table.from.webpage(temp, 'Equities') + + # + # Paging + # + library(stringr) + token = extract.token(txt,'
    ','
    ') + nstep = str_match(token,' data-ajax-paging-end-row="([0-9]+)">')[2] + nstep = as.numeric(nstep) + nfound = str_match(token,' data-ajax-paging-total-rows="([0-9]+)">')[2] + nfound = as.numeric(nfound) + + data = matrix('',nr=nfound,nc=2) + colnames(data) = spl('Name,Symbol') #spl('Name,Symbol,LastPrice,TodayChange,YearChange') + data[1:nstep,] = temp[,1:2] + + #[PhantomJS](http://stackoverflow.com/questions/15739263/phantomjs-click-an-element) + #[Short R tutorial: Scraping Javascript Generated Data with R](https://www.datacamp.com/community/tutorials/scraping-javascript-generated-data-with-r) + #[webshot::install_phantomjs()](https://cran.r-project.org/web/packages/webshot/index.html) + # + # URL options + # + #[Firefox - Web Developer Tools] + # Log request and Response Bodies + token = extract.token(txt,'
    ','
    ') + token = spl(token,'', replacement = '', temp, perl = TRUE) + + temp = extract.table.from.webpage(temp, has.header=F) + + data[istart:min(istart+nstep-1,nfound),] = temp[,1:2] + } + + if( file.exists(data.filename) && requireNamespace('ftouch', quietly = T) ) { + data.copy = data + load(file=data.filename) + + if( all.equal(data.copy, data) ) { + ftouch::touch(data.filename) + return(data) + } + } + + save(data,file=data.filename) + data +} + +# +# data function template: +# +# introduce following parameters: +# force.download = FALSE - flag to indicate that data need to be updated +# data.filename = 'data.Rdata' - location to save data +# data.keep.days = 30 - number of days that data does not need to be refreshed +# +# # if NOT forced to download and file exists and file is less than 30 days old +# if( !force.download && +# file.exists(data.filename) && +# as.numeric(Sys.Date() - as.Date(file.mtime(data.filename))) <= data.keep.days +# ) { +# load(file=data.filename) +# return(data) +# } +# +# Once data is downloaded check if needs to be saved +# +# if( file.exists(data.filename) && requireNamespace('ftouch', quietly = T) ) { +# data.copy = data +# load(file=data.filename) +# +# if( all.equal(data.copy,data) ) { +# ftouch::touch(data.filename) +# return(data) +# } +# } +# +# save(data,file=data.filename) +# data +#} +# + + +############################################################################### +# Data from https://www.ishares.com/us/products/etf-product-list +#' +#' [Download File in R with POST while sending data](https://stackoverflow.com/questions/34864162/download-file-in-r-with-post-while-sending-data) +#' +#' @examples +#' \dontrun{ +#' data.ishares.universe() +#' } +#' @export +#' @rdname DataFTFunctions +############################################################################### +data.ishares.universe = function +( + portfolios="239726-239623-239458-239566-239706-239763-239708-239637-239710-239467-239774-239565-239665-239826-239707-239500-239725-239695-239718-239644-244049-239451-244050-239452-239728-239456-239454-239465-239561-239719-239626-239766-239699-239572-239463-239717-239714-239855-239712-239709-239455-239600-239627-239563-239762-239650-239764-239723-239536-239520-239482-239724-239466-259622-239775-239681-239659-239641-239612-239534-239773-239605-239615-239499-239628-239736-256101-239686-239522-239622-239601-239854-239464-239468-239674-268708-244048-239690-239619-239594-239511-239657-239607-239737-239744-239670-239512-239507-251614-239508-239685-239741-239524-239768-239772-239506-264617-239516-239423-239683-239513-239505-239746-258100-239713-239757-239460-239769-239453-239580-239664-239543-239514-239761-239715-239750-239510-239830-239756-251616-239758-239716-239540-272532-239502-239771-239450-264619-239740-239523-239457-259623-239519-239579-239720-259624-239678-244051-239501-239509-239731-239582-239503-239661-239667-264615-239765-239545-239680-239649-264623-239517-239751-239521-239729-239689-239705-239648-239588-239618-239528-239462-239688-239692-239669-239684-239730-239677-239581-270319-239675-239668-239739-239733-239696-239459-239518-239645-271054-239585-239767-239742-239671-239606-251465-239583-268704-239676-239586-239584-239753-239748-239430-251474-239745-239752-279626-239666-239550-239614-239424-239662-239722-239655-239734-268752-239526-258098-239610-271056-239831-239429-272342-239654-272341-239663-239629-254263-264507-239759-239587-239829-239461-239621-239551-258510-254551-239504-239672-239721-239642-239515-254553-272343-269394-272824-239609-239738-239529-239539-239544-239431-239527-254555-272340-260973-239660-264503-239537-271544-251476-239770-272822-239693-239443-272344-239735-272346-264273-264613-239656-273753-251477-272345-275382-239445-239653-276546-264542-264275-272112-264544-239613-264611-273746-276544-239570-239652-239651-239530-239525-239647-239620-260652-260975-239673-272819-254562-271540-258806-239552-283378-239691-271538-264127-239444-273743-273775-239638-275389-280052-273771-272825-275397-264606-253433-280049-272823-275384-271542-272821-273750-272820-273763-279286-270316-280048-280051-280050-275399-280769-273748-280771-273766-280774-273759-273768", + # above list must be updated manually :( + force.download = FALSE, + data.filename = 'ishares.universe.Rdata', + data.folder = paste(getwd(), 'data.ishares', sep='/'), + data.keep.days = 30 +) +{ + data.filename = file.path(data.folder, data.filename) + + # if NOT forced to download and file exists and file is less than 30 days old + if( !force.download && + file.exists(data.filename) && + as.numeric(Sys.Date() - as.Date(file.mtime(data.filename))) <= data.keep.days + ) { + load(file=data.filename) + return(data) + } + + # make sure folder exists + dir.create(data.folder, F) + + # get data + url = 'https://www.ishares.com/us/product-screener-download.dl' + + library(curl) + h = new_handle() + handle_setopt(h, useragent = 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:36.0) Gecko/20100101 Firefox/36.0', referer='https://www.ishares.com/us/products/etf-product-list') + handle_setopt(h, customrequest = 'POST') + handle_setopt(h, postfields=paste0('productView=ishares&portfolios=', portfolios)) + + req = curl_fetch_memory(url, h) + if(req$status_code != 200) + warning('error getting data, status_code:', req$status_code, 'for url:', url, 'content:', rawToChar(req$content)) + + txt = rawToChar(req$content) + + # nchar(txt) + # write.file(txt,file='text.txt') + + # export data + temp = gsub('', '
    ', txt, perl = T, ignore.case = T) + temp = gsub('
    ', '', temp, perl = T, ignore.case = T) + temp = gsub('', '', temp, perl = T, ignore.case = T) + temp = gsub('', '', temp, perl = T, ignore.case = T) + temp = gsub('REP_\\1_IDX_\\1_ 0,] + month = temp[,1] + day = temp[,2] + + status = paste0( + ifna( str_match(day, '\\(.*\\)'), ''), + ifna( str_match(day, '\\*'), '') + ) + status = gsub('\\(','',gsub('\\)','',status)) + + day = str_replace(day, '(\\(.*?\\))','') + day = str_replace(day, '\\*','') + + day = paste(year, + sapply( iif(grepl('/',month), month, paste0(month,'/',month)), spl, '/'), + sapply( iif(grepl('-',day), day, paste0(day,'-',day)), spl, '-') + ) + day = matrix(day, nc=2, byrow=T) + + for(i in 1:len(status)) add(sb, day[i,1], day[i,2], status[i]) + } + data = matrix(scan(what='',text= string(sb),sep=',', quiet=T),nc=3,byrow=T) + close(sb) + sb=NULL + + first.year = min(as.numeric(substr(data[,1],1,4))) + recent.data = data + + # check if update is needed + if(!force.download && file.exists(data.filename)) { + load(file=data.filename) + # check if data needs to be updates + if( last(FOMC$day) == as.Date(last(recent.data[,2]),'%Y %B %d') ) + return(FOMC) + } + + # extract data from page + sb = string.buffer() + for(year in 1936:(first.year-1)) { + cat(year,'\n') + url = paste0('http://www.federalreserve.gov/monetarypolicy/fomchistorical', year, '.htm') + txt = join(readLines(url)) + + tokens = spl(txt,'
    ') + + for(token in tokens[-1]) + add(sb, colnames(extract.table.from.webpage(token, 'year'))[1]) + } + + data = scan(what='',text= string(sb),sep='\n', quiet=T) + close(sb) + sb=NULL + + # remove year + year = substring(data,nchar(data)-3) + day = tolower(substring(data,1,nchar(data)-4)) + # remove Conference Call, Conference Calls, Meeting, Meetings + status = paste0( + iif(grepl('conference call',day), 'conference call', ''), + iif(grepl('meeting',day), 'meeting', '') + ) + + day = gsub('conference call', '', gsub('conference calls','',day)) + day = gsub('meeting', '', gsub('meetings','',day)) + + day = gsub(',', '-', gsub('and', '',day)) + +#[870] "october 15 " +#[871] "november 2-3 " +#[872] "december 14 " +#[615] "october 21- 22- 23- 26- 27- 28- 29- 30 " +#[680] "june 30-july 1 " + + + # helper fn + parse.token = function(year, token) { + parts = trim(spl(token,'-')) + n = len(parts) + if( n > 1 ) { + month = ifna.prev(iif(nchar(parts) > 3, + sapply(parts, function(x) spl(x, ' ')[1]), # first token + NA)) + parts = iif(nchar(parts) > 3, parts, paste(month, parts)) + } + paste(year, parts[c(1,n)]) + } + + day = sapply(1:len(day), function(i) parse.token(year[i], day[i])) + all.data = rbind(cbind(t(day), status), recent.data) + + FOMC = list(day = as.Date(all.data[,2],'%Y %B %d'), start.day = as.Date(all.data[,1],'%Y %B %d'), status=all.data[,3]) + save(FOMC,file=data.filename) + FOMC +} + +# todo comute a$start.day - mlag(a$day) in buisness days +# parse Minutes: See end of minutes of October 29-30 meeting / (Released November 20, 2013) +# Minutes: See end of minutes of December 11 meeting / Minutes (Released Jan 2, 2008) + + +############################################################################### +# Get EDGAR info +# www.sec.gov/cgi-bin/browse-edgar?CIK=AAPL&Find=Search&owner=exclude&action=getcompany +# mktstk.wordpress.com/2015/03/03/sic-lookup-by-stock-symbol/ +#' @export +############################################################################### +edgar.info <- function(ticker) +{ + # please note readLines only works with http, for more detail please read + # http://stackoverflow.com/questions/26540485/readlines-does-not-read-from-https-url-when-called-from-systemrscript + url = paste0('http://www.sec.gov/cgi-bin/browse-edgar?CIK=', ticker, '&Find=Search&owner=exclude&action=getcompany') + txt = join(readLines(url)) + out = list() + + # extract table from this page + temp = extract.table.from.webpage(txt, 'seriesDiv,Filings', has.header = T) + out$fillings= clean.table(temp) + + temp = extract.token(txt, 'contentDiv,mailer,Mailing Address','
    ') + out$mailing = t(clean.table(extract.table.from.webpage(temp, has.header=F, end.marker=''))) + colnames(out$mailing) = 'Mailing Address' + + temp = extract.token(txt, 'contentDiv,mailer,Business Address','') + out$business = t(clean.table(extract.table.from.webpage(temp, has.header=F, end.marker=''))) + colnames(out$business) = 'Business Address' + + temp = extract.token(txt, 'contentDiv,companyInfo,>','') + temp = gsub('\\|', '', replace.token(temp, '','')) + temp = clean.table(extract.table.from.webpage(temp, has.header=F, end.marker='')) + out$company = t(temp) + colnames(out$company) = 'Company Info' + + out$sic = trim(spl(spl(temp[grep('SIC', temp)],':')[2],'-')) + + return(out) +} + + +############################################################################### +# Get Zacks info +# http://www.zacks.com/stock/research/IBM/earnings-announcements +#' @export +############################################################################### +zacks.info <- function(ticker = 'IBM') +{ + url = paste0('http://www.zacks.com/stock/research/', ticker, '/earnings-announcements') + txt = join(readLines(url)) + + out = list() + require(jsonlite) + + for(i in spl('earnings,webcasts,revisions,splits,dividends,guidance')) { + data = extract.token(txt,paste0('') + data = fromJSON(paste('{"data"', data)) + out[[i]] = data$data + } + out +} + + +############################################################################### +# Get quantumonline info +# www.quantumonline.com/search.cfm?tickersymbol=458140100&sopt=cusip&1.0.1=Search +# quantumonline.info(id = '458140100', type='cusip') +#' @export +############################################################################### +quantumonline.info <- function +( + id, + type=c( + 'cusip', # by CUSIP Number + 'symbol', # by Ticker Symbol + 'sname' # Symbol Lookup + ) +) +{ + # http://www.quantumonline.com/search.cfm?tickersymbol=458140100&sopt=cusip&1.0.1=Search + url = paste0('http://www.quantumonline.com/search.cfm?tickersymbol=', id, '&sopt=', type[1], '&1.0.1=Search') + txt = join(readLines(url)) + out = list() + + # extract table from this page + out$main = extract.table.from.webpage(gsub(' ', ',', txt), "Company's Online Profile", has.header = F) + out$address = extract.table.from.webpage( txt, 'Address:', has.header = F) + + return(out) +} + + +############################################################################### +#' URL for various data providers +#' +#' [lookup ticker](http://www.quotemedia.com/portal/quote?qm_symbol=pot:ca) +#' [check sector / industry info for any company](http://www.quotemedia.com/portal/profile?qm_symbol=m) +#' +#' hist = read.xts(hist.quotes.url('IBM', '1992-11-01', '2016-05-05', 'quotemedia')) +#' hist = read.xts(hist.quotes.url('HOU:CA', '1992-11-01', '2016-05-05', 'quotemedia')) +#' hist = read.xts(get.url(hist.quotes.url('HOD:CA', '1992-11-01', '2016-05-05', 'quotemedia'))) +#' +#' library(readr) +#' hist = read.xts(read_csv(get.url(hist.quotes.url('HOU:CA', '1992-11-01', '2016-05-05', 'quotemedia')),,na=c('','NA','N/A'))) +#' +#' http://web.tmxmoney.com/pricehistory.php?qm_page=90043&qm_symbol=HOD +#' http://www.quotemedia.com/portal/history?qm_symbol=HOD:CA +#' +#' @export +############################################################################### +hist.quotes.url <- function +( + ticker = 'IBM', + from = '1900-01-01', + to = Sys.Date(), + src = spl('yahoo,google,quotemedia') +) +{ + if(class(from) != 'Date') from = as.Date(from, '%Y-%m-%d') + if(class(to) != 'Date') to = as.Date(to, '%Y-%m-%d') + + switch(src[1], + yahoo = paste('http://ichart.finance.yahoo.com/table.csv?', + 's=', ticker, + '&a=', sprintf('%.2d', date.month(from) - 1), + format(from, '&b=%d&c=%Y'), + '&d=', sprintf('%.2d', date.month(to) - 1), + format(to, '&e=%d&f=%Y'), + '&g=d&q=q&y=0&z=file&x=.csv', + sep=''), + + google = paste('http://finance.google.com/finance/historical?', + 'q=', ticker, + '&startdate=', format(from, '%b+%d+%Y'), + '&enddate=', format(to, '%b+%d+%Y'), + '&output=csv', + sep=''), + + quotemedia = paste('http://app.quotemedia.com/quotetools/getHistoryDownload.csv?webmasterId=501&', + 'symbol=', ticker, + '&startMonth=', sprintf('%.2d', date.month(from) - 1), + format(from, '&startDay=%d&startYear=%Y'), + '&endMonth=', sprintf('%.2d', date.month(to) - 1), + format(to, '&endDay=%d&endYear=%Y'), + '&isRanged=true', + sep=''), + + # default + '' + ) +} + +############################################################################### +# Remove extreme data points +#' @export +############################################################################### +data.clean <- function +( + data, + min.ratio = 2.5, + min.obs = 3*252, + iqr.mult = 20 +) +{ + data$symbolnames = iif(is.null(data$symbolnames), ls(data), data$symbolnames) + + # remove all series that has less than minimum number of observations +if(min.obs > 0) { + index = names(which(sapply(data$symbolnames, function(x) as.numeric(count(Cl(data[[x]])))) < min.obs)) + if (len(index) > 0) { + cat('Removing', index, 'have less than', min.obs, 'observations','\n') + rm(list=index, envir=data) + + data$symbolnames = setdiff(data$symbolnames, index) + } +} + + for(ticker in data$symbolnames) + data[[ticker]] = data.clean.helper(data[[ticker]], ticker, min.ratio, iqr.mult) +} + +data.clean.helper <- function +( + data, + ticker, + min.ratio = 2.5, + iqr.mult = 20 +) +{ + data = data[Cl(data) > 0 & Ad(data) > 0] + + nperiods = nrow(data) + price = Ad(data) + + # forward ratio + ratio = as.vector((price)/mlag(price)) + index = which(ratio > min.ratio) + + if(len(index) > 0) + for(i in index) { + cat('Abnormal price found for', ticker, format(index(data)[i],'%d-%b-%Y'),'Ratio :', round(ratio[i],1),'\n') + for(name in find.names('Open,Close,High,Low,Adjusted', data)) + data[i:nperiods,name] = data[i:nperiods,name] / ratio[i] + } + + price = Ad(data) + ret = as.vector((price)/mlag(price)) - 1 + threshold = iqr.mult * IQR(ret, na.rm=T) + index = which(ret > threshold | ret < -threshold) + + if(len(index) > 0) + for(i in index) { + cat('Abnormal price found for', ticker, format(index(data)[i],'%d-%b-%Y'),'based on IQR, Ratio :', round(ratio[i],1),'\n') + for(name in find.names('Open,Close,High,Low,Adjusted', data)) + data[i:nperiods,name] = data[i:nperiods,name] / ratio[i] + } + + # backward ratio + price = Ad(data) + ratio = as.vector(mlag(price)/(price)) + index = which(ratio > min.ratio) + + if(len(index) > 0) + for(i in index) { + cat('Abnormal price found for', ticker, format(index(data)[i],'%d-%b-%Y'),'Inverse Ratio :', round(ratio[i],1),'\n') + for(name in find.names('Open,Close,High,Low,Adjusted', data)) + data[i:nperiods,name] = data[i:nperiods,name] * ratio[i] + } + + data +} + + +############################################################################### +# Create data proxy, more details at +# http://systematicinvestor.github.io/Data-Proxy/ +#' @export +############################################################################### +make.data.proxy <- function() { + #***************************************************************** + # Load external data + #****************************************************************** + load.packages('quantmod') + + raw.data = env() + + #-------------------------------- + # TRJ_CRB file was downloaded from the + # http://www.corecommodityllc.com/CoreIndexes.aspx + # select TR/CC-CRB Index-Total Return and click "See Chart" + # on Chart page click "Download to Spreadsheet" link + # copy TR_CC-CRB, downloaded file, to data folder + filename = 'data/TR_CC-CRB' + if(file.exists(filename)) { + temp = extract.table.from.webpage( join(readLines(filename)), 'EODValue' ) + temp = join( apply(temp, 1, join, ','), '\n' ) + raw.data$CRB = make.stock.xts( read.xts(temp, format='%m/%d/%y' ) ) + } + + #-------------------------------- + # load 3-Month Treasury Bill from FRED (BIL) + filename = 'data/TB3M.Rdata' + if(!file.exists(filename)) { + TB3M = quantmod::getSymbols('DTB3', src='FRED', auto.assign = FALSE) + save(TB3M, file=filename) + } + load(file=filename) + TB3M[] = ifna.prev(TB3M) + #compute.raw.annual.factor(TB3M) + raw.data$TB3M = make.stock.xts(processTBill(TB3M, timetomaturity = 1/4, 261)) + + + #-------------------------------- + # load 3 years t-bill from FRED (BIL) + filename = 'data/TB3Y.Rdata' + if(!file.exists(filename)) { + TB3Y = quantmod::getSymbols('DGS3', src='FRED', auto.assign = FALSE) + save(TB3Y, file=filename) + } + load(file=filename) + TB3Y[] = ifna.prev(TB3Y) + #compute.raw.annual.factor(TB3Y) + raw.data$TB3Y = make.stock.xts(processTBill(TB3Y, timetomaturity = 3, 261)) + + #-------------------------------- + # load 10 years t-bill from FRED (BIL) + filename = 'data/TB10Y.Rdata' + if(!file.exists(filename)) { + TB10Y = quantmod::getSymbols('DGS10', src='FRED', auto.assign = FALSE) + save(TB10Y, file=filename) + } + load(file=filename) + TB10Y[] = ifna.prev(TB10Y) + #compute.raw.annual.factor(TB10Y) + raw.data$TB10Y = make.stock.xts(processTBill(TB10Y, timetomaturity = 10, 261)) + + #-------------------------------- + # load 20 years t-bill from FRED (BIL) + filename = 'data/TB20Y.Rdata' + if(!file.exists(filename)) { + TB20Y = quantmod::getSymbols('GS20', src='FRED', auto.assign = FALSE) + save(TB20Y, file=filename) + } + load(file=filename) + + TB20Y[] = ifna.prev(TB20Y) + + #compute.raw.annual.factor(TB10Y) + raw.data$TB20Y = make.stock.xts(processTBill(TB20Y, timetomaturity = 20, 12)) + + #-------------------------------- + filename = 'data/GOLD.Rdata' + if(!file.exists(filename)) { + GOLD = bundes.bank.data.gold() + save(GOLD, file=filename) + } + load(file=filename) + raw.data$GOLD = make.stock.xts(GOLD) + + #-------------------------------- + # FTSE NAREIT U.S. Real Estate Index monthly total return series + # http://returns.reit.com/returns/MonthlyHistoricalReturns.xls + # https://r-forge.r-project.org/scm/viewvc.php/pkg/FinancialInstrument/inst/parser/download.NAREIT.R?view=markup&root=blotter + filename = 'data/NAREIT.xls' + if(!file.exists(filename)) { + url = 'http://returns.reit.com/returns/MonthlyHistoricalReturns.xls' + download.file(url, filename, mode = 'wb') + } + + load.packages('readxl') + temp = read_excel(filename, sheet='Index Data', skip=7) + NAREIT = make.xts(temp$Index, as.Date(temp$Date)) + + raw.data$NAREIT = make.stock.xts(NAREIT) + + + #-------------------------------- + + + tickers = ' +COM = DBC;GSG + CRB + +RExUS = [RWX] + VNQ + VGSIX +RE = [RWX] + VNQ + VGSIX +RE.US = [ICF] + VGSIX + +EMER.EQ = [EEM] + VEIEX +EMER.FI = [EMB] + PREMX + +GOLD = [GLD] + GOLD, +US.CASH = [BIL] + TB3M, +SHY + TB3Y, + +US.HY = [HYG] + VWEHX + +# Bonds +US.BOND = [AGG] + VBMFX +INTL.BOND = [BWX] + BEGBX + +JAPAN.EQ = [EWJ] + FJPNX +EUROPE.EQ = [IEV] + FIEUX +US.SMCAP = IWM;VB + NAESX +TECH.EQ = [QQQ] + ^NDX +US.EQ = [VTI] + VTSMX + VFINX +US.MID = [VO] + VIMSX +EAFE = [EFA] + VDMIX + VGTSX + +MID.TR = [IEF] + VFITX +CORP.FI = [LQD] + VWESX +TIPS = [TIP] + VIPSX + LSGSX +LONG.TR = [TLT] + VUSTX +' + + + data.proxy = env() + getSymbols.extra(tickers, src = 'yahoo', from = '1970-01-01', env = data.proxy, raw.data = raw.data, auto.assign = T) + + data.proxy.raw = raw.data + save(data.proxy.raw, file='data/data.proxy.raw.Rdata',compress='gzip') + save(data.proxy, file='data/data.proxy.Rdata',compress='gzip') +} + + +#***************************************************************** +# Load/download data from Excel file from AQR data set +# [Betting Against Beta: Equity Factors, Monthly](https://www.aqr.com/library/data-sets/betting-against-beta-equity-factors-monthly) +# http://www.aqr.com/library/data-sets/betting-against-beta-equity-factors-monthly/data +# +# [Time Series Momentum: Factors, Monthly](https://www.aqr.com/library/data-sets/time-series-momentum-factors-monthly) +# http://www.aqr.com/library/data-sets/time-series-momentum-factors-monthly/data +# +# [Andrea Frazzini - AQR Capital Management, LLC](http://www.econ.yale.edu/~af227/data_library.htm) +# http://www.aqr.com/library/data-sets/quality-minus-junk-factors-daily/data +# http://www.aqr.com/library/data-sets/quality-minus-junk-factors-monthly/data +# +#' @export +############################################################################### +load.aqr.data = function +( + data.set = 'betting-against-beta-equity-factors', #'time-series-momentum-factors' + frequency = c('monthly','daily'), + sheet = 1, + force.download = F, + last.col2extract = 'Global' +) +{ + warning('load.aqr.data is depreciated as of Apr 25, 2016 please use data.aqr function instead') + data.aqr(data.set, frequency, sheet, force.download, last.col2extract) +} + +#' @export +data.aqr = function +( + data.set = 'betting-against-beta-equity-factors', #'time-series-momentum-factors' + frequency = c('monthly','daily'), + sheet = 1, + force.download = F, + last.col2extract = 'Global' +) +{ + data.folder = paste(getwd(), 'aqr.data', sep='/') + url = paste0('http://www.aqr.com/library/data-sets/', data.set, '-', frequency[1], '/data') + filename = file.path(data.folder, paste0(data.set, '-', frequency[1],'.xlsx')) + + if( !file.exists(filename) || force.download) { + dir.create(data.folder, F) + download.file(url, filename, mode = 'wb') + } + + require(readxl) + data = read_excel(filename, sheet=sheet) + skip = which(data[,1]=='DATE') + data = read_excel(filename, sheet=sheet,skip=skip) + + if( is.character(last.col2extract) ) last.col2extract = which(colnames(data)==last.col2extract)-1 + data = data[!is.na(data[,1]), 1:last.col2extract] + data = data[rowSums(!is.na(data[,-1,drop=F])) > 0,] + + make.xts(data[,-1], as.Date(data[,1])) +} + + +############################################################################### +# Load/download CSI security master +# http://www.csidata.com/factsheets.php?type=commodity&format=csv +# (Stock Factsheet - TSX - Toronto Stock Exchange)[http://www.csidata.com/factsheets.php?type=stock&format=htmltable&exchangeid=82] +#' @export +############################################################################### +data.csi.security.master = function +( + type=c('commodity', 'stock'), + exchangeid=c(NA, 82), + force.download = FALSE, + data.filename = paste0(type[1],'.csv'), + data.keep.days = 30, + data.folder = 'data.csi' +) +{ + data.folder = paste(getwd(), data.folder, sep='/') + data.filename = file.path(data.folder, data.filename) + + # if NOT forced to download and file exists and file is less than 30 days old + if( !force.download && + file.exists(data.filename) && + as.numeric(Sys.Date() - as.Date(file.mtime(data.filename))) <= data.keep.days + ) { + return(read.csv(data.filename)) + } + + type = type[1] + exchangeid = exchangeid[1] + + if( is.na(exchangeid[1]) ) + url = paste0('http://www.csidata.com/factsheets.php?type=', type[1], '&format=csv') + else + url = paste0('http://www.csidata.com/factsheets.php?type=', type[1], '&format=csv&exchangeid=', exchangeid[1]) + + dir.create(data.folder, F) + txt = get.url(url) + write(txt, file=data.filename) + read.csv(data.filename) +} + +############################################################################### +#' Get list of FX symbols from FRED +#' [FRED H.10 Foreign Exchange Rates](https://research.stlouisfed.org/fred2/release?rid=17) +#' +#' @examples +#' \dontrun{ +#' info = fred.fx.symbol() +#' info$fx$symbol +#' } +#' @export +############################################################################### +fred.fx.symbol = function() { + url = 'https://research.stlouisfed.org/fred2/release/tables?rid=17&eid=23340' + txt = join(readLines(url)) + + # extract links:     AUSTRALIA + temp = gsub(pattern = 'series', replacement = '', txt, perl = TRUE) + temp = gsub(pattern = 'target', replacement = '<', temp, perl = TRUE) + + # extract Symbols table from this page + temp = extract.table.from.webpage(temp, 'Country', has.header = F) + + # format + data = gsub('/','',gsub('"','',trim(temp[,c(2,3,7)]))) + colnames(data) = spl('symbol,name,description') + data[,'description'] + + # remove empty + keep.index = !is.na(data[,'description']) & nchar(data[,'description']) > 0 + data = data.frame(data[keep.index,]) + + # split FX and index + index = grep('index',data[,'description'],T) + list(fx = data[-index,], index = data[index,]) +} + + +############################################################################### +#' Get list of FX symbols from FXHISTORICALDATA.COM +#' [FXHISTORICALDATA.COM](http://www.fxhistoricaldata.com/) +#' +#' @examples +#' \dontrun{ +#' info = fxhistoricaldata.fx.symbol() +#' info +#' } +#' @export +############################################################################### +fxhistoricaldata.fx.symbol = function() { + url = 'http://www.fxhistoricaldata.com/' + txt = join(readLines(url)) + + # extract list options + temp = gsub(pattern = '