├── README.md ├── R_script_in_class ├── FRE7241_Lecture_1.R ├── FRE7241_Lecture_2.R ├── FRE7241_Lecture_3.R ├── FRE7241_Lecture_4.R ├── FRE7241_Lecture_5.R ├── FRE7241_Lecture_6.R └── FRE7241_Lecture_7.R ├── Rcpp_and_armadillo ├── R_environment.R ├── app_dygraphs2.R ├── app_roll_portf.R ├── app_roll_portf2.R ├── armadillo_function_tests.R ├── armadillo_functions.cpp ├── garch_ou.cpp ├── numerical_analysis.R ├── rcpp_mult.cpp ├── rcpp_ou.cpp ├── rcpp_test3.cpp ├── rcpp_test4.cpp ├── rcpp_test5.cpp ├── rcpp_test6.cpp ├── rcpparmadillo_example1.cpp └── rcpparmadillo_example2.cpp ├── data ├── etf_data.RData ├── etf_list.csv ├── hf_data.RData ├── sp500_prices.RData └── zoo_data.RData ├── lecture_note ├── FRE7241_Lecture_1.pdf ├── FRE7241_Lecture_2.pdf ├── FRE7241_Lecture_3.pdf ├── FRE7241_Lecture_4.pdf ├── FRE7241_Lecture_5.pdf ├── FRE7241_Lecture_6.pdf └── FRE7241_Lecture_7.pdf ├── others ├── 2016-07-02-Publishing-documents-in-R.Rmd ├── 2016-07-05-Interactive-Plots-in-R.Rmd ├── FRE7241_Lecture_7.Rnw ├── dygraphs_plots.Rmd ├── r_markdown_example.Rmd ├── shiny_ewma.Rmd ├── shiny_ewma2.Rmd └── shiny_ewma_quantmod.Rmd ├── resources ├── Ardia DEoptim Portfolio Optimization.pdf ├── Aswani Regression Shrinkage Bias Variance Tradeoff.pdf ├── Blei Regression Lasso Shrinkage Bias Variance Tradeoff.pdf ├── Bolker Optimization Methods.pdf ├── Bouchaud Momentum Mean Reversion Equity Returns.pdf ├── Boudt DEoptim Large Portfolio Optimization.pdf ├── Boudt DEoptim Portfolio Optimization.pdf ├── DEoptim Introduction.pdf ├── DEoptimR.pdf ├── Farnsworth Econometrics in R.pdf ├── Hurst Pedersen AQR Momentum Evidence.pdf ├── James book Statistical Learning in R.pdf ├── Lemperiere Risk Two Centuries Trend Following Strategies.pdf ├── Matloff book The Art of R Programming.pdf ├── Moskowitz Time Series Momentum.pdf ├── Mullen Package DEoptim.pdf ├── RMarkdown_Reference_Guide.pdf ├── R_environment.pdf ├── Rcpp-FAQ.pdf ├── Rcpp-sugar.pdf ├── Rcpp.pdf ├── Storn Differential Evolution.pdf ├── Wickham Advanced R.pdf ├── Yollin Optimization.pdf ├── advancedR cheatsheet.pdf ├── baser cheatsheet.pdf ├── bootstrap_technique.pdf ├── data import cheatsheet.pdf ├── data transformation cheatsheet.pdf ├── devtools cheatsheet.pdf ├── doBootstrap_primer.pdf ├── ewma2_shiny.pdf ├── ggplot2 cheatsheet.pdf ├── numerical_analysis.pdf ├── pca-handout.pdf ├── pcaTutorial.pdf ├── plot par cheatsheet.pdf ├── purrr cheatsheet.pdf ├── rmarkdown cheatsheet.pdf ├── rmarkdown reference.pdf ├── rmarkdown_cheatsheet_2.0.pdf ├── rstudio cheatsheet.pdf ├── shiny cheatsheet.pdf ├── shiny_cheatsheet.pdf └── stringr cheatsheet.pdf └── tests ├── FRE7241_test1 outline.R ├── FRE7241_test1 solution.R ├── FRE7241_test2 solution.R ├── FRE7241_test3 solution.R ├── FRE7241_test4 solution.R ├── FRE7241_test5 solution.R ├── FRE7241_test6 solution.R ├── back_test.R └── ewma_model.R /README.md: -------------------------------------------------------------------------------- 1 | # Algorithmic-Portfolio-Management-in-R-programming-language 2 | The course, authored by Prof. Jerzy in NYU, applies the R programming language to momentum trading, statistical arbitrage (pairs trading), and other active portfolio management strategies. The course implements volatility and price forecasting models, asset pricing and factor models, and portfolio optimization. The course will apply machine learning techniques, such as backtesting (cross-validation) and parameter regularization (shrinkage). 3 | 4 | ## The following are some interesting cases I learnt from class: 5 | 6 | 7 | 8 | ### Case one: 9 | Plot the cumulative maximum of the adjusted close prices from utils::env_etf$VTI: 10 | ![drawdown_plot](https://user-images.githubusercontent.com/33269462/44305868-5b0c2080-a351-11e8-9473-5482ff133bd6.png) 11 | 12 | ![drawdown_vti](https://user-images.githubusercontent.com/33269462/44305874-6cedc380-a351-11e8-841d-581675b926ff.png) 13 | 14 | 15 | 16 | ### Case two: 17 | Plot the sub_portfolios from worst to best (based on final price) using a color ramp from red to blue. 18 | ![sp500_sub_portfolios](https://user-images.githubusercontent.com/33269462/44305911-0d43e800-a352-11e8-9a95-37cb9c39443f.png) 19 | 20 | 21 | 22 | ### Case three: 23 | Perform a rolling portfolio optimization over annual intervals, calculate optimized portfolio weights in each year, and apply them to out-of-sample returns in the following year, at the end, plot the cumulative returns of this max sharpe portfolio strategy. 24 | ![backtest_sharpe](https://user-images.githubusercontent.com/33269462/44305943-99560f80-a352-11e8-98d6-03394244843b.png) 25 | 26 | 27 | 28 | ### Case four: 29 | Calculate efficient portfolios with the lowest variance given a fixed target return. 30 | 31 | Plot the efficient frontier and the capital market lines for different values of the fixed target return. 32 | 33 | ![eff_front_tangent](https://user-images.githubusercontent.com/33269462/44305972-09649580-a353-11e8-991e-6390eda7384c.png) 34 | 35 | 36 | 37 | ### Case five: 38 | Also using shiny package in R to create interactive plot. 39 | 40 | interactive_plot beixi chen 41 | -------------------------------------------------------------------------------- /R_script_in_class/FRE7241_Lecture_6.R: -------------------------------------------------------------------------------- 1 | # sym_bols contains all the symbols in rutils::env_etf$re_turns except for "VXX" 2 | sym_bols <- colnames(rutils::env_etf$re_turns) 3 | sym_bols <- sym_bols[!(sym_bols=="VXX")] 4 | # Extract columns of rutils::env_etf$re_turns and remove NA values 5 | re_turns <- rutils::env_etf$re_turns[, sym_bols] 6 | re_turns <- zoo::na.locf(re_turns) 7 | re_turns <- na.omit(re_turns) 8 | # Calculate vector of monthly end points and start points 9 | look_back <- 12 10 | end_points <- rutils::calc_endpoints(re_turns, inter_val="months") 11 | end_points[end_points<2*NCOL(re_turns)] <- 2*NCOL(re_turns) 12 | len_gth <- NROW(end_points) 13 | # sliding window 14 | start_points <- c(rep_len(1, look_back-1), end_points[1:(len_gth-look_back+1)]) 15 | # expanding window 16 | start_points <- rep_len(1, NROW(end_points)) 17 | # risk_free is the daily risk-free rate 18 | risk_free <- 0.03/260 19 | # Calculate daily excess returns 20 | ex_cess <- re_turns - risk_free 21 | # Perform loop over end_points 22 | portf_rets <- lapply(2:NROW(end_points), 23 | function(i) { 24 | # subset the ex_cess returns 25 | ex_cess <- ex_cess[start_points[i-1]:end_points[i-1], ] 26 | in_verse <- solve(cov(ex_cess)) 27 | # calculate the maximum Sharpe ratio portfolio weights. 28 | weight_s <- in_verse %*% colMeans(ex_cess) 29 | weight_s <- drop(weight_s/sum(weight_s^2)) 30 | # subset the re_turns 31 | re_turns <- re_turns[(end_points[i-1]+1):end_points[i], ] 32 | # calculate the out-of-sample portfolio returns 33 | xts(re_turns %*% weight_s, index(re_turns)) 34 | } # end anonymous function 35 | ) # end lapply 36 | portf_rets <- rutils::do_call(rbind, portf_rets) 37 | colnames(portf_rets) <- "portf_rets" 38 | # Calculate compounded cumulative portfolio returns 39 | portf_rets <- cumsum(portf_rets) 40 | quantmod::chart_Series(portf_rets, 41 | name="Cumulative Returns of Max Sharpe Portfolio Strategy") 42 | # create random covariance matrix 43 | set.seed(1121) 44 | mat_rix <- matrix(runif(5e2), nc=5) 45 | cov_mat <- cov(mat_rix) 46 | cor_mat <- cor(mat_rix) 47 | std_dev <- sqrt(diag(cov_mat)) 48 | # calculate target matrix 49 | cor_mean <- mean(cor_mat[upper.tri(cor_mat)]) 50 | tar_get <- matrix(cor_mean, nr=NROW(cov_mat), nc=NCOL(cov_mat)) 51 | diag(tar_get) <- 1 52 | tar_get <- t(t(tar_get * std_dev) * std_dev) 53 | # calculate shrinkage covariance matrix 54 | al_pha <- 0.5 55 | cov_shrink <- (1-al_pha)*cov_mat + al_pha*tar_get 56 | # calculate inverse matrix 57 | in_verse <- solve(cov_shrink) 58 | # create random covariance matrix 59 | set.seed(1121) 60 | mat_rix <- matrix(runif(5e2), nc=5) 61 | cov_mat <- cov(mat_rix) 62 | # perform eigen decomposition 63 | ei_gen <- eigen(cov_mat) 64 | eigen_vec <- ei_gen$vectors 65 | # calculate regularized inverse matrix 66 | max_eigen <- 2 67 | in_verse <- eigen_vec[, 1:max_eigen] %*% 68 | (t(eigen_vec[, 1:max_eigen]) / ei_gen$values[1:max_eigen]) 69 | # VTI percentage returns 70 | re_turns <- rutils::diff_xts(log(quantmod::Cl(rutils::env_etf$VTI))) 71 | # define end points 72 | end_points <- seq_along(re_turns) 73 | len_gth <- NROW(end_points) 74 | look_back <- 51 75 | # start_points are multi-period lag of end_points 76 | start_points <- c(rep_len(1, look_back-1), 77 | end_points[1:(len_gth-look_back+1)]) 78 | # define list of look-back intervals for aggregations over past 79 | look_backs <- lapply(seq_along(end_points), 80 | function(in_dex) { 81 | start_points[in_dex]:end_points[in_dex] 82 | }) # end lapply 83 | # calculate realized VTI variance in sapply() loop 84 | vari_ance <- sapply(look_backs, 85 | function(look_back) { 86 | ret_s <- re_turns[look_back] 87 | sum((ret_s - mean(ret_s))^2) 88 | }) / (look_back-1) # end sapply 89 | tail(vari_ance) 90 | class(vari_ance) 91 | # coerce vari_ance into xts 92 | vari_ance <- xts(vari_ance, order.by=index(re_turns)) 93 | colnames(vari_ance) <- "VTI.variance" 94 | head(vari_ance) 95 | # calculate VTI variance using package roll 96 | library(roll) # load roll 97 | vari_ance <- 98 | roll::roll_var(re_turns, width=look_back) 99 | colnames(vari_ance) <- "VTI.variance" 100 | head(vari_ance) 101 | sum(is.na(vari_ance)) 102 | vari_ance[1:(look_back-1)] <- 0 103 | # benchmark calculation of rolling variance 104 | library(microbenchmark) 105 | summary(microbenchmark( 106 | roll_sapply=sapply(look_backs, function(look_back) { 107 | ret_s <- re_turns[look_back] 108 | sum((ret_s - mean(ret_s))^2) 109 | }), 110 | ro_ll=roll::roll_var(re_turns, width=look_back), 111 | times=10))[, c(1, 4, 5)] 112 | # calculate EWMA VTI variance using filter() 113 | wid_th <- 51 114 | weight_s <- exp(-0.1*1:wid_th) 115 | weight_s <- weight_s/sum(weight_s) 116 | vari_ance <- stats::filter(re_turns^2, 117 | filter=weight_s, sides=1) 118 | vari_ance[1:(wid_th-1)] <- vari_ance[wid_th] 119 | class(vari_ance) 120 | vari_ance <- as.numeric(vari_ance) 121 | x_ts <- xts:::xts(sqrt(vari_ance), order.by=index(re_turns)) 122 | # plot EWMA standard deviation 123 | chart_Series(x_ts, 124 | name="EWMA standard deviation") 125 | dygraphs::dygraph(x_ts, main="EWMA standard deviation") 126 | # calculate VTI variance using package roll 127 | library(roll) # load roll 128 | vari_ance <- roll::roll_var(re_turns, 129 | weights=rev(weight_s), width=wid_th) 130 | colnames(vari_ance) <- "VTI.variance" 131 | class(vari_ance) 132 | head(vari_ance) 133 | sum(is.na(vari_ance)) 134 | vari_ance[1:(wid_th-1)] <- 0 135 | x11(width=6, height=4) 136 | par(mar=c(4, 3, 1, 1), oma=c(0, 0, 0, 0)) 137 | # VTI percentage returns 138 | re_turns <- rutils::diff_xts(log(quantmod::Cl(rutils::env_etf$VTI))) 139 | # calculate VTI variance using package roll 140 | look_back <- 22 141 | vari_ance <- 142 | roll::roll_var(re_turns, width=look_back) 143 | vari_ance[1:(look_back-1)] <- 0 144 | colnames(vari_ance) <- "VTI.variance" 145 | # number of look_backs that fit over re_turns 146 | n_row <- NROW(re_turns) 147 | num_agg <- n_row %/% look_back 148 | end_points <- # define end_points with beginning stub 149 | n_row-look_back*num_agg + (0:num_agg)*look_back 150 | len_gth <- NROW(end_points) 151 | # subset vari_ance to end_points 152 | vari_ance <- vari_ance[end_points] 153 | # improved autocorrelation function 154 | acf_plus(coredata(vari_ance), lag=10, main="") 155 | title(main="acf of variance", line=-1) 156 | # partial autocorrelation 157 | pacf(coredata(vari_ance), lag=10, main="", ylab=NA) 158 | title(main="pacf of variance", line=-1) 159 | # define GARCH parameters 160 | om_ega <- 0.01 ; al_pha <- 0.2 161 | be_ta <- 0.2 ; len_gth <- 1000 162 | re_turns <- numeric(len_gth) 163 | vari_ance <- numeric(len_gth) 164 | vari_ance[1] <- om_ega/(1-al_pha-be_ta) 165 | re_turns[1] <- rnorm(1, sd=sqrt(vari_ance[1])) 166 | # simulate GARCH model 167 | set.seed(1121) # reset random numbers 168 | for (i in 2:len_gth) { 169 | re_turns[i] <- rnorm(n=1, sd=sqrt(vari_ance[i-1])) 170 | vari_ance[i] <- om_ega + al_pha*re_turns[i]^2 + 171 | be_ta*vari_ance[i-1] 172 | } # end for 173 | x11(width=6, height=4) 174 | par(mar=c(3, 3, 1, 1), oma=c(0, 0, 0, 0)) 175 | # plot GARCH cumulative returns 176 | plot(cumsum(re_turns/100), t="l", 177 | lwd=2, col="orange", xlab="", ylab="", 178 | main="GARCH cumulative returns") 179 | date_s <- seq.Date(from=Sys.Date()-len_gth+1, 180 | to=Sys.Date(), length.out=len_gth) 181 | x_ts <- xts:::xts(cumsum(re_turns/100), order.by=date_s) 182 | dygraphs::dygraph(x_ts, main="GARCH cumulative returns") 183 | # plot GARCH standard deviation 184 | plot(sqrt(vari_ance), t="l", 185 | col="orange", xlab="", ylab="", 186 | main="GARCH standard deviation") 187 | x_ts <- xts:::xts(sqrt(vari_ance), order.by=date_s) 188 | dygraphs::dygraph(x_ts, main="GARCH standard deviation") 189 | # define GARCH parameters 190 | om_ega <- 0.0001 ; al_pha <- 0.5 191 | be_ta <- 0.1 ; len_gth <- 10000 192 | re_turns <- numeric(len_gth) 193 | vari_ance <- numeric(len_gth) 194 | vari_ance[1] <- om_ega/(1-al_pha-be_ta) 195 | re_turns[1] <- rnorm(1, sd=sqrt(vari_ance[1])) 196 | # simulate GARCH model 197 | set.seed(1121) # reset random numbers 198 | for (i in 2:len_gth) { 199 | re_turns[i] <- rnorm(n=1, sd=sqrt(vari_ance[i-1])) 200 | vari_ance[i] <- om_ega + al_pha*re_turns[i]^2 + 201 | be_ta*vari_ance[i-1] 202 | } # end for 203 | # calculate kurtosis of GARCH returns 204 | moments::moment(re_turns, order=4) / 205 | moments::moment(re_turns, order=2)^2 206 | # perform Jarque-Bera test of normality 207 | tseries::jarque.bera.test(re_turns) 208 | # plot histogram of GARCH returns 209 | histo_gram <- hist(re_turns, col="lightgrey", 210 | xlab="returns", breaks=200, xlim=c(-0.05, 0.05), 211 | ylab="frequency", freq=FALSE, 212 | main="GARCH returns histogram") 213 | lines(density(re_turns, adjust=1.5), 214 | lwd=3, col="blue") 215 | optim_fit <- MASS::fitdistr(re_turns, 216 | densfun="t", df=2, lower=c(-1, 1e-7)) 217 | lo_cation <- optim_fit$estimate[1] 218 | sc_ale <- optim_fit$estimate[2] 219 | curve(expr=dt((x-lo_cation)/sc_ale, df=2)/sc_ale, 220 | type="l", xlab="", ylab="", lwd=3, 221 | col="red", add=TRUE) 222 | legend("topright", inset=0.05, 223 | leg=c("density", "t-distr w/ 2 dof"), 224 | lwd=6, lty=c(1, 1), 225 | col=c("blue", "red")) 226 | # use fixed notation instead of exponential notation 227 | options(scipen=999) 228 | library(fGarch) 229 | # fit returns into GARCH 230 | garch_fit <- fGarch::garchFit(data=re_turns) 231 | # fitted GARCH parameters 232 | round(garch_fit@fit$coef, 5) 233 | # actual GARCH parameters 234 | round(c(mu=mean(re_turns), omega=om_ega, 235 | alpha=al_pha, beta=be_ta), 5) 236 | # plot GARCH fitted standard deviation 237 | plot.zoo(sqrt(garch_fit@fit$series$h), t="l", 238 | col="orange", xlab="", ylab="", 239 | main="GARCH fitted standard deviation") 240 | # specify GARCH model 241 | garch_spec <- fGarch::garchSpec( 242 | model=list(omega=om_ega, alpha=al_pha, beta=be_ta)) 243 | # simulate GARCH model 244 | garch_sim <- 245 | fGarch::garchSim(spec=garch_spec, n=len_gth) 246 | re_turns <- as.numeric(garch_sim) 247 | # calculate kurtosis of GARCH returns 248 | moments::moment(re_turns, order=4) / 249 | moments::moment(re_turns, order=2)^2 250 | # perform Jarque-Bera test of normality 251 | tseries::jarque.bera.test(re_turns) 252 | # plot histogram of GARCH returns 253 | histo_gram <- hist(re_turns, col="lightgrey", 254 | xlab="returns", breaks=200, xlim=c(-0.05, 0.05), 255 | ylab="frequency", freq=FALSE, 256 | main="GARCH returns histogram") 257 | lines(density(re_turns, adjust=1.5), 258 | lwd=3, col="blue") 259 | # fir t-distribution into GARCH returns 260 | optim_fit <- MASS::fitdistr(re_turns, 261 | densfun="t", df=2, lower=c(-1, 1e-7)) 262 | lo_cation <- optim_fit$estimate[1] 263 | sc_ale <- optim_fit$estimate[2] 264 | curve(expr=dt((x-lo_cation)/sc_ale, df=2)/sc_ale, 265 | type="l", xlab="", ylab="", lwd=3, 266 | col="red", add=TRUE) 267 | legend("topright", inset=0.05, 268 | leg=c("density", "t-distr w/ 2 dof"), 269 | lwd=6, lty=c(1, 1), 270 | col=c("blue", "red")) 271 | # load package HighFreq 272 | library(HighFreq) 273 | head(SPY_TAQ) 274 | # load package HighFreq 275 | library(HighFreq) 276 | head(SPY) 277 | # install package HighFreq from github 278 | devtools::install_github(repo="algoquant/HighFreq") 279 | # load package HighFreq 280 | library(HighFreq) 281 | # get documentation for package HighFreq 282 | # get short description 283 | packageDescription("HighFreq") 284 | # load help page 285 | help(package="HighFreq") 286 | # list all datasets in "HighFreq" 287 | data(package="HighFreq") 288 | # list all objects in "HighFreq" 289 | ls("package:HighFreq") 290 | # remove HighFreq from search path 291 | detach("package:HighFreq") 292 | # load package HighFreq 293 | library(HighFreq) 294 | # you can see SPY when listing objects in HighFreq 295 | ls("package:HighFreq") 296 | # you can see SPY when listing datasets in HighFreq 297 | data(package="HighFreq") 298 | # but the SPY dataset isn't listed in the workspace 299 | ls() 300 | # HighFreq datasets are lazy loaded and available when needed 301 | head(SPY) 302 | # load all the datasets in package HighFreq 303 | data(hf_data) 304 | # HighFreq datasets are now loaded and in the workspace 305 | head(SPY) 306 | library(HighFreq) # load HighFreq 307 | # minutely SPY returns (unit per minute) single day 308 | re_turns <- rutils::diff_xts(log(SPY["2012-02-13", 4])) 309 | # minutely SPY volatility (unit per minute) 310 | sd(re_turns) 311 | # minutely SPY returns (unit per second) 312 | re_turns <- rutils::diff_xts(log(SPY["2012-02-13", 4])) / 313 | c(1, diff(.index(SPY["2012-02-13"]))) 314 | # minutely SPY volatility scaled to unit per minute 315 | 60*sd(re_turns) 316 | # minutely SPY returns multiple days no overnight scaling 317 | re_turns <- rutils::diff_xts(log(SPY[, 4])) 318 | # minutely SPY volatility (unit per minute) 319 | sd(re_turns) 320 | # minutely SPY returns (unit per second) 321 | re_turns <- rutils::diff_xts(log(SPY[, 4])) / 322 | c(1, diff(.index(SPY))) 323 | # minutely SPY volatility scaled to unit per minute 324 | 60*sd(re_turns) 325 | table(c(1, diff(.index(SPY)))) 326 | library(HighFreq) # load HighFreq 327 | # daily OHLC SPY prices 328 | SPY_daily <- 329 | rutils::to_period(oh_lc=SPY, period="days") 330 | # daily SPY returns and volatility 331 | sd(rutils::diff_xts(log(SPY_daily[, 4]))) 332 | # minutely SPY returns (unit per minute) 333 | re_turns <- rutils::diff_xts(log(SPY[, 4])) 334 | # minutely SPY volatility scaled to daily interval 335 | sqrt(6.5*60)*sd(re_turns) 336 | 337 | # minutely SPY returns (unit per second) 338 | re_turns <- rutils::diff_xts(log(SPY[, 4])) / 339 | c(1, diff(.index(SPY))) 340 | # minutely SPY volatility scaled to daily aggregation interval 341 | 60*sqrt(6.5*60)*sd(re_turns) 342 | 343 | # daily SPY volatility 344 | # including extra time over weekends and holidays 345 | 24*60*60*sd(rutils::diff_xts(log(SPY_daily[, 4])) / 346 | c(1, diff(.index(SPY_daily)))) 347 | table(c(1, diff(.index(SPY_daily)))) 348 | library(HighFreq) # load HighFreq 349 | # daily SPY volatility from minutely prices using package TTR 350 | library(TTR) 351 | sqrt((6.5*60)*mean(na.omit( 352 | TTR::volatility(SPY, N=1, 353 | calc="yang.zhang"))^2)) 354 | # SPY volatility using package HighFreq 355 | 60*sqrt((6.5*60)*agg_regate(oh_lc=SPY, 356 | weight_ed=FALSE, mo_ment="run_variance", 357 | calc_method="yang_zhang")) 358 | library(HighFreq) # load HighFreq 359 | # calculate variance 360 | var_close <- 361 | HighFreq::run_variance(oh_lc=env_etf$VTI, 362 | calc_method="close") 363 | var_yang_zhang <- 364 | HighFreq::run_variance(oh_lc=env_etf$VTI) 365 | vari_ance <- 366 | 252*(24*60*60)^2*cbind(var_close, var_yang_zhang) 367 | colnames(vari_ance) <- 368 | c("close var", "Yang-Zhang var") 369 | # plot 370 | plot_theme <- chart_theme() 371 | plot_theme$col$line.col <- c("black", "red") 372 | x11() 373 | chart_Series(vari_ance["2011-06/2011-12"], 374 | theme=plot_theme, name="Close and YZ variances") 375 | legend("top", legend=colnames(vari_ance), 376 | bg="white", lty=c(1, 1), lwd=c(6, 6), 377 | col=plot_theme$col$line.col, bty="n") 378 | # R startup chunk 379 | # ```{r setup, include=FALSE} 380 | library(shiny) 381 | library(quantmod) 382 | inter_val <- 31 383 | cl_ose <- quantmod::Cl(rutils::env_etf$VTI) 384 | plot_theme <- chart_theme() 385 | plot_theme$col$line.col <- c("orange", "blue") 386 | # ``` 387 | #end R startup chunk 388 | inputPanel( 389 | sliderInput("lamb_da", label="lambda:", 390 | min=0.01, max=0.2, value=0.1, step=0.01) 391 | ) # end inputPanel 392 | renderPlot({ 393 | # calculate EWMA prices 394 | lamb_da <- input$lamb_da 395 | weight_s <- exp(-lamb_da*1:inter_val) 396 | weight_s <- weight_s/sum(weight_s) 397 | ew_ma <- filter(cl_ose, filter=weight_s, sides=1) 398 | ew_ma[1:(inter_val-1)] <- ew_ma[inter_val] 399 | ew_ma <- xts(cbind(cl_ose, ew_ma), order.by=index(cl_ose)) 400 | colnames(ew_ma) <- c("VTI", "VTI EWMA") 401 | # plot EWMA prices 402 | ch_ob <- chart_Series(ew_ma, theme=plot_theme, name="EWMA prices") 403 | plot(ch_ob) 404 | legend("top", legend=colnames(ew_ma), 405 | inset=0.1, bg="white", lty=c(1, 1), lwd=c(2, 2), 406 | col=plot_theme$col$line.col, bty="n") 407 | }) # end renderPlot 408 | -------------------------------------------------------------------------------- /R_script_in_class/FRE7241_Lecture_7.R: -------------------------------------------------------------------------------- 1 | # calculate covariance matrix of returns and its inverse 2 | cov_mat <- cov(re_turns) 3 | cov_inv <- solve(a=cov_mat) 4 | u_nit <- rep(1, NCOL(cov_mat)) 5 | # minimum variance weights with constraint 6 | # weight_s <- solve(a=cov_mat, b=u_nit) 7 | weight_s <- cov_inv %*% u_nit 8 | weight_s <- weight_s / drop(t(u_nit) %*% weight_s) 9 | # minimum variance 10 | t(weight_s) %*% cov_mat %*% weight_s 11 | 1/(t(u_nit) %*% cov_inv %*% u_nit) 12 | # calculate vector of mean returns 13 | mean_rets <- colMeans(re_turns) 14 | # specify the target return 15 | tar_get <- 1.5*mean(re_turns) 16 | # products of inverse with mean returns and unit vector 17 | f_mat <- matrix(c( 18 | t(u_nit) %*% cov_inv %*% u_nit, 19 | t(u_nit) %*% cov_inv %*% mean_rets, 20 | t(mean_rets) %*% cov_inv %*% u_nit, 21 | t(mean_rets) %*% cov_inv %*% mean_rets), nc=2) 22 | # solve for the Lagrange multipliers 23 | multipli_ers <- 24 | solve(a=f_mat, b=c(2, 2*tar_get)) 25 | # calculate weights 26 | weight_s <- drop(0.5*cov_inv %*% 27 | cbind(u_nit, mean_rets) %*% multipli_ers) 28 | # calculate constraints 29 | all.equal(1, sum(weight_s)) 30 | all.equal(tar_get, sum(mean_rets*weight_s)) 31 | # calculate portfolio return and standard deviation 32 | portf_rets <- drop(re_turns %*% weight_s) 33 | c(return=mean(portf_rets), sd=sd(portf_rets)) 34 | all.equal(mean(portf_rets), tar_get) 35 | # calculate portfolio variance 36 | uu <- c(1, tar_get) 37 | f_inv <- solve(f_mat) 38 | all.equal(var(portf_rets), drop(t(uu) %*% f_inv %*% uu)) 39 | # calculate vertex of variance parabola 40 | weight_s <- drop(cov_inv %*% u_nit / 41 | drop(t(u_nit) %*% cov_inv %*% u_nit)) 42 | portf_rets <- drop(re_turns %*% weight_s) 43 | v_rets <- 44 | drop(t(u_nit) %*% cov_inv %*% mean_rets / 45 | t(u_nit) %*% cov_inv %*% u_nit) 46 | all.equal(mean(portf_rets), v_rets) 47 | var_min <- 48 | drop(1/t(u_nit) %*% cov_inv %*% u_nit) 49 | all.equal(var(portf_rets), var_min) 50 | # calculate efficient frontier 51 | target_s <- v_rets*(1+seq(from=-1, to=1, by=0.1)) 52 | eff_front <- sapply(target_s, function(tar_get) { 53 | uu <- c(1, tar_get) 54 | sqrt(drop(t(uu) %*% f_inv %*% uu)) 55 | }) # end sapply 56 | # plot efficient frontier 57 | x11(width=6, height=5) 58 | plot(x=eff_front, y=target_s, t="l", col="blue", lwd=2, 59 | main="Efficient Frontier and Minimum Variance Portfolio", 60 | xlab="standard deviation", ylab="return") 61 | points(x=sqrt(var_min), y=v_rets, col="green", lwd=6) 62 | text(x=sqrt(var_min), y=v_rets, labels="minimum \nvariance", 63 | pos=4, cex=0.8) 64 | # calculate excess re_turns 65 | risk_free <- 0.03/252 66 | ex_cess <- re_turns - risk_free 67 | # calculate covariance and inverse matrix 68 | cov_mat <- cov(re_turns) 69 | u_nit <- rep(1, NCOL(cov_mat)) 70 | cov_inv <- solve(a=cov_mat) 71 | # calculate mean excess returns 72 | ex_cess <- sapply(ex_cess, mean) 73 | # weights of maximum Sharpe portfolio 74 | # weight_s <- solve(a=cov_mat, b=re_turns) 75 | weight_s <- cov_inv %*% ex_cess 76 | weight_s <- weight_s/drop(t(u_nit) %*% weight_s) 77 | # Sharpe ratios 78 | sqrt(252)*sum(weight_s * ex_cess) / 79 | sqrt(drop(weight_s %*% cov_mat %*% weight_s)) 80 | sapply(re_turns - risk_free, 81 | function(x) sqrt(252)*mean(x)/sd(x)) 82 | weights_maxsharpe <- weight_s 83 | x11(wid_th <- 6, hei_ght <- 6) 84 | # calculate minimum variance weights 85 | weight_s <- cov_inv %*% u_nit 86 | weight_s <- weight_s / drop(t(u_nit) %*% weight_s) 87 | # minimum standard deviation and return 88 | std_dev <- sqrt(252*drop(weight_s %*% cov_mat %*% weight_s)) 89 | min_ret <- 252*sum(weight_s * mean_rets) 90 | # calculate maximum Sharpe portfolios 91 | risk_free <- (min_ret * seq(-10, 10, by=0.1)^3)/252 92 | eff_front <- sapply(risk_free, function(risk_free) { 93 | weight_s <- cov_inv %*% (mean_rets - risk_free) 94 | weight_s <- weight_s/drop(t(u_nit) %*% weight_s) 95 | # portfolio return and standard deviation 96 | c(return=252*sum(weight_s * mean_rets), 97 | stddev=sqrt(252*drop(weight_s %*% cov_mat %*% weight_s))) 98 | }) # end sapply 99 | eff_front <- cbind(252*risk_free, t(eff_front)) 100 | colnames(eff_front)[1] <- "risk-free" 101 | eff_front <- eff_front[is.finite(eff_front[, "stddev"]), ] 102 | eff_front <- eff_front[order(eff_front[, "return"]), ] 103 | # plot maximum Sharpe portfolios 104 | plot(x=eff_front[, "stddev"], 105 | y=eff_front[, "return"], t="l", 106 | xlim=c(0.0*std_dev, 3.0*std_dev), 107 | ylim=c(0.0*min_ret, 2.0*min_ret), 108 | main="Efficient Frontier and Capital Market Line", 109 | xlab="standard deviation", ylab="return") 110 | points(x=eff_front[, "stddev"], y=eff_front[, "return"], 111 | col="red", lwd=3) 112 | # plot minimum variance portfolio 113 | points(x=std_dev, y=min_ret, col="green", lwd=6) 114 | text(std_dev, min_ret, labels="minimum \nvariance", 115 | pos=4, cex=0.8) 116 | # draw Capital Market Line 117 | sor_ted <- sort(eff_front[, 1]) 118 | risk_free <- 119 | sor_ted[findInterval(x=0.5*min_ret, vec=sor_ted)] 120 | points(x=0, y=risk_free, col="blue", lwd=6) 121 | text(x=0, y=risk_free, labels="risk-free", 122 | pos=4, cex=0.8) 123 | in_dex <- match(risk_free, eff_front[, 1]) 124 | points(x=eff_front[in_dex, "stddev"], 125 | y=eff_front[in_dex, "return"], 126 | col="blue", lwd=6) 127 | text(x=eff_front[in_dex, "stddev"], 128 | y=eff_front[in_dex, "return"], 129 | labels="market portfolio", 130 | pos=2, cex=0.8) 131 | sharp_e <- (eff_front[in_dex, "return"]-risk_free)/ 132 | eff_front[in_dex, "stddev"] 133 | abline(a=risk_free, b=sharp_e, col="blue", lwd=2) 134 | text(x=0.7*eff_front[in_dex, "stddev"], 135 | y=0.7*eff_front[in_dex, "return"]+0.01, 136 | labels="Capital Market Line", pos=2, cex=0.8, 137 | srt=45*atan(sharp_e*hei_ght/wid_th)/(0.25*pi)) 138 | # calculate rolling variance of S&P500 portfolio 139 | wid_th <- 252 140 | vari_ance <- roll::roll_var(re_turns, width=wid_th) 141 | vari_ance <- zoo::na.locf(vari_ance) 142 | vari_ance[is.na(vari_ance)] <- 0 143 | # calculate rolling Sharpe of S&P500 portfolio 144 | returns_width <- rutils::diff_it(price_s, lagg=wid_th) 145 | weight_s <- returns_width/sqrt(wid_th*vari_ance) 146 | weight_s[vari_ance==0] <- 0 147 | weight_s[1:wid_th, ] <- 1 148 | weight_s[is.na(weight_s)] <- 0 149 | weight_s <- weight_s/rowSums(abs(weight_s))/price_s 150 | weight_s[is.na(weight_s)] <- 0 151 | weight_s <- rutils::lag_it(weight_s) 152 | sum(is.na(weight_s)) 153 | # calculate portfolio profits and losses 154 | pnl_s <- rowSums(weight_s*re_turns) 155 | # Calculate transaction costs 156 | bid_offer <- 0.001 157 | cost_s <- 0.5*bid_offer*price_s*abs(rutils::diff_it(weight_s)) 158 | cost_s <- rowSums(cost_s) 159 | pnl_s <- (pnl_s - cost_s) 160 | pnl_s <- cumsum(pnl_s) 161 | pnl_s <- xts(pnl_s, order.by=index(price_s)) 162 | pnl_s <- cbind(rutils::env_etf$VTI[, 4], pnl_s) 163 | pnl_s <- na.omit(pnl_s) 164 | colnames(pnl_s) <- c("VTI", "momentum") 165 | col_names <- colnames(pnl_s) 166 | # plot momentum and VTI 167 | dygraphs::dygraph(pnl_s, main=paste(col_names, collapse=" and ")) %>% 168 | dyAxis("y", label=col_names[1], independentTicks=TRUE) %>% 169 | dyAxis("y2", label=col_names[2], independentTicks=TRUE) %>% 170 | dySeries(col_names[2], axis="y2", col=c("red", "blue")) 171 | library(HighFreq) 172 | load("C:/Develop/R/lecture_slides/data/sp500_prices.RData") 173 | n_col <- NCOL(price_s) 174 | # define end_points 175 | end_points <- rutils::calc_endpoints(price_s, inter_val="months") 176 | end_points <- end_points[end_points>50] 177 | len_gth <- NROW(end_points) 178 | look_back <- 12 179 | start_points <- c(rep_len(1, look_back-1), end_points[1:(len_gth-look_back+1)]) 180 | # scale price_s 181 | date_s <- index(price_s) 182 | price_s <- t(t(price_s) / as.numeric(price_s[1, ])) 183 | sum(is.na(price_s)) 184 | in_dex <- xts(rowSums(price_s)/n_col, date_s) 185 | re_turns <- diff_it(price_s) 186 | # compile backtest function 187 | Rcpp::sourceCpp(file="C:/Develop/R/lecture_slides/scripts/rcpp_test6.cpp") 188 | # run backtest function 189 | al_pha <- 0.01 190 | max_eigen <- 2 191 | strat_rets_arma <- roll_portf(re_turns, 192 | re_turns, 193 | start_points-1, 194 | end_points-1, 195 | al_pha=al_pha, 196 | max_eigen=max_eigen) 197 | # plot strategy 198 | strat_rets_arma <- cumsum(strat_rets_arma) 199 | strat_rets_arma <- xts(strat_rets_arma, date_s) 200 | library(dygraphs) 201 | strat_rets_arma <- cbind(strat_rets_arma, in_dex) 202 | col_names <- c("Strategy", "Index") 203 | colnames(strat_rets_arma) <- col_names 204 | dygraphs::dygraph(strat_rets_arma, main=paste(col_names, collapse=" and ")) %>% 205 | dyAxis("y", label=col_names[1], independentTicks=TRUE) %>% 206 | dyAxis("y2", label=col_names[2], independentTicks=TRUE) %>% 207 | dySeries(col_names[2], axis="y2", col=c("red", "blue")) 208 | library(HighFreq) # load HighFreq 209 | # daily SPY volatility from minutely prices using package TTR 210 | library(TTR) 211 | sqrt((6.5*60)*mean(na.omit( 212 | TTR::volatility(SPY, N=1, 213 | calc="yang.zhang"))^2)) 214 | # SPY volatility using package HighFreq 215 | 60*sqrt((6.5*60)*agg_regate(oh_lc=SPY, 216 | weight_ed=FALSE, mo_ment="run_variance", 217 | calc_method="yang_zhang")) 218 | # standard errors of TTR variance estimators using bootstrap 219 | boot_strap <- sapply(1:1e2, function(x) { 220 | # create random OHLC 221 | oh_lc <- HighFreq::random_ohlc() 222 | # calculate variance estimate 223 | c(var=var(oh_lc[, 4]), 224 | yang_zhang=HighFreq::calc_variance( 225 | oh_lc, calc_method="yang_zhang", sca_le=FALSE)) 226 | }) # end sapply 227 | # analyze bootstrapped variance 228 | boot_strap <- t(boot_strap) 229 | head(boot_strap) 230 | colMeans(boot_strap) 231 | apply(boot_strap, MARGIN=2, sd) / 232 | colMeans(boot_strap) 233 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/R_environment.R: -------------------------------------------------------------------------------- 1 | # display documentation on function "getwd" 2 | help(getwd) 3 | ?getwd # equivalent to "help(getwd)" 4 | help.start() # open the hypertext documentation 5 | # "<-" and "=" are valid assignment operators 6 | my_var <- 3 7 | 8 | # typing a symbol or expression evaluates it 9 | my_var 10 | 11 | # text in quotes is interpreted as a string 12 | my_var <- "Hello World!" 13 | 14 | # typing a symbol or expression evaluates it 15 | my_var 16 | 17 | my_var # text after hash is treated as comment 18 | getwd() # get cwd 19 | setwd("C:/Develop/R") # set cwd 20 | getwd() # get cwd 21 | Sys.time() # get date and time 22 | 23 | Sys.Date() # get date only 24 | rm(list=ls()) 25 | setwd("C:/Develop/R/lecture_slides/data") 26 | var1 <- 3 # define new object 27 | ls() # list all objects in workspace 28 | # list objects starting with "v" 29 | ls(pattern=glob2rx("v*")) 30 | # remove all objects starting with "v" 31 | rm(list=ls(pattern=glob2rx("v*"))) 32 | save.image() # save workspace to file .RData in cwd 33 | rm(var1) # remove object 34 | ls() # list objects 35 | load(".RData") 36 | ls() # list objects 37 | var2 <- 5 # define another object 38 | save(var1, var2, # save selected objects 39 | file="C:/Develop/R/lecture_slides/data/my_data.RData") 40 | rm(list=ls()) # remove all objects 41 | ls() # list objects 42 | load_ed <- load(file="C:/Develop/R/lecture_slides/data/my_data.RData") 43 | load_ed 44 | ls() # list objects 45 | q() # quit R session 46 | history(5) # display last 5 commands 47 | savehistory(file="myfile") # default is ".Rhistory" 48 | loadhistory(file="myfile") # default is ".Rhistory" 49 | sessionInfo() # get R version and other session info 50 | Sys.getenv()[5:7] # list some environment variables 51 | 52 | Sys.getenv("Home") # get R user HOME directory 53 | 54 | Sys.setenv(Home="C:/Develop/data") # set HOME directory 55 | 56 | Sys.getenv("Home") # get user HOME directory 57 | 58 | Sys.getenv("R_home") # get R_HOME directory 59 | 60 | R.home() # get R_HOME directory 61 | 62 | R.home("etc") # get "etc" sub-directory of R_HOME 63 | # ?options # long list of global options 64 | # interpret strings as characters, not factors 65 | getOption("stringsAsFactors") # display option 66 | options("stringsAsFactors") # display option 67 | options(stringsAsFactors=FALSE) # set option 68 | # number of digits printed for numeric values 69 | options(digits=3) 70 | # control exponential scientific notation of print method 71 | # positive "scipen" values bias towards fixed notation 72 | # negative "scipen" values bias towards scientific notation 73 | options(scipen=100) 74 | # maximum number of items printed to console 75 | options(max.print=30) 76 | # warning levels options 77 | # negative - warnings are ignored 78 | options(warn=-1) 79 | # zero - warnings are stored and printed after top-level function has completed 80 | options(warn=0) 81 | # one - warnings are printed as they occur 82 | options(warn=1) 83 | # two or larger - warnings are turned into errors 84 | options(warn=2) 85 | # save all options in variable 86 | op_tions <- options() 87 | # restore all options from variable 88 | options(op_tions) 89 | # R startup (site) directory 90 | paste(R.home(), "etc", sep="/") 91 | 92 | file.path(R.home(), "etc") # better way 93 | 94 | # perform tilde-expansions and convert to readable format 95 | normalizePath(file.path(R.home(), "etc"), winslash="/") 96 | 97 | normalizePath(R.home("etc"), winslash="/") 98 | normalizePath("~", winslash="/") # Windows user HOME directory 99 | 100 | Sys.getenv("Home") # R user HOME directory 101 | 102 | setwd("C:/Develop/R") 103 | getwd() # current working directory 104 | 105 | # R startup (site) directory 106 | normalizePath(file.path(R.home(), "etc"), winslash="/") 107 | 108 | # R executable directory 109 | normalizePath(file.path(R.home(), "bin/x64"), winslash="/") 110 | 111 | # R documentation directory 112 | normalizePath(file.path(R.home(), "doc/manual"), winslash="/") 113 | # options(max.print=5) 114 | setwd("C:/Develop/R/lecture_slides/data") 115 | sample(dir(), 5) # get 5 file names - dir() lists all files 116 | sample(dir(pattern="csv"), 5) # list files containing "csv" 117 | sample(list.files(R.home()), 5) # all files in R_HOME directory 118 | sample(list.files(R.home("etc")), 5) # all files in "etc" sub-directory of R_HOME directory 119 | sample(list.dirs(), 5) # directories in cwd 120 | list.dirs(R.home("etc")) # directories in "etc" sub-directory 121 | sample(Sys.glob("*.csv"), 5) 122 | Sys.glob(R.home("etc")) 123 | getwd() # get cwd 124 | setwd("C:/Develop/R") 125 | # help(Startup) # description of R session startup mechanism 126 | 127 | # files in R startup directory directory 128 | dir(normalizePath(file.path(R.home(), "etc"), winslash="/")) 129 | 130 | # *.R* files in cwd directory 131 | getwd() 132 | dir(getwd(), all.files=TRUE, pattern="\\.R") 133 | dir(getwd(), all.files=TRUE, pattern=glob2rx("*.R*")) 134 | setwd("C:/Develop/R") 135 | 136 | scan(file=".Rprofile", what=character(), sep="\n") 137 | cat("sourcing .Rprofile file\n") 138 | 139 | 140 | cat("sourcing .Rprofile file\n") 141 | 142 | 143 | rm(list=ls()) 144 | # get base environment 145 | baseenv() 146 | # get global environment 147 | globalenv() 148 | # get current environment 149 | environment() 150 | # get environment class 151 | class(environment()) 152 | # define variable in current environment 153 | glob_var <- 1 154 | # get objects in current environment 155 | ls(environment()) 156 | # create new environment 157 | new_env <- new.env() 158 | # get calling environment of new environment 159 | parent.env(new_env) 160 | # assign Value to Name 161 | assign("new_var1", 3, envir=new_env) 162 | # create object in new environment 163 | new_env$new_var2 <- 11 164 | # get objects in new environment 165 | ls(new_env) 166 | # get objects in current environment 167 | ls(environment()) 168 | # environments are subset like lists 169 | new_env$new_var1 170 | # environments are subset like lists 171 | new_env[["new_var1"]] 172 | search() # get search path for R objects 173 | my_list <- 174 | list(flowers=c("rose", "daisy", "tulip"), 175 | trees=c("pine", "oak", "maple")) 176 | my_list$trees 177 | attach(my_list) 178 | trees 179 | search() # get search path for R objects 180 | detach(my_list) 181 | head(trees) # "trees" is in datasets base package 182 | library(HighFreq) # load package HighFreq 183 | # ETF symbols 184 | sym_bols <- c("VTI", "VEU", "IEF", "VNQ") 185 | # extract and merge all data, subset by sym_bols 186 | price_s <- do.call(merge, 187 | as.list(rutils::env_etf)[sym_bols]) 188 | # extract and merge adjusted prices, subset by sym_bols 189 | price_s <- do.call(merge, 190 | lapply(as.list(rutils::env_etf)[sym_bols], Ad)) 191 | # same, but works only for OHLC series 192 | price_s <- do.call(merge, 193 | eapply(rutils::env_etf, Ad)[sym_bols]) 194 | # drop ".Adjusted" from colnames 195 | colnames(price_s) <- 196 | sapply(colnames(price_s), 197 | function(col_name) 198 | strsplit(col_name, split="[.]")[[1]])[1, ] 199 | tail(price_s[, 1:2], 3) 200 | # which objects in global environment are class xts? 201 | unlist(eapply(globalenv(), is.xts)) 202 | 203 | # save xts to csv file 204 | write.zoo(price_s, 205 | file='etf_series.csv', sep=",") 206 | # copy price_s into env_etf and save to .RData file 207 | assign("price_s", price_s, envir=env_etf) 208 | save(env_etf, file='etf_data.RData') 209 | # "trees" is in datasets base package 210 | head(trees, 3) 211 | colnames(trees) 212 | mean(Girth) 213 | mean(trees$Girth) 214 | with(trees, 215 | c(mean(Girth), mean(Height), mean(Volume))) 216 | setwd("C:/Develop/R/lecture_slides/data") 217 | cat("Enter\ttab") # cat() interprets backslash escape sequences 218 | print("Enter\ttab") 219 | 220 | my_text <- print("hello") 221 | my_text # print() returns its argument 222 | 223 | # create string 224 | my_text <- "Title: My Text\nSome numbers: 1,2,3,...\nRprofile files contain code executed at R startup,\n" 225 | 226 | cat(my_text, file="mytext.txt") # write to text file 227 | 228 | cat("Title: My Text", # write several lines to text file 229 | "Some numbers: 1,2,3,...", 230 | "Rprofile files contain code executed at R startup,", 231 | file="mytext.txt", sep="\n") 232 | 233 | save(my_text, file="mytext.RData") # write to binary file 234 | print(pi) 235 | print(pi, digits=10) 236 | getOption("digits") 237 | foo <- 12 238 | bar <- "months" 239 | sprintf("There are %i %s in the year", foo, bar) 240 | setwd("C:/Develop/R/lecture_slides/data") 241 | # read text from file 242 | scan(file="mytext.txt", what=character(), sep="\n") 243 | 244 | # read lines from file 245 | readLines(con="mytext.txt") 246 | 247 | # read text from console 248 | in_put <- readline("Enter a number: ") 249 | class(in_put) 250 | # coerce to numeric 251 | in_put <- as.numeric(in_put) 252 | 253 | # read text from file and display in editor: 254 | # file.show("mytext.txt") 255 | # file.show("mytext.txt", pager="") 256 | setwd("C:/Develop/R/lecture_slides/data") 257 | data_frame <- data.frame(type=c("rose", "daisy", "tulip"), color=c("red", "white", "yellow"), price=c(1.5, 0.5, 1.0), row.names=c("flower1", "flower2", "flower3")) # end data.frame 258 | mat_rix <- matrix(sample(1:12), ncol=3, dimnames=list(NULL, c("col1", "col2", "col3"))) 259 | rownames(mat_rix) <- paste("row", 1:NROW(mat_rix), sep="") 260 | # write data frame to text file, and then read it back 261 | write.table(data_frame, file="florist.txt") 262 | data_read <- read.table(file="florist.txt") 263 | data_read # a data frame 264 | 265 | # write matrix to text file, and then read it back 266 | write.table(mat_rix, file="matrix.txt") 267 | mat_read <- read.table(file="matrix.txt") 268 | mat_read # write.table() coerced matrix to data frame 269 | class(mat_read) 270 | # coerce from data frame back to matrix 271 | mat_read <- as.matrix(mat_read) 272 | class(mat_read) 273 | setwd("C:/Develop/R/lecture_slides/data") 274 | data_frame <- data.frame(small=c(3, 5), medium=c(9, 11), large=c(15, 13)) 275 | data_frame <- read.table("mydata.txt", header=TRUE) 276 | data_frame <- read.table("clipboard", header=TRUE) 277 | 278 | write.table(x=data_frame, file="clipboard", sep="\t") 279 | 280 | # wrapper function for copying data frame from clipboard into R 281 | # by default, data is tab delimited, with a header 282 | read_clip <- function(file="clipboard", sep="\t", 283 | header=TRUE, ...) { 284 | read.table(file=file, sep=sep, header=header, ...) 285 | } # end read_clip 286 | 287 | data_frame <- read_clip() 288 | 289 | # wrapper function for copying data frame from R into clipboard 290 | # by default, data is tab delimited, with a header 291 | write_clip <- function(data, row.names=FALSE, 292 | col.names=TRUE, ...) { 293 | write.table(x=data, file="clipboard", sep="\t", 294 | row.names=row.names, col.names=col.names, ...) 295 | } # end write_clip 296 | 297 | write_clip(data=data_frame) 298 | 299 | # launch spreadsheet-style data editor 300 | data_frame <- edit(data_frame) 301 | setwd("C:/Develop/R/lecture_slides/data") 302 | # write data frame to CSV file, and then read it back 303 | write.csv(data_frame, file="florist.csv") 304 | data_read <- read.csv(file="florist.csv", 305 | stringsAsFactors=FALSE) 306 | data_read # the row names are read in as extra column 307 | # restore row names 308 | rownames(data_read) <- data_read[, 1] 309 | data_read <- data_read[, -1] # remove extra column 310 | data_read 311 | # read data frame, with row names from first column 312 | data_read <- read.csv(file="florist.csv", row.names=1) 313 | data_read 314 | setwd("C:/Develop/R/lecture_slides/data") 315 | # write data frame to CSV file, without row names 316 | write.csv(data_frame, row.names=FALSE, file="florist.csv") 317 | data_read <- read.csv(file="florist.csv") 318 | data_read # a data frame without row names 319 | setwd("C:/Develop/R/lecture_slides/data") 320 | # write matrix to csv file, and then read it back 321 | write.csv(mat_rix, file="matrix.csv") 322 | mat_read <- read.csv(file="matrix.csv", row.names=1) 323 | mat_read # read.csv() reads matrix as data frame 324 | class(mat_read) 325 | mat_read <- as.matrix(mat_read) # coerce to matrix 326 | identical(mat_rix, mat_read) 327 | write.csv(mat_rix, row.names=FALSE, 328 | file="matrix_ex_rows.csv") 329 | mat_read <- read.csv(file="matrix_ex_rows.csv") 330 | mat_read <- as.matrix(mat_read) 331 | mat_read # a matrix without row names 332 | setwd("C:/Develop/R/lecture_slides/data") 333 | library(MASS) # load package "MASS" 334 | # write to CSV file by row - it's very SLOW!!! 335 | write.matrix(mat_rix, file="matrix.csv", sep=",") 336 | system.time( # scan reads faster - skip first line with colnames 337 | mat_read <- scan(file="matrix.csv", sep=",", 338 | skip=1, what=numeric())) 339 | col_names <- readLines(con="matrix.csv", n=1) # read colnames 340 | col_names # this is a string! 341 | col_names <- strsplit(col_names, s=",")[[1]] # convert to char vector 342 | mat_read # mat_read is a vector, not matrix! 343 | # coerce by row to matrix 344 | mat_read <- matrix(mat_read, ncol=length(col_names), 345 | byrow=TRUE) 346 | colnames(mat_read) <- col_names # restore colnames 347 | mat_read 348 | setwd("C:/Develop/R/lecture_slides/data") 349 | # read data from a csv file, including row names 350 | mat_rix <- read.csv(file="matrix_bad.csv", row.names=1, 351 | stringsAsFactors=FALSE) 352 | mat_rix 353 | class(mat_rix) 354 | # columns with bad data are character or factor 355 | sapply(mat_rix, class) 356 | row_names <- row.names(mat_rix) # copy row names 357 | # sapply loop over columns and coerce to numeric 358 | mat_rix <- sapply(mat_rix, as.numeric) 359 | row.names(mat_rix) <- row_names # restore row names 360 | # replace NAs with zero 361 | mat_rix[is.na(mat_rix)] <- 0 362 | # matrix without NAs 363 | mat_rix 364 | setwd("C:/Develop/R/lecture_slides/data") 365 | rm(list=ls()) 366 | set.seed(1121) # reset random number generator 367 | library(zoo) # load package zoo 368 | # create zoo with Date index 369 | in_dex <- seq(from=as.Date("2013-06-15"), 370 | by="day", length.out=100) 371 | zoo_series <- zoo(cumsum(rnorm(NROW(in_dex))), 372 | order.by=in_dex) 373 | tail(zoo_series, 3) 374 | # write zoo to text file, and then read it back 375 | write.zoo(zoo_series, file="zoo_series.txt") 376 | zoo_series <- read.zoo("zoo_series.txt") # read it back 377 | tail(zoo_series, 3) 378 | setwd("C:/Develop/R/lecture_slides/data") 379 | rm(list=ls()) 380 | set.seed(1121) # reset random number generator 381 | library(zoo) # load package zoo 382 | # create zoo with POSIXct date-time index 383 | in_dex <- seq(from=as.POSIXct("2013-06-15"), 384 | by="hour", length.out=1000) 385 | zoo_series <- zoo(cumsum(rnorm(length(in_dex))), 386 | order.by=in_dex) 387 | tail(zoo_series, 3) 388 | # write zoo to text file, and then read it back 389 | write.zoo(zoo_series, file="zoo_series.txt") 390 | zoo_series <- read.zoo("zoo_series.txt") # read it back 391 | # time field was read as a separate column 392 | tail(zoo_series, 3) 393 | # read and specify that second column is time field 394 | zoo_series <- read.zoo(file="zoo_series.txt", 395 | index.column=list(1,2), 396 | tz="America/New_York") 397 | tail(zoo_series, 3) 398 | setwd("C:/Develop/R/lecture_slides/data") 399 | library(zoo) # load package zoo 400 | # write zoo to CSV file, and then read it back 401 | write.zoo(zoo_series, file="zoo_series.csv", 402 | sep=",", col.names=TRUE) 403 | zoo_series <- read.zoo(file="zoo_series.csv", 404 | header=TRUE, sep=",", 405 | drop=FALSE, 406 | FUN=as.POSIXct, tz="America/New_York") 407 | tail(zoo_series, 3) 408 | # read zoo from CSV file, with custom date-time format 409 | zoo_frame <- read.table(file="zoo_series2.csv", 410 | sep=",") 411 | tail(zoo_frame, 3) # date-time format mm/dd/yyyy hh:mm 412 | zoo_series <- read.zoo(file="zoo_series2.csv", 413 | header=TRUE, sep=",", 414 | drop=FALSE, 415 | FUN=as.POSIXct, 416 | tz="America/New_York", 417 | format="%m/%d/%Y %H:%M") 418 | tail(zoo_series, 3) 419 | rm(list=ls()) # remove all objects 420 | var1 <- 1; var2 <- 2 421 | ls() # list all objects 422 | ls()[1] # list first object 423 | args(save) # list arguments of save function 424 | # save "var1" to a binary file using string argument 425 | save("var1", file="my_data.RData") 426 | # save "var1" to a binary file using object name 427 | save(var1, file="my_data.RData") 428 | # save multiple objects 429 | save(var1, var2, file="my_data.RData") 430 | # save first object in list by passing to "..." argument 431 | # ls()[1] is not evaluated 432 | save(ls()[1], file="my_data.RData") 433 | # save first object in list by passing to "list" argument 434 | save(list=ls()[1], file="my_data.RData") 435 | # save whole list by passing it to the "list" argument 436 | save(list=ls(), file="my_data.RData") 437 | rm(list=ls()) # remove all objects 438 | # load objects from file 439 | load_ed <- load(file="my_data.RData") 440 | load_ed # vector of loaded objects 441 | ls() # list objects 442 | # assign new values to objects in global environment 443 | sapply(load_ed, function(sym_bol) { 444 | assign(sym_bol, runif(1), envir=globalenv()) 445 | }) # end sapply 446 | ls() # list objects 447 | # assign new values to objects using for loop 448 | for (sym_bol in load_ed) { 449 | assign(sym_bol, runif(1)) 450 | } # end for 451 | ls() # list objects 452 | # save vector of objects 453 | save(list=load_ed, file="my_data.RData") 454 | # remove only loaded objects 455 | rm(list=load_ed) 456 | # remove the object "load_ed" 457 | rm(load_ed) 458 | sink("sinkdata.txt")# redirect text output to file 459 | 460 | cat("Redirect text output from R\n") 461 | print(runif(10)) 462 | cat("\nEnd data\nbye\n") 463 | 464 | sink() # turn redirect off 465 | 466 | pdf("Rgraph.pdf", width=7, height=4) # redirect graphics to pdf file 467 | 468 | cat("Redirect data from R into pdf file\n") 469 | my_var <- seq(-2*pi, 2*pi, len=100) 470 | plot(x=my_var, y=sin(my_var), main="Sine wave", 471 | xlab="", ylab="", type="l", lwd=2, col="red") 472 | cat("\nEnd data\nbye\n") 473 | 474 | dev.off() # turn pdf output off 475 | 476 | png("r_plot.png") # redirect graphics output to png file 477 | 478 | cat("Redirect graphics from R into png file\n") 479 | plot(x=my_var, y=sin(my_var), main="Sine wave", 480 | xlab="", ylab="", type="l", lwd=2, col="red") 481 | cat("\nEnd data\nbye\n") 482 | 483 | dev.off() # turn png output off 484 | # install latest version of googlesheets 485 | devtools::install_github("jennybc/googlesheets") 486 | # load package googlesheets 487 | library(googlesheets) 488 | library(dplyr) 489 | # authenticate authorize R to view and manage your files 490 | gs_auth(new_user=TRUE) 491 | # list the files in Google Sheets 492 | googlesheets::gs_ls() 493 | # register a sheet 494 | google_sheet <- gs_title("my_data") 495 | # view sheet summary 496 | google_sheet 497 | # list tab names in sheet 498 | tab_s <- gs_ws_ls(google_sheet) 499 | # set curl options 500 | library(httr) 501 | httr::set_config(config(ssl_verifypeer=0L)) 502 | # read data from sheet 503 | gs_read(google_sheet) 504 | # read data from single tab of sheet 505 | gs_read(google_sheet, ws=tab_s[1]) 506 | gs_read_csv(google_sheet, ws=tab_s[1]) 507 | # or using dplyr pipes 508 | google_sheet %>% gs_read(ws=tab_s[1]) 509 | # download data from sheet into file 510 | gs_download(google_sheet, ws=tab_s[1], 511 | to="C:/Develop/R/lecture_slides/data/google_sheet.csv") 512 | # open sheet in internet browser 513 | gs_browse(google_sheet) 514 | # install latest version of googlesheets 515 | devtools::install_github("jennybc/googlesheets") 516 | # load package googlesheets 517 | library(googlesheets) 518 | library(dplyr) 519 | # authenticate authorize R to view and manage your files 520 | gs_auth(new_user=TRUE) 521 | # list the files in Google Sheets 522 | googlesheets::gs_ls() 523 | # register a sheet 524 | google_sheet <- gs_title("my_data") 525 | # view sheet summary 526 | google_sheet 527 | # list tab names in sheet 528 | tab_s <- gs_ws_ls(google_sheet) 529 | # set curl options 530 | library(httr) 531 | httr::set_config(config(ssl_verifypeer=0L)) 532 | # read data from sheet 533 | gs_read(google_sheet) 534 | # read data from single tab of sheet 535 | gs_read(google_sheet, ws=tab_s[1]) 536 | gs_read_csv(google_sheet, ws=tab_s[1]) 537 | # or using dplyr pipes 538 | google_sheet %>% gs_read(ws=tab_s[1]) 539 | # download data from sheet into file 540 | gs_download(google_sheet, ws=tab_s[1], 541 | to="C:/Develop/R/lecture_slides/data/google_sheet.csv") 542 | # open sheet in internet browser 543 | gs_browse(google_sheet) 544 | script_dir <- "C:/Develop/R/scripts" 545 | # execute script file and print the commands 546 | source(file.path(script_dir, "script.R"), 547 | echo=TRUE) 548 | 549 | #################################### 550 | #script.R file contains R script to demonstrate sourcing from script files 551 | 552 | # print information about this process 553 | print(paste0("print: This test script was run at: ", format(Sys.time()))) 554 | cat("cat: This test script was run at:", format(Sys.time()), "\n") 555 | 556 | # display first 6 rows of cars data frame 557 | head(cars) 558 | 559 | # define a function 560 | fun_c <- function(x) x+1 561 | 562 | # read a line from console 563 | readline("Press Return to continue") 564 | 565 | # plot sine function in x11 window 566 | x11() 567 | curve(expr=sin, type="l", xlim=c(-2*pi, 2*pi), 568 | xlab="", ylab="", lwd=2, col="orange", 569 | main="Sine function") 570 | # get help about running R scripts and batch processes 571 | ?BATCH 572 | ?Rscript 573 | #script_args.R contains R script that accepts arguments 574 | # print information about this process 575 | cat("cat: This script was run at:", format(Sys.time()), "\n") 576 | # read arguments supplied on the command line 577 | arg_s <- commandArgs(TRUE) 578 | # print the arguments 579 | cat(paste0("arguments supplied on command line: ", paste(arg_s, collapse=", "), "\n")) 580 | # return sum of arguments 581 | sum(as.numeric(arg_s)) 582 | #plot_to_file.R 583 | #R script to demonstrate plotting to file 584 | 585 | # redirect graphics output to png file 586 | plot_dir <- "C:/Develop/data" 587 | png(file.path(plot_dir, "r_plot.png")) 588 | 589 | # plot sine function 590 | curve(expr=sin, type="l", xlim=c(-2*pi, 2*pi), 591 | xlab="", ylab="", lwd=2, col="orange", 592 | main="Sine function") 593 | 594 | # turn png output off 595 | dev.off() 596 | #plot_interactive.R 597 | #R script to demonstrate interactive plotting 598 | 599 | # plot sine function in x11 window 600 | x11() 601 | curve(expr=sin, type="l", xlim=c(-2*pi, 2*pi), 602 | xlab="", ylab="", lwd=2, col="orange", 603 | main="Sine function") 604 | 605 | # wait until x11 window is closed 606 | while (!is.null(dev.list())) Sys.sleep(1) 607 | #perform calculations in R, 608 | #and export to CSV files 609 | setwd("C:/Develop/R/lecture_slides/data") 610 | # read data frame, with row names from first column 611 | data_read <- read.csv(file="florist.csv", 612 | row.names=1) 613 | # subset data frame 614 | data_read <- 615 | data_read[data_read[, "type"]=="daisy", ] 616 | # write data frame to CSV file, with row names 617 | write.csv(data_read, file="daisies.csv") 618 | #perform calculations in R, 619 | #and export to CSV files 620 | setwd("C:/Develop/R/lecture_slides/data") 621 | # read data frame, with row names from first column 622 | data_read <- read.csv(file="florist.csv", 623 | row.names=1) 624 | # subset data frame 625 | data_read <- 626 | data_read[data_read[, "type"]=="daisy", ] 627 | # write data frame to CSV file, with row names 628 | write.csv(data_read, file="daisies.csv") 629 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/app_dygraphs2.R: -------------------------------------------------------------------------------- 1 | ############################## 2 | # This is an example of creating a dynamic shiny app 3 | # which produces an interactive dygraphs plot. 4 | # Just press the "Run App" button on upper right of this panel. 5 | ############################## 6 | 7 | library(shiny) 8 | library(dygraphs) 9 | library(rutils) 10 | 11 | 12 | # Define elements of the UI user interface 13 | inter_face <- shiny::shinyUI(fluidPage( 14 | 15 | titlePanel("VTI prices"), 16 | 17 | sidebarLayout( 18 | sidebarPanel( 19 | sliderInput("lamb_da", label="lambda:", 20 | min=0.01, max=0.5, value=0.2, step=0.05), 21 | numericInput("wid_th", label="wid_th:", min=10, max=201, value=51) 22 | ), 23 | mainPanel( 24 | dygraphOutput("dygraph") 25 | ) 26 | ) 27 | )) # end shinyUI interface 28 | 29 | 30 | # Define the server code 31 | ser_ver <- shiny::shinyServer(function(input, output) { 32 | 33 | # source the model function 34 | source("C:/Develop/R/lecture_slides/scripts/ewma_model.R") 35 | 36 | # Calculate the data for plotting 37 | da_ta <- reactive({ 38 | # get model parameters from input 39 | lamb_da <- input$lamb_da 40 | wid_th <- input$wid_th 41 | # calculate close prices 42 | cl_ose <- quantmod::Cl(rutils::env_etf$VTI["2008/2009"]) 43 | # calculate EWMA prices 44 | weight_s <- exp(-lamb_da*(1:wid_th)) 45 | weight_s <- weight_s/sum(weight_s) 46 | ew_ma <- filter(cl_ose, filter=weight_s, sides=1) 47 | ew_ma[1:(wid_th-1)] <- ew_ma[wid_th] 48 | ew_ma <- xts(cbind(cl_ose, ew_ma), order.by=index(cl_ose)) 49 | colnames(ew_ma) <- c("VTI", "VTI_EWMA") 50 | ew_ma # return data for plotting 51 | }) # end reactive data 52 | 53 | # Define the output plot 54 | output$dygraph <- renderDygraph({ 55 | dygraph(da_ta(), main="VTI prices") %>% 56 | dySeries("VTI", label="VTI", strokeWidth=1.5, color=c("red", "blue")) 57 | }) # end output plot 58 | 59 | }) 60 | 61 | # Return a Shiny app object 62 | shiny::shinyApp(ui=inter_face, server=ser_ver) 63 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/app_roll_portf.R: -------------------------------------------------------------------------------- 1 | ############################## 2 | # This is a shiny app for simulating rolling portfolio 3 | # optimization strategies, which produces an interactive 4 | # dygraphs plot. 5 | # Just press the "Run App" button on upper right of this panel. 6 | ############################## 7 | 8 | ## Below is the setup code that runs once when the shiny app is started 9 | 10 | # load packages 11 | library(shiny) 12 | library(dygraphs) 13 | library(rutils) 14 | 15 | # Model and data setup 16 | # source the model function 17 | source("C:/Develop/R/lecture_slides/scripts/roll_portf.R") 18 | max_eigen <- 2 19 | sym_bols <- colnames(rutils::env_etf$re_turns) 20 | sym_bols <- sym_bols[!(sym_bols=="VXX")] 21 | n_weights <- NROW(sym_bols) 22 | re_turns <- rutils::env_etf$re_turns[, sym_bols] 23 | re_turns <- zoo::na.locf(re_turns) 24 | re_turns <- na.omit(re_turns) 25 | risk_free <- 0.03/260 26 | ex_cess <- re_turns - risk_free 27 | # calculate equal weight portfolio 28 | equal_portf <- cumsum(re_turns %*% rep(1/sqrt(NCOL(re_turns)), NCOL(re_turns))) 29 | 30 | # Define end_points 31 | end_points <- rutils::calc_endpoints(re_turns, inter_val="months") 32 | end_points <- end_points[end_points>50] 33 | len_gth <- NROW(end_points) 34 | 35 | # End setup code 36 | 37 | 38 | ## Define elements of the UI user interface 39 | inter_face <- shiny::shinyUI(fluidPage( 40 | 41 | titlePanel("Max Sharpe Strategy"), 42 | 43 | sidebarLayout( 44 | sidebarPanel( 45 | # Define look_back interval 46 | sliderInput("look_back", label="lookback interval:", 47 | min=6, max=30, value=12, step=1), 48 | # Define the shrinkage intensity 49 | sliderInput("al_pha", label="shrinkage intensity alpha:", 50 | min=0.01, max=0.99, value=0.1, step=0.05) 51 | ), 52 | mainPanel( 53 | dygraphOutput("dygraph") 54 | ) 55 | ) 56 | )) # end shinyUI interface 57 | 58 | 59 | ## Define the server code 60 | ser_ver <- shiny::shinyServer(function(input, output) { 61 | 62 | # Re-calculate the data and rerun the model 63 | da_ta <- reactive({ 64 | # get model parameters from input 65 | look_back <- input$look_back 66 | al_pha <- input$al_pha 67 | # define start_points 68 | start_points <- c(rep_len(1, look_back-1), end_points[1:(len_gth-look_back+1)]) 69 | # rerun the model 70 | strat_rets <- cbind( 71 | roll_portf_r(ex_cess, re_turns, start_points, end_points, al_pha, max_eigen), 72 | equal_portf) # end cbind 73 | colnames(strat_rets) <- c("strat_rets", "equal weight") 74 | strat_rets 75 | }) # end reactive code 76 | 77 | # Create the output plot 78 | output$dygraph <- renderDygraph({ 79 | dygraph(da_ta(), main="Max Sharpe Strategy") %>% 80 | dySeries("strat_rets", label="max Sharpe", strokeWidth=1, color=c("blue", "red")) 81 | }) # end output plot 82 | 83 | }) # end server code 84 | 85 | ## Return a Shiny app object 86 | shiny::shinyApp(ui=inter_face, server=ser_ver) 87 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/app_roll_portf2.R: -------------------------------------------------------------------------------- 1 | ############################## 2 | # This is a shiny app for simulating rolling portfolio 3 | # optimization strategies, which produces an interactive 4 | # dygraphs plot. 5 | # Just press the "Run App" button on upper right of this panel. 6 | ############################## 7 | 8 | ## Below is the setup code that runs once when the shiny app is started 9 | 10 | # load packages 11 | library(shiny) 12 | library(dygraphs) 13 | library(rutils) 14 | 15 | # Model and data setup 16 | # source the model function 17 | source("C:/Develop/R/lecture_slides/scripts/roll_portf.R") 18 | max_eigen <- 2 19 | sym_bols <- colnames(rutils::env_etf$re_turns) 20 | sym_bols <- sym_bols[!(sym_bols=="VXX")] 21 | n_weights <- NROW(sym_bols) 22 | re_turns <- rutils::env_etf$re_turns[, sym_bols] 23 | re_turns <- zoo::na.locf(re_turns) 24 | re_turns <- na.omit(re_turns) 25 | risk_free <- 0.03/260 26 | ex_cess <- re_turns - risk_free 27 | # calculate equal weight portfolio 28 | equal_portf <- cumsum(re_turns %*% rep(1/sqrt(NCOL(re_turns)), NCOL(re_turns))) 29 | 30 | # Define end_points 31 | end_points <- rutils::calc_endpoints(re_turns, inter_val="months") 32 | end_points <- end_points[end_points>50] 33 | len_gth <- NROW(end_points) 34 | 35 | # End setup code 36 | 37 | 38 | ## Create elements of the user interface 39 | inter_face <- shiny::fluidPage( 40 | titlePanel("Rolling Portfolio Optimization Strategy for 19 ETFs"), 41 | 42 | # create single row with two slider inputs 43 | fluidRow( 44 | # input look_back interval 45 | column(width=5, sliderInput("look_back", label="lookback interval (months):", 46 | min=6, max=30, value=12, step=1)), 47 | # input the shrinkage intensity 48 | column(width=5, sliderInput("al_pha", label="shrinkage intensity alpha:", 49 | min=0.01, max=0.99, value=0.1, step=0.05)) 50 | ), # end fluidRow 51 | 52 | # create output plot panel 53 | mainPanel(dygraphOutput("dygraph"), width=12) 54 | ) # end fluidPage interface 55 | 56 | 57 | ## Define the server code 58 | ser_ver <- shiny::shinyServer(function(input, output) { 59 | 60 | # re-calculate the data and rerun the model 61 | da_ta <- reactive({ 62 | # get model parameters from input argument 63 | look_back <- input$look_back 64 | al_pha <- input$al_pha 65 | # define start_points 66 | start_points <- c(rep_len(1, look_back-1), end_points[1:(len_gth-look_back+1)]) 67 | # rerun the model 68 | strat_rets <- cbind( 69 | roll_portf_r(ex_cess, re_turns, start_points, end_points, al_pha, max_eigen), 70 | equal_portf) # end cbind 71 | colnames(strat_rets) <- c("strategy", "equal weight") 72 | strat_rets 73 | }) # end reactive code 74 | 75 | # return the dygraph plot to output argument 76 | output$dygraph <- renderDygraph({ 77 | dygraph(da_ta(), main="Rolling Portfolio Optimization Strategy") %>% 78 | dySeries("strategy", label="strategy", strokeWidth=1, color=c("blue", "red")) 79 | }) # end output plot 80 | 81 | }) # end server code 82 | 83 | ## Return a Shiny app object 84 | shiny::shinyApp(ui=inter_face, server=ser_ver) 85 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/armadillo_function_tests.R: -------------------------------------------------------------------------------- 1 | ######################## 2 | ### RcppArmadillo scripts 3 | ######################## 4 | 5 | ######### 6 | ## Scripts for calling RcppArmadillo functions for manipulating vectors and matrices 7 | 8 | # Compile Rcpp functions 9 | Rcpp::sourceCpp(file="C:/Develop/R/scripts/armadillo_functions.cpp") 10 | 11 | 12 | ### sum_na() sum_if() conditional sums Rcpp functions 13 | 14 | # Create synthetic data 15 | vec_tor <- 1:100 16 | vec_tor[sample(1:100, 5)] <- NA 17 | 18 | sum(is.na(vec_tor)) 19 | sum_na(vec_tor) 20 | sum_na_stl(vec_tor) 21 | 22 | # Benchmark Rcpp sum_na() function 23 | library(microbenchmark) 24 | summary(microbenchmark( 25 | sum_na=sum_na(vec_tor), 26 | sum_na_stl=sum_na_stl(vec_tor), 27 | sum_is_na=sum(is.na(vec_tor)), 28 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 29 | 30 | # microbenchmark shows: 31 | # sum(is.na()) is 5 times faster than Rcpp 32 | # expr mean median 33 | # 1 sum_na 3778.50 3910 34 | # 2 sum_na_stl 3592.92 3422 35 | # 3 sum_is_na 728.87 490 36 | 37 | sum_if(vec_tor, 5) 38 | sum_if_cpp(vec_tor, 5) 39 | sum_if_stl(vec_tor, 5) 40 | sum(vec_tor < 5) 41 | 42 | summary(microbenchmark( 43 | sum_if_cpp=sum_if_cpp(vec_tor, 5), 44 | sum_if=sum_if(vec_tor, 5), 45 | sum_if_stl=sum_if_stl(vec_tor, 5), 46 | r_code=sum(vec_tor < 5), 47 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 48 | 49 | # microbenchmark shows: 50 | # sum(vec_tor < 5) is over 2 times faster than Rcpp 51 | # expr mean median 52 | # 1 sum_if_cpp 2424.76 2444 53 | # 2 sum_if 2419.90 2444 54 | # 3 sum_if_stl 2185.26 1956 55 | # 4 r_code 1056.44 978 56 | 57 | 58 | ### which() Rcpp functions 59 | 60 | # Create synthetic data 61 | vec_tor <- round(runif(16), 2) 62 | mat_rix <- matrix(round(runif(16), 2), nc=4) 63 | bool_ean <- sample(c(TRUE, rep(FALSE, 9)), size=1e3, replace=TRUE) 64 | 65 | # whi_ch3(bool_ean) 66 | all.equal(whi_ch3(bool_ean), whi_ch4(bool_ean)) 67 | 68 | # Benchmark Rcpp which functions 69 | library(microbenchmark) 70 | summary(microbenchmark( 71 | whi_ch32=whi_ch32(bool_ean), 72 | whi_ch33=whi_ch33(bool_ean), 73 | whi_ch34=whi_ch34(bool_ean), 74 | whi_ch=whi_ch(bool_ean), 75 | whi_ch2=whi_ch2(bool_ean), 76 | whi_ch4=whi_ch4(bool_ean), 77 | whi_ch3=whi_ch3(bool_ean), 78 | which=which(bool_ean), 79 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 80 | 81 | # microbenchmark shows: which() is fastest followed by whi_ch3(): 82 | # expr mean median 83 | # 1 whi_ch5 59.05335 57.181 84 | # 2 whi_ch 7.16539 6.843 85 | # 3 whi_ch2 8.05976 7.332 86 | # 4 whi_ch4 4.17935 3.911 87 | # 5 whi_ch3 3.32402 2.934 88 | # 6 which 2.28303 2.444 89 | 90 | 91 | ### select elements and assign values 92 | 93 | # sub-matrix Rcpp functions 94 | sub_mat(mat_rix=mat_rix, row_num=c(1, 3), col_num=1:2) 95 | sub_mat(mat_rix=mat_rix, row_num=1:2, col_num=1:2) 96 | sub_mat_cast(mat_rix=mat_rix, row_num=1:2, col_num=1:2) 97 | 98 | 99 | select_sub_mat(mat_rix=mat_rix, 0.4, 0) 100 | find_sub_mat(mat_rix=mat_rix, 0.4, 0) 101 | 102 | library(microbenchmark) 103 | summary(microbenchmark( 104 | select_sub_mat=select_sub_mat(mat_rix=mat_rix, 0.4, 0), 105 | find_sub_mat=find_sub_mat(mat_rix=mat_rix, 0.4, 0), 106 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 107 | 108 | # microbenchmark shows: both about the same 109 | # expr mean median 110 | # 1 select_sub_mat 3.21168 2.933 111 | # 2 find_sub_mat 2.79620 2.445 112 | 113 | 114 | # function to assign values to selected vector elements 115 | sub_assign(vec_tor=vec_tor, in_dex=c(2, 4, 6), da_ta=c(3, 5, 7)) 116 | # function to find selected vector elements and to assign values 117 | find_assign_vec(vec_tor=vec_tor, fi_nd=0.5, da_ta=0.1) 118 | # function to find selected vector elements and to assign values 119 | find_assign_vec_point(vec_tor=vec_tor, fi_nd=0.5, da_ta=0.1) 120 | # Rcpp function to assign values to selected matrix elements 121 | find_assign_mat(mat_rix=mat_rix, fi_nd=0.5, da_ta=1) 122 | # Rcpp function to assign values to selected matrix elements 123 | find_extract_mat(mat_rix=mat_rix, fi_nd=0.8) 124 | 125 | library(microbenchmark) 126 | summary(microbenchmark( 127 | in_place=find_assign_vec_point(vec_tor=vec_tor, fi_nd=0.5, da_ta=1), 128 | find_assign=find_assign_vec(vec_tor=vec_tor, fi_nd=0.5, da_ta=1), 129 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 130 | 131 | # microbenchmark shows: 132 | # find_assign_vec_point() is slightly faster than find_assign_vec() 133 | # expr mean median 134 | # 1 in_place 540.4299 543.465 135 | # 2 find_assign 940.3258 815.197 136 | 137 | 138 | # column compare Rcpp functions 139 | compare_col(mat_rix=mat_rix, 0.5, 1) 140 | compare_col_arma(mat_rix=mat_rix, 0.5) 141 | compare_col_arma(mat_rix=mat_rix, 0.5, 1) 142 | compare_col_armaa(mat_rix=mat_rix, 0.5, 1) 143 | 144 | library(microbenchmark) 145 | summary(microbenchmark( 146 | compare_col=compare_col(mat_rix=mat_rix, 0.5, 1), 147 | compare_col_arma=compare_col_arma(mat_rix=mat_rix, 0.5, 1), 148 | compare_col_armaa=compare_col_armaa(mat_rix=mat_rix, 0.5, 1), 149 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 150 | 151 | # microbenchmark shows: compare_col() is fastest 152 | # expr mean median 153 | # 1 compare_col 1525.52 1466 154 | # 2 compare_col_arma 2366.22 2444 155 | # 3 compare_col_armaa 2024.09 1956 156 | 157 | # which column Rcpp function 158 | which_col(mat_rix=mat_rix, 0.5, 2) 159 | which_col(mat_rix=mat_rix, 0.5) 160 | 161 | 162 | ######### 163 | ## Scripts for calling RcppArmadillo functions for matrix algebra 164 | 165 | ## de-mean the columns of a matrix 166 | 167 | summary(microbenchmark( 168 | demean_mat=demean_mat(mat_rix), 169 | demean_arma=demean_arma(mat_rix), 170 | apply=(apply(mat_rix, 2, mean)), 171 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 172 | 173 | # microbenchmark shows: 174 | # demean_mat() is over 5 times faster than demean_arma() 175 | # and over 20 times faster than apply() 176 | # expr mean median 177 | # 1 demean_mat 1.206325 1.188584 178 | # 2 demean_arma 9.909479 5.964911 179 | # 3 apply 44.555462 25.05482 180 | 181 | 182 | ## bind the columns of two matrices 183 | 184 | mat_rix1 <- matrix(runif(1e6), nc=1e3) 185 | mat_rix2 <- matrix(runif(1e6), nc=1e3) 186 | # cbind(mat_rix1, mat_rix2) 187 | all.equal(cbind_rcpp(mat_rix1, mat_rix2), cbind_arma(mat_rix1, mat_rix2)) 188 | 189 | summary(microbenchmark( 190 | cbind_arma=cbind_arma(mat_rix1, mat_rix2), 191 | cbind_rcpp=cbind_rcpp(mat_rix1, mat_rix2), 192 | cbind=cbind(mat_rix1, mat_rix2), 193 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 194 | 195 | # microbenchmark shows: 196 | # cbind_rcpp() is as fast as cbind(), and more that 2 times faster than 197 | # cbind_arma(). 198 | # expr mean median 199 | # 1 cbind_arma 12.893332 12.414150 200 | # 2 cbind_rcpp 5.943275 4.813715 201 | # 3 cbind 5.829133 4.906573 202 | 203 | 204 | ## calculate the inner (dot) product of two vectors. 205 | 206 | vec1 <- runif(1e5) 207 | vec2 <- runif(1e5) 208 | 209 | vec_in(vec1, vec2) 210 | vec1 %*% vec2 211 | 212 | summary(microbenchmark( 213 | vec_in=vec_in(vec1, vec2), 214 | r_code=(vec1 %*% vec2), 215 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 216 | 217 | # microbenchmark shows: 218 | # vec_in() is several times faster than %*%, especially for longer vectors. 219 | # expr mean median 220 | # 1 vec_in 110.7067 110.4530 221 | # 2 r_code 585.5127 591.3575 222 | 223 | 224 | ## calculate the product of a matrix times a vector. 225 | 226 | mat_rix <- matrix(runif(1e7), nc=1e5) 227 | vec1 <- runif(1e5) 228 | all.equal(mat_rix %*% vec1, mat_vec_in(vec_tor=vec1, mat_rix=mat_rix)) 229 | 230 | summary(microbenchmark( 231 | mat_vec_in=mat_vec_in(vec_tor=vec1, mat_rix=mat_rix), 232 | r_code=(mat_rix %*% vec1), 233 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 234 | 235 | # microbenchmark shows: 236 | # mat_vec_in() is 3 times faster than %*%, for matrix with 100,000 columns. 237 | # expr mean median 238 | # 1 mat_vec_in 7.299448 7.180375 239 | # 2 r_code 21.133891 21.048730 240 | 241 | 242 | vec2 <- runif(1e2) 243 | all.equal(drop(vec2 %*% (mat_rix %*% vec1)), mat_2vec_in(vec2, mat_rix, vec1)) 244 | 245 | summary(microbenchmark( 246 | mat_2vec_in=mat_2vec_in(vec2, mat_rix, vec1), 247 | r_code=(vec2 %*% (mat_rix %*% vec1)), 248 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 249 | 250 | # microbenchmark shows: 251 | # mat_2vec_in() is 3 times faster than %*%, for matrix with 100,000 columns. 252 | # expr mean median 253 | # 1 mat_2vec_in 7.138696 7.071877 254 | # 2 r_code 20.826379 20.678520 255 | 256 | 257 | ## calculate product of matrix and vectors 258 | # multiply the matrix elements *by* the vector elements 259 | 260 | vec1 <- runif(NROW(mat_rix)) 261 | prod_uct <- vec1 * mat_rix 262 | mat_vec_by(vec_tor=vec1, mat_rix=mat_rix) 263 | all.equal(prod_uct, mat_rix) 264 | 265 | summary(microbenchmark( 266 | mat_vec_by=mat_vec_by(vec_tor=vec1, mat_rix=mat_rix), 267 | r_code=(vec1 * mat_rix), 268 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 269 | 270 | # microbenchmark shows: 271 | # mat_vec_by() is slightly slower than %*%, for matrix with 100,000 columns. 272 | # expr mean median 273 | # 1 mat_vec_by 44.90964 44.69138 274 | # 2 r_code 32.89803 25.79500 275 | 276 | 277 | # multiply the matrix elements *by* the elements of two vectors 278 | 279 | mat_rix <- matrix(runif(1e7), nc=1e5) 280 | vec1 <- runif(NCOL(mat_rix)) 281 | vec2 <- runif(NROW(mat_rix)) 282 | prod_uct <- t(t(vec2*mat_rix)*vec1) 283 | mat_2vec_by(vec2, mat_rix, vec1) 284 | all.equal(mat_rix, prod_uct) 285 | 286 | summary(microbenchmark( 287 | mat_2vec_by=mat_2vec_by(vec2, mat_rix, vec1), 288 | mat_2vec_rcpp_by=mat_2vec_rcpp_by(vec2, mat_rix, vec1), 289 | mat_2vec_rcpp_by2=mat_2vec_rcpp_by2(vec2, mat_rix, vec1), 290 | r_code=(t(t(vec2*mat_rix)*vec1)), 291 | times=10))[, c(1, 4, 5)] # end microbenchmark summary 292 | 293 | # microbenchmark shows: 294 | # mat_2vec_by() is over 2 times faster than %*% and t(), for matrix 295 | # with 100,000 columns. 296 | # expr mean median 297 | # 1 mat_2vec_by 73.65367 73.50842 298 | # 2 mat_2vec_rcpp_by 101.39165 100.44875 299 | # 3 mat_2vec_rcpp_by2 612.48159 612.98899 300 | # 4 r_code 182.74140 174.80584 301 | 302 | 303 | 304 | ## matrix inversion 305 | 306 | # create random positive semi-definite matrix 307 | mat_rix <- matrix(runif(25), nc=5) 308 | mat_rix <- t(mat_rix) %*% mat_rix 309 | 310 | matrix_inv <- solve(mat_rix) 311 | matrix_inv <- invspd_arma(mat_rix) 312 | matrix_inv <- invspd_rcpp(mat_rix) 313 | 314 | library(microbenchmark) 315 | summary(microbenchmark( 316 | inv_mat=inv_mat(mat_rix), 317 | invspd_arma=invspd_arma(mat_rix), 318 | invspd_rcpp=invspd_rcpp(mat_rix), 319 | solve=solve(mat_rix), 320 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 321 | 322 | # microbenchmark shows: 323 | # inv_mat() is over 10 times faster than solve() 324 | # invspd_arma() is over 7 times faster than solve() 325 | # expr mean median 326 | # 1 inv_mat 3.42669 2.933 327 | # 2 invspd_arma 4.68759 3.911 328 | # 3 invspd_rcpp 4.74625 3.911 329 | # 4 solve 32.00254 31.280 330 | 331 | 332 | ## linear regression 333 | # define explanatory variable 334 | len_gth <- 100 335 | n_var <- 5 336 | ex_plain <- matrix(rnorm(n_var*len_gth), nc=n_var) 337 | # calculate de-meaned ex_plain matrix 338 | explan_zm <- t(t(ex_plain) - colSums(ex_plain)/len_gth) 339 | noise <- rnorm(len_gth, sd=0.5) 340 | # response equals linear form plus error terms 341 | weight_s <- rnorm(n_var) 342 | res_ponse <- -3 + ex_plain %*% weight_s + noise 343 | # calculate de-meaned response vector 344 | response_zm <- res_ponse - mean(res_ponse) 345 | 346 | # multivariate regression using lm() 347 | reg_model <- lm(res_ponse ~ ex_plain) 348 | coef(reg_model) 349 | 350 | # multivariate regression using lm_arma() 351 | reg_model <- lm_arma(res_ponse=res_ponse, ex_plain=ex_plain) 352 | reg_model_sum <- summary(reg_model) 353 | reg_model_sum$coefficients 354 | 355 | # library(MASS) 356 | # multivariate regression using MASS::ginv() in lm_r() 357 | lm_r <- function(res_ponse, ex_plain) { 358 | # solve for regression betas 359 | ex_plain <- cbind(rep(1, NROW(ex_plain)), ex_plain) 360 | beta_s <- MASS::ginv(ex_plain) %*% res_ponse 361 | fit_ted <- drop(ex_plain %*% beta_s) 362 | # calculate residuals 363 | resid_uals <- drop(res_ponse - fit_ted) 364 | # variance of residuals 365 | deg_free <- len_gth-NCOL(ex_plain) 366 | resid_var <- sum(resid_uals^2)/deg_free 367 | # explanatory matrix squared 368 | explain_squared <- crossprod(ex_plain) 369 | # calculate covariance matrix of betas 370 | beta_covar <- resid_var*MASS::ginv(explain_squared) 371 | beta_sd <- sqrt(diag(beta_covar)) 372 | # calculate t-values of betas 373 | beta_tvals <- drop(beta_s)/beta_sd 374 | # calculate two-sided p-values of betas 375 | beta_pvals <- 2*pt(-abs(beta_tvals), df=deg_free) 376 | cbind(beta_s, beta_sd, beta_tvals, beta_pvals) 377 | } # end lm_r 378 | lm_r(res_ponse, ex_plain) 379 | 380 | 381 | library(microbenchmark) 382 | summary(microbenchmark( 383 | lm_arma=lm_arma(res_ponse, ex_plain), 384 | lm_r=lm_r(res_ponse, ex_plain), 385 | lm=lm(res_ponse ~ ex_plain), 386 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 387 | 388 | # microbenchmark shows: 389 | # lm_arma() is over 10 times faster than lm() and over 3 times faster than 390 | # lm_r(). 391 | # expr mean median 392 | # 1 lm_arma 99.31485 98.4795 393 | # 2 lm_r 328.17102 324.5155 394 | # 3 lm 1070.44432 1036.8345 395 | 396 | 397 | 398 | ## split-apply-combine procedure 399 | 400 | # Create synthetic data 401 | vec_tor <- sample(1:5, 1e3, replace=TRUE) 402 | fac_tor <- sample(1:5, 1e3, replace=TRUE) 403 | mat_rix <- matrix(runif(2e3), nc=2) 404 | mat_rix <- cbind(vec_tor, mat_rix) 405 | 406 | # The function tapply_arma() performs aggregations over a vector using a factor. 407 | # It produces the same result as the R code: 408 | # tapply(X=vec_tor, INDEX=fac_tor, FUN=NROW) 409 | 410 | tapply_arma(vec_tor, fac_tor) 411 | tapply(X=vec_tor, INDEX=fac_tor, FUN=NROW) 412 | all.equal(drop(tapply_arma(vec_tor, fac_tor)), as.numeric(tapply(X=vec_tor, INDEX=fac_tor, FUN=NROW))) 413 | 414 | summary(microbenchmark( 415 | tapply_arma=tapply_arma(vec_tor, fac_tor), 416 | tapply=tapply(X=vec_tor, INDEX=fac_tor, FUN=NROW), 417 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 418 | 419 | # microbenchmark shows: 420 | # tapply_arma() is almost 4 times faster than tapply(), for vector with 1,000 421 | # elements, but it loses its advantage for longer vectors. 422 | # expr mean median 423 | # 1 tapply_arma 45.19329 44.4750 424 | # 2 tapply 178.35619 173.0095 425 | 426 | 427 | 428 | # The function apply_agg() performs aggregations over a matrix using its 429 | # first column as a factor. 430 | # It produces the same result as the R code: 431 | # sapply(X=unique(mat_rix[, 1]), FUN=function(mat_rix[, -1])) 432 | 433 | tapply(X=mat_rix[, 2], INDEX=mat_rix[, 1], FUN=mean) 434 | 435 | all.equal(sort(apply_agg(mat_rix)), 436 | sort(sapply(X=unique(mat_rix[, 1]), FUN=function(x) { 437 | foo <- mat_rix[which(mat_rix[, 1] == x), -1, drop=FALSE] 438 | sum(apply(foo, 1, prod)) 439 | # sum(foo) 440 | }))) 441 | 442 | summary(microbenchmark( 443 | apply_agg=apply_agg(mat_rix), 444 | sapply=sapply(X=unique(mat_rix[, 1]), FUN=function(x) { 445 | foo <- mat_rix[which(mat_rix[, 1] == x), -1, drop=FALSE] 446 | sum(apply(foo, 1, prod)) 447 | # sum(foo) 448 | }), 449 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 450 | 451 | # microbenchmark shows: 452 | # apply_agg() is over 40 times faster than sapply(), for matrix with 1,000 453 | # rows. 454 | # expr mean median 455 | # 1 apply_agg 66.95125 54.494 456 | # 2 sapply 2433.73195 2351.748 457 | 458 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/garch_ou.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // The function garch_proc() simulates a GARCH model 5 | //' @export 6 | // [[Rcpp::export]] 7 | NumericMatrix garch_proc(int len_gth, double om_ega, double al_pha, double be_ta, NumericVector r_norm) { 8 | NumericVector vari_ance(len_gth); 9 | NumericVector re_turns(len_gth); 10 | vari_ance[0] = om_ega/(1-al_pha-be_ta); 11 | re_turns[0] = sqrt(vari_ance[0])*r_norm[0]; 12 | for (int i = 1; i < len_gth; ++i) { 13 | re_turns[i] = sqrt(vari_ance[i-1])*r_norm[i]; 14 | vari_ance[i] = om_ega + al_pha*pow(re_turns[i], 2) + be_ta*vari_ance[i-1]; 15 | } 16 | return cbind(re_turns, vari_ance); 17 | } 18 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_mult.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // This is a simple example of exporting a C++ function to R. 5 | // You can source this function into an R session using the 6 | // function Rcpp::sourceCpp() 7 | // (or via the Source button on the editor toolbar). 8 | // Learn more about Rcpp at: 9 | // http://www.rcpp.org/ 10 | // http://adv-r.had.co.nz/Rcpp.html 11 | // http://gallery.rcpp.org/ 12 | 13 | // Define function rcpp_mult() to multiply two numbers 14 | // [[Rcpp::export]] 15 | double rcpp_mult(double x, double y) { 16 | return x * y; 17 | } 18 | 19 | // Define function rcpp_mult_vec() to multiply two vectors 20 | // [[Rcpp::export]] 21 | NumericVector rcpp_mult_vec(NumericVector x, NumericVector y) { 22 | return x * y; 23 | } 24 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_ou.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // This is a simple example of exporting a C++ function to R. 5 | // You can source this function into an R session using the 6 | // function Rcpp::sourceCpp() 7 | // (or via the Source button on the editor toolbar). 8 | // Learn more about Rcpp at: 9 | // http://www.rcpp.org/ 10 | // http://adv-r.had.co.nz/Rcpp.html 11 | // http://gallery.rcpp.org/ 12 | 13 | // The function rcpp_ou_proc() simulates an Ornstein-Uhlenbeck process 14 | //' @export 15 | // [[Rcpp::export]] 16 | NumericVector rcpp_ou_proc(int len_gth, double eq_price, double vol_at, double the_ta, NumericVector r_norm) { 17 | NumericVector price_s(len_gth); 18 | NumericVector re_turns(len_gth); 19 | price_s[0] = eq_price; 20 | for (int i = 1; i < len_gth; ++i) { 21 | re_turns[i] = the_ta*(eq_price - price_s[i-1]) + vol_at*r_norm[i-1]; 22 | price_s[i] = price_s[i-1] * exp(re_turns[i]); 23 | } 24 | return price_s; 25 | } 26 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_test3.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | #include 4 | using namespace std; 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | //////////////////////////// 10 | // RcppArmadillo functions for test #3 11 | //////////////////////////// 12 | 13 | 14 | // The function get_eigen() calculates the eigen_values 15 | // of the matrix cov_mat. 16 | //' @export 17 | // [[Rcpp::export]] 18 | arma::vec get_eigen(const arma::mat& cov_mat) { 19 | arma::vec eig_vals = arma::eig_sym(cov_mat); 20 | return eig_vals; 21 | } // end get_eigen 22 | 23 | 24 | // The function get_min_eigens() performs a loop over the 25 | // end_points, subsets the re_turns matrix, and calculates 26 | // the smallest eigenvalues as a function of the number of 27 | // time periods (rows) in the re_turns matrix. 28 | //' @export 29 | // [[Rcpp::export]] 30 | arma::vec get_min_eigens(const arma::mat& re_turns, const IntegerVector& end_points) { 31 | arma::vec eig_vals(end_points.size()); 32 | arma::mat sub_returns; 33 | // perform a loop over the end_points 34 | for (int i = 0; i < end_points.size(); i++) { 35 | // subset the returns 36 | arma::mat sub_returns = re_turns.rows(0, end_points[i]); 37 | // calculate the covariance matrix and its smallest eigenvalue 38 | eig_vals[i] = min(arma::eig_sym(cov(sub_returns))); 39 | } // end for 40 | return eig_vals; 41 | } // end get_min_eigens 42 | 43 | 44 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_test4.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | #include 4 | using namespace std; 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | //////////////////////////// 10 | // RcppArmadillo functions for test #4 11 | //////////////////////////// 12 | 13 | 14 | // The function get_pca() calculates the PCA 15 | // of the matrix re_turns. 16 | //' @export 17 | // [[Rcpp::export]] 18 | List get_pca(const arma::mat& re_turns) { 19 | arma::mat co_eff; 20 | arma::mat sco_re; 21 | arma::vec la_tent; 22 | arma::vec t_squared; 23 | 24 | arma::princomp(co_eff, sco_re, la_tent, t_squared, re_turns); 25 | 26 | return List::create(Named("coefficients") = co_eff, 27 | Named("score") = sco_re, 28 | Named("latent") = la_tent, 29 | Named("tsquared") = t_squared); 30 | 31 | } // end get_pca 32 | 33 | 34 | // The function get_pca_var() performs a loop over the 35 | // end_points, subsets the re_turns matrix, and calculates 36 | // the PCA variances using eigen decomposition. 37 | //' @export 38 | // [[Rcpp::export]] 39 | arma::mat get_pca_var(const arma::mat& re_turns, const IntegerVector& end_points) { 40 | arma::mat variance_s(re_turns.n_cols, end_points.size()-1); 41 | 42 | // perform a loop over the end_points 43 | for (arma::uword i = 1; i < end_points.size(); i++) { 44 | // subset the returns 45 | arma::mat sub_returns = re_turns.rows(end_points[i-1]+1, end_points[i]); 46 | // perform PCA using eigen decomposition 47 | variance_s.col(i-1) = arma::eig_sym(cor(sub_returns)); 48 | } // end for 49 | // return the variances 50 | return variance_s; 51 | } // end get_pca_var 52 | 53 | 54 | // The function get_pca_varr() performs a loop over the 55 | // end_points, subsets the re_turns matrix, centers and 56 | // scales it, and calculates the PCA variances using 57 | // arma::princomp() 58 | // The function get_pca_varr() produces the same output as 59 | // get_pca_var() but it's about 30 times slower! 60 | //' @export 61 | // [[Rcpp::export]] 62 | arma::mat get_pca_varr(const arma::mat& re_turns, const IntegerVector& end_points) { 63 | arma::mat variance_s(re_turns.n_cols, end_points.size()-1); 64 | arma::mat co_eff; 65 | arma::mat sco_re; 66 | arma::vec la_tent; 67 | arma::vec t_squared; 68 | 69 | // perform a loop over the end_points 70 | for (arma::uword i = 1; i < end_points.size(); i++) { 71 | // subset the returns 72 | arma::mat sub_returns = re_turns.rows(end_points[i-1]+1, end_points[i]); 73 | // de-mean (center) and scale sub_returns 74 | for (arma::uword j = 0; j < sub_returns.n_cols; j++) { 75 | sub_returns.col(j) -= arma::mean(sub_returns.col(j)); 76 | sub_returns.col(j) /= arma::stddev(sub_returns.col(j)); 77 | } // end for 78 | // perform PCA 79 | arma::princomp(co_eff, sco_re, la_tent, t_squared, sub_returns); 80 | variance_s.col(i-1) = la_tent; 81 | } // end for 82 | // return the variances 83 | return variance_s; 84 | } // end get_pca_varr 85 | 86 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_test5.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | #include 4 | using namespace std; 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | //////////////////////////// 10 | // RcppArmadillo functions for test #5 11 | //////////////////////////// 12 | 13 | 14 | // The function sharpe_weights() calculates the maximum 15 | // Sharpe ratio portfolio weights for the matrix re_turns. 16 | //' @export 17 | // [[Rcpp::export]] 18 | arma::vec sharpe_weights(const arma::mat& re_turns) { 19 | arma::mat in_verse = arma::inv_sympd(cov(re_turns)); 20 | arma::vec weight_s = arma::trans(arma::mean(re_turns, 0)); 21 | 22 | weight_s = in_verse*weight_s; 23 | return weight_s/sum(weight_s); 24 | } // end sharpe_weights 25 | 26 | 27 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpp_test6.cpp: -------------------------------------------------------------------------------- 1 | // #include 2 | #include 3 | #include 4 | using namespace std; 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | //////////////////////////// 10 | // RcppArmadillo functions for test #6 11 | //////////////////////////// 12 | 13 | 14 | 15 | // The function inv_reg() calculates the regularized inverse 16 | // of the covariance matrix, by truncating the number of 17 | // eigen-vectors to max_eigen. 18 | //' @export 19 | // [[Rcpp::export]] 20 | arma::mat inv_reg(const arma::mat& re_turns, const arma::uword& max_eigen) { 21 | arma::mat eigen_vec; 22 | arma::vec eigen_val; 23 | 24 | arma::eig_sym(eigen_val, eigen_vec, cov(re_turns)); 25 | eigen_vec = eigen_vec.cols(eigen_vec.n_cols-max_eigen, eigen_vec.n_cols-1); 26 | eigen_val = 1/eigen_val.subvec(eigen_val.n_elem-max_eigen, eigen_val.n_elem-1); 27 | // arma::mat eigen_valmat = diagmat(eigen_val); 28 | 29 | return eigen_vec*diagmat(eigen_val)*eigen_vec.t(); 30 | 31 | } // end inv_reg 32 | 33 | 34 | // The function sharpe_weights_reg() calculates the maximum 35 | // Sharpe ratio portfolio weights for the matrix re_turns. 36 | // It uses the regularized inverse of the covariance matrix. 37 | //' @export 38 | // [[Rcpp::export]] 39 | arma::vec sharpe_weights_reg(const arma::mat& re_turns, 40 | const double& al_pha, 41 | const arma::uword& max_eigen) { 42 | arma::mat in_verse = inv_reg(re_turns, max_eigen); 43 | arma::vec weight_s = arma::trans(arma::mean(re_turns, 0)); 44 | arma::vec mean_s(weight_s.n_elem); 45 | mean_s.fill(arma::mean(weight_s)); 46 | arma::vec alpha_s(weight_s.n_elem); 47 | alpha_s.fill(al_pha); 48 | arma::vec alphas_b(weight_s.n_elem); 49 | alphas_b.fill(1-al_pha); 50 | 51 | // shrink weight_s to the mean of weight_s 52 | weight_s = (alphas_b % weight_s + alpha_s % mean_s); 53 | // apply regularized inverse 54 | weight_s = in_verse*weight_s; 55 | return weight_s/sqrt(sum(square(weight_s))); 56 | } // end sharpe_weights_reg 57 | 58 | 59 | 60 | // The function roll_portf() performs a loop over the 61 | // end_points, subsets the re_turns matrix, and calculates 62 | // the PCA variances using eigen decomposition. 63 | //' @export 64 | // [[Rcpp::export]] 65 | arma::mat roll_portf(const arma::mat& ex_cess, // portfolio returns 66 | const arma::mat& re_turns, // portfolio returns 67 | const arma::uvec& start_points, 68 | const arma::uvec& end_points, 69 | const double& al_pha, 70 | const arma::uword& max_eigen) { 71 | arma::vec sre_turns = zeros(re_turns.n_rows); 72 | arma::vec weight_s(re_turns.n_cols); 73 | 74 | // sre_turns.subvec(1, 11) = ones(11); 75 | 76 | // perform a loop over the end_points 77 | for (arma::uword i = 1; i < end_points.size(); i++) { 78 | // subset the returns 79 | arma::mat sub_returns = ex_cess.rows(start_points[i-1], end_points[i-1]); 80 | // calculate portfolio weights 81 | weight_s = sharpe_weights_reg(sub_returns, al_pha, max_eigen); 82 | // sub_returns = re_turns.rows(end_points[i-1]+1, end_points[i]); 83 | sre_turns.subvec(end_points[i-1]+1, end_points[i]) = re_turns.rows(end_points[i-1]+1, end_points[i])*weight_s; 84 | // arma::mat foo = re_turns.rows(end_points[i-1]+1, end_points[i])*weight_s; 85 | } // end for 86 | // return the strategy returns 87 | return sre_turns; 88 | } // end roll_portf 89 | 90 | 91 | 92 | // The function garch_proc() simulates a GARCH model 93 | //' @export 94 | // [[Rcpp::export]] 95 | NumericMatrix garch_proc(int len_gth, 96 | double om_ega, 97 | double al_pha, 98 | double be_ta, 99 | NumericVector r_norm) { 100 | NumericVector vari_ance(len_gth); 101 | NumericVector re_turns(len_gth); 102 | vari_ance[0] = om_ega/(1-al_pha-be_ta); 103 | re_turns[0] = sqrt(vari_ance[0])*r_norm[0]; 104 | 105 | for (int i = 1; i < len_gth; i++) { 106 | re_turns[i] = sqrt(vari_ance[i-1])*r_norm[i]; 107 | vari_ance[i] = om_ega + al_pha*pow(re_turns[i], 2) + be_ta*vari_ance[i-1]; 108 | } 109 | return cbind(re_turns, vari_ance); 110 | } // end garch_proc 111 | 112 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpparmadillo_example1.cpp: -------------------------------------------------------------------------------- 1 | // This is the first RcppArmadillo example in numerical_analysis.pdf 2 | 3 | // Rcpp header with information for C++ compiler 4 | #include 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | // Examples of RcppArmadillo functions below 10 | 11 | // vec_in() calculates the inner (dot) product of two vectors. 12 | // It accepts pointers to the two vectors and returns a double. 13 | //' @export 14 | // [[Rcpp::export]] 15 | double vec_in(const arma::vec& vec1, const arma::vec& vec2){ 16 | return arma::dot(vec1, vec2); 17 | } // end vec_in 18 | 19 | // mat_2vec_in() calculates the inner (dot) product of a matrix 20 | // with two vectors. 21 | // It accepts pointers to the matrix and vectors, and returns a double. 22 | //' @export 23 | // [[Rcpp::export]] 24 | double mat_2vec_in(const arma::vec& vec_tor2, const arma::mat& mat_rix, const arma::vec& vec_tor1){ 25 | return arma::as_scalar(trans(vec_tor2) * (mat_rix * vec_tor1)); 26 | } // end mat_2vec_in 27 | -------------------------------------------------------------------------------- /Rcpp_and_armadillo/rcpparmadillo_example2.cpp: -------------------------------------------------------------------------------- 1 | // This is the second RcppArmadillo example in numerical_analysis.pdf 2 | 3 | // Rcpp header with information for C++ compiler 4 | #include 5 | using namespace Rcpp; 6 | using namespace arma; 7 | // [[Rcpp::depends(RcppArmadillo)]] 8 | 9 | // Examples of RcppArmadillo functions below 10 | 11 | // demean_mat() calculates a matrix with de-meaned columns. 12 | // It accepts a pointer to a matrix and operates on the matrix in place. 13 | // It returns the number of columns of the input matrix. 14 | //' @export 15 | // [[Rcpp::export]] 16 | double demean_mat(arma::mat& mat_rix){ 17 | for (unsigned int i = 0; i < mat_rix.n_cols; i++) { 18 | mat_rix.col(i) -= arma::mean(mat_rix.col(i)); 19 | } // end for 20 | return mat_rix.n_cols; 21 | } // end demean_mat 22 | 23 | // inv_mat() calculates the inverse of symmetric positive 24 | // definite matrix. 25 | // It accepts a pointer to a matrix and operates on the matrix in place. 26 | // It returns the number of columns of the input matrix. 27 | // It uses RcppArmadillo. 28 | //' @export 29 | // [[Rcpp::export]] 30 | double inv_mat(arma::mat& mat_rix){ 31 | mat_rix = arma::inv_sympd(mat_rix); 32 | return mat_rix.n_cols; 33 | } // end inv_mat 34 | -------------------------------------------------------------------------------- /data/etf_data.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/data/etf_data.RData -------------------------------------------------------------------------------- /data/etf_list.csv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/data/etf_list.csv -------------------------------------------------------------------------------- /data/hf_data.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/data/hf_data.RData -------------------------------------------------------------------------------- /data/sp500_prices.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/data/sp500_prices.RData -------------------------------------------------------------------------------- /data/zoo_data.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/data/zoo_data.RData -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_1.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_2.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_3.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_3.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_4.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_4.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_5.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_5.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_6.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_6.pdf -------------------------------------------------------------------------------- /lecture_note/FRE7241_Lecture_7.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/lecture_note/FRE7241_Lecture_7.pdf -------------------------------------------------------------------------------- /others/2016-07-02-Publishing-documents-in-R.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: Publishing documents in R 3 | date: 2016-07-02 12:00:00 4 | layout: post 5 | categories: R, markdown 6 | output: html_document 7 | --- 8 | 9 | ### *R* document publishing for reproducible research 10 | 11 | An *R* document is a file containing: 12 | 13 | - plain text combined with markup code, 14 | - formulas, 15 | - and *R* code chunks. 16 | 17 | Publishing an *R* document means compiling it into an easily readable *pdf* or *HTML* file, together with tables and plots produced from executing the *R* code chunks. The output document should be produced without having to copy and paste objects from different sources. 18 | 19 | Compiling *R* documents into readable documents is part of a *reproducible research* framework, because it allows for easily reproducing the published documents from its source *R* file, together with tables and plots produced from executing the *R* code chunks embedded in the source. 20 | 21 | Over the years, two different frameworks for publishing documents have emerged: 22 | 23 | + The first is the older *PostScript* framework, created by Adobe Systems for desktop publishing and printing. In the *PostScript* framework documents are published as *pdf* files, and they can't be interactive. 24 | 25 | + The second is the newer *HTML* framework, created for web publishing. In the *HTML* framework documents are published as *HTML* files, and they can be interactive. 26 | 27 | The publishing of *R* documents has followed the same pattern, and there are now two different frameworks for publishing *R* documents: 28 | 29 | + The first is the older *Sweave* framework for producing *pdf* files, 30 | 31 | + The second is the newer *R Markdown* framework for producing *HTML* and *pdf* files. 32 | 33 | There are consequently two types of *R* documents: *Sweave* files and *R Markdown* files. 34 | 35 | 36 | ### Publishing *R* documents using the *Sweave* framework 37 | 38 | A *Sweave* document is a file (usually with extension *Rnw*) containing: 39 | 40 | - plain text combined with *LaTeX* markup code, 41 | - formulas written in *LaTeX*, 42 | - and *R* code chunks. 43 | 44 | Publishing a *Sweave* document means compiling it into a *pdf* file, together with tables and plots produced from executing the *R* code chunks. 45 | 46 | *Sweave* documents can be compiled into *pdf* documents using the *knitr* package. The *knitr* function `knit2pdf()` compiles an *Rnw* file into a *pdf* file, for example: 47 | `knitr::knit2pdf("statistics.Rnw")` 48 | *Sweave* documents can't be compiled into *HTML* format, so they can't incorporate interactive plots. 49 | 50 | Many examples of *Sweave* documents can be found in algoquant's *GitHub* repository of lecture slides: algoquant's lecture slides on *GitHub* 51 | 52 | 53 | ### Publishing *R* documents using the *R Markdown* framework 54 | 55 | An *R Markdown* document is a file (with extension *Rmd*) containing: 56 | 57 | - a *YAML* header, 58 | - plain text combined with markdown code, 59 | - formulas written in *LaTeX*, nested between either '\$' or '\$$' symbols, 60 | - and *R* code chunks, nested between either single '`' or quadruple '````' backtick symbols. 61 | 62 | Publishing an *R Markdown* document means compiling it into a *pdf* or *HTML* file, together with tables and plots produced from executing the *R* code chunks. *R Markdown* documents are compiled using the *markdown* package, and can be compiled into *HTML* documents, so they can incorporate interactive plots. The *R Markdown* framework is relatively easy to use because it relies on the simple *markdown* markup language, which is close to plain text and is therefore easy to read. 63 | 64 | The function `render()` from package *rmarkdown* compiles an *Rmd* file into either a *pdf* or *HTML* file: 65 | 66 | `rmarkdown::render("R-publishing.Rmd")` 67 | 68 | The type of file produced by `render()` depends on the *YAML* header in the *Rmd* file. If the *YAML* header includes: 69 | `output: pdf_document` then a *pdf* document is produced. 70 | If the *YAML* header includes: 71 | `output: html_document`then a *HTML* document is produced. 72 | 73 | This post is an *R Markdown* document that was compiled into an *HTML* document, and can be found in algoquant's *GitHub* repository here: R publishing 74 | 75 | 76 | ### Resources for publishing *R* documents 77 | 78 | Links to books, blogs, and tutorials about publishing *R documents* using the *knitr* package: 79 | 80 | - *knitr* package 81 | 82 | - *knitr* package on *CRAN* 83 | 84 | - *knitr* repository on *GitHub* 85 | 86 | - *knitr* FAQ 87 | 88 | - *knitr* introduction 89 | 90 | - *knitr* showcase 91 | 92 | - *knitr* demos 93 | 94 | - compiling *Sweave* using *knitr* 95 | 96 |
97 | 98 | Links to books, blogs, and tutorials about publishing *R documents* using the *rmarkdown* package: 99 | 100 | - rmarkdown tutorial 101 | 102 | - *rmarkdown* package website 103 | 104 | - publishing on web using *R Markdown* 105 | 106 | - simple *R Markdown* document templates 107 | 108 | - simple *R Markdown* templates repository on *GitHub* 109 | 110 | - *R Markdown* document template for academic manuscripts 111 | 112 | - Marian Schmidt tutorial: Reproducible Research Using RStudio, RMarkdown, and Git 113 | 114 |
115 | 116 | Links to books, blogs, and tutorials about publishing *R documents* and *reproducible research*: 117 | 118 | - Karl Broman course Reproducible Research 119 | 120 | - Christopher Gandrud book on Reproducible Research Using R and RStudio 121 | 122 | - Christopher Gandrud book repository on *GitHub* 123 | 124 | - CRAN Task View for Reproducible Research 125 | -------------------------------------------------------------------------------- /others/2016-07-05-Interactive-Plots-in-R.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: Interactive Plots in R 3 | date: 2016-07-05 12:00:00 4 | layout: post 5 | categories: R plots 6 | output: html_document 7 | --- 8 | 9 | ### Publishing *R Markdown* documents containing interactive plots 10 | 11 | One of the advantages of writing *R Markdown* documents is that they can be compiled into *HTML* documents, which can incorporate interactive plots. This post is an *R Markdown* document that was compiled into an *HTML* document, and can be found in algoquant's *GitHub* repository here: R interactive plots 12 | 13 | Before creating interactive plots, we need to install the package *rutils* from *GitHub*: 14 | ```{r eval=FALSE} 15 | # install.packages("devtools") 16 | devtools::install_github(repo="algoquant/rutils") 17 | library(rutils) 18 | ``` 19 | 20 | The *rutils* package contains a dataset of daily *OHLC* time series in *xts* format, for a portfolio of stock symbols. The time series are contained in an environment called *env_etf*. The data is set up for lazy loading, so it doesn't require calling `data(etf_data)` to load it before being able to call it. 21 | 22 | Now we can create interactive plots using the time series data from package *rutils*. Below is an example of an interactive time series plot produced using the *dygraphs* package. Left-click on the plot and drag your mouse, to select a date range, then double-click to return to the original range. 23 | 24 | ```{r eval=TRUE, fig.width=7, fig.height=4} 25 | # load rutils which contains env_etf dataset 26 | suppressMessages(suppressWarnings(library(rutils))) 27 | suppressMessages(suppressWarnings(library(dygraphs))) 28 | x_ts <- env_etf$price_s[, c("VTI", "IEF")] 29 | # plot dygraph with date range selector 30 | dygraph(x_ts, main="VTI and IEF prices") %>% 31 | dyOptions(colors=c("blue","green")) %>% 32 | dyRangeSelector() 33 | ``` 34 | 35 |
36 | The *dygraphs* package in *R* is an interface to the *dygraphs JavaScript* charting library. Interactive *dygraphs* plots require running *JavaScript* code, which can be embedded in *HTML* documents, and displayed by web browsers. 37 | But *pdf* documents can't run *JavaScript* code, so they can't display interactive dygraph() plots, 38 | 39 | 40 | ### Publishing *R Markdown* documents with *plotly* interactive plots 41 | 42 | Below is an example of an interactive time series plot produced using the *plotly* package. Left-click on the plot and drag your mouse, to select a date range, then double-click to return to the original range. 43 | 44 | ```{r eval=TRUE, fig.width=7, fig.height=4} 45 | # load rutils which contains env_etf dataset 46 | suppressMessages(suppressWarnings(library(rutils))) 47 | suppressMessages(suppressWarnings(library(plotly))) 48 | # create data frame of time series 49 | data_frame <- 50 | data.frame(dates=index(env_etf$price_s), 51 | coredata(env_etf$price_s[, c("VTI", "IEF")])) 52 | # plotly syntax using pipes 53 | data_frame %>% 54 | plot_ly(x=dates, y=VTI, fill="tozeroy", name="VTI") %>% 55 | add_trace(x=dates, y=IEF, fill="tonexty", name="IEF") %>% 56 | layout(title="VTI and IEF prices", 57 | xaxis=list(title="Time"), 58 | yaxis=list(title="Stock Prices"), 59 | legend=list(x=0.1, y=0.9)) 60 | # standard plotly syntax - for reference 61 | # p_lot <- plot_ly(data=data_frame, x=dates, y=VTI, fill="tozeroy", name="VTI") 62 | # p_lot <- add_trace(p=p_lot, x=dates, y=IEF, fill="tonexty", name="IEF") 63 | # p_lot <- layout(title="VTI and IEF prices", xaxis=list(title="Time"), yaxis=list(title="Stock Prices"), legend=list(x=0.1, y=0.9)) 64 | # p_lot 65 | ``` 66 | 67 | 68 | ### Resources for creating interactive plots in *R* 69 | 70 | Links to resources for the *R* package *dygraphs*: 71 | 72 | - *dygraphs* website 73 | 74 | - *dygraphs* gallery 75 | 76 | - *dygraphs* repository on *GitHub* 77 | 78 | - *R* package *dygraphs* website 79 | 80 | - *R* package *dygraphs* repository on *GitHub* 81 | 82 | - Dan Vanderkam's website, the author of the *dygraphs JavaScript* library 83 | 84 | - Dan Vanderkam's repository on *GitHub* 85 | 86 | 87 | Links to resources for the *R* package *plotly*: 88 | 89 | - *plotly* website 90 | 91 | - *plotly* project on *GitHub* 92 | 93 | - *R* package *plotly* website 94 | 95 | - *plotly* gallery 96 | 97 | - *plotly* repository on *GitHub* 98 | -------------------------------------------------------------------------------- /others/dygraphs_plots.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Dashboard of Interactive Time Series Plots" 3 | author: "Jerzy Pawlowski at NYU Tandon" 4 | affiliation: NYU Tandon School of Engineering 5 | email: jp3900@nyu.edu 6 | date: '`r format(Sys.time(), "%m-%d-%Y %H:%M")`' 7 | output: 8 | html_document: 9 | fig_width: 6 10 | fig_height: 4 11 | --- 12 | 13 | ```{r setup, include=FALSE} 14 | # This is an R setup chunk, containing default options applied to all other chunks 15 | knitr::opts_chunk$set(echo=FALSE) 16 | library(rutils) 17 | library(dygraphs) 18 | ``` 19 | 20 | 21 | ### A dashboard of interactive time series plots written in *Rmarkdown* 22 | 23 | This *Rmarkdown* document contains interactive *dygraphs* plots of time series contained in the package *rutils*. The interactive time series plots are produced using the package *dygraphs*. It creates a list of *dygraphs* objects in a loop, and then uses the package *htmltools* to render (plot) the *dygraphs* objects. 24 | 25 | ### You can click and drag your mouse to zoom into any plot. 26 | 27 | Double-click your mouse to restore the plot. 28 | 29 | 30 | ```{r echo=FALSE} 31 | # extract the closing prices into a list of xts time series 32 | price_s <- lapply(rutils::env_etf$sym_bols, function(sym_bol) { 33 | quantmod::Cl(get(sym_bol, envir=rutils::env_etf)) 34 | }) # end lapply 35 | 36 | # flatten (cbind) list of prices into single xts series 37 | price_s <- rutils::do_call(cbind, price_s) 38 | 39 | # overwrite NA values 40 | price_s <- rutils::na_locf(price_s) 41 | price_s <- rutils::na_locf(price_s, from_last=TRUE) 42 | 43 | # make nice column names 44 | colnames(price_s) <- rutils::do_call_rbind(strsplit(colnames(price_s), split="[.]"))[, 1] 45 | 46 | # create a list of dygraphs objects in loop 47 | dy_graphs <- lapply(price_s, function(pric_e) { 48 | dygraphs::dygraph(pric_e, main=paste("Plot of:", colnames(pric_e)), width=600, height=400) 49 | }) # end lapply 50 | 51 | # render the dygraphs objects 52 | htmltools::tagList(dy_graphs) 53 | ``` 54 | -------------------------------------------------------------------------------- /others/r_markdown_example.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Example R Markdown Document" 3 | author: Jerzy Pawlowski 4 | date: '`r format(Sys.time(), "%m/%d/%Y")`' 5 | output: html_document 6 | --- 7 | 8 | ```{r setup, include=FALSE} 9 | knitr::opts_chunk$set(echo=TRUE) 10 | 11 | # install package quantmod if it can't be loaded successfully 12 | if (!require("quantmod")) 13 | install.packages("quantmod") 14 | ``` 15 | 16 | ### R Markdown 17 | 18 | This is an *R Markdown* document. Markdown is a simple formatting syntax for authoring *HTML*, *pdf*, and *MS Word* documents. For more details on using *R Markdown* see . 19 | 20 | One of the advantages of writing documents *R Markdown* is that they can be compiled into *HTML* documents, which can incorporate interactive plots, 21 | 22 | You can read more about publishing documents using *R* here: 23 | https://algoquant.github.io/r,/markdown/2016/07/02/Publishing-documents-in-R/ 24 | 25 | 26 | You can read more about using *R* to create *HTML* documents with interactive plots here: 27 | https://algoquant.github.io/2016/07/05/Interactive-Plots-in-R/ 28 | 29 | 30 | You can read more markdown tutorials: 31 | http://daringfireball.net/projects/markdown/syntax 32 | https://guides.github.com/features/mastering-markdown/ 33 | http://markdown-guide.readthedocs.io/en/latest/basics.html 34 | 35 | Here are markdown cheatsheets: 36 | https://markdown-it.github.io/ 37 | https://github.com/adam-p/markdown-here/wiki/Markdown-Cheatsheet 38 | https://daringfireball.net/projects/markdown/ 39 | https://github.com/adam-p/markdown-here/wiki/Markdown-Cheatsheet 40 | 41 | This is a markdown interpreter: 42 | http://www.markitdown.net/markdown 43 | 44 | You can read more about R markdown: 45 | http://rmarkdown.rstudio.com/ 46 | https://guides.github.com/features/mastering-markdown/ 47 | 48 | 49 | ### The **knitr** package 50 | 51 | Clicking the **knit** button in *RStudio*, compiles the *R Markdown* document, including embedded *math formulas* and *R* code chunks, into output documents. 52 | 53 | Example of an *R* code chunk: 54 | 55 | ```{r cars} 56 | summary(cars) 57 | ``` 58 | 59 | 60 | ### Plots in *R Markdown* documents 61 | 62 | Plots can also be embeded, for example: 63 | 64 | ```{r pressure, echo=FALSE} 65 | plot(pressure) 66 | ``` 67 | 68 | Note that the `echo = FALSE` parameter was added to the code chunk to prevent printing of the R code that generated the plot. 69 | 70 | 71 | ### Math formulas in *R Markdown* documents 72 | 73 | Math formulas can also be embeded in *R Markdown* documents. 74 | 75 | For example inline formulas: $\frac{2}{3}$, $\sqrt{b^2 - 4ac}$, and $\hat{\lambda}=1.02$. 76 | 77 | Or display formulas (the Cauchy-Schwarz inequality): 78 | 79 | $$ 80 | \left( \sum_{k=1}^n a_k b_k \right)^2 81 | \leq 82 | \left( \sum_{k=1}^n a_k^2 \right) 83 | \left( \sum_{k=1}^n b_k^2 \right) 84 | $$ 85 | 86 | 87 | -------------------------------------------------------------------------------- /others/shiny_ewma.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "EWMA prices" 3 | author: "Jerzy Pawlowski" 4 | affiliation: NYU Tandon School of Engineering 5 | email: jp3900@nyu.edu 6 | date: '`r format(Sys.time(), "%m/%d/%Y")`' 7 | output: html_document 8 | runtime: shiny 9 | --- 10 | 11 | ```{r setup, include=FALSE} 12 | # this is a setup chunk run only once at start of shiny 13 | knitr::opts_chunk$set(echo=FALSE) 14 | # load package 15 | library(shiny) 16 | library(quantmod) 17 | # set look-back interval for averaging 18 | inter_val <- 31 19 | # calculate close prices 20 | cl_ose <- quantmod::Cl(rutils::env_etf$VTI["2008/2009"]) 21 | # set plot_theme plot line colors 22 | plot_theme <- chart_theme() 23 | plot_theme$col$line.col <- c("orange", "blue") 24 | ``` 25 | 26 | ```{r ewma_model, echo=FALSE} 27 | inputPanel( 28 | sliderInput("lamb_da", label="lambda:", 29 | min=0.01, max=1.0, value=0.3, step=0.1) 30 | ) # end inputPanel 31 | 32 | renderPlot({ 33 | 34 | # get EWMA decay parameter from input 35 | lamb_da <- input$lamb_da 36 | # calculate EWMA prices 37 | weight_s <- exp(lamb_da*1:inter_val) 38 | weight_s <- weight_s/sum(weight_s) 39 | ew_ma <- filter(cl_ose, filter=rev(weight_s), sides=1) 40 | ew_ma[1:(inter_val-1)] <- ew_ma[inter_val] 41 | ew_ma <- xts(cbind(cl_ose, ew_ma), order.by=index(cl_ose)) 42 | colnames(ew_ma) <- c("VTI", "VTI EWMA") 43 | # plot EWMA prices 44 | plot(chart_Series(ew_ma, theme=plot_theme, name="EWMA prices")) 45 | legend("top", legend=colnames(ew_ma), 46 | inset=0.1, bg="white", lty=c(1, 1), lwd=c(6, 6), 47 | col=plot_theme$col$line.col, bty="n") 48 | 49 | }) # end renderPlot 50 | ``` 51 | -------------------------------------------------------------------------------- /others/shiny_ewma2.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Performance of Strategy with Two EWMAs" 3 | author_no_print: "Jerzy Pawlowski" 4 | affiliation: NYU Tandon School of Engineering 5 | date_no_print: '`r format(Sys.time(), "%m/%d/%Y")`' 6 | email: jp3900@nyu.edu 7 | output: html_document 8 | runtime: shiny 9 | --- 10 | 11 | ```{r setup, include=FALSE} 12 | knitr::opts_chunk$set(echo=TRUE) 13 | source("C:/Develop/R/lecture_slides/scripts/ewma_model.R") 14 | ``` 15 | 16 | ```{r ewma_model, echo=FALSE} 17 | inputPanel( 18 | sliderInput("lambda_1", label="lambda_1:", 19 | min=0.01, max=0.5, value=0.25, step=0.01), 20 | sliderInput("lambda_2", label="lambda_2:", 21 | min=0.01, max=0.5, value=0.05, step=0.01), 22 | numericInput("wid_th", label="wid_th:", min=10, max=201, value=51) 23 | ) # end inputPanel 24 | 25 | renderPlot({ 26 | 27 | lambda_1 <- input$lambda_1 28 | lambda_2 <- input$lambda_2 29 | wid_th <- input$wid_th 30 | 31 | library(HighFreq) # load package HighFreq 32 | # select OHLC data 33 | oh_lc <- rutils::env_etf$VTI["/2011"] 34 | # calculate close prices 35 | cl_ose <- Cl(oh_lc) 36 | 37 | # simulate EWMA strategy 38 | ewma_strat <- simu_ewma2(oh_lc=oh_lc, lambda_1=lambda_1, lambda_2=lambda_2, wid_th=wid_th) 39 | 40 | # collect and combine output 41 | ewma_1 <- ewma_strat[, "ewma_1"] 42 | ewma_2 <- ewma_strat[, "ewma_2"] 43 | po_sitions <- xts(ewma_strat[, "po_sitions"], order.by=index(oh_lc)) 44 | pn_l <- cumsum(ewma_strat[, "re_turns"]) 45 | pn_l <- cbind(cl_ose-as.numeric(cl_ose[1, ]), pn_l, ewma_1, ewma_2) 46 | colnames(pn_l) <- c("VTI", "EWMA PnL", "ewma_1", "ewma_2") 47 | re_turns <- rutils::diff_xts(cl_ose) 48 | shar_pe <- sqrt(260)*sum(re_turns)/sd(re_turns)/NROW(re_turns) 49 | re_turns <- ewma_strat[, "re_turns"] 50 | sharpe_ewma <- sqrt(260)*sum(re_turns)/sd(re_turns)/NROW(re_turns) 51 | 52 | # plot EWMA strategy with custom line colors and position shading 53 | plot_theme <- chart_theme() 54 | plot_theme$col$line.col <- c("orange", "blue", "yellow", "magenta2") 55 | 56 | ch_ob <- chart_Series(pn_l, theme=plot_theme, 57 | name="Performance of Strategy with Two EWMAs") 58 | add_TA(po_sitions > 0, on=-1, 59 | col="lightgreen", border="lightgreen") 60 | add_TA(po_sitions < 0, on=-1, 61 | col="lightgrey", border="lightgrey") 62 | plot(ch_ob) 63 | legend("bottomleft", 64 | title=paste(c(paste0(colnames(pn_l)[1], " Sharpe ratio = ", format(shar_pe, digits=3)), 65 | paste0("strategy Sharpe ratio = ", format(sharpe_ewma, digits=3))), 66 | collapse="\n"), 67 | legend=colnames(pn_l), 68 | inset=0.05, bg="white", lty=rep(1, 4), lwd=rep(8, 4), 69 | col=plot_theme$col$line.col, bty="n") 70 | 71 | }) # end renderPlot 72 | ``` 73 | -------------------------------------------------------------------------------- /others/shiny_ewma_quantmod.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "EWMA prices" 3 | author_no_print: "Jerzy Pawlowski" 4 | affiliation: NYU Tandon School of Engineering 5 | date_no_print: '`r format(Sys.time(), "%m/%d/%Y")`' 6 | email: jp3900@nyu.edu 7 | output: html_document 8 | runtime: shiny 9 | --- 10 | 11 | ```{r setup, include=FALSE} 12 | knitr::opts_chunk$set(echo=TRUE) 13 | library(HighFreq) # load package HighFreq 14 | # select OHLC data 15 | oh_lc <- rutils::env_etf$VTI["/2011"] 16 | # calculate close prices 17 | cl_ose <- Cl(oh_lc) 18 | # define lookback window and decay parameter 19 | win_dow <- 51 20 | plot_theme <- chart_theme() 21 | plot_theme$col$line.col <- c("orange", "blue") 22 | 23 | # source("C:/Develop/R/scripts/ewma_model.R") 24 | ``` 25 | 26 | ```{r ewma_model, echo=FALSE} 27 | inputPanel( 28 | sliderInput("lamb_da", label="lambda:", 29 | min=0.01, max=0.2, value=0.1, step=0.01) 30 | ) # end inputPanel 31 | 32 | renderPlot({ 33 | 34 | lamb_da <- input$lamb_da 35 | 36 | # calculate EWMA prices 37 | weight_s <- exp(-lamb_da*1:win_dow) 38 | weight_s <- weight_s/sum(weight_s) 39 | ew_ma <- filter(cl_ose, filter=weight_s, sides=1) 40 | ew_ma[1:(win_dow-1)] <- ew_ma[win_dow] 41 | ew_ma <- xts(cbind(cl_ose, ew_ma), 42 | order.by=index(oh_lc)) 43 | colnames(ew_ma) <- c("VTI", "VTI EWMA") 44 | 45 | # plot EWMA prices 46 | # x11(width=12, height=9) 47 | ch_ob <- chart_Series(ew_ma, theme=plot_theme, name="EWMA prices") 48 | plot(ch_ob) 49 | legend("top", legend=colnames(ew_ma), 50 | inset=0.1, bg="white", lty=c(1, 1), lwd=c(2, 2), 51 | col=plot_theme$col$line.col, bty="n") 52 | 53 | }) # end renderPlot 54 | ``` 55 | -------------------------------------------------------------------------------- /resources/Ardia DEoptim Portfolio Optimization.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Ardia DEoptim Portfolio Optimization.pdf -------------------------------------------------------------------------------- /resources/Aswani Regression Shrinkage Bias Variance Tradeoff.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Aswani Regression Shrinkage Bias Variance Tradeoff.pdf -------------------------------------------------------------------------------- /resources/Blei Regression Lasso Shrinkage Bias Variance Tradeoff.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Blei Regression Lasso Shrinkage Bias Variance Tradeoff.pdf -------------------------------------------------------------------------------- /resources/Bolker Optimization Methods.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Bolker Optimization Methods.pdf -------------------------------------------------------------------------------- /resources/Bouchaud Momentum Mean Reversion Equity Returns.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Bouchaud Momentum Mean Reversion Equity Returns.pdf -------------------------------------------------------------------------------- /resources/Boudt DEoptim Large Portfolio Optimization.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Boudt DEoptim Large Portfolio Optimization.pdf -------------------------------------------------------------------------------- /resources/Boudt DEoptim Portfolio Optimization.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Boudt DEoptim Portfolio Optimization.pdf -------------------------------------------------------------------------------- /resources/DEoptim Introduction.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/DEoptim Introduction.pdf -------------------------------------------------------------------------------- /resources/DEoptimR.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/DEoptimR.pdf -------------------------------------------------------------------------------- /resources/Farnsworth Econometrics in R.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Farnsworth Econometrics in R.pdf -------------------------------------------------------------------------------- /resources/Hurst Pedersen AQR Momentum Evidence.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Hurst Pedersen AQR Momentum Evidence.pdf -------------------------------------------------------------------------------- /resources/James book Statistical Learning in R.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/James book Statistical Learning in R.pdf -------------------------------------------------------------------------------- /resources/Lemperiere Risk Two Centuries Trend Following Strategies.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Lemperiere Risk Two Centuries Trend Following Strategies.pdf -------------------------------------------------------------------------------- /resources/Matloff book The Art of R Programming.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Matloff book The Art of R Programming.pdf -------------------------------------------------------------------------------- /resources/Moskowitz Time Series Momentum.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Moskowitz Time Series Momentum.pdf -------------------------------------------------------------------------------- /resources/Mullen Package DEoptim.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Mullen Package DEoptim.pdf -------------------------------------------------------------------------------- /resources/RMarkdown_Reference_Guide.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/RMarkdown_Reference_Guide.pdf -------------------------------------------------------------------------------- /resources/R_environment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/R_environment.pdf -------------------------------------------------------------------------------- /resources/Rcpp-FAQ.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Rcpp-FAQ.pdf -------------------------------------------------------------------------------- /resources/Rcpp-sugar.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Rcpp-sugar.pdf -------------------------------------------------------------------------------- /resources/Rcpp.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Rcpp.pdf -------------------------------------------------------------------------------- /resources/Storn Differential Evolution.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Storn Differential Evolution.pdf -------------------------------------------------------------------------------- /resources/Wickham Advanced R.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Wickham Advanced R.pdf -------------------------------------------------------------------------------- /resources/Yollin Optimization.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/Yollin Optimization.pdf -------------------------------------------------------------------------------- /resources/advancedR cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/advancedR cheatsheet.pdf -------------------------------------------------------------------------------- /resources/baser cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/baser cheatsheet.pdf -------------------------------------------------------------------------------- /resources/bootstrap_technique.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/bootstrap_technique.pdf -------------------------------------------------------------------------------- /resources/data import cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/data import cheatsheet.pdf -------------------------------------------------------------------------------- /resources/data transformation cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/data transformation cheatsheet.pdf -------------------------------------------------------------------------------- /resources/devtools cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/devtools cheatsheet.pdf -------------------------------------------------------------------------------- /resources/doBootstrap_primer.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/doBootstrap_primer.pdf -------------------------------------------------------------------------------- /resources/ewma2_shiny.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/ewma2_shiny.pdf -------------------------------------------------------------------------------- /resources/ggplot2 cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/ggplot2 cheatsheet.pdf -------------------------------------------------------------------------------- /resources/numerical_analysis.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/numerical_analysis.pdf -------------------------------------------------------------------------------- /resources/pca-handout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/pca-handout.pdf -------------------------------------------------------------------------------- /resources/pcaTutorial.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/pcaTutorial.pdf -------------------------------------------------------------------------------- /resources/plot par cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/plot par cheatsheet.pdf -------------------------------------------------------------------------------- /resources/purrr cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/purrr cheatsheet.pdf -------------------------------------------------------------------------------- /resources/rmarkdown cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/rmarkdown cheatsheet.pdf -------------------------------------------------------------------------------- /resources/rmarkdown reference.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/rmarkdown reference.pdf -------------------------------------------------------------------------------- /resources/rmarkdown_cheatsheet_2.0.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/rmarkdown_cheatsheet_2.0.pdf -------------------------------------------------------------------------------- /resources/rstudio cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/rstudio cheatsheet.pdf -------------------------------------------------------------------------------- /resources/shiny cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/shiny cheatsheet.pdf -------------------------------------------------------------------------------- /resources/shiny_cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/shiny_cheatsheet.pdf -------------------------------------------------------------------------------- /resources/stringr cheatsheet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BessieChen/Algorithmic-Portfolio-Management-in-R-programming-language/cbcaecb49659a33a5d3b1b4b70467fe072344331/resources/stringr cheatsheet.pdf -------------------------------------------------------------------------------- /tests/FRE7241_test1 outline.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #1 Outline January 30, 2018 3 | ################################# 4 | # Max score 110pts 5 | 6 | # This file is an outline for test #1, designed to help prepare for it. 7 | # The actual test #1 file will be more detailed. 8 | 9 | ############## Part I 10 | # 1. (20pts) 11 | # Calculate the percentage (log) returns of EuStockMarkets 12 | # and call them re_turns. 13 | # You can use functions diff() and log(). 14 | 15 | # load quantmod 16 | library(quantmod) 17 | 18 | ### write your code here 19 | 20 | 21 | # For each column of EuStockMarkets, calculate the dates 22 | # with extreme returns, either above +3% or below -3%. 23 | # You should produce a list of four elements, with each 24 | # element being a vector of extreme dates. 25 | # You can use functions lapply(), time(), and an 26 | # anonymous function. 27 | 28 | ### write your code here 29 | 30 | 31 | # Calculate the number of extreme dates for each symbol. 32 | # You can use functions sapply() and NROW(). 33 | 34 | ### write your code here 35 | 36 | 37 | 38 | # 2. (10pts) 39 | # Set all the extreme returns (either above +3% or below -3%) in 40 | # re_turns to zero. 41 | 42 | ### write your code here 43 | 44 | 45 | # 3. (10pts) 46 | # Calculate the cumulative DAX returns from the first column 47 | # of re_turns, and call them cum_returns. 48 | # Append 1 to the beginning of cum_returns, so that it has 49 | # the same number of elements as there are rows in EuStockMarkets. 50 | # Multiply cum_returns by EuStockMarkets[1, 1]. 51 | # You can use functions exp(), cumsum(), and c(). 52 | 53 | ### write your code here 54 | 55 | 56 | # 4. (10pts) Coerce the DAX prices in EuStockMarkets into an xts 57 | # time series called dax_prices. 58 | # The time index of xts_eustocks should be of class POSIXct, and 59 | # the timezone should be equal to "America/New_York". 60 | # You can use functions coredata(), xts(), index(), 61 | # and date_decimal(). 62 | 63 | library(lubridate) 64 | 65 | ### write your code here 66 | 67 | 68 | # cbind() cum_returns as a second column to dax_prices, 69 | # and assign the column names "DAX", "DAX clean". 70 | # You can use functions cbind(), colnames(), and c(). 71 | 72 | ### write your code here 73 | 74 | 75 | # 5. (10pts) Create a dygraphs plot of dax_prices. 76 | 77 | ### write your code here 78 | 79 | 80 | 81 | ############## Part II 82 | # Summary: Select recurring times of day from OHLC time series 83 | # bar data without using the "T notation". 84 | 85 | # load package HighFreq 86 | library(HighFreq) 87 | 88 | # The package HighFreq contains the SPY dataset, which is an xts 89 | # time series containing OHLC prices and trading volumes for the 90 | # SPY etf. 91 | # The SPY dataset contains several years of data, collected 92 | # during trading hours. 93 | # Each day of the SPY data starts at 09:31 and ends at 16:01 94 | # (with the exception of some trading days before holidays). 95 | # Each row of SPY contains a single bar of prices at 1-minute 96 | # intervals, with Open, High, Low, and Close prices, and Volume. 97 | 98 | head(HighFreq::SPY) 99 | tail(HighFreq::SPY) 100 | 101 | 102 | # 1. (10pts) Select recurring times of day from the SPY time 103 | # series using the "T notation". 104 | # Select the data for all the days in April 2012, starting from 105 | # 09:41 to 16:00 using the "T notation", and call it sub_SPY. 106 | 107 | ### write your code here 108 | 109 | 110 | # 2. (20pts) Select the same data as in p.1, but without using 111 | # the "T notation", and call it sub_SPY_bis. 112 | # You can use the functions format(), index(), c(), 113 | # and paste0(), and the operators "%in%", or ">" and "<". 114 | 115 | ### write your code here 116 | 117 | 118 | # Verify that sub_SPY is identical to sub_SPY_bis using 119 | # the function identical(): 120 | 121 | identical(sub_SPY, sub_SPY_bis) 122 | 123 | 124 | 125 | ############## Part III 126 | # 1. (20pts) Create a vector of weekly POSIXct dates corresponding 127 | # to Mondays at 09:30AM, and call it "mon_days", 128 | # start with the date "2015-02-09", and end at the most recent Monday 129 | # before today (today is defined by Sys.time()), 130 | # set the timezone to "America/New_York", 131 | # first calculate the number of weeks between today and the start date, 132 | # and use that number to create a vector of weekly POSIXct dates, 133 | # use functions Sys.setenv(), as.POSIXct(), difftime() and ceiling(), 134 | # and lubridate function weeks(), 135 | 136 | ### write your code here 137 | 138 | 139 | # Convert "mon_days" to the days of the week, using three different methods, 140 | # to verify that all the dates in "mon_days" are indeed Mondays, 141 | 142 | # use function weekdays(), 143 | 144 | ### write your code here 145 | 146 | # use function as.POSIXlt(), 147 | 148 | ### write your code here 149 | 150 | # use lubridate function wday(), 151 | 152 | ### write your code here 153 | 154 | -------------------------------------------------------------------------------- /tests/FRE7241_test1 solution.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #1 Solution January 30, 2018 3 | ################################# 4 | # Max score 110pts 5 | 6 | # The below solutions are examples, 7 | # Slightly different solutions are also possible. 8 | 9 | ############## Part I 10 | # 1. (20pts) 11 | # Calculate the percentage (log) returns of EuStockMarkets 12 | # and call them re_turns. 13 | # You can use functions diff() and log(). 14 | 15 | # load quantmod 16 | library(quantmod) 17 | 18 | re_turns <- diff(log(EuStockMarkets)) 19 | 20 | # For each column of EuStockMarkets, calculate the dates 21 | # with extreme returns, either above +3% or below -3%. 22 | # You should produce a list of four elements, with each 23 | # element being a vector of extreme dates. 24 | # You can use functions lapply(), time(), and an 25 | # anonymous function. 26 | 27 | extreme_dates <- lapply(re_turns, function(col_umn) { 28 | time(col_umn)[(col_umn > 0.03) | (col_umn < -0.03)] 29 | }) # end lapply 30 | 31 | # You should get the following output: 32 | # > extreme_dates 33 | # $DAX 34 | # [1] 1991.631 1991.638 1992.708 1992.765 1993.527 1994.208 1994.785 1995.742 1997.269 1997.285 35 | # [11] 1997.577 1997.638 1997.692 1997.719 1997.731 1997.835 1997.846 1997.850 1997.900 1997.938 36 | # [21] 1998.015 1998.031 1998.354 1998.427 1998.592 1998.635 37 | # 38 | # $SMI 39 | # [1] 1991.631 1991.638 1992.708 1992.765 1994.477 1996.200 1996.608 1997.269 1997.581 1997.654 40 | # [11] 1997.665 1997.681 1997.692 1997.846 1997.850 1998.054 1998.362 1998.635 41 | # 42 | # $CAC 43 | # [1] 1991.631 1991.638 1991.981 1992.273 1992.650 1992.681 1992.708 1992.727 1992.746 1992.765 44 | # [11] 1992.808 1995.365 1995.531 1995.742 1997.419 1997.427 1997.692 1997.835 1997.846 1997.850 45 | # [21] 1997.969 1998.354 46 | # 47 | # $FTSE 48 | # [1] 1991.631 1992.281 1992.719 1992.723 1992.765 1997.762 1997.835 49 | 50 | 51 | # Calculate the number of extreme dates for each symbol. 52 | # You can use functions sapply() and NROW(). 53 | 54 | sapply(extreme_dates, NROW) 55 | 56 | # You should get the following output: 57 | # DAX SMI CAC FTSE 58 | # 26 18 22 7 59 | 60 | 61 | # 2. (10pts) 62 | # Set all the extreme returns (either above +3% or below -3%) in 63 | # re_turns to zero. 64 | 65 | re_turns[(re_turns > 0.03) | (re_turns < -0.03)] <- 0 66 | 67 | # 3. (10pts) 68 | # Calculate the cumulative DAX returns from the first column 69 | # of re_turns, and call them cum_returns. 70 | # Append 1 to the beginning of cum_returns, so that it has 71 | # the same number of elements as there are rows in EuStockMarkets. 72 | # Multiply cum_returns by EuStockMarkets[1, 1]. 73 | # You can use functions exp(), cumsum(), and c(). 74 | 75 | cum_returns <- exp(cumsum(re_turns[, 1])) 76 | cum_returns <- EuStockMarkets[1, 1] * c(1, cum_returns) 77 | 78 | 79 | # 4. (10pts) Coerce the DAX prices in EuStockMarkets into an xts 80 | # time series called dax_prices. 81 | # The time index of xts_eustocks should be of class POSIXct, and 82 | # the timezone should be equal to "America/New_York". 83 | # You can use functions coredata(), xts(), index(), 84 | # and date_decimal(). 85 | 86 | library(lubridate) 87 | dax_prices <- xts(coredata(EuStockMarkets[, 1]), 88 | order.by=date_decimal(index(EuStockMarkets), 89 | tz="America/New_York")) 90 | 91 | 92 | # cbind() cum_returns as a second column to dax_prices, 93 | # and assign the column names "DAX", "DAX clean". 94 | # You can use functions cbind(), colnames(), and c(). 95 | 96 | dax_prices <- cbind(dax_prices, cum_returns) 97 | colnames(dax_prices) <- c("DAX", "DAX clean") 98 | 99 | 100 | # 5. (10pts) Create a dygraphs plot of dax_prices. 101 | 102 | dygraphs::dygraph(dax_prices, main="DAX prices") 103 | 104 | # Your plot should be similar to dax_prices.png 105 | 106 | 107 | 108 | ############## Part II 109 | # Summary: Select recurring times of day from OHLC time series 110 | # bar data without using the "T notation". 111 | 112 | # load package HighFreq 113 | library(HighFreq) 114 | 115 | # The package HighFreq contains the SPY dataset, which is an xts 116 | # time series containing OHLC prices and trading volumes for the 117 | # SPY etf. 118 | # The SPY dataset contains several years of data, collected 119 | # during trading hours. 120 | # Each day of the SPY data starts at 09:31 and ends at 16:01 121 | # (with the exception of some trading days before holidays). 122 | # Each row of SPY contains a single bar of prices at 1-minute 123 | # intervals, with Open, High, Low, and Close prices, and Volume. 124 | 125 | head(HighFreq::SPY) 126 | tail(HighFreq::SPY) 127 | 128 | 129 | # 1. (10pts) Select recurring times of day from the SPY time 130 | # series using the "T notation". 131 | # Select the data for all the days in April 2012, starting from 132 | # 09:41 to 16:00 using the "T notation", and call it sub_SPY. 133 | 134 | sub_SPY <- HighFreq::SPY["2012-04"] ["T09:41:00/T16:00:00"] 135 | 136 | 137 | # 2. (20pts) Select the same data as in p.1, but without using 138 | # the "T notation", and call it sub_SPY_bis. 139 | # You can use the functions format(), index(), c(), 140 | # and paste0(), and the operators "%in%", or ">" and "<". 141 | 142 | sub_SPY_bis <- SPY["2012-04"] 143 | in_dex <- format(index(sub_SPY_bis), "%H:%M") 144 | in_dex <- (in_dex > "09:40") & (in_dex < "16:01") 145 | sub_SPY_bis <- sub_SPY_bis[in_dex, ] 146 | 147 | # or 148 | sub_SPY_bis <- SPY["2012-04"] 149 | in_dex <- format(index(sub_SPY_bis), "%H:%M") 150 | in_dex <- in_dex %in% c(paste0("09:", 31:40), "16:01") 151 | sub_SPY_bis <- sub_SPY_bis[!in_dex, ] 152 | 153 | 154 | # Verify that sub_SPY is identical to sub_SPY_bis using 155 | # the function identical(): 156 | 157 | identical(sub_SPY, sub_SPY_bis) 158 | 159 | 160 | 161 | ############## Part III 162 | # 1. (20pts) Create a vector of weekly POSIXct dates corresponding 163 | # to Mondays at 09:30AM, and call it "mon_days", 164 | # start with the date "2015-02-09", and end at the most recent Monday 165 | # before today (today is defined by Sys.time()), 166 | # set the timezone to "America/New_York", 167 | # first calculate the number of weeks between today and the start date, 168 | # and use that number to create a vector of weekly POSIXct dates, 169 | # use functions Sys.setenv(), as.POSIXct(), difftime() and ceiling(), 170 | # and lubridate function weeks(), 171 | 172 | Sys.setenv(TZ="America/New_York") 173 | start_date <- as.POSIXct("2015-02-09 09:30:00") 174 | end_date <- Sys.time() 175 | 176 | num_weeks <- ceiling(difftime(end_date, start_date, units="weeks")) 177 | 178 | mon_days <- start_date + lubridate::weeks(0:num_weeks) 179 | mon_days <- mon_days[(mon_days <= end_date)] 180 | head(mon_days) 181 | tail(mon_days) 182 | 183 | # Convert "mon_days" to the days of the week, using three different methods, 184 | # to verify that all the dates in "mon_days" are indeed Mondays, 185 | 186 | # use function weekdays(), 187 | weekdays(mon_days) 188 | 189 | # use function as.POSIXlt(), 190 | as.POSIXlt(mon_days)$wday 191 | 192 | # use lubridate function wday(), 193 | lubridate::wday(mon_days, TRUE) 194 | 195 | 196 | -------------------------------------------------------------------------------- /tests/FRE7241_test2 solution.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #2 Solutions February 6, 2018 3 | ################################# 4 | # Max score 130pts 5 | 6 | # The below solutions are examples, 7 | # Slightly different solutions are also possible. 8 | 9 | ############## Part I 10 | # Summary: Perform interval aggregations on an OHLC time 11 | # series, to obtain an OHLC series with lower periodicity, 12 | # with the same output as function to.period() from package 13 | # xts, or function to_period() from package rutils. 14 | 15 | # 1. (20pts) Define an OHLC time series called oh_lc 16 | # as follows: 17 | 18 | oh_lc <- rutils::env_etf$VTI 19 | 20 | # Define an aggregation function for OHLC data, 21 | # called agg_ohlc(). 22 | # agg_ohlc() should return a named vector of Open, 23 | # High, Low, and Close prices, and Volume. 24 | # The Open price should be the first Open price. 25 | # The High price should be the max of the High prices. 26 | # The Low price should be the min of the Low prices. 27 | # The Close price should be the last Close price. 28 | # The Volume should be the sum of Volumes. 29 | # You can use functions c(), NROW(), and coredata(). 30 | 31 | agg_ohlc <- function(oh_lc) 32 | c(Open=coredata(oh_lc[1, 1]), 33 | High=max(oh_lc[, 2]), 34 | Low=min(oh_lc[, 3]), 35 | Close=coredata(oh_lc[NROW(oh_lc), 4]), 36 | Volume=sum(oh_lc[, 5])) 37 | 38 | # You should get the following output: 39 | # > round(agg_ohlc(oh_lc)) 40 | # Open High Low Close Volume 41 | # 42 147 0 147 7113840736 42 | 43 | 44 | # 2. (10pts) Calculate equally spaced end points 45 | # over oh_lc, with a stub interval at the beginning, 46 | # and call them end_points. 47 | 48 | # define look-back interval 49 | look_back <- 252 50 | 51 | n_row <- NROW(oh_lc) 52 | num_agg <- n_row %/% look_back 53 | end_points <- n_row-look_back*num_agg + look_back*(0:num_agg) 54 | len_gth <- NROW(end_points) 55 | 56 | # Calculate starting points as the lag of end_points, 57 | # and call them start_points. 58 | # The start_points and end_points should together 59 | # form non-overlapping intervals over oh_lc. 60 | 61 | start_points <- c(1, end_points[1:(len_gth-1)]+1) 62 | 63 | # You should get the following output: 64 | # > end_points 65 | # [1] 158 410 662 914 1166 1418 1670 1922 2174 2426 2678 66 | # [12] 2930 3182 3434 3686 3938 4190 67 | # 68 | # > start_points 69 | # [1] 1 159 411 663 915 1167 1419 1671 1923 2175 2427 2679 2931 70 | # [14] 3183 3435 3687 3939 71 | 72 | 73 | # 3. (20pts) Perform an sapply() loop over the length of 74 | # end_points, applying agg_ohlc() to the intervals 75 | # defined by the start_points and end_points along 76 | # the way. Call the output agg_s. 77 | # You can use functions sapply(), xts(), index(), 78 | # is.vector(), and t(). 79 | 80 | agg_s <- sapply(1:len_gth, 81 | function(it_er) { 82 | agg_ohlc(oh_lc[start_points[it_er]:end_points[it_er]]) 83 | }) # end sapply 84 | 85 | # Coerce the output of the sapply() loop into an xts series. 86 | 87 | if (is.vector(agg_s)) 88 | agg_s <- t(agg_s) 89 | agg_s <- t(agg_s) 90 | # coerce agg_s into xts series 91 | agg_s <- xts(agg_s, order.by=index(oh_lc[end_points])) 92 | 93 | # You should get the following output: 94 | # > round(tail(agg_s), 3) 95 | # Open High Low Close Volume 96 | # 2013-01-24 59.718 70.360 57.988 70.033 488161341 97 | # 2014-01-24 70.306 89.261 69.661 86.445 598609684 98 | # 2015-01-26 86.445 101.608 83.731 100.179 657858412 99 | # 2016-01-26 99.405 105.120 88.322 93.017 801628646 100 | # 2017-01-25 92.757 116.412 88.120 116.373 655389957 101 | # 2018-01-26 116.412 146.870 114.566 146.860 547883108 102 | 103 | 104 | # 4. (10pts) 105 | # Verify that function rutils::to_period() from package 106 | # rutils produces the same result as agg_s. 107 | # You can use functions unname() and coredata(). 108 | # You must use function all.equal(). 109 | # hint: use arguments: 110 | # oh_lc=oh_lc[, 1:5] 111 | # end_points=c(0, end_points) 112 | 113 | aggs_rutils <- rutils::to_period(oh_lc=oh_lc[, 1:5], end_points=c(0, end_points)) 114 | all.equal(unname(coredata(agg_s)), unname(coredata(aggs_rutils))) 115 | 116 | 117 | 118 | ############## Part II 119 | # Summary: Calculate the number of trades in an 120 | # EWMA strategy, and plot the number of trades as 121 | # a function of the lambda decay parameter. 122 | 123 | # 1. (20pts) Calculate the number of trades in an 124 | # EWMA strategy, using the function simu_ewma() 125 | # from the lecture code. 126 | # The number of trades is equal to the number of 127 | # times the EWMA strategy changes its risk position, 128 | # including the first trade when the strategy trades 129 | # out of the initial zero risk position. 130 | # You can use functions NROW(), which(), diff(), 131 | # and as.numeric(). 132 | 133 | # Specify EWMA strategy parameters 134 | library(HighFreq) 135 | oh_lc <- rutils::env_etf$VTI 136 | wid_th <- 251 137 | lamb_da <- 0.01 138 | 139 | # Source the function simu_ewma() from the file 140 | # ewma_model.R, using function source(). 141 | source("C:/Develop/R/lecture_slides/scripts/ewma_model.R") 142 | 143 | # Simulate EWMA strategy using simu_ewma() 144 | ewma_strat <- simu_ewma(oh_lc=oh_lc, lamb_da=lamb_da, wid_th=wid_th) 145 | po_sitions <- ewma_strat[, 1] 146 | 147 | # Calculate the number of trades 148 | sum(diff(as.numeric(po_sitions)) != 0) 149 | # or 150 | sum(rutils::diff_it(po_sitions) != 0) 151 | # or 152 | (sum(abs(rutils::diff_it(as.numeric(po_sitions))))+1)/2 153 | 154 | # You should get the following output: 155 | # [1] 184 156 | 157 | 158 | # 2. (20pts) Perform an sapply() loop to calculate 159 | # the number of trades as a function of the lambda 160 | # decay parameter. 161 | 162 | # Specify lamb_das parameters 163 | lamb_das <- seq(0.01, 0.4, 0.01) 164 | 165 | number_trades <- sapply(lamb_das, function(lamb_da) { 166 | po_sitions <- simu_ewma(oh_lc=oh_lc, lamb_da=lamb_da, wid_th=wid_th)[, 1] 167 | sum(rutils::diff_it(po_sitions) != 0) 168 | }) # end sapply 169 | 170 | # You should get the following output: 171 | # > number_trades 172 | # [1] 184 194 258 290 364 390 422 466 500 530 546 566 582 616 173 | # [15] 636 666 686 700 720 742 760 788 798 820 842 856 876 892 174 | # [29] 898 902 912 930 954 966 980 996 1002 1008 1024 1036 175 | 176 | # Plot the number of trades using plot(). 177 | # Your plot should be similar to ewma_number_trades.png 178 | x11() 179 | plot(x=lamb_das, y=number_trades, t="l", 180 | main="Number of trades 181 | as function of the decay parameter lambda") 182 | 183 | 184 | ############## Part III 185 | # Summary: Perform multiple back-tests of momentum strategies 186 | # for an ETF portfolio, using parallel computing. 187 | 188 | # Source the function back_test(), and define the 189 | # momentum strategy parameters: 190 | 191 | library(HighFreq) 192 | source("C:/Develop/R/lecture_slides/scripts/back_test.R") 193 | look_backs <- seq(5, 60, by=5) 194 | re_balance <- "weeks" 195 | bid_offer <- 0.001 196 | # Calculate ETF prices and simple returns 197 | sym_bols <- c("VTI", "IEF", "DBC") 198 | price_s <- rutils::env_etf$price_s[, sym_bols] 199 | price_s <- zoo::na.locf(price_s) 200 | price_s <- na.omit(price_s) 201 | re_turns <- rutils::diff_it(price_s) 202 | # Define aggregation function 203 | agg_fun <- function(re_turns) sum(re_turns)/sd(re_turns) 204 | 205 | 206 | # 1. (20pts) Perform a parallel apply loop over look_backs, 207 | # and perform back-tests of momentum strategies using 208 | # function back_test(). 209 | # You should get an xts series of back-test returns called 210 | # back_tests. 211 | # You can use functions parLapply(), makeCluster(), 212 | # clusterExport(), rutils::do_call(), cbind(), colnames(), 213 | # and paste0(). 214 | 215 | # NOTE: the function back_test() in file back_test.R was 216 | # renamed to back_test_ep() in the newest version of 217 | # file back_test.R 218 | # Full credit will be given for using either one of the 219 | # functions. 220 | 221 | # initialize compute cluster 222 | library(parallel) 223 | clus_ter <- makeCluster(detectCores()-1) 224 | clusterExport(clus_ter, 225 | varlist=c("back_test_ep", "agg_fun", "re_turns", 226 | "price_s", "re_balance", "bid_offer")) 227 | 228 | # perform parallel loop over look_backs under Windows 229 | back_tests <- parLapply(clus_ter, look_backs, 230 | function(look_back) { 231 | # perform back-test 232 | back_test_ep(re_turns=re_turns, 233 | price_s=price_s, 234 | agg_fun=agg_fun, 235 | look_back=look_back, 236 | re_balance=re_balance, 237 | bid_offer=bid_offer) 238 | }) # end parLapply 239 | 240 | # or 241 | back_tests <- parLapply(clus_ter, 242 | X=look_backs, 243 | fun=back_test_ep, 244 | re_turns=re_turns, 245 | price_s=price_s, 246 | agg_fun=agg_fun, 247 | re_balance=re_balance, 248 | bid_offer=bid_offer 249 | ) # end parLapply 250 | 251 | # perform parallel loop over look_backs under Mac-OSX or Linux 252 | back_tests <- mclapply(look_backs, function(look_back) { 253 | # perform back-test 254 | back_test_ep(re_turns=re_turns, 255 | price_s=price_s, 256 | agg_fun=agg_fun, 257 | look_back=look_back, 258 | re_balance=re_balance, 259 | bid_offer=bid_offer) 260 | }) # end mclapply 261 | 262 | # or 263 | back_tests <- mclapply(clus_ter, 264 | X=look_backs, 265 | FUN=back_test_ep, 266 | re_turns=re_turns, 267 | price_s=price_s, 268 | agg_fun=agg_fun, 269 | re_balance=re_balance, 270 | bid_offer=bid_offer 271 | ) # end parLapply 272 | 273 | 274 | # stop R processes over cluster under Windows 275 | stopCluster(clus_ter) 276 | 277 | # flatten list into xts 278 | back_tests <- rutils::do_call(cbind, back_tests) 279 | colnames(back_tests) <- paste0("back=", look_backs) 280 | 281 | # You should get the following output: 282 | # > round(tail(back_tests[, 1:6]), 3) 283 | # back=5 back=10 back=15 back=20 back=25 back=30 284 | # 2017-12-15 0.297 0.667 0.767 0.899 0.952 0.786 285 | # 2017-12-22 0.291 0.672 0.770 0.904 0.960 0.792 286 | # 2017-12-29 0.302 0.686 0.786 0.920 0.974 0.807 287 | # 2018-01-05 0.317 0.701 0.802 0.935 0.990 0.822 288 | # 2018-01-12 0.318 0.707 0.805 0.939 0.993 0.825 289 | # 2018-01-19 0.335 0.723 0.822 0.955 1.011 0.843 290 | 291 | 292 | # 2. (10pts) Plot the cumulative strategy pnls as a 293 | # function of look_back, by plotting the last row 294 | # of back_tests. 295 | # You can use functions as.numeric(), plot(), NROW(), 296 | # and cbind(). 297 | 298 | pro_files <- as.numeric(back_tests[NROW(back_tests), ]) 299 | pro_files <- cbind(look_backs, pro_files) 300 | plot(pro_files, t="l", 301 | main="Strategy PnL as function of look_back", 302 | xlab="look_back (weeks)", ylab="pnl") 303 | 304 | # Your plot should be similar to look_back_profile.png 305 | 306 | -------------------------------------------------------------------------------- /tests/FRE7241_test3 solution.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #3 Solutions February 20, 2018 3 | ################################# 4 | # Max score 110pts 5 | 6 | # The below solutions are examples, 7 | # Slightly different solutions are also possible. 8 | 9 | ############## Part I 10 | # Summary: Calculate the maximum drawdown of a time series. 11 | 12 | # 1. (20pts) Extract the adjusted close prices from 13 | # rutils::env_etf$VTI into a variable called price_s. 14 | # You can use function Ad() from package quantmod. 15 | 16 | library(quantmod) 17 | price_s <- Ad(rutils::env_etf$VTI) 18 | 19 | # The cumulative maximum of a price series is the maximum 20 | # price in the past, reached up to that point in time. 21 | # Calculate the cumulative maximum of price_s using 22 | # function cummax(). 23 | # Plot the cumulative maximum of price_s using function 24 | # chart_Series(). 25 | 26 | chart_Series(x=cummax(price_s), 27 | name="Cumulative maximum prices") 28 | 29 | # A drawdown is a drop in price from its previous maximum. 30 | # Calculate the xts time series of drawdowns of price_s, 31 | # as the difference between price_s minus the cumulative 32 | # maximum of price_s, and call it draw_down. 33 | 34 | draw_down <- (price_s - cummax(price_s)) 35 | 36 | # plot draw_down using function chart_Series(). 37 | 38 | plot_theme <- chart_theme() 39 | plot_theme$col$line.col <- c("blue") 40 | chart_Series(x=draw_down, name="VTI Drawdowns", theme=plot_theme) 41 | 42 | # Find the minimum value of draw_down (call it 43 | # max_drawdown) and the date when it reaches its 44 | # minimum (call it date_trough). 45 | # You can use functions index() and which.min(). 46 | 47 | in_dex <- index(price_s) 48 | date_trough <- in_dex[which.min(draw_down)] 49 | max_drawdown <- draw_down[date_trough] 50 | 51 | # You should get the following output: 52 | # > date_trough 53 | # [1] "2009-03-09" 54 | # > max_drawdown 55 | # VTI.Adjusted 56 | # 2009-03-09 -35.0769 57 | 58 | 59 | # Add a vertical red line to the draw_down plot, 60 | # at the date date_trough. 61 | # hint: use function match() and index() to first 62 | # calculate the index of date_trough. 63 | # You can use functions match(), index(), and abline(), 64 | 65 | abline(v=match(date_trough, index(draw_down)), 66 | lwd=2, col="red") 67 | 68 | # Your plot should be similar to drawdown_plot.png 69 | 70 | 71 | # 2. (20pts) Divide draw_down into two time series at 72 | # the date date_trough. 73 | # First subset draw_down to dates before date_trough, 74 | # and call it pre_drawdown, 75 | 76 | pre_drawdown <- draw_down[in_dexdate_trough] 82 | 83 | # Now find the date when the drawdown period starts. 84 | # The drawdown starts when draw_down is first zero 85 | # and then starts decreasing to some price below zero. 86 | # Find the latest date when pre_drawdown was still 87 | # equal to zero, and call it date_from. 88 | # date_from is when the drawdown started. 89 | # You can use functions index() and max(). 90 | 91 | date_from <- max((index(pre_drawdown))[pre_drawdown==0]) 92 | 93 | # Now find the date when the drawdown period ends. 94 | # When the current price exceeds the previous maximum 95 | # price, then draw_down returns back to zero, and the 96 | # drawdown period is over. 97 | # A drawdown ends when draw_down first returns back 98 | # to zero after date_trough. 99 | # Find the first date when post_drawdown returns back 100 | # to zero, and call it date_to. 101 | # date_to is when the drawdown has ended. 102 | # You can use functions index() and min(), 103 | 104 | date_to <- min((index(post_drawdown))[post_drawdown==0]) 105 | 106 | # You should get the following output: 107 | # > date_from 108 | # [1] "2007-10-09" 109 | # > date_to 110 | # [1] "2012-03-13" 111 | 112 | 113 | # 3. (20pts) Combine the three dates: date_from, 114 | # date_trough, and date_to into a named vector with 115 | # names "from", "trough", and "to", and call it 116 | # drawdown_dates, 117 | 118 | drawdown_dates <- c(from=date_from, trough=date_trough, to=date_to) 119 | 120 | # You should get the following output: 121 | # drawdown_dates 122 | # from trough to 123 | # "2007-10-09" "2009-03-09" "2012-03-13" 124 | 125 | # Plot price_s using function chart_Series(). 126 | 127 | plot_theme <- chart_theme() 128 | plot_theme$col$line.col <- c("blue") 129 | chart_Series(x=price_s, name="VTI drawdown dates", 130 | theme=plot_theme) 131 | 132 | # Add vertical green, red, and orange lines for the 133 | # three dates: date_from, date_trough, date_to. 134 | # Add text at the vertical lines equal to 135 | # names(drawdown_dates). 136 | # hint: use function match() and index() to first 137 | # calculate the index of drawdown_dates. 138 | # You can use functions match(), index(), abline(), 139 | # and text(). 140 | 141 | abline(v=match(drawdown_dates, index(draw_down)), 142 | lwd=2, col=c("green", "red", "orange")) 143 | text(x=match(drawdown_dates, index(draw_down)), 144 | y=as.vector(price_s[drawdown_dates]), 145 | labels=names(drawdown_dates), pos=3, cex=0.8) 146 | 147 | # Your plot should be similar to drawdown_vti.png 148 | 149 | 150 | 151 | ############## Part II 152 | # Summary: Calculate the eigenvectors and eigenvalues 153 | # of the covariance matrix of returns as a function of 154 | # the number of time periods, using RcppArmadillo. 155 | 156 | # First perform the calculations in R below (run the code). 157 | # Create a matrix called re_turns, of random returns 158 | # with the number of columns equal to n_assets, and 159 | # the number of rows equal to n_assets^2. 160 | n_assets <- 10 161 | set.seed(1121) 162 | re_turns <- matrix(rnorm(2*n_assets^2), nc=n_assets) 163 | # Calculate the eigenvalues 164 | cov_mat <- cov(re_turns) 165 | eigen_values <- eigen(cov_mat)$values 166 | 167 | # 1. (20pts) 168 | # Create an Rcpp function called get_eigen(), which 169 | # calculates the eigen_values of the matrix cov_mat. 170 | # Hint: You can use the RcppArmadillo function arma::eig_sym(). 171 | # The function get_eigen() requires at most two lines 172 | # of Rcpp code. 173 | # Save the Rcpp code in a file called rcpp_test3.cpp, 174 | # and compile it as follows: 175 | 176 | Rcpp::sourceCpp(file="C:/Develop/R/lecture_slides/scripts/rcpp_test3.cpp") 177 | 178 | # Calculate the eigenvalues using the Rcpp function 179 | # get_eigen() and save the output to rcpp_eigen_values. 180 | # Hint: if get_eigen() returns a matrix then you may 181 | # need to coerce it into a vector, and you may also 182 | # need to sort it. 183 | # Hint: You can use function sort(). 184 | 185 | rcpp_eigen_values <- get_eigen(cov_mat) 186 | rcpp_eigen_values <- sort(rcpp_eigen_values, decreasing=TRUE) 187 | 188 | # Verify that eigen_values and rcpp_eigen_values are 189 | # the same using function all.equal(): 190 | 191 | all.equal(eigen_values, rcpp_eigen_values) 192 | 193 | 194 | # 2. (30pts) 195 | # This part of the exercise demonstrates that if the 196 | # number of time periods of returns (rows) is less than 197 | # the number of portfolio assets (columns), then the 198 | # returns are collinear, so the covariance matrix 199 | # is singular, and some of its eigenvalues are zero, 200 | 201 | # Calculate the smallest eigenvalues as a function 202 | # of the number of time periods (rows) (run the code). 203 | 204 | n_rows <- (n_assets/2):(2*n_assets) 205 | eigen_values <- sapply(n_rows, function(x) { 206 | # subset the returns 207 | re_turns <- re_turns[1:x, ] 208 | # calculate the covariance matrix 209 | cov_mat <- cov(re_turns) 210 | # return the smallest eigenvalue 211 | min(eigen(cov_mat)$values) 212 | }) # end sapply 213 | 214 | 215 | # Create an Rcpp function called get_min_eigens(), which 216 | # reproduces the above sapply loop and returns the same 217 | # values as in eigen_values. 218 | # Hint: To perform matrix subsetting, you can use the 219 | # RcppArmadillo function arma::re_turns.rows(). 220 | # The function get_min_eigens() requires at most seven 221 | # lines of Rcpp code. 222 | # Save the Rcpp code in a file called rcpp_test3.cpp, 223 | # and compile it as follows: 224 | 225 | Rcpp::sourceCpp(file="C:/Develop/R/lecture_slides/scripts/rcpp_test3.cpp") 226 | 227 | # Calculate the eigenvalues using the Rcpp function 228 | # get_min_eigens() and save the output to rcpp_eigen_values. 229 | # Hint: if get_min_eigens() returns a matrix then you may 230 | # need to coerce it into a vector. 231 | # Hint: You can use function as.vector(). 232 | 233 | rcpp_eigen_values <- get_min_eigens(re_turns, n_rows-1) 234 | rcpp_eigen_values <- as.vector(rcpp_eigen_values) 235 | 236 | # Verify that eigen_values and rcpp_eigen_values are 237 | # the same using function all.equal(): 238 | 239 | all.equal(eigen_values, rcpp_eigen_values) 240 | 241 | 242 | # Benchmark the function get_min_eigens() compared 243 | # to the sapply loop, using the function microbenchmark(). 244 | # You should obtain a speedup on the order of 50 times! 245 | 246 | library(microbenchmark) 247 | summary(microbenchmark( 248 | r_cpp=get_min_eigens(re_turns, n_rows-1), 249 | s_apply=sapply(n_rows, function(x) { 250 | re_turns <- re_turns[1:x, ] 251 | re_turns <- apply(re_turns, MARGIN=2, function(y) (y-mean(y))) 252 | cov_mat <- crossprod(re_turns) / (x-1) 253 | min(eigen(cov_mat)$values) 254 | }), 255 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 256 | 257 | 258 | -------------------------------------------------------------------------------- /tests/FRE7241_test4 solution.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #4 Solutions February 27, 2018 3 | ################################# 4 | # Max score 110pts 5 | 6 | # The below solutions are examples, 7 | # Slightly different solutions are also possible. 8 | 9 | 10 | ############## Part I 11 | # Summary: Calculate performance of random sub-portfolios 12 | # of S&P500 constituent stocks. 13 | 14 | # 1. (20pts) Load the file sp500_prices.RData containing 15 | # an xts series called price_s, with the daily closing 16 | # prices of the S&P500 stock index constituents. 17 | 18 | load("C:/Develop/R/lecture_slides/data/sp500_prices.RData") 19 | 20 | 21 | # Create a vector of dates called date_s, equal to the 22 | # index of price_s. 23 | # Use function index(), 24 | 25 | date_s <- index(price_s) 26 | 27 | # Normalize the columns of price_s, so that the first 28 | # row for all columns is equal to 1. 29 | # The columns of price_s represent the growth of one 30 | # dollar invested in that stock. 31 | # You can use functions as.numeric() and t(). 32 | 33 | price_s <- t(t(price_s) / as.numeric(price_s[1, ])) 34 | 35 | # You should get the following output: 36 | # round(price_s[1:6, 1:6], 3) 37 | # RCL BBY HP DVN CME MSFT 38 | # 2007-01-03 1.000 1.000 1.000 1.000 1.000 1.000 39 | # 2007-01-04 1.007 1.016 0.997 0.982 1.007 0.998 40 | # 2007-01-05 0.997 1.019 1.000 1.007 1.012 0.993 41 | # 2007-01-08 1.007 1.007 1.005 1.012 1.023 1.002 42 | # 2007-01-09 1.034 1.000 1.011 1.012 1.029 1.003 43 | # 2007-01-10 1.021 1.007 1.003 0.997 1.058 0.993 44 | # 45 | # round(price_s[(NROW(price_s)-5):NROW(price_s), 1:6], 3) 46 | # RCL BBY HP DVN CME MSFT 47 | # 2018-01-19 3.490 2.054 3.830 0.753 2.216 3.919 48 | # 2018-01-22 3.483 2.086 3.829 0.788 2.233 3.989 49 | # 2018-01-23 3.443 2.072 3.853 0.782 2.216 4.002 50 | # 2018-01-24 3.586 2.052 3.843 0.782 2.226 3.998 51 | # 2018-01-25 3.570 2.038 3.968 0.772 2.214 4.020 52 | # 2018-01-26 3.653 2.081 3.989 0.771 2.229 4.096 53 | 54 | 55 | # Calculate a vector equal to the equal dollar-weighted 56 | # prices of the index components, i.e. the average of 57 | # the rows of price_s, and call it in_dex. 58 | # You can use functions NCOL() and rowSums(). 59 | 60 | n_col <- NCOL(price_s) 61 | in_dex <- rowSums(price_s)/n_col 62 | 63 | # You should get the following output: 64 | # > tail(in_dex) 65 | # 2018-01-19 2018-01-22 2018-01-23 2018-01-24 2018-01-25 2018-01-26 66 | # 3.831064 3.855518 3.882164 3.886024 3.890283 3.929215 67 | 68 | 69 | # 2. (30pts) Select twenty equally dollar-weighted, 70 | # random sub-portfolios from the columns of price_s, 71 | # with each sub-portfolio being the average of five 72 | # randomly selected columns (stocks) of price_s. 73 | # Bind the sub-portfolio prices into a single xts 74 | # series called sub_portfolios. 75 | # You can use the vector of dates called date_s. 76 | # You can use function sample.int() with "replace=FALSE". 77 | # The initial instructions had a typo with "replace=TRUE". 78 | # You will get full credit in either case. 79 | # You can use functions sapply(), xts::xts(), 80 | # rowSums(), and colnames(). 81 | 82 | n_portf <- 20 83 | n_stocks <- 5 84 | set.seed(1121) 85 | sub_portfolios <- sapply(1:n_portf, function(x) { 86 | price_s <- price_s[, sample.int(n=n_col, size=n_stocks, replace=FALSE)] 87 | rowSums(price_s)/n_stocks 88 | }) # end sapply 89 | 90 | sub_portfolios <- xts(sub_portfolios, order.by=date_s) 91 | colnames(sub_portfolios) <- paste0("portf", 1:n_portf) 92 | 93 | # You should get the following output: 94 | # 95 | # round(sub_portfolios[1:4, 1:4], 3) 96 | # portf1 portf2 portf3 portf4 97 | # 2007-01-03 1.000 1.000 1.000 1.000 98 | # 2007-01-04 1.010 1.000 1.013 1.000 99 | # 2007-01-05 1.013 0.989 1.004 1.001 100 | # 2007-01-08 1.022 0.990 0.999 1.004 101 | # 102 | # round(sub_portfolios[(NROW(price_s)-3):NROW(price_s), 1:4], 3) 103 | # portf1 portf2 portf3 portf4 104 | # 2018-01-23 5.582 1.878 2.535 5.055 105 | # 2018-01-24 5.545 1.870 2.522 5.066 106 | # 2018-01-25 5.468 1.859 2.528 5.089 107 | # 2018-01-26 5.510 1.884 2.569 5.169 108 | 109 | 110 | # Plot the sub_portfolios from worst to best (based 111 | # on final price) using a color ramp from red to blue. 112 | # 113 | # Create a color ramp, using functions colorRampPalette() 114 | # and order(). 115 | 116 | col_ors <- colorRampPalette(c("red", "blue"))(n_portf) 117 | col_ors <- col_ors[order(order(sub_portfolios[NROW(sub_portfolios), ]))] 118 | 119 | # Create a plot of the sub_portfolios with the custom 120 | # color ramp, using either function zoo::plot.zoo(), 121 | # or functions chart_theme() and chart_Series(). 122 | 123 | # plot using chart_theme() and chart_Series() 124 | plot_theme <- chart_theme() 125 | plot_theme$col$line.col <- col_ors 126 | quantmod::chart_Series(sub_portfolios, theme=plot_theme, 127 | name="Random S&P500 stock sub-portfolios (normalized)") 128 | 129 | # OR plot using zoo::plot.zoo() 130 | zoo::plot.zoo(sub_portfolios, plot.type="single", 131 | col=col_ors, xlab="", ylab="", 132 | main="Random S&P500 stock sub-portfolios (normalized)") 133 | 134 | 135 | # Your plot should be similar to sp500_sub_portfolios.png 136 | 137 | 138 | # Calculate an xts series called above_index, with the 139 | # percentage of sub-portfolios whose prices at the end 140 | # of each year are above the index price in_dex. 141 | # You can use functions endpoints(), rowSums(), 142 | # chart_theme(), and xts(). 143 | 144 | end_points <- xts::endpoints(date_s, on="years") 145 | above_index <- (sub_portfolios[end_points, ] > in_dex[end_points]) 146 | above_index <- rowSums(above_index)/n_portf 147 | above_index <- xts::xts(above_index, order.by=date_s[end_points]) 148 | colnames(above_index) <- "percentage" 149 | 150 | # You should get output similar to the following: 151 | # > above_index 152 | # percentage 153 | # 2007-12-31 0.70 154 | # 2008-12-31 0.55 155 | # 2009-12-31 0.60 156 | # 2010-12-31 0.65 157 | # 2011-12-30 0.60 158 | # 2012-12-31 0.60 159 | # 2013-12-31 0.40 160 | # 2014-12-31 0.40 161 | # 2015-12-31 0.45 162 | # 2016-12-30 0.35 163 | # 2017-12-29 0.40 164 | # 2018-01-26 0.40 165 | 166 | # Create a plot of above_index using function 167 | # zoo::plot.zoo(). 168 | 169 | zoo::plot.zoo(above_index, col="blue", lwd=2, xlab="", ylab="", 170 | main="Percentage of Random Sub-portfolios 171 | Above the Index") 172 | 173 | # Your plot should be similar to sp500_sub_portfolios_above.png 174 | 175 | 176 | 177 | ############## Part II 178 | # Summary: Perform PCA of returns over annual intervals 179 | # using RcppArmadillo. 180 | 181 | # 1. (20pts) Load the file sp500_prices.RData containing 182 | # an xts series called price_s, with the daily closing 183 | # prices of the S&P500 stock index constituents. 184 | 185 | library(HighFreq) 186 | load("C:/Develop/R/lecture_slides/data/sp500_prices.RData") 187 | 188 | # Calculate the simple returns (differences not percentages) 189 | # of the first six columns of price_s and call it re_turns. 190 | # You can use function rutils::diff_it(). 191 | 192 | re_turns <- rutils::diff_it(price_s[, 1:6]) 193 | 194 | # De-mean (center) and scale the returns. 195 | # You can use functions t(), colMeans(), colSums(), 196 | # and NROW(). 197 | 198 | re_turns <- t(t(re_turns) - colMeans(re_turns)) 199 | re_turns <- t(t(re_turns) / sqrt(colSums(re_turns^2)/(NROW(re_turns)-1))) 200 | date_s <- index(price_s) 201 | re_turns <- xts(re_turns, date_s) 202 | 203 | # Perform PCA as follows: 204 | 205 | pc_a <- prcomp(re_turns, center=TRUE, scale=TRUE) 206 | 207 | # Create an Rcpp function called get_pca(), which 208 | # calculates a list containing the PCA objects 209 | # (sdev, rotation, etc.) from the matrix re_turns. 210 | # Hint: You can use the RcppArmadillo function 211 | # arma::princomp(). 212 | # The function get_pca() requires just a few lines 213 | # of Rcpp code. 214 | # Save the Rcpp code in a file called rcpp_test4.cpp, 215 | # and compile it as follows: 216 | 217 | Rcpp::sourceCpp(file="C:/Develop/R/lecture_slides/scripts/rcpp_test4.cpp") 218 | 219 | # Calculate the PCA using the Rcpp function get_pca() 220 | # and save the output to a list called pca_arma. 221 | # Verify that the elements of pc_a and pca_arma contain 222 | # the same numbers by using function all.equal(). 223 | # You can also use functions zoo::coredata(), unname(), 224 | # and drop(). 225 | 226 | pca_arma <- get_pca(re_turns) 227 | 228 | all.equal(unname(pc_a$rotation), pca_arma$coefficients) 229 | all.equal(unname(pc_a$sdev)^2, drop(pca_arma$latent)) 230 | all.equal(unname(pc_a$x), pca_arma$score) 231 | 232 | 233 | # 2. (20pts) Create a vector of annual end points 234 | # from the index of price_s, and call it end_points. 235 | # Use function endpoints() from package xts. 236 | 237 | end_points <- xts::endpoints(price_s, on="years") 238 | 239 | # You should get the following output: 240 | # > end_points 241 | # [1] 0 251 504 756 1008 1260 1510 1762 2014 2266 2518 2769 2787 242 | 243 | # Perform an sapply() loop over the length of end_points. 244 | # Inside the loop subset (select) the annual returns from 245 | # re_turns, then de-mean (center) and scale them, perform 246 | # PCA on the annual returns, and extract the vector pc_a$sdev. 247 | # The sapply() loop should produce a matrix with six rows and 248 | # (NROW(end_points)-1) columns. 249 | 250 | s_dev <- sapply(2:NROW(end_points), function(i) { 251 | re_turns <- re_turns[(end_points[i-1] + 1):end_points[i], ] 252 | pc_a <- prcomp(re_turns, center=TRUE, scale=TRUE) 253 | pc_a$sdev 254 | }) # end sapply 255 | 256 | # You should get the following output: 257 | # > round(s_dev, 3) 258 | # [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] 259 | # [1,] 1.662 1.754 1.828 1.860 1.904 1.633 1.535 1.569 1.545 1.508 1.301 1.437 260 | # [2,] 0.977 1.184 0.878 0.863 0.880 0.951 0.981 1.025 1.193 1.073 1.211 1.066 261 | # [3,] 0.861 0.700 0.792 0.779 0.726 0.870 0.930 0.908 0.898 0.949 1.003 0.990 262 | # [4,] 0.829 0.691 0.731 0.726 0.685 0.817 0.875 0.857 0.802 0.919 0.928 0.881 263 | # [5,] 0.733 0.622 0.685 0.619 0.600 0.782 0.784 0.783 0.689 0.753 0.797 0.833 264 | # [6,] 0.563 0.411 0.507 0.529 0.492 0.627 0.659 0.562 0.517 0.510 0.582 0.592 265 | 266 | 267 | # 3. (30pts) Create an Rcpp function called get_pca_var(), 268 | # which reproduces the above sapply loop and returns a 269 | # matrix of PCA variances equal to s_dev^2. 270 | # Hint: To perform matrix subsetting, you can use the 271 | # RcppArmadillo function arma::re_turns.rows(). 272 | # The function get_pca_var() requires at most seven 273 | # lines of Rcpp code. 274 | # Save the Rcpp code in a file called rcpp_test4.cpp, 275 | # and compile it as follows: 276 | # Verify that get_pca_var() returns a matrix of PCA 277 | # variances equal to s_dev^2, using function all.equal(). 278 | 279 | pca_var <- get_pca_var(re_turns, end_points-1) 280 | 281 | all.equal(s_dev^2, pca_var[NROW(pca_var):1, ]) 282 | 283 | 284 | # Benchmark the function get_pca_var() compared 285 | # to the sapply loop, using the function microbenchmark(). 286 | # You should obtain a speedup of almost 3 times. 287 | # The function get_pca_varr() is another possible solution, 288 | # but it's about 30 times slower than get_pca_var()! 289 | 290 | library(microbenchmark) 291 | summary(microbenchmark( 292 | get_pca_var=get_pca_var(zoo::coredata(re_turns), end_points-1), 293 | get_pca_varr=get_pca_varr(zoo::coredata(re_turns), end_points-1), 294 | s_apply=sapply(2:NROW(end_points), function(i) { 295 | re_turns <- re_turns[(end_points[i-1] + 1):end_points[i], ] 296 | pc_a <- prcomp(re_turns, center=TRUE, scale=TRUE) 297 | pc_a$sdev 298 | }), 299 | times=100))[, c(1, 4, 5)] # end microbenchmark summary 300 | 301 | 302 | -------------------------------------------------------------------------------- /tests/FRE7241_test5 solution.R: -------------------------------------------------------------------------------- 1 | ################################# 2 | ### FRE7241 Test #5 Solutions March 6, 2018 3 | ################################# 4 | # Max score 190pts 5 | 6 | # The below solutions are examples, 7 | # Slightly different solutions are also possible. 8 | 9 | ############## Part I 10 | # Summary: Calculate the minimum variance portfolio weights 11 | # using matrix algebra and quadratic programming. 12 | 13 | # 1. (20pts) 14 | # Create a vector of strings called sym_bols, with all the 15 | # symbols in rutils::env_etf$re_turns except for "VXX". 16 | # You can't simply type the symbol strings, but you must 17 | # use R code. 18 | # You can use the function colnames() and the "!" operator. 19 | 20 | sym_bols <- colnames(rutils::env_etf$re_turns) 21 | sym_bols <- sym_bols[!(sym_bols=="VXX")] 22 | n_weights <- NROW(sym_bols) 23 | 24 | # You should get the following output: 25 | # > sym_bols 26 | # [1] "VTI" "VEU" "IEF" "VNQ" "DBC" "XLY" "XLP" "XLE" "XLF" "XLV" 27 | # [11] "XLI" "XLB" "XLK" "XLU" "VYM" "IVW" "IWB" "IWD" "IWF" 28 | 29 | 30 | # Extract the columns of rutils::env_etf$re_turns for 31 | # the sym_bols, into an xts called re_turns. 32 | # Remove NA values from re_turns by first carrying forward 33 | # non-NA re_turns, and then removing any remaining NAs. 34 | # You can use the functions zoo::na.locf() and na.omit(). 35 | 36 | re_turns <- rutils::env_etf$re_turns[, sym_bols] 37 | re_turns <- zoo::na.locf(re_turns) 38 | re_turns <- na.omit(re_turns) 39 | 40 | # You should get the following output: 41 | # > dim(re_turns) 42 | # [1] 2741 19 43 | # 44 | # > round(re_turns[1:5, 1:5], 3) 45 | # VTI VEU IEF VNQ DBC 46 | # 2007-03-09 0.000 0.007 -0.006 0.013 -0.013 47 | # 2007-03-12 0.003 0.005 0.003 0.005 -0.009 48 | # 2007-03-13 -0.018 -0.026 0.004 -0.024 -0.008 49 | # 2007-03-14 0.005 0.001 -0.001 0.005 0.002 50 | # 2007-03-15 0.004 0.008 -0.001 0.009 -0.006 51 | 52 | 53 | # Calculate the covariance matrix of re_turns and call 54 | # it co_var, and its inverse and call it in_verse. 55 | # You can use the functions cov() and solve(). 56 | 57 | co_var <- cov(re_turns) 58 | in_verse <- solve(a=co_var) 59 | 60 | # Calculate the minimum variance weights using matrix 61 | # algebra, with the constraint that the sum of weights 62 | # is equal 1. 63 | 64 | u_nit <- rep(1, NCOL(co_var)) 65 | weight_s <- in_verse %*% u_nit 66 | weight_s <- weight_s / drop(t(u_nit) %*% weight_s) 67 | 68 | 69 | # You should get the following output: 70 | # > round(drop(weight_s), 3) 71 | # VTI VEU IEF VNQ DBC XLY XLP XLE XLF XLV 72 | # -0.104 -0.057 0.688 -0.051 0.100 -0.015 0.088 -0.061 -0.019 0.006 73 | # XLI XLB XLK XLU VYM IVW IWB IWD IWF 74 | # 0.025 -0.012 -0.008 -0.035 0.141 -0.026 0.188 0.042 0.109 75 | 76 | # Calculate the variance of the minimum variance portfolio. 77 | 78 | t(weight_s) %*% co_var %*% weight_s 79 | # or 80 | 1/(t(u_nit) %*% in_verse %*% u_nit) 81 | 82 | # You should get the following output: 83 | # [,1] 84 | # [1,] 8.717695e-06 85 | 86 | 87 | # 2. (20pts) 88 | # Calculate the minimum variance portfolio weights 89 | # using the function quadprog::solve.QP(), to 90 | # demonstrate that they are the same as from p.1. 91 | 92 | op_tim <- quadprog::solve.QP(Dmat=2*co_var, 93 | dvec=numeric(n_weights), 94 | Amat=matrix(1, nr=n_weights, nc=1), 95 | bvec=1) 96 | 97 | # You should get the following output: 98 | # > all.equal(unname(drop(weight_s)), op_tim$solution) 99 | # [1] TRUE 100 | 101 | 102 | # 3. (20pts) 103 | # Repeat the calculations of p.1 and p.2, and 104 | # calculate the minimum variance portfolio weights 105 | # using the function quadprog::solve.QP(), but with 106 | # the additional constraints that the weights are 107 | # constrained between -1 and +1, and that the sum 108 | # of weights for a sub-portfolio are equal to 0.8. 109 | # hint: You can adapt code from the slide "Portfolio 110 | # Optimization Using Package quadprog". 111 | 112 | # Define the sub-portfolio symbols: 113 | 114 | symbols_sub <- c("XLF", "XLE", "XLB") 115 | 116 | # Calculate a Boolean vector called portfolio_sub 117 | # which is TRUE if sym_bols is in symbols_sub. 118 | # You can use the %in% operator. 119 | 120 | portfolio_sub <- sym_bols %in% symbols_sub 121 | 122 | # You should get the following output: 123 | # > portfolio_sub 124 | # [1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE TRUE FALSE FALSE 125 | # [12] TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 126 | 127 | # Add the constraint that the sum of the symbols_sub weights 128 | # is equal to 0.8. 129 | 130 | a_mat <- cbind(matrix(1, nr=n_weights, nc=1), 131 | portfolio_sub*matrix(1, nr=n_weights, nc=1), 132 | diag(n_weights), -diag(n_weights)) 133 | b_vec <- c(1, 0.8, rep(-1, n_weights), rep(-1, n_weights)) 134 | op_tim <- quadprog::solve.QP(Dmat=2*co_var, 135 | dvec=numeric(n_weights), 136 | Amat=a_mat, 137 | bvec=b_vec, 138 | meq=2) 139 | 140 | weight_s <- op_tim$solution 141 | 142 | # You should get the following output: 143 | # > round(weight_s, 3) 144 | # [1] -0.499 -0.155 0.779 -0.083 0.022 0.117 0.314 0.219 0.368 0.185 145 | # [11] 0.077 0.213 0.190 0.069 -0.221 -0.105 -0.189 -0.471 0.171 146 | # 147 | # > sum(portfolio_sub*weight_s) 148 | # [1] 0.8 149 | # 150 | # > sum(weight_s) 151 | # [1] 1 152 | 153 | # Calculate the variance of the minimum variance portfolio. 154 | t(weight_s) %*% co_var %*% weight_s 155 | # or 156 | 1/(t(u_nit) %*% in_verse %*% u_nit) 157 | 158 | # You should get the following output: 159 | # [,1] 160 | # [1,] 1.84783e-05 161 | 162 | 163 | 164 | ############## Part II 165 | # Summary: Calculate the maximum Sharpe ratio portfolio 166 | # weights using matrix algebra and RcppArmadillo. 167 | # You can use the re_turns and in_verse matrices from 168 | # Part I above. 169 | 170 | # 1. (20pts) Calculate the xts series of re_turns and 171 | # the in_verse of the covariance matrix of re_turns, 172 | # if you haven't done it already. 173 | 174 | # Calculate the covariance matrix of re_turns and call 175 | # it co_var, and its inverse and call it in_verse. 176 | # You can use the functions cov() and solve(). 177 | 178 | co_var <- cov(re_turns) 179 | in_verse <- solve(a=co_var) 180 | 181 | 182 | # Calculate the vector of average daily excess returns 183 | # called ex_cess. 184 | # risk_free is the daily risk-free rate. 185 | 186 | risk_free <- 0.03/260 187 | ex_cess <- re_turns - risk_free 188 | ex_cess <- colMeans(ex_cess) 189 | 190 | # Calculate the maximum Sharpe ratio portfolio weights. 191 | 192 | weight_s <- in_verse %*% ex_cess 193 | weight_s <- drop(weight_s/sum(weight_s)) 194 | 195 | # You should get the following output: 196 | # > round(weight_s, 3) 197 | # VTI VEU IEF VNQ DBC XLY XLP XLE XLF XLV 198 | # -0.011 -0.340 0.596 -0.038 -0.116 0.137 0.268 0.196 0.069 0.197 199 | # XLI XLB XLK XLU VYM IVW IWB IWD IWF 200 | # 0.201 0.024 0.229 -0.065 0.367 0.099 -0.424 -0.814 0.426 201 | 202 | 203 | # Calculate the Sharpe ratio of the weighted portfolio returns, 204 | # assuming 260 business days in a year. 205 | 206 | sqrt(260)*sum(weight_s * ex_cess) / 207 | sqrt(drop(weight_s %*% co_var %*% weight_s)) 208 | 209 | # You should get the following output: 210 | # [1] 1.246343 211 | 212 | 213 | # 2. (20pts) Create an objective function equal to minus 214 | # the Sharpe ratio. 215 | # The objective function should accept the arguments: 216 | # weights: the portfolio weights, 217 | # ex_cess: a vector of average excess returns, 218 | # co_var: the covariance matrix, 219 | 220 | object_ive <- function(weight_s, ex_cess, co_var) { 221 | -sum(weight_s * ex_cess) / sqrt(drop(weight_s %*% co_var %*% weight_s)) 222 | } # end object_ive 223 | 224 | # Perform portfolio optimization using the function optim(), 225 | # and calculate the maximum Sharpe ratio portfolio weights 226 | # to demonstrate that they are close to the weights obtained 227 | # from matrix inversion. 228 | 229 | op_tim <- optim(par=rep(1.0, n_weights), 230 | fn=object_ive, 231 | method="L-BFGS-B", 232 | upper=rep(10, n_weights), 233 | lower=rep(-10, n_weights), 234 | ex_cess=ex_cess, 235 | co_var=co_var) 236 | 237 | weight_s <- op_tim$par/sum(op_tim$par) 238 | 239 | # You should get output similar to the following: 240 | # > round(weight_s, 3) 241 | # [1] -0.017 -0.339 0.596 -0.038 -0.116 0.136 0.267 0.196 0.068 0.197 242 | # [11] 0.201 0.024 0.228 -0.066 0.366 0.096 -0.416 -0.812 0.428 243 | 244 | 245 | # 3. (30pts) 246 | # Create an RcppArmadillo function called sharpe_weights(), 247 | # which calculates the maximum Sharpe ratio portfolio weights, 248 | # and produces the same result as p.1 above. 249 | # The function sharpe_weights() should accept a single argument, 250 | # an xts time series of returns called re_turns. 251 | # sharpe_weights() should calculate the covariance matrix of 252 | # re_turns and its inverse. 253 | # sharpe_weights() should calculate and return a vector of the 254 | # maximum Sharpe ratio portfolio weights, using matrix algebra 255 | # in RcppArmadillo. 256 | # Save the Rcpp code in a file called rcpp_test5.cpp, 257 | # and compile it as follows: 258 | 259 | Rcpp::sourceCpp(file="C:/Develop/R/lecture_slides/scripts/rcpp_test5.cpp") 260 | 261 | # Calculates the weights using sharpe_weights() and call them 262 | # weights_arma. 263 | 264 | weights_arma <- sharpe_weights(re_turns-risk_free) 265 | 266 | # You should get the following result: 267 | # > all.equal(as.vector(weights_arma), unname(weight_s)) 268 | # [1] TRUE 269 | 270 | 271 | 272 | ############## Part III 273 | # Summary: Perform a rolling portfolio optimization 274 | # over annual intervals, calculate optimized portfolio 275 | # weights in each year, and apply them to out-of-sample 276 | # returns in the following year. 277 | 278 | # 1. (20pts) Calculate the xts series of re_turns (if 279 | # you haven't done it already). 280 | 281 | # Calculate a vector of annual end points from 282 | # the index of re_turns, and call it end_points. 283 | # Use function rutils::calc_endpoints(). 284 | 285 | end_points <- rutils::calc_endpoints(re_turns, inter_val="years") 286 | 287 | # Define starting points as the one-year (single period) 288 | # lag of end_points. 289 | 290 | len_gth <- NROW(end_points) 291 | start_points <- c(1, end_points[1:(len_gth-1)]) 292 | 293 | # You should get the following output: 294 | # > end_points 295 | # [1] 206 459 711 963 1215 1465 1717 1969 2221 2473 2724 2741 296 | # 297 | # > start_points 298 | # [1] 1 206 459 711 963 1215 1465 1717 1969 2221 2473 2724 299 | 300 | 301 | # 2. (20pts) Define the daily risk-free rate as risk_free: 302 | 303 | risk_free <- 0.03/260 304 | 305 | # Calculate the xts series of excess daily returns called 306 | # ex_cess, by subtracting risk_free from the re_turns. 307 | 308 | ex_cess <- re_turns - risk_free 309 | 310 | 311 | # Perform an sapply() loop over the range 1:(NROW(end_points)-1), 312 | # and inside the loop, first subset the ex_cess returns 313 | # from start_points[i] to end_points[i], and then 314 | # calculate the maximum Sharpe ratio portfolio weights 315 | # using matrix algebra. 316 | # Call the matrix returned by sapply() weight_s. 317 | # You can use functions sapply(), solve(), cov(), 318 | # colMeans(), drop(), sum(), and an anonymous function, 319 | 320 | weight_s <- sapply(1:(NROW(end_points)-1), 321 | function(i) { 322 | # subset the ex_cess returns 323 | ex_cess <- ex_cess[start_points[i]:end_points[i], ] 324 | in_verse <- solve(cov(ex_cess)) 325 | # calculate the maximum Sharpe ratio portfolio weights. 326 | weight_s <- in_verse %*% colMeans(ex_cess) 327 | weight_s <- drop(weight_s/sum(weight_s)) 328 | } # end anonymous function 329 | ) # end sapply 330 | 331 | # You should get the following output: 332 | # > round(weight_s, 2) 333 | # [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] 334 | # VTI 0.05 -4.61 -1.51 0.72 -0.09 -1.72 2.34 -1.43 3.66 -1.11 -3.60 335 | # VEU 0.06 -5.85 -1.11 -0.33 -0.29 0.19 -1.16 -0.95 -0.05 -1.54 0.32 336 | # IEF 0.53 -21.09 2.84 0.67 0.55 0.73 0.21 1.59 0.37 0.10 0.08 337 | # VNQ -0.01 -8.44 -0.05 0.02 0.06 0.01 -0.76 0.53 -0.22 0.34 -0.01 338 | # DBC 0.01 10.18 -0.57 0.05 0.04 0.03 -0.62 -1.60 0.82 0.50 0.22 339 | # XLY -0.57 -8.88 -1.00 0.33 0.26 0.47 1.15 -0.49 -1.94 0.83 0.07 340 | # XLP 0.40 -4.82 -0.56 0.25 0.10 -0.01 0.06 -0.04 -0.70 0.17 0.01 341 | # XLE 0.18 -17.31 1.27 0.21 0.31 -0.25 -0.01 0.61 -0.70 0.42 -0.04 342 | # XLF -0.21 -2.04 -1.68 -0.14 -0.01 0.19 -1.07 0.30 -0.45 2.28 0.52 343 | # XLV 0.11 -2.67 -2.66 -0.51 0.24 0.35 0.63 0.20 -0.86 0.68 0.01 344 | # XLI 0.40 6.36 0.81 0.23 0.15 -0.08 0.60 -0.23 0.66 1.73 0.08 345 | # XLB -0.03 4.10 -1.81 -0.21 -0.05 -0.13 -0.14 -0.13 -0.34 -0.13 0.07 346 | # XLK 0.04 5.38 -3.47 -0.58 0.35 0.09 0.88 0.69 -1.52 5.97 -0.68 347 | # XLU -0.03 3.60 -0.76 -0.39 0.19 -0.32 -0.06 0.03 0.28 1.03 0.11 348 | # VYM 0.15 8.60 6.74 1.01 0.53 -0.35 0.97 -0.63 -2.58 1.40 1.10 349 | # IVW -0.21 6.35 2.78 0.25 0.85 0.61 -1.07 1.26 2.57 -8.06 -0.98 350 | # IWB 0.21 22.91 -0.77 -0.60 -0.56 1.27 -1.03 0.36 0.74 -1.24 2.79 351 | # IWD -0.37 -5.29 4.08 -0.44 -0.27 0.85 1.85 2.30 2.77 -2.29 -1.81 352 | # IWF 0.31 14.53 -1.58 0.45 -1.38 -0.94 -1.77 -1.38 -1.51 -0.08 2.76 353 | 354 | 355 | # 3. (20pts) Perform an lapply() loop over the range 356 | # 2:NROW(end_points), and inside the loop apply the 357 | # lagged weight_s to the columns of the subset re_turns, 358 | # to calculate the out-of-sample portfolio returns. 359 | # hint: subset the re_turns by the interval 360 | # (end_points[i-1]+1):end_points[i] 361 | # Inside the loop coerce the portfolio returns to an 362 | # xts series and return it, to produce a list of xts 363 | # called portf_rets. 364 | # You can use functions lapply(), xts(), index(), 365 | # and an anonymous function, 366 | 367 | portf_rets <- lapply(2:NROW(end_points), 368 | function(i) { 369 | # subset the ex_cess returns 370 | re_turns <- re_turns[(end_points[i-1]+1):end_points[i], ] 371 | # calculate the out-of-sample portfolio returns 372 | xts(re_turns %*% weight_s[, i-1], index(re_turns)) 373 | } # end anonymous function 374 | ) # end lapply 375 | 376 | # Flatten portf_rets into a single xts series. 377 | # You can use functions rutils::do_call() and rbind(), 378 | 379 | portf_rets <- rutils::do_call(rbind, portf_rets) 380 | colnames(portf_rets) <- "portf_rets" 381 | 382 | # You should get the following output: 383 | # dim(portf_rets) 384 | # [1] 2535 1 385 | # 386 | # > tail(portf_rets, 11) 387 | # portf_rets 388 | # 2018-01-10 0.0006433005 389 | # 2018-01-11 0.0006631701 390 | # 2018-01-12 0.0097569820 391 | # 2018-01-16 -0.0014937710 392 | # 2018-01-17 0.0064484704 393 | # 2018-01-18 -0.0001588550 394 | # 2018-01-19 0.0047600417 395 | # 2018-01-22 0.0011479045 396 | # 2018-01-23 0.0071458638 397 | # 2018-01-24 0.0064285156 398 | # 2018-01-26 0.0134055880 399 | 400 | # The portf_rets are percentage returns, because re_turns 401 | # are percentage returns. 402 | 403 | # Calculate the Sharpe ratio of the weighted portfolio returns, 404 | # assuming 260 business days in a year. 405 | 406 | sqrt(260)*(mean(portf_rets)-risk_free) / sd(portf_rets) 407 | 408 | # You should get the following output: 409 | # [1] 0.5204891 410 | 411 | # Compound portf_rets into a single xts series of compounded 412 | # cumulative returns. 413 | # Use functions cumsum() and exp(), 414 | 415 | portf_rets <- exp(cumsum(portf_rets)) 416 | 417 | # You should get the following output: 418 | # > tail(portf_rets, 11) 419 | # portf_rets 420 | # 2018-01-10 4359.759 421 | # 2018-01-11 4362.651 422 | # 2018-01-12 4405.425 423 | # 2018-01-16 4398.850 424 | # 2018-01-17 4427.307 425 | # 2018-01-18 4426.604 426 | # 2018-01-19 4447.725 427 | # 2018-01-22 4452.833 428 | # 2018-01-23 4484.767 429 | # 2018-01-24 4513.690 430 | # 2018-01-26 4574.606 431 | 432 | 433 | # Plot portf_rets using quantmod::chart_Series(). 434 | 435 | quantmod::chart_Series(portf_rets, 436 | name="Cumulative Returns of Max Sharpe Portfolio Strategy") 437 | 438 | # Your plot should be similar to backtest_sharpe.png 439 | 440 | 441 | 442 | -------------------------------------------------------------------------------- /tests/back_test.R: -------------------------------------------------------------------------------- 1 | # Functions for back-testing momentum strategies 2 | 3 | # Function back_test_ep() performs a back-test over end-points 4 | back_test_ep <- function(re_turns, price_s, agg_fun=sum, 5 | look_back=12, re_balance="months", bid_offer=0.001, 6 | end_points=rutils::calc_endpoints(re_turns, inter_val=re_balance), 7 | with_weights=FALSE, ...) { 8 | stopifnot("package:quantmod" %in% search() || require("quantmod", quietly=TRUE)) 9 | # Define look-back and look-forward intervals 10 | n_col <- NCOL(re_turns) 11 | len_gth <- NROW(end_points) 12 | start_points <- c(rep_len(1, look_back-1), end_points[1:(len_gth-look_back+1)]) 13 | fwd_points <- end_points[c(2:len_gth, len_gth)] 14 | # Perform loop over end-points and calculate aggregations 15 | agg_s <- sapply(1:(len_gth-1), function(it_er) { 16 | c(back_aggs=sapply(re_turns[start_points[it_er]:end_points[it_er]], agg_fun, ...), # end sapply 17 | fwd_rets=sapply(re_turns[(end_points[it_er]+1):fwd_points[it_er]], sum)) # end sapply 18 | }) # end sapply 19 | agg_s <- t(agg_s) 20 | # Select look-back and look-forward aggregations 21 | back_aggs <- agg_s[, 1:n_col] 22 | fwd_rets <- agg_s[, n_col+1:n_col] 23 | # Calculate portfolio weights equal to number of shares 24 | end_prices <- price_s[end_points[-len_gth]] 25 | weight_s <- back_aggs/rowSums(abs(back_aggs))/end_prices 26 | weight_s[is.na(weight_s)] <- 0 27 | colnames(weight_s) <- colnames(re_turns) 28 | # Calculate profits and losses 29 | pnl_s <- rowSums(weight_s*fwd_rets) 30 | pnl_s <- xts(pnl_s, index(end_prices)) 31 | colnames(pnl_s) <- "pnls" 32 | # Calculate transaction costs 33 | cost_s <- 0.5*bid_offer*end_prices*abs(rutils::diff_it(weight_s)) 34 | cost_s <- rowSums(cost_s) 35 | pnl_s <- (pnl_s - cost_s) 36 | pnl_s <- cumsum(pnl_s) 37 | if (with_weights) 38 | cbind(pnl_s, weight_s) 39 | else 40 | pnl_s 41 | } # end back_test_ep 42 | 43 | 44 | # Function back_test_rolling() performs a back-test over rolling points 45 | back_test_rolling <- function(re_turns, price_s, 46 | wid_th=252, bid_offer=0.001, tre_nd=1, ...) { 47 | stopifnot("package:quantmod" %in% search() || require("quantmod", quietly=TRUE)) 48 | # Define look-back and look-forward intervals 49 | n_col <- NCOL(re_turns) 50 | vari_ance <- roll::roll_var(re_turns, width=wid_th) 51 | vari_ance <- zoo::na.locf(vari_ance) 52 | vari_ance[is.na(vari_ance)] <- 0 53 | # calculate rolling Sharpe of S&P500 portfolio 54 | returns_width <- rutils::diff_it(price_s, lagg=wid_th) 55 | weight_s <- tre_nd*returns_width/sqrt(wid_th*vari_ance) 56 | weight_s[vari_ance==0] <- 0 57 | weight_s[1:wid_th, ] <- 1 58 | weight_s[is.na(weight_s)] <- 0 59 | weight_s <- weight_s/rowSums(abs(weight_s))/price_s 60 | weight_s[is.na(weight_s)] <- 0 61 | weight_s <- rutils::lag_it(weight_s) 62 | # calculate portfolio profits and losses 63 | pnl_s <- rowSums(weight_s*re_turns) 64 | # Calculate transaction costs 65 | bid_offer <- 0.001 66 | cost_s <- 0.5*bid_offer*price_s*abs(rutils::diff_it(weight_s)) 67 | cost_s <- rowSums(cost_s) 68 | pnl_s <- (pnl_s - cost_s) 69 | pnl_s <- cumsum(pnl_s) 70 | pnl_s 71 | } # end back_test_rolling 72 | 73 | -------------------------------------------------------------------------------- /tests/ewma_model.R: -------------------------------------------------------------------------------- 1 | # Functions for simulating EWMA strategies 2 | 3 | # library(HighFreq) # load package HighFreq 4 | 5 | # simulate single EWMA model using historical oh_lc data 6 | simu_ewma <- function(oh_lc, lamb_da=0.01, wid_th=251, bid_offer=0.001, tre_nd=1) { 7 | # calculate EWMA prices 8 | weight_s <- exp(-lamb_da*1:wid_th) 9 | weight_s <- weight_s/sum(weight_s) 10 | cl_ose <- quantmod::Cl(oh_lc) 11 | ew_ma <- stats::filter(as.numeric(cl_ose), filter=weight_s, sides=1) 12 | ew_ma[1:(wid_th-1)] <- ew_ma[wid_th] 13 | # determine dates right after EWMA has crossed prices 14 | in_dic <- tre_nd*xts::xts(sign(as.numeric(cl_ose) - ew_ma), order.by=index(oh_lc)) 15 | trade_dates <- (rutils::diff_it(in_dic) != 0) 16 | trade_dates <- which(trade_dates) + 1 17 | trade_dates <- trade_dates[trade_dates