From noreply at r-forge.r-project.org Tue Jul 1 19:27:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Jul 2014 19:27:29 +0200 (CEST) Subject: [Returnanalytics-commits] r3454 - pkg/FactorAnalytics/R Message-ID: <20140701172729.D3D50186148@r-forge.r-project.org> Author: gyollin Date: 2014-07-01 19:27:29 +0200 (Tue, 01 Jul 2014) New Revision: 3454 Modified: pkg/FactorAnalytics/R/summary.tsfm.r Log: removed non-ascii character from comment Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-06-30 21:40:38 UTC (rev 3453) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-01 17:27:29 UTC (rev 3454) @@ -15,8 +15,8 @@ #' #' @note For a more detailed printed summary for each asset, refer to #' \code{print.summary.lm}, which tries to be smart about formatting the -#' coefficients, standard errors, etc. and additionally gives ?significance -#' stars? if \code{signif.stars} is TRUE. +#' coefficients, standard errors, etc. and additionally gives significance +#' stars if \code{signif.stars} is TRUE. #' #' @author Yi-An Chen & Sangeetha Srinivasan. #' From noreply at r-forge.r-project.org Tue Jul 1 21:45:57 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Jul 2014 21:45:57 +0200 (CEST) Subject: [Returnanalytics-commits] r3455 - in pkg/PortfolioAnalytics: . R man Message-ID: <20140701194557.ED13D185763@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-01 21:45:57 +0200 (Tue, 01 Jul 2014) New Revision: 3455 Added: pkg/PortfolioAnalytics/R/ac_ranking.R pkg/PortfolioAnalytics/man/ac.ranking.Rd Modified: pkg/PortfolioAnalytics/NAMESPACE pkg/PortfolioAnalytics/R/meucci_ranking.R pkg/PortfolioAnalytics/man/meucci.ranking.Rd Log: Add functions for ranking views based on Almgren and Chriss paper. Fixed a typo in meucci.ranking function. Modified: pkg/PortfolioAnalytics/NAMESPACE =================================================================== --- pkg/PortfolioAnalytics/NAMESPACE 2014-07-01 17:27:29 UTC (rev 3454) +++ pkg/PortfolioAnalytics/NAMESPACE 2014-07-01 19:45:57 UTC (rev 3455) @@ -71,6 +71,7 @@ export(CCCgarch.MM) export(EntropyProg) export(HHI) +export(ac.ranking) export(add.constraint) export(add.objective) export(add.objective_v1) Added: pkg/PortfolioAnalytics/R/ac_ranking.R =================================================================== --- pkg/PortfolioAnalytics/R/ac_ranking.R (rev 0) +++ pkg/PortfolioAnalytics/R/ac_ranking.R 2014-07-01 19:45:57 UTC (rev 3455) @@ -0,0 +1,76 @@ + +#' Asset Ranking +#' +#' Compute the first moment from a single complete sort +#' +#' This function computes the estimated centroid vector from a single complete +#' sort using the analytical approximation as described in R. Almgren and +#' N. Chriss, "Portfolios from Sorts". The centroid is estimated and then +#' scaled such that it is on a scale similar to the asset returns. By default, +#' the centroid vector is scaled according to the median of the asset mean +#' returns. +#' +#' @param R xts object of asset returns +#' @param order a vector of indexes of the relative ranking of expected asset +#' returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} means +#' that the expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}. +#' @param \dots any other passthrough parameters +#' +#' @return The estimated first moments based on ranking views +#' +#' @references +#' R. Almgren and N. Chriss, "Portfolios from Sorts" +#' \url{http://papers.ssrn.com/sol3/papers.cfm?abstract_id=720041} +#' +#' @examples +#' data(edhec) +#' R <- edhec[,1:4] +#' ac.ranking(R, c(2, 3, 1, 4)) +#' @export +ac.ranking <- function(R, order, ...){ + if(length(order) != ncol(R)) stop("The length of the order vector must equal the number of assets") + nassets <- ncol(R) + if(hasArg(max.value)) { + max.value <- match.call(expand.dots=TRUE)$max.value + } else { + max.value <- median(colMeans(R)) + } + # Compute the scaled centroid + c_hat <- scale.range(centroid(nassets), max.value) + + # Here we reorder the vector such that the highest centroid value is assigned + # to the asset index with the highest expected return and so on and so forth + # until the smallest centroid value is assigned to the asset index with the + # lowest expected return. The asset index with the lowest expected return + # is order[1] + out <- vector("numeric", nassets) + out[rev(order)] <- c_hat + return(out) +} + +# compute the centroid for a single complete sort +centroid <- function(n){ + # Analytical solution to the centroid for single complete sort + # http://papers.ssrn.com/sol3/papers.cfm?abstract_id=720041 + A <- 0.4424 + B <- 0.1185 + beta <- 0.21 + alpha <- A - B * n^(-beta) + j <- seq(from=1, to=n, by=1) + c_hat <- qnorm((n + 1 - j - alpha) / (n - 2 * alpha + 1)) + c_hat +} + +# If we used the unscaled centroid vector in the optimization, the optimal +# portfolio would be correct but anything that uses moments$mu will not make +# sense + +# What is a valid value for max.value? +# - by default we use the median of the asset mean returns +scale.range <- function(x, max.value){ + new.max <- 0.05 + new.min <- -new.max + old.range <- max(x) - min(x) + new.range <- new.max - new.min + ((x - min(x)) * new.range) / old.range + new.min +} Modified: pkg/PortfolioAnalytics/R/meucci_ranking.R =================================================================== --- pkg/PortfolioAnalytics/R/meucci_ranking.R 2014-07-01 17:27:29 UTC (rev 3454) +++ pkg/PortfolioAnalytics/R/meucci_ranking.R 2014-07-01 19:45:57 UTC (rev 3455) @@ -10,9 +10,9 @@ #' #' @param R xts object of asset returns #' @param p a vector of the prior probability values -#' @param order a vector of indexes of the relative of expected asset returns in -#' ascending order. For example, \code{order = c(2, 3, 1, 4)} means that the -#' expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}. +#' @param order a vector of indexes of the relative ranking of expected asset +#' returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} means +#' that the expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}. #' #' @return The estimated moments based on ranking views #' Added: pkg/PortfolioAnalytics/man/ac.ranking.Rd =================================================================== --- pkg/PortfolioAnalytics/man/ac.ranking.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/ac.ranking.Rd 2014-07-01 19:45:57 UTC (rev 3455) @@ -0,0 +1,40 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{ac.ranking} +\alias{ac.ranking} +\title{Asset Ranking} +\usage{ +ac.ranking(R, order, ...) +} +\arguments{ +\item{R}{xts object of asset returns} + +\item{order}{a vector of indexes of the relative ranking of expected asset +returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} means +that the expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}.} + +\item{\dots}{any other passthrough parameters} +} +\value{ +The estimated first moments based on ranking views +} +\description{ +Compute the first moment from a single complete sort +} +\details{ +This function computes the estimated centroid vector from a single complete +sort using the analytical approximation as described in R. Almgren and +N. Chriss, "Portfolios from Sorts". The centroid is estimated and then +scaled such that it is on a scale similar to the asset returns. By default, +the centroid vector is scaled according to the median of the asset mean +returns. +} +\examples{ +data(edhec) +R <- edhec[,1:4] +ac.ranking(R, c(2, 3, 1, 4)) +} +\references{ +R. Almgren and N. Chriss, "Portfolios from Sorts" +\url{http://papers.ssrn.com/sol3/papers.cfm?abstract_id=720041} +} + Modified: pkg/PortfolioAnalytics/man/meucci.ranking.Rd =================================================================== --- pkg/PortfolioAnalytics/man/meucci.ranking.Rd 2014-07-01 17:27:29 UTC (rev 3454) +++ pkg/PortfolioAnalytics/man/meucci.ranking.Rd 2014-07-01 19:45:57 UTC (rev 3455) @@ -10,9 +10,9 @@ \item{p}{a vector of the prior probability values} -\item{order}{a vector of indexes of the relative of expected asset returns in -ascending order. For example, \code{order = c(2, 3, 1, 4)} means that the -expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}.} +\item{order}{a vector of indexes of the relative ranking of expected asset +returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} means +that the expected returns of \code{R[,2] < R[,3], < R[,1] < R[,4]}.} } \value{ The estimated moments based on ranking views From noreply at r-forge.r-project.org Tue Jul 1 22:56:32 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Jul 2014 22:56:32 +0200 (CEST) Subject: [Returnanalytics-commits] r3456 - pkg/PortfolioAnalytics/demo Message-ID: <20140701205632.AB1B11874CE@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-01 22:56:32 +0200 (Tue, 01 Jul 2014) New Revision: 3456 Added: pkg/PortfolioAnalytics/demo/relative_ranking.R Removed: pkg/PortfolioAnalytics/demo/meucci_relative_ranking.R Modified: pkg/PortfolioAnalytics/demo/00Index Log: Adding demo for relative ranking that includes both Meucci Fully Flexible Views and Almgren and Chriss Portfolios from Sorts. Deleting meucci_relative_ranking demo since that is redundant. Modified: pkg/PortfolioAnalytics/demo/00Index =================================================================== --- pkg/PortfolioAnalytics/demo/00Index 2014-07-01 19:45:57 UTC (rev 3455) +++ pkg/PortfolioAnalytics/demo/00Index 2014-07-01 20:56:32 UTC (rev 3456) @@ -32,4 +32,4 @@ higher_moments_boudt Demonstrate using a statistical factor model to estimate moments based on work by Kris Boudt. multi_layer_optimization Demonstrate multi layer optimization of optimization problem with two layers and two sub portfolios in the lower layer. meucci_ffv Demonstrate Meucci's Fully Flexible Views framework to estimate moments and use as inputs for minimum variance optimization. -meucci_relative_ranking Demonstrate Meucci's Fully Flexible Views framework to express views on relative ranking and estimate moments used as inputs for mean-variance optimization. +relative_ranking Demonstrate expressing views on the relative ranking of expected returns based on two methods; 1) R. Almgren and N. Chriss, "Portfolios from Sorts" and 2) A. Meucci, "Fully Flexible Views: Theory and Practice". Deleted: pkg/PortfolioAnalytics/demo/meucci_relative_ranking.R =================================================================== --- pkg/PortfolioAnalytics/demo/meucci_relative_ranking.R 2014-07-01 19:45:57 UTC (rev 3455) +++ pkg/PortfolioAnalytics/demo/meucci_relative_ranking.R 2014-07-01 20:56:32 UTC (rev 3456) @@ -1,72 +0,0 @@ -# Demonstrate Meucci's Fully Flexible Views framework to express views on -# relative ranking and estimate moments used as inputs for mean-variance -# optimization - -library(PortfolioAnalytics) -data(edhec) -R <- edhec[,1:4] -funds <- colnames(R) - -# Construct initial portfolio -init.portf <- portfolio.spec(assets=funds) -init.portf <- add.constraint(portfolio=init.portf, type="weight_sum", - min_sum=0.99, max_sum=1.01) -init.portf <- add.constraint(portfolio=init.portf, type="box", - min=0.05, max=0.5) -init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") -init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") - -# Prior probabilities -p <- rep(1 / nrow(R), nrow(R)) - -# Relative ordering view -# E{ R[,2] < R[,3], < R[,1] < R[,4] } -moments <- meucci.ranking(R, p, c(2, 3, 1, 4)) - -# Generate random portfolios -rp <- random_portfolios(init.portf, 5000) - -# Optimization using first and second moments estimated from Meucci's Fully -# Flexible Views framework. -opt.meucci <- optimize.portfolio(R, - init.portf, - optimize_method="random", - rp=rp, - trace=TRUE, - method="meucci", - momentargs=moments) - - -# Optimization using sample estimates for first and second moments -opt.sample <- optimize.portfolio(R, - init.portf, - optimize_method="random", - rp=rp, - trace=TRUE) - -#Extract the stats for plotting -stats.meucci <- extractStats(opt.meucci) -stats.sample <- extractStats(opt.sample) - - -# Plots -# Plot the optimal weights -chart.Weights(combine.optimizations(list(meucci=opt.meucci, sample=opt.sample)), ylim=c(0,1)) - -# Plot the risk-reward of each chart on the same scale -xrange <- range(c(stats.meucci[,"StdDev"], stats.sample[,"StdDev"])) -yrange <- range(c(stats.meucci[,"mean"], stats.sample[,"mean"])) -layout(matrix(c(1,2)), widths=1, heights=1) -# c(bottom, left, top, right) -par(mar=c(0, 4, 4, 4) + 0.1) -plot(x=stats.meucci[,"StdDev"], stats.meucci[,"mean"], xlab="", ylab="mean", - xlim=xrange, ylim=yrange, xaxt="n", yaxt="n") -axis(2, pretty(yrange), cex.axis=0.8) -legend("topleft", legend="Meucci", bty="n") -par(mar=c(5, 4, 0, 4) + 0.1) -plot(x=stats.sample[,"StdDev"], stats.sample[,"mean"], xlab="StdDev", ylab="", - xlim=xrange, ylim=yrange, yaxt="n", cex.axis=0.8) -axis(4, pretty(yrange), cex.axis=0.8) -legend("topleft", legend="Sample", bty="n") -par(mar=c(5, 4, 4, 2) + 0.1) -layout(matrix(1), widths=1, heights=1) Added: pkg/PortfolioAnalytics/demo/relative_ranking.R =================================================================== --- pkg/PortfolioAnalytics/demo/relative_ranking.R (rev 0) +++ pkg/PortfolioAnalytics/demo/relative_ranking.R 2014-07-01 20:56:32 UTC (rev 3456) @@ -0,0 +1,146 @@ +# Demonstrate expressing views on the relative ranking of expected +# returns based on two methods +# 1) R. Almgren and N. Chriss, "Portfolios from Sorts" +# 2) A. Meucci, "Fully Flexible Views: Theory and Practice" + +library(PortfolioAnalytics) +data(edhec) +R <- edhec[,1:4] +funds <- colnames(R) + +# Construct initial portfolio +init.portf <- portfolio.spec(assets=funds) +init.portf <- add.constraint(portfolio=init.portf, type="weight_sum", + min_sum=0.99, max_sum=1.01) +init.portf <- add.constraint(portfolio=init.portf, type="box", + min=0.05, max=0.5) +init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") +init.portf <- add.objective(portfolio=init.portf, type="return", name="mean") + +# Views on the relative rank of the assets +# E{ R[,2] < R[,3] < R[,1] < R[,4] } +asset.rank <- c(2, 3, 1, 4) + +# Meucci Fully Flexible Views framework +# Prior probabilities +p <- rep(1 / nrow(R), nrow(R)) + +# Relative ordering view +m.moments <- meucci.ranking(R, p, asset.rank) + +# Almgren and Chriss Portfolios from Sorts +ac.moments <- list() +ac.moments$mu <- ac.ranking(R, asset.rank) +# Sample estimate for second moment +ac.moments$sigma <- cov(R) + +# Generate random portfolios +rp <- random_portfolios(init.portf, 5000) + +# Optimization using first and second moments estimated from Meucci's Fully +# Flexible Views framework +opt.meucci <- optimize.portfolio(R, + init.portf, + optimize_method="random", + rp=rp, + trace=TRUE, + momentargs=m.moments) + +# Optimization using first moment estimated based on Almgren and Chriss, +# "Portfolios from Sorts" +opt.ac <- optimize.portfolio(R, + init.portf, + optimize_method="random", + rp=rp, + trace=TRUE, + momentargs=ac.moments) + +# Optimization using sample estimates for first and second moments +opt.sample <- optimize.portfolio(R, + init.portf, + optimize_method="random", + rp=rp, + trace=TRUE) + + +# Plots +# Plot the optimal weights +chart.Weights(combine.optimizations(list(meucci=opt.meucci, + ac=opt.ac, + sample=opt.sample)), + ylim=c(0,1), plot.type="barplot") + +# Custom moment function to estimate moments based on relative ranking views +# Asset are ranked according to a momentum or reversal view based on the +# previous n periods. +moment.ranking <- function(R, n=1, momentum=TRUE, method=c("meucci", "ac")){ + # Moment function to estimate moments based on relative ranking of + # expected returns. + + method <- match.arg(method) + + # Use the most recent n periods of returns + tmpR <- apply(tail(R, n), 2, function(x) prod(1 + x) - 1) + + if(momentum){ + # Assume that the assets with the highest return will continue to outperform + asset.rank <- order(tmpR) + } else { + # Assume that the assets with the highest return will reverse + asset.rank <- rev(order(tmpR)) + } + switch(method, + meucci = { + # Meucci Fully Flexible Views framework + # Prior probabilities + p <- rep(1 / nrow(R), nrow(R)) + + # Relative ordering view + moments <- meucci.ranking(R, p, asset.rank) + }, + ac = { + # Almgren and Chriss Portfolios from Sorts + moments <- list() + moments$mu <- ac.ranking(R, asset.rank) + # Sample estimate for second moment + moments$sigma <- cov(R) + } + ) + return(moments) +} + +# Test out of sample performance +opt.bt.meucci <- optimize.portfolio.rebalancing(R, init.portf, + optimize_method="random", + rebalance_on="quarters", + training_period=100, + rp=rp, + momentFUN="moment.ranking", + n=2, + momentum=TRUE, + method="meucci") + +opt.bt.ac <- optimize.portfolio.rebalancing(R, init.portf, + optimize_method="random", + rebalance_on="quarters", + training_period=100, + rp=rp, + momentFUN="moment.ranking", + n=2, + momentum=TRUE, + method="ac") + +opt.bt.sample <- optimize.portfolio.rebalancing(R, init.portf, + optimize_method="random", + rebalance_on="quarters", + training_period=100, + rp=rp) + +# Compute returns and chart performance summary +ret.meucci <- Return.portfolio(R, extractWeights(opt.bt.meucci)) +ret.ac <- Return.portfolio(R, extractWeights(opt.bt.ac)) +ret.sample <- Return.portfolio(R, extractWeights(opt.bt.sample)) +ret <- cbind(ret.meucci, ret.ac, ret.sample) +colnames(ret) <- c("meucci.rank", "ac.rank", "sample") +charts.PerformanceSummary(ret, main="Ranking Views Performance") + From noreply at r-forge.r-project.org Wed Jul 2 00:11:50 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 2 Jul 2014 00:11:50 +0200 (CEST) Subject: [Returnanalytics-commits] r3457 - pkg/PortfolioAnalytics/sandbox Message-ID: <20140701221150.8DDC8184503@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-02 00:11:50 +0200 (Wed, 02 Jul 2014) New Revision: 3457 Added: pkg/PortfolioAnalytics/sandbox/centroids.R Log: Adding script to numerically compute the centroids Added: pkg/PortfolioAnalytics/sandbox/centroids.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/centroids.R (rev 0) +++ pkg/PortfolioAnalytics/sandbox/centroids.R 2014-07-01 22:11:50 UTC (rev 3457) @@ -0,0 +1,89 @@ + +# Numerically compute the centroid for different cases as described in +# the Almgren and Chriss paper. + +# These replicate the paper, now I just need to functionalize them + + +# Complete sort +nsim <- 1000 +nassets <- 50 +out <- matrix(0, nsim, nassets) +for(i in 1:nsim){ + out[i,] <- sort(rnorm(nassets), decreasing=TRUE) +} + +barplot(colMeans(out)) + +# Complete sort with multiple sectors +sectors <- list() +sectors[[1]] <- 1:10 +sectors[[2]] <- 11:40 +nassets <- length(unlist(sectors)) +nsectors <- length(sectors) + +sim.list <- vector("list", nsectors) +for(j in 1:nsectors){ + nassets <- length(sectors[[j]]) + out <- matrix(0, nsim, nassets) + for(i in 1:nsim){ + out[i,] <- sort(rnorm(nassets), decreasing=TRUE) + } + sim.list[[j]] <- out +} +barplot(unlist(lapply(sim.list, colMeans))) + +# Complete sort with comparison to 0 +my.list <- list() +my.list$pos <- c(1, 2, 3, 4) +my.list$neg <- c(5, 6, 7, 8 , 9, 10) +pos <- length(my.list$pos) +neg <- length(my.list$neg) + +nsim <- 1000 +nassets <- pos + neg + +out <- matrix(0, nsim, nassets) +for(i in 1:nsim){ + tmp <- rnorm(nassets) + tmp.pos <- tmp[1:pos] + tmp.neg <- tmp[(pos+1):(pos+neg)] + + # Sign correct the pos assets + idx <- which(tmp.pos < 0) + if(length(idx) != 0){ + tmp.pos[idx] <- -1 * tmp.pos[idx] + } + + # Sign correct the neg assets + idx <- which(tmp.neg > 0) + if(length(idx) != 0){ + tmp.neg[idx] <- -1 * tmp.neg[idx] + } + out[i,] <- sort(c(tmp.pos, tmp.neg), decreasing=TRUE) +} + +barplot(colMeans(out)) + + +# Complete sort with "buckets" +qlist <- list() +qlist[[1]] <- c(1, 2, 3, 4) +qlist[[2]] <- c(5, 6, 7, 8) +qlist[[3]] <- c(9, 10, 11, 12) +qlist[[4]] <- c(13, 14, 15, 16) + +nsim <- 1000 +nassets <- length(unlist(qlist)) +nbuckets <- length(qlist) +out <- matrix(0, nsim, nassets) +for(i in 1:nsim){ + tmp <- sort(rnorm(nbuckets), decreasing=TRUE) + vec <- c() + for(j in 1:nbuckets){ + vec <- c(vec, rep(tmp[j], length(qlist[[j]]))) + } + out[i,] <- vec +} + +barplot(colMeans(out)) From noreply at r-forge.r-project.org Wed Jul 2 04:03:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 2 Jul 2014 04:03:41 +0200 (CEST) Subject: [Returnanalytics-commits] r3458 - in pkg/PortfolioAnalytics: . R man sandbox Message-ID: <20140702020341.B7CCF1876EE@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-02 04:03:40 +0200 (Wed, 02 Jul 2014) New Revision: 3458 Added: pkg/PortfolioAnalytics/man/centroid.buckets.Rd pkg/PortfolioAnalytics/man/centroid.complete.mc.Rd pkg/PortfolioAnalytics/man/centroid.sectors.Rd pkg/PortfolioAnalytics/man/centroid.sign.Rd Modified: pkg/PortfolioAnalytics/NAMESPACE pkg/PortfolioAnalytics/R/ac_ranking.R pkg/PortfolioAnalytics/man/ac.ranking.Rd pkg/PortfolioAnalytics/sandbox/centroids.R Log: Adding centroid functions to replicate the examples from the Almgren and Chriss paper Modified: pkg/PortfolioAnalytics/NAMESPACE =================================================================== --- pkg/PortfolioAnalytics/NAMESPACE 2014-07-01 22:11:50 UTC (rev 3457) +++ pkg/PortfolioAnalytics/NAMESPACE 2014-07-02 02:03:40 UTC (rev 3458) @@ -81,6 +81,10 @@ export(black.litterman) export(box_constraint) export(center) +export(centroid.buckets) +export(centroid.complete.mc) +export(centroid.sectors) +export(centroid.sign) export(chart.Concentration) export(chart.EfficientFrontier) export(chart.EfficientFrontierOverlay) Modified: pkg/PortfolioAnalytics/R/ac_ranking.R =================================================================== --- pkg/PortfolioAnalytics/R/ac_ranking.R 2014-07-01 22:11:50 UTC (rev 3457) +++ pkg/PortfolioAnalytics/R/ac_ranking.R 2014-07-02 02:03:40 UTC (rev 3458) @@ -26,6 +26,8 @@ #' data(edhec) #' R <- edhec[,1:4] #' ac.ranking(R, c(2, 3, 1, 4)) +#' @seealso \code{\link{centroid.complete.mc}} \code{\link{centroid.sectors}} +#' \code{\link{centroid.sign}} \code{\link{centroid.buckets}} #' @export ac.ranking <- function(R, order, ...){ if(length(order) != ncol(R)) stop("The length of the order vector must equal the number of assets") @@ -74,3 +76,165 @@ new.range <- new.max - new.min ((x - min(x)) * new.range) / old.range + new.min } + +# Numerically compute the centroid for different cases as described in +# the Almgren and Chriss paper. + +#' Complete Cases Centroid +#' +#' Numerical method to estimate complete cases centroid +#' @param order a vector of indexes of the relative ranking of expected asset +#' returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} +#' expresses a view on the expected returns such that +#' R_2 < R_3 < R_1 < R_4 +#' @param simulations number of simulations +#' @return the centroid vector +#' @examples +#' # Express a view on the assets such that +#' # R_2 < R_1 < R_3 < R_4 +#' centroid.complete.mc(c(2, 1, 3, 4)) +#' @author Ross Bennett +#' @export +centroid.complete.mc <- function(order, simulations=1000){ + n <- length(order) + c_hat <- matrix(0, simulations, n) + for(i in 1:simulations){ + c_hat[i,] <- sort(rnorm(n), decreasing=TRUE) + } + out <- vector("numeric", n) + out[rev(order)] <- colMeans(c_hat) + return(out) +} + +#' Multiple Sectors Centroid +#' +#' Compute the centroid for expressing views on the relative ranking of assets +#' within sectors. +#' +#' @param sectors a list where each list element contains the order of each +#' asset in the given sector +#' @param simulations number of simulations +#' @return the centroid vector +#' @examples +#' # Express a view on the assets in two sectors +#' # Sector 1 View: R_2 < R_1 < R_3 +#' # Sector 2 View: R_5 < R_4 +#' x <- list() +#' x[[1]] <- c(2, 1, 3) +#' x[[2]] <- c(5, 4) +#' centroid.sectors(x) +#' @author Ross Bennett +#' @export +centroid.sectors <- function(sectors, simulations=1000){ + if(!is.list(sectors)) stop("sectors must be a list") + + # Get the number of assets and number of sectors + nassets <- length(unlist(sectors)) + nsectors <- length(sectors) + + # Compute the centroid for each sector and combine at the end + sim.list <- vector("list", nsectors) + for(j in 1:nsectors){ + # number of assets in sector j + n <- length(sectors[[j]]) + out <- matrix(0, simulations, n) + for(i in 1:simulations){ + out[i,] <- sort(rnorm(n), decreasing=TRUE) + } + sim.list[[j]] <- out + } + c_hat <- lapply(sim.list, colMeans) + out <- vector("numeric", nassets) + for(i in 1:length(c_hat)){ + out[rev(sectors[[i]])] <- c_hat[[i]] + } + return(out) +} + +#' Positive and Negative View Centroid +#' +#' Compute the centroid for expressing a view on assets with positive or +#' negative expected returns +#' +#' @param positive a vector of the index of assets with positive expected +#' return in ascending order +#' @param negative a vector of the index of assets with negative expected +#' return in ascending order. +#' @param simulations number of simulations +#' @return the centroid vector +#' @examples +#' # Express a view that +#' # R_1 < R_2 < 0 < R_3 < R_4 +#' centroid.sign(c(1, 2), c(4, 3)) +#' @author Ross Bennett +#' @export +centroid.sign <- function(positive, negative, simulations=1000){ + + # Number of positive and negative assets + pos <- length(positive) + neg <- length(negative) + nassets <- pos + neg + + c_hat <- matrix(0, simulations, nassets) + for(i in 1:simulations){ + tmp <- rnorm(nassets) + # subset the positive and negative assets + tmp.pos <- tmp[1:pos] + tmp.neg <- tmp[(pos+1):(pos+neg)] + + # Sign correct the positive assets + idx <- which(tmp.pos < 0) + if(length(idx) != 0){ + tmp.pos[idx] <- -1 * tmp.pos[idx] + } + + # Sign correct the negative assets + idx <- which(tmp.neg > 0) + if(length(idx) != 0){ + tmp.neg[idx] <- -1 * tmp.neg[idx] + } + c_hat[i,] <- sort(c(tmp.pos, tmp.neg), decreasing=TRUE) + } + xx <- colMeans(c_hat) + out <- vector("numeric", nassets) + out[rev(positive)] <- xx[1:pos] + out[rev(negative)] <- xx[(1+pos):(pos+neg)] + return(out) +} + +#' Buckets Centroid +#' +#' Compute the centroid for buckets of assets +#' +#' A common use of buckets is to divide the assets into quartiles or deciles, +#' but is generalized here for an arbitrary number of buckets and arbitrary +#' number of assets in each bucket. +#' +#' @param buckets a list where each element contains the index of the assets in +#' the respective bucket. The assets within each bucket have no order. +#' The bucket elements are in ascending order such that +#' R_bucket_1 < ... < R_bucket_n +#' @param simulations number of simulations +#' @return the centroid vector +#' @author Ross Bennett +#' @export +centroid.buckets <- function(buckets, simulations=1000){ + if(!is.list(buckets)) stop("buckets must be a list") + + # number of assets and buckets + nassets <- length(unlist(buckets)) + nbuckets <- length(buckets) + + # Run simulations so we simulate n values for n buckets and then replicate + # that value for the number of assets in the given bucket + c_hat <- matrix(0, simulations, nbuckets) + for(i in 1:simulations){ + c_hat[i,] <- sort(rnorm(nbuckets), decreasing=TRUE) + } + xx <- colMeans(c_hat) + out <- vector("numeric", nassets) + for(j in 1:nbuckets){ + out[buckets[[j]]] <- xx[j] + } + return(out) +} Modified: pkg/PortfolioAnalytics/man/ac.ranking.Rd =================================================================== --- pkg/PortfolioAnalytics/man/ac.ranking.Rd 2014-07-01 22:11:50 UTC (rev 3457) +++ pkg/PortfolioAnalytics/man/ac.ranking.Rd 2014-07-02 02:03:40 UTC (rev 3458) @@ -37,4 +37,8 @@ R. Almgren and N. Chriss, "Portfolios from Sorts" \url{http://papers.ssrn.com/sol3/papers.cfm?abstract_id=720041} } +\seealso{ +\code{\link{centroid.complete.mc}} \code{\link{centroid.sectors}} +\code{\link{centroid.sign}} \code{\link{centroid.buckets}} +} Added: pkg/PortfolioAnalytics/man/centroid.buckets.Rd =================================================================== --- pkg/PortfolioAnalytics/man/centroid.buckets.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/centroid.buckets.Rd 2014-07-02 02:03:40 UTC (rev 3458) @@ -0,0 +1,30 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{centroid.buckets} +\alias{centroid.buckets} +\title{Buckets Centroid} +\usage{ +centroid.buckets(buckets, simulations = 1000) +} +\arguments{ +\item{buckets}{a list where each element contains the index of the assets in +the respective bucket. The assets within each bucket have no order. +The bucket elements are in ascending order such that +R_bucket_1 < ... < R_bucket_n} + +\item{simulations}{number of simulations} +} +\value{ +the centroid vector +} +\description{ +Compute the centroid for buckets of assets +} +\details{ +A common use of buckets is to divide the assets into quartiles or deciles, +but is generalized here for an arbitrary number of buckets and arbitrary +number of assets in each bucket. +} +\author{ +Ross Bennett +} + Added: pkg/PortfolioAnalytics/man/centroid.complete.mc.Rd =================================================================== --- pkg/PortfolioAnalytics/man/centroid.complete.mc.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/centroid.complete.mc.Rd 2014-07-02 02:03:40 UTC (rev 3458) @@ -0,0 +1,30 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{centroid.complete.mc} +\alias{centroid.complete.mc} +\title{Complete Cases Centroid} +\usage{ +centroid.complete.mc(order, simulations = 1000) +} +\arguments{ +\item{order}{a vector of indexes of the relative ranking of expected asset +returns in ascending order. For example, \code{order = c(2, 3, 1, 4)} +expresses a view on the expected returns such that +R_2 < R_3 < R_1 < R_4} + +\item{simulations}{number of simulations} +} +\value{ +the centroid vector +} +\description{ +Numerical method to estimate complete cases centroid +} +\examples{ +# Express a view on the assets such that +# R_2 < R_1 < R_3 < R_4 +centroid.complete.mc(c(2, 1, 3, 4)) +} +\author{ +Ross Bennett +} + Added: pkg/PortfolioAnalytics/man/centroid.sectors.Rd =================================================================== --- pkg/PortfolioAnalytics/man/centroid.sectors.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/centroid.sectors.Rd 2014-07-02 02:03:40 UTC (rev 3458) @@ -0,0 +1,33 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{centroid.sectors} +\alias{centroid.sectors} +\title{Multiple Sectors Centroid} +\usage{ +centroid.sectors(sectors, simulations = 1000) +} +\arguments{ +\item{sectors}{a list where each list element contains the order of each +asset in the given sector} + +\item{simulations}{number of simulations} +} +\value{ +the centroid vector +} +\description{ +Compute the centroid for expressing views on the relative ranking of assets +within sectors. +} +\examples{ +# Express a view on the assets in two sectors +# Sector 1 View: R_2 < R_1 < R_3 +# Sector 2 View: R_5 < R_4 +x <- list() +x[[1]] <- c(2, 1, 3) +x[[2]] <- c(5, 4) +centroid.sectors(x) +} +\author{ +Ross Bennett +} + Added: pkg/PortfolioAnalytics/man/centroid.sign.Rd =================================================================== --- pkg/PortfolioAnalytics/man/centroid.sign.Rd (rev 0) +++ pkg/PortfolioAnalytics/man/centroid.sign.Rd 2014-07-02 02:03:40 UTC (rev 3458) @@ -0,0 +1,32 @@ +% Generated by roxygen2 (4.0.1): do not edit by hand +\name{centroid.sign} +\alias{centroid.sign} +\title{Positive and Negative View Centroid} +\usage{ +centroid.sign(positive, negative, simulations = 1000) +} +\arguments{ +\item{positive}{a vector of the index of assets with positive expected +return in ascending order} + +\item{negative}{a vector of the index of assets with negative expected +return in ascending order.} + +\item{simulations}{number of simulations} +} +\value{ +the centroid vector +} +\description{ +Compute the centroid for expressing a view on assets with positive or +negative expected returns +} +\examples{ +# Express a view that +# R_1 < R_2 < 0 < R_3 < R_4 +centroid.sign(c(1, 2), c(4, 3)) +} +\author{ +Ross Bennett +} + Modified: pkg/PortfolioAnalytics/sandbox/centroids.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/centroids.R 2014-07-01 22:11:50 UTC (rev 3457) +++ pkg/PortfolioAnalytics/sandbox/centroids.R 2014-07-02 02:03:40 UTC (rev 3458) @@ -1,89 +1,39 @@ -# Numerically compute the centroid for different cases as described in -# the Almgren and Chriss paper. -# These replicate the paper, now I just need to functionalize them +# Complete cases centroid computed numerically +centroid.complete.mc(order = c(3, 1, 2, 4)) +barplot(centroid.complete.mc(50:1)) +# Express a view on the assets in two sectors +# Sector 1 View: R_2 < R_1 < R_4 +# Sector 2 View: R_5 < R_3 +x <- list() +x[[1]] <- c(2, 1, 4) +x[[2]] <- c(5, 3) +barplot(centroid.sectors(x)) -# Complete sort -nsim <- 1000 -nassets <- 50 -out <- matrix(0, nsim, nassets) -for(i in 1:nsim){ - out[i,] <- sort(rnorm(nassets), decreasing=TRUE) -} +y <- list() +y[[1]] <- 10:1 +y[[2]] <- 40:11 +barplot(centroid.sectors(y)) -barplot(colMeans(out)) +# Express a view that +# R_1 < R_2 < 0 < R_3 < R_4 +centroid.sign(c(1, 2), c(4, 3)) -# Complete sort with multiple sectors -sectors <- list() -sectors[[1]] <- 1:10 -sectors[[2]] <- 11:40 -nassets <- length(unlist(sectors)) -nsectors <- length(sectors) +# The centroid values of 16:50 are negative +barplot(centroid.sign(15:1, 50:16)) -sim.list <- vector("list", nsectors) -for(j in 1:nsectors){ - nassets <- length(sectors[[j]]) - out <- matrix(0, nsim, nassets) - for(i in 1:nsim){ - out[i,] <- sort(rnorm(nassets), decreasing=TRUE) - } - sim.list[[j]] <- out -} -barplot(unlist(lapply(sim.list, colMeans))) +z <- list() +z[[1]] <- c(1, 3) +z[[2]] <- c(2, 4) +barplot(centroid.buckets(z)) -# Complete sort with comparison to 0 -my.list <- list() -my.list$pos <- c(1, 2, 3, 4) -my.list$neg <- c(5, 6, 7, 8 , 9, 10) -pos <- length(my.list$pos) -neg <- length(my.list$neg) +zz <- list() +zz[[1]] <- 10:1 +zz[[2]] <- 20:11 +zz[[3]] <- 30:21 +zz[[4]] <- 40:31 +zz[[5]] <- 50:41 +barplot(centroid.buckets(zz)) -nsim <- 1000 -nassets <- pos + neg - -out <- matrix(0, nsim, nassets) -for(i in 1:nsim){ - tmp <- rnorm(nassets) - tmp.pos <- tmp[1:pos] - tmp.neg <- tmp[(pos+1):(pos+neg)] - - # Sign correct the pos assets - idx <- which(tmp.pos < 0) - if(length(idx) != 0){ - tmp.pos[idx] <- -1 * tmp.pos[idx] - } - - # Sign correct the neg assets - idx <- which(tmp.neg > 0) - if(length(idx) != 0){ - tmp.neg[idx] <- -1 * tmp.neg[idx] - } - out[i,] <- sort(c(tmp.pos, tmp.neg), decreasing=TRUE) -} - -barplot(colMeans(out)) - - -# Complete sort with "buckets" -qlist <- list() -qlist[[1]] <- c(1, 2, 3, 4) -qlist[[2]] <- c(5, 6, 7, 8) -qlist[[3]] <- c(9, 10, 11, 12) -qlist[[4]] <- c(13, 14, 15, 16) - -nsim <- 1000 -nassets <- length(unlist(qlist)) -nbuckets <- length(qlist) -out <- matrix(0, nsim, nassets) -for(i in 1:nsim){ - tmp <- sort(rnorm(nbuckets), decreasing=TRUE) - vec <- c() - for(j in 1:nbuckets){ - vec <- c(vec, rep(tmp[j], length(qlist[[j]]))) - } - out[i,] <- vec -} - -barplot(colMeans(out)) From noreply at r-forge.r-project.org Wed Jul 2 08:10:51 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 2 Jul 2014 08:10:51 +0200 (CEST) Subject: [Returnanalytics-commits] r3459 - in pkg/FactorAnalytics: . R man Message-ID: <20140702061051.C37631849A4@r-forge.r-project.org> Author: pragnya Date: 2014-07-02 08:10:51 +0200 (Wed, 02 Jul 2014) New Revision: 3459 Added: pkg/FactorAnalytics/R/covFM.r pkg/FactorAnalytics/man/covFM.Rd Removed: pkg/FactorAnalytics/R/coef.sfm.r pkg/FactorAnalytics/R/coef.tsfm.R pkg/FactorAnalytics/R/factorModelCovariance.r pkg/FactorAnalytics/R/fitted.sfm.r pkg/FactorAnalytics/R/fitted.tsfm.r pkg/FactorAnalytics/R/residuals.sfm.r pkg/FactorAnalytics/R/residuals.tsfm.r pkg/FactorAnalytics/R/tsfm.r pkg/FactorAnalytics/man/coef.sfm.Rd pkg/FactorAnalytics/man/coef.tsfm.Rd pkg/FactorAnalytics/man/factorModelCovariance.Rd pkg/FactorAnalytics/man/fitted.sfm.Rd pkg/FactorAnalytics/man/fitted.tsfm.Rd pkg/FactorAnalytics/man/print.summary.tsfm.Rd pkg/FactorAnalytics/man/residuals.sfm.Rd pkg/FactorAnalytics/man/residuals.tsfm.Rd Modified: pkg/FactorAnalytics/DESCRIPTION pkg/FactorAnalytics/NAMESPACE pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/R/predict.tsfm.r pkg/FactorAnalytics/R/print.tsfm.r pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd pkg/FactorAnalytics/man/predict.tsfm.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd Log: Added covFM method, combined generic accessor function Rd files for fitTSFM Modified: pkg/FactorAnalytics/DESCRIPTION =================================================================== --- pkg/FactorAnalytics/DESCRIPTION 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/DESCRIPTION 2014-07-02 06:10:51 UTC (rev 3459) @@ -3,16 +3,17 @@ Title: Factor Analytics Version: 1.0 Date: 2014-06-18 -Author: Eric Zivot and Yi-An Chen -Maintainer: Yi-An Chen +Author: Eric Zivot, Yi-An Chen and Sangeetha Srinivasan +Maintainer: Sangeetha Srinivasan Description: An R package for the estimation and risk analysis of linear factor models for asset returns and portfolios. It contains model fitting methods for the three major types of factor models: time series (or, macroeconomic) factor model, fundamental factor model and statistical factor model. They allow for different types of distributions to be specified for modeling the fat-tailed behavior of financial returns, including Edgeworth expansions. - Risk analysis measures such as VaR and ES and performance attribution (to - factor-contributed and idiosyncratic returns) are also included. + Risk analysis measures such as VaR and ES, as well as performance + attribution for factor models (factor-contributed vs idiosyncratic returns) + are included. License: GPL-2 Depends: R (>= 2.14.0), @@ -30,3 +31,4 @@ testthat, quantmod LazyLoad: yes LazyDataCompression: xz +URL: http://r-forge.r-project.org/R/?group_id=579 Modified: pkg/FactorAnalytics/NAMESPACE =================================================================== --- pkg/FactorAnalytics/NAMESPACE 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/NAMESPACE 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,8 +1,7 @@ # Generated by roxygen2 (4.0.1): do not edit by hand -S3method(coef,sfm) S3method(coef,tsfm) -S3method(fitted,sfm) +S3method(covFM,tsfm) S3method(fitted,tsfm) S3method(plot,FundamentalFactorModel) S3method(plot,StatFactorModel) @@ -16,14 +15,13 @@ S3method(print,pafm) S3method(print,summary.tsfm) S3method(print,tsfm) -S3method(residuals,sfm) S3method(residuals,tsfm) S3method(summary,FundamentalFactorModel) S3method(summary,StatFactorModel) S3method(summary,pafm) S3method(summary,tsfm) +export(covFM) export(dCornishFisher) -export(factorModelCovariance) export(factorModelEsDecomposition) export(factorModelMonteCarlo) export(factorModelSdDecomposition) Deleted: pkg/FactorAnalytics/R/coef.sfm.r =================================================================== --- pkg/FactorAnalytics/R/coef.sfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/coef.sfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,23 +0,0 @@ -#' @title Extract coefficients from a fitted stochastic factor model -#' -#' @description Method or helper function for fit object of class \code{sfm}. -#' -#' @param object a fit object of class \code{sfm} which is returned by -#' \code{\link{fitSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{coef.mat}{an N x (K+1) matrix of all coefficients} -#' where, N is the number of assets and K is the number of factors. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitTSFM}} -#' -#' @method coef sfm -#' @export - -coef.sfm <- function(object,...){ - coef.mat <- t(sapply(object$asset.fit, coef)) - return(coef.mat) -} \ No newline at end of file Deleted: pkg/FactorAnalytics/R/coef.tsfm.R =================================================================== --- pkg/FactorAnalytics/R/coef.tsfm.R 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/coef.tsfm.R 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,34 +0,0 @@ -#' @title Extract coefficients from a fitted time series factor model -#' -#' @description Method or helper function for fit object of class \code{tsfm}. -#' -#' @param object a fit object of class \code{tsfm} which is returned by -#' \code{\link{fitTSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{coef.mat}{an N x (K+1) matrix of all coefficients} -#' where, N is the number of assets and K is the number of factors. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitTSFM}} -#' -#' @examples -#' \dontrun{ -#' data(managers.df) -#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=colnames(managers.df[,7:9]), -#' market.name="SP500.TR", -#' data=data, fit.method="OLS", variable.selection="none", -#' add.up.market=TRUE, add.market.sqd=TRUE) -#' coef(fit) -#' } -#' -#' @method coef tsfm -#' @export - -coef.tsfm <- function(object,...){ - coef.mat <- t(sapply(object$asset.fit, coef)) - return(coef.mat) -} Added: pkg/FactorAnalytics/R/covFM.r =================================================================== --- pkg/FactorAnalytics/R/covFM.r (rev 0) +++ pkg/FactorAnalytics/R/covFM.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -0,0 +1,79 @@ +#' @title Covariance Matrix for assets' returns from fitted factor model. +#' +#' @description Computes the covariance matrix for assets' returns based on a +#' fitted factor model. This is a generic function with methods for classes +#' \code{tsfm}, \code{sfm} and \code{ffm}. +#' +#' @details \code{R(i, t)}, the return on asset \code{i} at time \code{t}, +#' is assumed to follow a factor model of the form, \cr \cr +#' \code{R(i,t) = alpha(i) + beta*F(t) + e(i,t)}, \cr \cr +#' where, \code{alpha(i)} is the intercept, \code{F(t)} is a {K x 1} vector of +#' the \code{K} factor values at time \code{t}, \code{beta} is a \code{1 x K} +#' vector of factor exposures and the error terms \code{e(i,t)} are serially +#' uncorrelated across time and contemporaneously uncorrelated across assets +#' so that \code{e(i,t) ~ iid(0,sig(i)^2)}. Thus, the variance of asset +#' \code{i}'s return is given by \cr \cr +#' \code{var(R(i,t)) = beta*var(F(t))*tr(beta) + sig(i)^2}. \cr \cr +#' And, the \code{N x N} covariance matrix of N asset returns is \cr \cr +#' \code{var(R) = B*var(F(t))*tr(B) + D}, \cr \cr +#' where, B is the \code{N x K} matrix of factor betas and \code{D} is a +#' diagonal matrix with \code{sig(i)^2} along the diagonal. +#' +#' @param object fit object of class \code{tsfm}, \code{sfm} or \code{ffm}. +#' +#' @return The computed \code{N x N} covariance matrix for asset returns based +#' on the fitted factor model. +#' +#' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. +#' +#' @references +#' \enumerate{ +#' \item Zivot, Eric, and W. A. N. G. Jia-hui. "Modeling Financial Time Series +#' with S-Plus Springer-Verlag." (2006). +#' } +#' +#' @seealso \code{\link{fitTSFM}}, \code{\link{fitSFM}}, \code{\link{fitFFM}} +#' +#' @examples +#' \dontrun{ +#' # Time Series Factor model +#' data(managers.df) +#' factors = managers.df[, (7:9)] +#' fit <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), +#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' fit.method="OLS") +#' covFM(fit) +#' +#' # Statistical Factor Model +#' data(stat.fm.data) +#' sfm.pca.fit <- fitStatisticalFactorModel(sfm.dat, k=2) +#' #' covFM(t(sfm.pca.fit$loadings), var(sfm.pca.fit$factors), +#' sfm.pca.fit$resid.sd) +#' +#' sfm.apca.fit <- fitSFM(sfm.apca.dat, k=2) +#' +#' covFM(t(sfm.apca.fit$loadings), var(sfm.apca.fit$factors), +#' sfm.apca.fit$resid.sd) +#' +#' # Fundamental Factor Model +#' data(stock) +#' # there are 447 assets +#' exposure.names <- c("BOOK2MARKET", "LOG.MARKETCAP") +#' beta.mat <- subset(stock, DATE=="2003-12-31")[, exposure.names] +#' beta.mat1 <- cbind(rep(1, 447), beta.mat1) +#' # FM return covariance +#' fit.fund <- fitFFM(exposure.names=c("BOOK2MARKET", "LOG.MARKETCAP"), +#' data=stock, returnsvar="RETURN", datevar="DATE", +#' assetvar="TICKER", wls=TRUE, regression="classic", +#' covariance="classic", full.resid.cov=FALSE) +#' ret.cov.fundm <- covFM(beta.mat1, fit.fund$factor.cov$cov, +#' fit.fund$resid.sd) +#' fit.fund$returns.cov$cov == ret.cov.fundm +#' } +#' +#' @rdname covFM +#' @export + +covFM <- function(object){ +UseMethod("covFM") +} Deleted: pkg/FactorAnalytics/R/factorModelCovariance.r =================================================================== --- pkg/FactorAnalytics/R/factorModelCovariance.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/factorModelCovariance.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,102 +0,0 @@ -#' @title Factor model Covariance Matrix for assets' returns. -#' -#' @description Computes the covariance matrix for assets' returns based on a -#' fitted factor model. -#' -#' @details The return on asset \code{i} is assumed to follow a factor model -#' of the form, \cr \cr \code{R(i,t) = alpha + beta*F(t) + e(i,t)}, \cr \cr -#' where, \code{e(i,t) ~ iid(0,sig(i)^2)}, \code{beta} is a \code{1 x K} vector -#' of factor exposures and the error terms are serially uncorrelated and -#' contenporaneously uncorrelated across assets. Thus, the variance of asset -#' \code{i}'s return is given by \cr \cr -#' \code{var(R(i,t)) = beta*var(F(t))*tr(beta) + sig(i)^2}. \cr \cr -#' And, the \code{N x N} covariance matrix of N asset returns is \cr \cr -#' \code{var(R) = B*var(F(t))*tr(B) + D}, \cr \cr -#' where, B is the \code{N x K} matrix of asset betas and \code{D} is a diagonal -#' matrix with \code{sig(i)^2} along the diagonal. -#' -#' @param beta an \code{N x K} matrix of factor betas, where \code{N} is the -#' number of assets and \code{K} is the number of factors. -#' @param factor.cov a \code{K x K} factor covariance matrix. -#' @param resid.sd an \code{N x 1} vector of asset specific residual -#' volatilities from the factor model. -#' -#' @return The computed \code{N x N} covariance matrix for asset returns based -#' on the given factor model parameters. -#' -#' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. -#' -#' @references Zivot, E. and J. Wang (2006), \emph{Modeling Financial Time -#' Series with S-PLUS, Second Edition}, Springer-Verlag. -#' -#' @seealso \code{\link{fitTSFM}}, \code{\link{fitSFM}}, \code{\link{fitFFM}} -#' -#' @examples -#' \dontrun{ -#' # Time Series Factor model -#' data(managers.df) -#' factors = managers.df[, (7:9)] -#' fit <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), -#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, -#' fit.method="OLS") -#' factors = managers.df[, (7:8)] -#' factorModelCovariance(fit$beta, var(factors), fit$resid.sd) -#' -#' # Statistical Factor Model -#' data(stat.fm.data) -#' sfm.pca.fit <- fitStatisticalFactorModel(sfm.dat, k=2) -#' #' factorModelCovariance(t(sfm.pca.fit$loadings), var(sfm.pca.fit$factors), -#' sfm.pca.fit$resid.sd) -#' -#' sfm.apca.fit <- fitSFM(sfm.apca.dat, k=2) -#' -#' factorModelCovariance(t(sfm.apca.fit$loadings), var(sfm.apca.fit$factors), -#' sfm.apca.fit$resid.sd) -#' -#' # Fundamental Factor Model -#' data(stock) -#' # there are 447 assets -#' exposure.names <- c("BOOK2MARKET", "LOG.MARKETCAP") -#' beta.mat <- subset(stock, DATE=="2003-12-31")[, exposure.names] -#' beta.mat1 <- cbind(rep(1, 447), beta.mat1) -#' # FM return covariance -#' fit.fund <- fitFFM(exposure.names=c("BOOK2MARKET", "LOG.MARKETCAP"), -#' data=stock, returnsvar="RETURN", datevar="DATE", -#' assetvar="TICKER", wls=TRUE, regression="classic", -#' covariance="classic", full.resid.cov=FALSE) -#' ret.cov.fundm <- factorModelCovariance(beta.mat1, fit.fund$factor.cov$cov, -#' fit.fund$resid.sd) -#' fit.fund$returns.cov$cov == ret.cov.fundm -#' } -#' @export -#' - -factorModelCovariance <- function(beta, factor.cov, resid.sd) { - - beta = as.matrix(beta) - factor.cov = as.matrix(factor.cov) - sig2.e = as.vector(resid.sd)^2 - - if (length(sig2.e) > 1) { - D.e = diag(as.vector(sig2.e)) - } else { - D.e = as.matrix(sig2.e) - } - - if (ncol(beta) != ncol(factor.cov)) { - stop("'beta' and 'factor.cov' must have same number of columns.") - } - - if (nrow(D.e) != nrow(beta)) { - stop("'beta' and 'D.e' must have same number of rows.") - } - - cov.fm = beta %*% factor.cov %*% t(beta) + D.e - - if (any(diag(chol(cov.fm)) == 0)) { - warning("Covariance matrix is not positive definite!") - } - - return(cov.fm) -} - Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-02 06:10:51 UTC (rev 3459) @@ -34,7 +34,9 @@ #' regression, following Henriksson & Merton (1981), to account for market #' timing (price movement of the general stock market relative to fixed income #' securities). The coefficient can be interpreted as the number of free put -#' options. +#' options. Similarly, if \code{add.market.sqd = TRUE}, (Rm-Rf)^2 is added as +#' a factor in the regression, following Treynor-Mazuy (1966), to account for +#' market timing with respect to volatility. #' #' Finally, for both the "lars" and "lasso" methods, the "Cp" statistic #' (defined in page 17 of Efron et al. (2002)) is calculated using @@ -42,14 +44,14 @@ #' cross-validated mean squared prediction error using #' \code{\link[lars]{cv.lars}}. #' -#' @param asset.names vector containing names of assets, whose returns or +#' @param asset.names vector containing names of assets, whose returns or #' excess returns are the dependent variable. #' @param factor.names vector containing names of the macroeconomic factors. #' @param market.name name of the column for market excess returns (Rm-Rf). -#' Is required only if \code{add.up.market} or \code{add.up.market.squared} +#' Is required only if \code{add.up.market} or \code{add.market.sqd} #' are \code{TRUE}. #' @param data vector, matrix, data.frame, xts, timeSeries or zoo object -#' containing column(s) named \code{asset.names}, \code{factor.names} and +#' containing column(s) named in \code{asset.names}, \code{factor.names} and #' optionally, \code{market.name}. #' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". #' See details. @@ -82,9 +84,19 @@ #' and "DLS" fits. Scope argument is not available presently. Also plan to #' include other controls passed to \code{lmRob} soon. #' -#' @return fitTSFM returns an object of class -#' \code{tsfm}. The returned object is a list -#' containing the following components: +#' @return fitTSFM returns an object of class \code{tsfm}. +#' +#' The generic functions \code{summary}, \code{predict} and \code{plot} are +#' used to obtain and print a summary, predicted asset returns for new factor +#' data and plot selected characteristics for one or more assets. The generic +#' accessor functions \code{coefficients}, \code{fitted} and \code{residuals} +#' extract various useful features of the fit object. \code{coef.tsfm} extracts +#' coefficients from the fitted factor model and returns an N x (K+1) matrix of +#' all coefficients, \code{fitted.tsfm} gives an N x T data object of fitted +#' values and \code{residuals.tsfm} gives an N x T data object of residuals. +#' +#' An object of class \code{tsfm} is a list containing the following +#' components: #' \item{asset.fit}{list of fitted objects for each asset. Each object is of #' class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if #' the \code{fit.method="Robust"}, or class \code{lars} if @@ -99,33 +111,35 @@ #' \item{factor.names}{factor.names as input.} #' \item{fit.method}{fit.method as input.} #' \item{variable.selection}{variable.selection as input.} -#' Where N is the number of assets and K is the number of factors. +#' Where N is the number of assets, K is the number of factors and T is the +#' number of time periods. #' -#' @family Factor Models -#' #' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. #' #' @references #' \enumerate{ -#' \item Christopherson, Carino and Ferson (2009). Portfolio Performance -#' Measurement and Benchmarking, McGraw Hill. -#' \item Efron, Hastie, Johnstone and Tibshirani (2002) "Least Angle -#' Regression" (with discussion) Annals of Statistics. Also refer to -#' \url{http://www-stat.stanford.edu/~hastie/Papers/LARS/LeastAngle_2002.pdf}. -#' \item Hastie, Tibshirani and Friedman (2008) Elements of Statistical -#' Learning 2nd edition, Springer, NY. -#' \item Henriksson and Merton (1981). On market timing and investment -#' performance. II. Statistical procedures for evaluating forecasting skills, -#' Journal of Business, Vol 54, No 4. +#' \item Christopherson, Jon A., David R. Carino, and Wayne E. Ferson. +#' Portfolio performance measurement and benchmarking. McGraw Hill +#' Professional, 2009. +#' \item Efron, Bradley, Trevor Hastie, Iain Johnstone, and Robert Tibshirani. +#' "Least angle regression." The Annals of statistics 32, no. 2 (2004): 407-499. +#' \item Hastie, Trevor, Robert Tibshirani, Jerome Friedman, T. Hastie, J. +#' Friedman, and R. Tibshirani. The elements of statistical learning. Vol. 2, +#' no. 1. New York: Springer, 2009. +#' \item Henriksson, Roy D., and Robert C. Merton. "On market timing and +#' investment performance. II. Statistical procedures for evaluating +#' forecasting skills." Journal of business (1981): 513-533. +#' \item Treynor, Jack, and Kay Mazuy. "Can mutual funds outguess the market." +#' Harvard business review 44, no. 4 (1966): 131-136. #' } #' -#' @seealso The following generic method functions: \code{\link{plot.tsfm}}, -#' \code{\link{predict.tsfm}}, \code{\link{print.tsfm}} and -#' \code{\link{summary.tsfm}}. +#' @seealso The \code{tsfm} methods for generic functions: +#' \code{\link{plot.tsfm}}, \code{\link{predict.tsfm}}, +#' \code{\link{print.tsfm}} and \code{\link{summary.tsfm}}. #' -#' And, the following extractor functions: \code{\link{coef.tsfm}}, -#' \code{\link{cov.tsfm}}, \code{\link{fitted.tsfm}} and -#' \code{\link{residuals.tsfm}}. +#' And, the following extractor functions: \code{\link[stats]{coef}}, +#' \code{\link{covFM}}, \code{\link[stats]{fitted}} and +#' \code{\link[stats]{residuals}}. #' #' \code{\link{paFM}} for Performance Attribution. #' @@ -137,6 +151,8 @@ #' fit.method="OLS", variable.selection="none") #' # summary of HAM1 #' summary(fit$asset.fit$HAM1) +#' # fitted values all 6 asset returns +#' fitted(fit) #' # plot actual vs. fitted over time for HAM1 #' # using chart.TimeSeries() function from PerformanceAnalytics package #' dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers.df$HAM1)) @@ -144,7 +160,6 @@ #' chart.TimeSeries(dataToPlot, main="FM fit for HAM1", #' colorset=c("black","blue"), legend.loc="bottomleft") #' -#' #' @export fitTSFM <- function(asset.names, factor.names, market.name, data=data, @@ -450,4 +465,81 @@ w <- d^seq((t-1),0,-1) # ensure that the weights sum to unity w/sum(w) -} \ No newline at end of file +} + + +#' @param object a fit object of class \code{tsfm} which is returned by +#' \code{fitTSFM} + +#' @rdname fitTSFM +#' @method coef tsfm +#' @export + +coef.tsfm <- function(object,...){ + coef.mat <- t(sapply(object$asset.fit, coef)) + return(coef.mat) +} + +#' @rdname fitTSFM +#' @method fitted tsfm +#' @export + +fitted.tsfm <- function(object,...){ + # get fitted values from each linear factor model fit + # and convert them into xts/zoo objects + fitted.list = sapply(object$asset.fit, function(x) checkData(fitted(x))) + # this is a list of xts objects, indexed by the asset name + # merge the objects in the list into one xts object + fitted.xts <- do.call(merge, fitted.list) + return(fitted.xts) +} + + +#' @rdname fitTSFM +#' @method residuals tsfm +#' @export + +residuals.tsfm <- function(object ,...) { + # get residuals from each linear factor model fit + # and convert them into xts/zoo objects + residuals.list = sapply(object$asset.fit, function(x) checkData(residuals(x))) + # this is a list of xts objects, indexed by the asset name + # merge the objects in the list into one xts object + residuals.xts <- do.call(merge, residuals.list) + return(residuals.xts) +} + +#' @rdname fitTSFM +#' @method covFM tsfm +#' @export + +covFM.tsfm <- function(object) { + + # check input object validity + if (!inherits(object, c("tsfm", "sfm", "ffm"))) { + stop("Invalid argument: Object should be of class 'tsfm', 'sfm' or 'ffm'.") + } + + # get parameters and factors from factor model + beta <- object$beta + sig2.e = object$resid.sd^2 + factor <- object$data[, colnames(object$beta)] + + # factor covariance matrix + factor.cov = var(factor, use="na.or.complete") + + # residual covariance matrix D + if (length(sig2.e) > 1) { + D.e = diag(sig2.e) + } else { + D.e = as.vector(sig2.e) + } + + cov.fm = beta %*% factor.cov %*% t(beta) + D.e + + if (any(diag(chol(cov.fm)) == 0)) { + warning("Covariance matrix is not positive definite!") + } + + return(cov.fm) +} Deleted: pkg/FactorAnalytics/R/fitted.sfm.r =================================================================== --- pkg/FactorAnalytics/R/fitted.sfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/fitted.sfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,28 +0,0 @@ -#' @title Get fitted values from a stochastic factor model -#' -#' @description Method or helper function for fit object of class \code{sfm}. -#' -#' @param object a fit object of class \code{sfm} which is returned by -#' \code{\link{fitSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{fitted.xts}{an N x T data object of fitted values} -#' where, N is the number of assets and T is the number of time periods. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitSFM}} -#' -#' @method fitted sfm -#' @export - -fitted.sfm <- function(object,...){ - # get fitted values from each linear factor model fit - # and convert them into xts/zoo objects - fitted.list = sapply(object$asset.fit, function(x) checkData(fitted(x))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - fitted.xts <- do.call(merge, fitted.list) - return(fitted.xts) -} Deleted: pkg/FactorAnalytics/R/fitted.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/fitted.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/fitted.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,39 +0,0 @@ -#' @title Get fitted values from a time series factor model -#' -#' @description Method or helper function for fit object of class \code{tsfm}. -#' -#' @param object a fit object of class \code{tsfm} which is returned by -#' \code{\link{fitTSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{fitted.xts}{an N x T data object of fitted values} -#' where, N is the number of assets and T is the number of time periods. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitTSFM}} -#' -#' @examples -#' \dontrun{ -#' data(managers.df) -#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=colnames(managers.df[,7:9]), -#' market.name="SP500.TR", -#' data=data, fit.method="OLS", variable.selection="none", -#' add.up.market=TRUE, add.market.sqd=TRUE) -#' fitted(fit) -#' } -#' -#' @method fitted tsfm -#' @export - -fitted.tsfm <- function(object,...){ - # get fitted values from each linear factor model fit - # and convert them into xts/zoo objects - fitted.list = sapply(object$asset.fit, function(x) checkData(fitted(x))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - fitted.xts <- do.call(merge, fitted.list) - return(fitted.xts) -} Modified: pkg/FactorAnalytics/R/plot.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -41,7 +41,7 @@ #' 10= CUSUM plot of recursive residuals,\cr #' 11= CUSUM plot of OLS residuals,\cr #' 12= CUSUM plot of recursive estimates relative to full sample estimates,\cr -#' 13= rolling estimates over an observation window of length 24. +#' 13= rolling estimates over a 24-period observation window #' @param VaR.method a method for computing VaR; one of "modified", "gaussian", #' "historical" or "kernel". VaR is computed using #' \code{\link[PerformanceAnalytics]{VaR}}. Default is "historical". @@ -49,8 +49,7 @@ #' #' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan #' -#' @seealso \code{\link{fitTSFM}}, \code{\link{summary.tsfm}}, -#' \code{\link{tsfm}} +#' @seealso \code{\link{fitTSFM}}, \code{\link{summary.tsfm}} #' #' @examples #' @@ -96,7 +95,7 @@ ## 10 CUSUM plot of recursive residuals ## 11 CUSUM plot of OLS residuals ## 12 CUSUM plot of recursive estimates relative to full sample estimates - ## 13 rolling estimates over an observation window of length 24 + ## 13 rolling estimates over a 24-period observation window which.plot.single<-which.plot.single[1] if (missing(asset.name) == TRUE) { stop("Neet to specify an asset to plot if plot.single is TRUE.") @@ -129,7 +128,7 @@ "CUSUM plot of recursive residuals", "CUSUM plot of OLS residuals", "CUSUM plot of recursive estimates relative to full sample estimates", - "rolling estimates over an observation window of length 24"), + "rolling estimates over a 24-period observation window"), title="\nMake a plot selection (or 0 to exit):\n") switch(which.plot.single, "1L" = { @@ -206,7 +205,7 @@ stop("CUMSUM applies only on OLS method") }, "13L"= { - ## rolling regression over 24 month window + ## Rolling estimates over 24-period observation window if (as.character(x$call["fit.method"]) == "OLS") { rollReg <- function(data.z, formula) { coef(lm(formula, data = as.data.frame(data.z))) @@ -214,7 +213,7 @@ reg.z = zoo(fit.lm$model, as.Date(rownames(fit.lm$model))) rollReg.z = rollapply(reg.z, FUN=rollReg, fit.formula, width=24, by.column = FALSE, align="right") - plot(rollReg.z, main=paste("24-month rolling regression estimates:", asset.name, sep=" ")) + plot(rollReg.z, main=paste("Rolling estimates over 24-period observation window:", asset.name, sep=" ")) } else if (as.character(x$call["fit.method"]) == "DLS") { decay.factor <- as.numeric(as.character(x$call["decay.factor"])) t.length <- 24 @@ -231,7 +230,7 @@ fit.formula = as.formula(paste(asset.name,"~", paste(factorNames, collapse="+"), sep=" ")) rollReg.z = rollapply(reg.z, FUN=rollReg.w, fit.formula,w, width=24, by.column = FALSE, align="right") - plot(rollReg.z, main=paste("24-month rolling regression estimates:", asset.name, sep=" ")) + plot(rollReg.z, main=paste("Rolling estimates over 24-period observation window:", asset.name, sep=" ")) } }, invisible() Modified: pkg/FactorAnalytics/R/predict.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -4,8 +4,7 @@ #' calls the \code{predict} method for fitted objects of class \code{lm}, #' \code{lmRob} or \code{lars} as appropriate. #' -#' @param object an object of class \code{\link[stats]{tsfm}} produced by -#' \code{fitTSFM}. +#' @param object an object of class \code{tsfm} produced by \code{fitTSFM}. #' @param newdata a vector, matrix, data.frame, xts, timeSeries or zoo object #' containing the variables with which to predict. #' @param ... optional arguments passed to \code{predict.lm} or @@ -17,8 +16,7 @@ #' #' @author Yi-An Chen and Sangeetha Srinivasan #' -#' @seealso \code{\link{fitTSFM}}, \code{\link{summary.tsfm}}, -#' \code{\link{tsfm}} +#' @seealso \code{\link{fitTSFM}}, \code{\link{summary.tsfm}} #' #' @examples #' # load data from the database Modified: pkg/FactorAnalytics/R/print.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/print.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/print.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -38,7 +38,7 @@ cat("\nRegression Alphas:\n") print(x$alpha, digits = digits, ...) cat("\nFactor Betas:\n") - print(t(x$beta), digits = digits, ...) + print(x$beta, digits = digits, ...) cat("\nR-squared values:\n") print(x$r2, digits = digits, ...) cat("\nResidual Volatilities:\n") Deleted: pkg/FactorAnalytics/R/residuals.sfm.r =================================================================== --- pkg/FactorAnalytics/R/residuals.sfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/residuals.sfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,28 +0,0 @@ -#' @title Get residuals from a fitted stochastic factor model -#' -#' @description Method or helper function for fit object of class \code{sfm}. -#' -#' @param object a fit object of class \code{sfm} which is returned by -#' \code{\link{fitSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{residuals.xts}{an N x T data object of residuals} -#' where, N is the number of assets and T is the number of time periods. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitSFM}} -#' -#' @method residuals sfm -#' @export - -residuals.sfm <- function(object,...) { - # get residuals from each linear factor model fit - # and convert them into xts/zoo objects - residuals.list = sapply(object$asset.fit, function(x) checkData(residuals(x))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - residuals.xts <- do.call(merge, residuals.list) - return(residuals.xts) -} Deleted: pkg/FactorAnalytics/R/residuals.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/residuals.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/residuals.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,39 +0,0 @@ -#' @title Get residuals from a fitted time series factor model -#' -#' @description Method or helper function for fit object of class \code{tsfm}. -#' -#' @param object a fit object of class \code{tsfm} which is returned by -#' \code{\link{fitTSFM}} -#' @param ... other arguments passed -#' -#' @return -#' \item{residuals.xts}{an N x T data object of residuals} -#' where, N is the number of assets and T is the number of time periods. -#' -#' @author Eric Zivot and Sangeetha Srinivasan -#' -#' @seealso \code{\link{fitTSFM}} -#' -#' @examples -#' \dontrun{ -#' data(managers.df) -#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=colnames(managers.df[,7:9]), -#' market.name="SP500.TR", -#' data=data, fit.method="OLS", variable.selection="none", -#' add.up.market=TRUE, add.market.sqd=TRUE) -#' residuals(fit) -#' } -#' -#' @method residuals tsfm -#' @export - -residuals.tsfm <- function(object ,...) { - # get residuals from each linear factor model fit - # and convert them into xts/zoo objects - residuals.list = sapply(object$asset.fit, function(x) checkData(residuals(x))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - residuals.xts <- do.call(merge, residuals.list) - return(residuals.xts) -} Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-02 02:03:40 UTC (rev 3458) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) @@ -1,26 +1,28 @@ #' @title Summarizing a fitted time series factor model #' -#' @description S3 \code{summary} method for object of class \code{tsfm}. -#' Resulting object is of class {summary.tsfm}. There is a generic -#' \code{print} method for this object. [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3459 From noreply at r-forge.r-project.org Thu Jul 3 02:08:54 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Jul 2014 02:08:54 +0200 (CEST) Subject: [Returnanalytics-commits] r3460 - in pkg/FactorAnalytics: R man Message-ID: <20140703000854.B63E1186A65@r-forge.r-project.org> Author: pragnya Date: 2014-07-03 02:08:53 +0200 (Thu, 03 Jul 2014) New Revision: 3460 Modified: pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd Log: Added HC/HAC stats to summary.tsfm. Edited fitTSFM, covFM to accomodate differing factors across assets. Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-02 06:10:51 UTC (rev 3459) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 00:08:53 UTC (rev 3460) @@ -21,24 +21,24 @@ #' Criterion (AIC), improves. And, "all subsets" enables subsets selection #' using \code{\link[leaps]{regsubsets}} that chooses the n-best performing #' subsets of any given size (specified as \code{num.factor.subsets} here). -#' "lars" and "lasso" correspond to variants of least angle regression using -#' \code{\link[lars]{lars}}. If "lars" or "lasso" are chosen, \code{fit.method} +#' "lar" and "lasso" correspond to variants of least angle regression using +#' \code{\link[lars]{lars}}. If "lar" or "lasso" are chosen, \code{fit.method} #' will be ignored. #' -#' Note: If \code{variable.selection}="lars" or "lasso", \code{fit.method} -#' will be ignored. And, "Robust" \code{fit.method} is not truly available with -#' \code{variable.selection="all subsets"}; instead, results are produced for -#' \code{variable.selection="none"} with "Robust" to include all factors. +#' Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} +#' will be ignored. And, \code{fit.method="Robust"} is not truly available with +#' \code{variable.selection="all subsets"}; instead, +#' \code{variable.selection="none"} is used to include all factors. #' -#' If \code{add.up.market = TRUE}, max(0, Rm-Rf) is added as a factor in the +#' If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in the #' regression, following Henriksson & Merton (1981), to account for market #' timing (price movement of the general stock market relative to fixed income #' securities). The coefficient can be interpreted as the number of free put -#' options. Similarly, if \code{add.market.sqd = TRUE}, (Rm-Rf)^2 is added as +#' options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added as #' a factor in the regression, following Treynor-Mazuy (1966), to account for #' market timing with respect to volatility. #' -#' Finally, for both the "lars" and "lasso" methods, the "Cp" statistic +#' Finally, for both the "lar" and "lasso" methods, the "Cp" statistic #' (defined in page 17 of Efron et al. (2002)) is calculated using #' \code{\link[lars]{summary.lars}} . While, "cv" computes the K-fold #' cross-validated mean squared prediction error using @@ -56,7 +56,7 @@ #' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". #' See details. #' @param variable.selection the variable selection method, one of "none", -#' "stepwise","all subsets","lars" or "lasso". See details. +#' "stepwise","all subsets","lar" or "lasso". See details. #' @param subsets.method one of "exhaustive", "forward", "backward" or "seqrep" #' (sequential replacement) to specify the type of subset search/selection. #' Required if "all subsets" variable selection is chosen. @@ -75,7 +75,7 @@ #' regressor and \code{market.name} is also required. Default is \code{FALSE}. #' @param decay a scalar in (0, 1] to specify the decay factor for #' \code{fit.method="DLS"}. Default is 0.95. -#' @param lars.criterion an option to assess model selection for the "lars" or +#' @param lars.criterion an option to assess model selection for the "lar" or #' "lasso" variable.selection methods; one of "Cp" or "cv". See details. #' Default is "Cp". #' @param ... optional arguments passed to the \code{step} function for @@ -100,7 +100,7 @@ #' \item{asset.fit}{list of fitted objects for each asset. Each object is of #' class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if #' the \code{fit.method="Robust"}, or class \code{lars} if -#' \code{variable.selection="lars" or "lasso"}.} +#' \code{variable.selection="lar" or "lasso"}.} #' \item{alpha}{N x 1 vector of estimated alphas.} #' \item{beta}{N x K matrix of estimated betas.} #' \item{r2}{N x 1 vector of R-squared values.} @@ -165,7 +165,7 @@ fitTSFM <- function(asset.names, factor.names, market.name, data=data, fit.method = c("OLS","DLS","Robust"), variable.selection = c("none","stepwise","all subsets", - "lars","lasso"), + "lar","lasso"), subsets.method = c("exhaustive", "backward", "forward", "seqrep"), nvmax=8, force.in=NULL, num.factors.subset=1, @@ -207,7 +207,7 @@ market.name, fit.method, subsets.method, nvmax, force.in, num.factors.subset, add.up.market, add.market.sqd, decay) - } else if (variable.selection == "lars" | variable.selection == "lasso"){ + } else if (variable.selection == "lar" | variable.selection == "lasso"){ result.lars <- SelectLars(dat.xts, asset.names, factor.names, market.name, variable.selection, add.up.market, add.market.sqd, decay, lars.criterion) @@ -217,14 +217,14 @@ } else { stop("Invalid argument: variable.selection must be either 'none', - 'stepwise','all subsets','lars' or 'lasso'") + 'stepwise','all subsets','lar' or 'lasso'") } # extract the fitted factor models, coefficients, r2 values and residual vol # from returned factor model fits above - coef.mat <- t(sapply(reg.list, coef)) - alpha <- coef.mat[, 1] - beta <- coef.mat[, -1] + coef.mat <- makePaddedDataFrame(lapply(reg.list, coef)) + alpha <- coef.mat[, 1, drop = FALSE] + beta <- coef.mat[, -1, drop = FALSE] r2 <- sapply(reg.list, function(x) summary(x)$r.squared) resid.sd <- sapply(reg.list, function(x) summary(x)$sigma) # create list of return values. @@ -380,7 +380,7 @@ } -### method variable.selection = "lars" or "lasso" +### method variable.selection = "lar" or "lasso" # SelectLars <- function(dat.xts, asset.names, factor.names, market.name, variable.selection, add.up.market, add.market.sqd, @@ -467,6 +467,15 @@ w/sum(w) } +### make a data frame (padded with NAs) from columns of unequal length +# +makePaddedDataFrame <- function(l){ + DF <- do.call(rbind, lapply(lapply(l, unlist), "[", + unique(unlist(c(sapply(l,names)))))) + DF <- as.data.frame(DF) + names(DF) <- unique(unlist(c(sapply(l,names)))) + DF +} #' @param object a fit object of class \code{tsfm} which is returned by #' \code{fitTSFM} @@ -521,9 +530,10 @@ } # get parameters and factors from factor model - beta <- object$beta + beta <- as.matrix(object$beta) + beta[is.na(beta)] <- 0 sig2.e = object$resid.sd^2 - factor <- object$data[, colnames(object$beta)] + factor <- as.matrix(object$data[, colnames(object$beta)]) # factor covariance matrix factor.cov = var(factor, use="na.or.complete") @@ -537,9 +547,9 @@ cov.fm = beta %*% factor.cov %*% t(beta) + D.e - if (any(diag(chol(cov.fm)) == 0)) { - warning("Covariance matrix is not positive definite!") - } +# if (any(diag(chol(cov.fm)) == 0)) { +# warning("Covariance matrix is not positive definite!") +# } return(cov.fm) } Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-02 06:10:51 UTC (rev 3459) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 00:08:53 UTC (rev 3460) @@ -2,23 +2,39 @@ #' #' @description \code{summary} method for object of class \code{tsfm}. #' Returned object is of class {summary.tsfm}. +#' +#' @details The default \code{summary} method for a fitted \code{lm} object +#' computes the standard errors and t-statistics under the assumption of +#' homoskedasticty. Argument \code{se.type} gives the option to compute +#' heteroskedasticity-consistent (HC) or +#' heteroskedasticity-autocorrelation-consistent (HAC) standard errors and +#' t-statistics using \code{\link[lmtest]{coeftest}}. This option is meaningful +#' only if \code{fit.method = "OLS" or "DLS"}. #' #' @param object an object of class \code{tsfm} returned by \code{fitTSFM}. +#' @param se.type one of "Default", "HC" or "HAC"; option for computing +#' HC/HAC standard errors and t-statistics. #' @param x an object of class \code{summary.tsfm}. #' @param digits number of significants digits to use when printing. #' Default is 3. #' @param ... futher arguments passed to or from other methods. #' -#' @return Returns an object of class \code{summary.tsfm}, which is a list -#' containing the function call to \code{fitTSFM} and the -#' \code{summary.lm} objects fitted for each asset in the factor model. +#' @return Returns an object of class \code{summary.tsfm}. #' The print method for class \code{summary.tsfm} outputs the call, -#' coefficients, r-squared and residual volatilty for all assets. +#' coefficients (with standard errors and t-statistics), r-squared and +#' residual volatilty (under the homoskedasticity assumption) for all assets. #' +#' Object of class \code{summary.tsfm} is a list of length N + 2 containing: +#' \item{call}{the function call to \code{fitTSFM}} +#' \item{se.type}{standard error type as input} +#' \item{}{summaries of the N fit objects (of class \code{lm}, \code{lmRob} +#' or \code{lars}) for each asset in the factor model.} +#' #' @note For a more detailed printed summary for each asset, refer to -#' \code{print.summary.lm}, which further formats the coefficients, -#' standard errors, etc. and additionally gives significance -#' stars if \code{signif.stars} is TRUE. +#' \code{\link[stats]{summary.lm}} or \code{\link[robustbase]{lmRob}}, which +#' include F-statistics, Multiple R-squared, Adjusted R-squared and further +#' format the coefficients, standard errors, etc. and additionally give +#' significance stars if \code{signif.stars} is TRUE. #' #' @author Yi-An Chen & Sangeetha Srinivasan. #' @@ -32,7 +48,7 @@ #' fit.method="OLS", variable.selection="none", #' add.up.market=TRUE, add.market.sqd=TRUE) #' # summary of factor model fit for all assets -#' summary(fit) +#' summary(fit, "HAC") #' #' # summary of lm fit for a single asset #' summary(fit$asset.fit[[1]]) @@ -40,15 +56,30 @@ #' @method summary tsfm #' @export -summary.tsfm <- function(object, ...){ +summary.tsfm <- function(object, se.type="Default", ...){ # check input object validity if (!inherits(object, "tsfm")) { stop("Invalid 'tsfm' object") } + if (object$fit.method=="Robust" && se.type!="default") { + stop("Invalid argument: HC/HAC standard errors are applicable only if + fit.method = 'OLS' or 'DLS'") + } + # extract summary.lm objects for each asset sum <- lapply(object$asset.fit, summary) - # include the call to fitTSFM - sum <- c(call=object$call, sum) + + # convert to HC/HAC standard errors and t-stats if specified + for (i in object$asset.names) { + if (se.type == "HC") { + sum[[i]]$coefficients <- coeftest(fit$asset.fit[[i]], vcovHC)[,1:4] + } else if (se.type == "HAC") { + sum[[i]]$coefficients <- coeftest(fit$asset.fit[[i]], vcovHAC)[,1:4] + } + } + + # include the call and se.type to fitTSFM + sum <- c(call=object$call, Type=se.type, sum) class(sum) <- "summary.tsfm" return(sum) } @@ -63,12 +94,14 @@ cat("\nCall:\n") dput(cl) } - cat("\nFactor Model Coefficients:\n") + cat("\nFactor Model Coefficients:\n", + sep="") n <- length(x) - for (i in 2:n) { + for (i in 3:n) { options(digits = digits) - cat("\nAsset", i-1, ": ", names(x[i]), "\n", sep = "") - table.coef <- t(x[[i]]$coefficients) + cat("\nAsset", i-2, ": ", names(x[i]), "\n(",x$Type, + " Standard Errors & T-stats)\n\n", sep = "") + table.coef <- x[[i]]$coefficients print(table.coef, digits = digits, ...) cat("\nR-squared: ", x[[i]]$r.squared,", Residual Volatility: " , x[[i]]$sigma,"\n", sep = "") Modified: pkg/FactorAnalytics/man/fitTSFM.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-02 06:10:51 UTC (rev 3459) +++ pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-03 00:08:53 UTC (rev 3460) @@ -9,11 +9,10 @@ \usage{ fitTSFM(asset.names, factor.names, market.name, data = data, fit.method = c("OLS", "DLS", "Robust"), variable.selection = c("none", - "stepwise", "all subsets", "lars", "lasso"), - subsets.method = c("exhaustive", "backward", "forward", "seqrep"), - nvmax = 8, force.in = NULL, num.factors.subset = 1, - add.up.market = FALSE, add.market.sqd = FALSE, decay = 0.95, - lars.criterion = "Cp", ...) + "stepwise", "all subsets", "lar", "lasso"), subsets.method = c("exhaustive", + "backward", "forward", "seqrep"), nvmax = 8, force.in = NULL, + num.factors.subset = 1, add.up.market = FALSE, add.market.sqd = FALSE, + decay = 0.95, lars.criterion = "Cp", ...) \method{coef}{tsfm}(object, ...) @@ -41,7 +40,7 @@ See details.} \item{variable.selection}{the variable selection method, one of "none", -"stepwise","all subsets","lars" or "lasso". See details.} +"stepwise","all subsets","lar" or "lasso". See details.} \item{subsets.method}{one of "exhaustive", "forward", "backward" or "seqrep" (sequential replacement) to specify the type of subset search/selection. @@ -68,7 +67,7 @@ \item{decay}{a scalar in (0, 1] to specify the decay factor for \code{fit.method="DLS"}. Default is 0.95.} -\item{lars.criterion}{an option to assess model selection for the "lars" or +\item{lars.criterion}{an option to assess model selection for the "lar" or "lasso" variable.selection methods; one of "Cp" or "cv". See details. Default is "Cp".} @@ -98,7 +97,7 @@ \item{asset.fit}{list of fitted objects for each asset. Each object is of class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if the \code{fit.method="Robust"}, or class \code{lars} if -\code{variable.selection="lars" or "lasso"}.} +\code{variable.selection="lar" or "lasso"}.} \item{alpha}{N x 1 vector of estimated alphas.} \item{beta}{N x K matrix of estimated betas.} \item{r2}{N x 1 vector of R-squared values.} @@ -134,24 +133,24 @@ Criterion (AIC), improves. And, "all subsets" enables subsets selection using \code{\link[leaps]{regsubsets}} that chooses the n-best performing subsets of any given size (specified as \code{num.factor.subsets} here). -"lars" and "lasso" correspond to variants of least angle regression using -\code{\link[lars]{lars}}. If "lars" or "lasso" are chosen, \code{fit.method} +"lar" and "lasso" correspond to variants of least angle regression using +\code{\link[lars]{lars}}. If "lar" or "lasso" are chosen, \code{fit.method} will be ignored. -Note: If \code{variable.selection}="lars" or "lasso", \code{fit.method} -will be ignored. And, "Robust" \code{fit.method} is not truly available with -\code{variable.selection="all subsets"}; instead, results are produced for -\code{variable.selection="none"} with "Robust" to include all factors. +Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} +will be ignored. And, \code{fit.method="Robust"} is not truly available with +\code{variable.selection="all subsets"}; instead, +\code{variable.selection="none"} is used to include all factors. -If \code{add.up.market = TRUE}, max(0, Rm-Rf) is added as a factor in the +If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in the regression, following Henriksson & Merton (1981), to account for market timing (price movement of the general stock market relative to fixed income securities). The coefficient can be interpreted as the number of free put -options. Similarly, if \code{add.market.sqd = TRUE}, (Rm-Rf)^2 is added as +options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added as a factor in the regression, following Treynor-Mazuy (1966), to account for market timing with respect to volatility. -Finally, for both the "lars" and "lasso" methods, the "Cp" statistic +Finally, for both the "lar" and "lasso" methods, the "Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated using \code{\link[lars]{summary.lars}} . While, "cv" computes the K-fold cross-validated mean squared prediction error using Modified: pkg/FactorAnalytics/man/summary.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-02 06:10:51 UTC (rev 3459) +++ pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 00:08:53 UTC (rev 3460) @@ -4,13 +4,16 @@ \alias{summary.tsfm} \title{Summarizing a fitted time series factor model} \usage{ -\method{summary}{tsfm}(object, ...) +\method{summary}{tsfm}(object, se.type = "Default", ...) \method{print}{summary.tsfm}(x, digits = 3, ...) } \arguments{ \item{object}{an object of class \code{tsfm} returned by \code{fitTSFM}.} +\item{se.type}{one of "Default", "HC" or "HAC"; option for computing +HC/HAC standard errors and t-statistics.} + \item{x}{an object of class \code{summary.tsfm}.} \item{digits}{number of significants digits to use when printing. @@ -19,21 +22,36 @@ \item{...}{futher arguments passed to or from other methods.} } \value{ -Returns an object of class \code{summary.tsfm}, which is a list -containing the function call to \code{fitTSFM} and the -\code{summary.lm} objects fitted for each asset in the factor model. +Returns an object of class \code{summary.tsfm}. The print method for class \code{summary.tsfm} outputs the call, -coefficients, r-squared and residual volatilty for all assets. +coefficients (with standard errors and t-statistics), r-squared and +residual volatilty (under the homoskedasticity assumption) for all assets. + +Object of class \code{summary.tsfm} is a list of length N + 2 containing: +\item{call}{the function call to \code{fitTSFM}} +\item{se.type}{standard error type as input} +\item{}{summaries of the N fit objects (of class \code{lm}, \code{lmRob} +or \code{lars}) for each asset in the factor model.} } \description{ \code{summary} method for object of class \code{tsfm}. Returned object is of class {summary.tsfm}. } +\details{ +The default \code{summary} method for a fitted \code{lm} object +computes the standard errors and t-statistics under the assumption of +homoskedasticty. Argument \code{se.type} gives the option to compute +heteroskedasticity-consistent (HC) or +heteroskedasticity-autocorrelation-consistent (HAC) standard errors and +t-statistics using \code{\link[lmtest]{coeftest}}. This option is meaningful +only if \code{fit.method = "OLS" or "DLS"}. +} \note{ For a more detailed printed summary for each asset, refer to -\code{print.summary.lm}, which further formats the coefficients, -standard errors, etc. and additionally gives significance -stars if \code{signif.stars} is TRUE. +\code{\link[stats]{summary.lm}} or \code{\link[robustbase]{lmRob}}, which +include F-statistics, Multiple R-squared, Adjusted R-squared and further +format the coefficients, standard errors, etc. and additionally give +significance stars if \code{signif.stars} is TRUE. } \examples{ data(managers.df) @@ -43,7 +61,7 @@ fit.method="OLS", variable.selection="none", add.up.market=TRUE, add.market.sqd=TRUE) # summary of factor model fit for all assets -summary(fit) +summary(fit, "HAC") # summary of lm fit for a single asset summary(fit$asset.fit[[1]]) From noreply at r-forge.r-project.org Thu Jul 3 06:56:05 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Jul 2014 06:56:05 +0200 (CEST) Subject: [Returnanalytics-commits] r3461 - in pkg/FactorAnalytics: R inst/tests man Message-ID: <20140703045605.4911A18769C@r-forge.r-project.org> Author: pragnya Date: 2014-07-03 06:56:04 +0200 (Thu, 03 Jul 2014) New Revision: 3461 Modified: pkg/FactorAnalytics/R/factorModelEsDecomposition.R pkg/FactorAnalytics/R/factorModelVaRDecomposition.R pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/paFM.r pkg/FactorAnalytics/R/plot.pafm.r pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/R/predict.tsfm.r pkg/FactorAnalytics/R/print.pafm.r pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/inst/tests/test-fitTSFM.r pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd pkg/FactorAnalytics/man/paFM.Rd pkg/FactorAnalytics/man/plot.pafm.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd pkg/FactorAnalytics/man/predict.tsfm.Rd pkg/FactorAnalytics/man/print.pafm.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd Log: Edits to examples related to fitTSFM and covFM Modified: pkg/FactorAnalytics/R/factorModelEsDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-03 04:56:04 UTC (rev 3461) @@ -45,7 +45,7 @@ #' \item Epperlein and Smillie (2006) "Cracking VAR with Kernels," Risk. #' } #' @examples -#' +#' \dontrun{ #' data(managers.df) #' fit.macro <- fitTSFM (asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), @@ -76,6 +76,7 @@ #' factorModelEsDecomposition(tmpData, #' fit.fund$beta["STI",], #' fit.fund$resid.variance["STI"], tail.prob=0.05,VaR.method="historical") +#' } #' #' @export #' Modified: pkg/FactorAnalytics/R/factorModelVaRDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-03 04:56:04 UTC (rev 3461) @@ -41,7 +41,7 @@ #' \item Meucci (2007). "Risk Contributions from Generic User-Defined Factors," Risk. #' } #' @examples -#' +#' \dontrun{ #' data(managers.df) #' fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), @@ -55,7 +55,7 @@ #' factor.VaR.decomp.HAM1 = factorModelVaRDecomposition(tmpData, fit.macro$beta[1,], #' fit.macro$resid.sd[1], tail.prob=0.05, #' VaR.method="historical") -#' +#' } #' @export factorModelVaRDecomposition <- function(Data, beta.vec, sig2.e, tail.prob = 0.01, Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 04:56:04 UTC (rev 3461) @@ -223,8 +223,10 @@ # extract the fitted factor models, coefficients, r2 values and residual vol # from returned factor model fits above coef.mat <- makePaddedDataFrame(lapply(reg.list, coef)) - alpha <- coef.mat[, 1, drop = FALSE] - beta <- coef.mat[, -1, drop = FALSE] + alpha <- coef.mat[, 1, drop=FALSE] + # to make class of alpha numeric instead of matrix + # aplha <- coef.mat[,1] + beta <- coef.mat[, -1, drop=FALSE] r2 <- sapply(reg.list, function(x) summary(x)$r.squared) resid.sd <- sapply(reg.list, function(x) summary(x)$sigma) # create list of return values. @@ -474,6 +476,7 @@ unique(unlist(c(sapply(l,names)))))) DF <- as.data.frame(DF) names(DF) <- unique(unlist(c(sapply(l,names)))) + # as.matrix(DF) # if matrix output needed DF } Modified: pkg/FactorAnalytics/R/paFM.r =================================================================== --- pkg/FactorAnalytics/R/paFM.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/paFM.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -30,14 +30,12 @@ #' @seealso \code{\link{fitTSFM}}, \code{\link{fitSFM}}, \code{\link{fitFFM}} #' #' @examples -#' \dontrun{ #' data(managers.df) -#' fit.ts <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), -#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df, fit.method="OLS") +#' fit <- fitTSFM(asset.names=colnames(managers.df[, (1:6)]), +#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' fit.method="OLS", variable.selection="none") #' # without benchmark -#' fm.attr <- paFM(fit.ts) -#' } +#' fm.attr <- paFM(fit) #' #' @export #' @@ -71,7 +69,7 @@ # active portfolio management p.512 17A.9 # top-down method - cum.ret <- Return.cumulative(actual.xts) + cum.ret <- Return.cumulative(actual.xts) # setup initial value attr.ret.xts.all <- xts(, as.Date(date)) @@ -95,7 +93,7 @@ spec.ret.xts <- actual.xts - xts(as.matrix(fit.lm$model[, -1])%*%as.matrix(fit.lm$coef[-1]), as.Date(date)) - cum.spec.ret[k] <- cum.ret - Return.cumulative(actual.xts - spec.ret.xts) + cum.spec.ret[k,1] <- cum.ret - Return.cumulative(actual.xts - spec.ret.xts) attr.list[[k]] <- merge(attr.ret.xts.all, spec.ret.xts) colnames(attr.list[[k]]) <- c(factorName, "specific.returns") } Modified: pkg/FactorAnalytics/R/plot.pafm.r =================================================================== --- pkg/FactorAnalytics/R/plot.pafm.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/plot.pafm.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -27,16 +27,17 @@ #' @examples #' \dontrun{ #' data(managers.df) -#' fit.ts <- fitTimeSeriesFactorModel(assets.names=colnames(managers.df[,(1:6)]), -#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df,fit.method="OLS") -#' fm.attr <- paFM(fit.ts) +#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), +#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' fit.method="OLS", variable.selection="none") +#' fm.attr <- paFM(fit) #' # plot all #' plot(fm.attr,legend.loc="topleft",max.show=6) #' dev.off() #' # plot only one assets "HAM1 #' plot(fm.attr,plot.single=TRUE,fundName="HAM1") #' } +#' #' @method plot pafm #' @export #' Modified: pkg/FactorAnalytics/R/plot.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -58,7 +58,8 @@ #' data(managers.df) #' fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df,fit.method="OLS") +#' data=managers.df, fit.method="OLS", +#' variable.selection="none") #' # plot all assets and show only the first 4 assets. #' plot(fit.macro,max.show=4) #' # plot of an individual asset, "HAM1" @@ -373,7 +374,7 @@ }, "4L" = { - cov.fm<- factorModelCovariance(x$beta,cov.factors,x$resid.variance) + cov.fm<- covFM(x) cor.fm = cov2cor(cov.fm) rownames(cor.fm) = colnames(cor.fm) ord <- order(cor.fm[1,]) Modified: pkg/FactorAnalytics/R/predict.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -24,8 +24,8 @@ #' ret.assets = managers.df[,(1:6)] #' # fit the factor model with OLS #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df, fit.method="OLS") +#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' fit.method="OLS", variable.selection="none") #' #' pred.fit <- predict(fit) #' newdata <- data.frame(EDHEC.LS.EQ = rnorm(n=120), SP500.TR = rnorm(n=120) ) Modified: pkg/FactorAnalytics/R/print.pafm.r =================================================================== --- pkg/FactorAnalytics/R/print.pafm.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/print.pafm.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -8,17 +8,15 @@ #' @param ... Other arguments for \code{print} methods. #' @author Yi-An Chen. #' @examples -#' \dontrun{ #' # load data from the database #' data(managers.df) -#' # fit the factor model with OLS -#' fit.ts <- fitTimeSeriesFactorModel(assets.names=colnames(managers.df[,(1:6)]), -#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df,fit.method="OLS") -#' -#' fm.attr <- paFM(fit.ts) -#' print(fm.attr) -#' } +#' # fit the factor model with OLS +#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), +#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' fit.method="OLS", variable.selection="none") +#' fm.attr <- paFM(fit) +#' print(fm.attr) +#' #' @method print pafm #' @export #' Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -31,7 +31,7 @@ #' or \code{lars}) for each asset in the factor model.} #' #' @note For a more detailed printed summary for each asset, refer to -#' \code{\link[stats]{summary.lm}} or \code{\link[robustbase]{lmRob}}, which +#' \code{\link[stats]{summary.lm}} or \code{\link[robust]{lmRob}}, which #' include F-statistics, Multiple R-squared, Adjusted R-squared and further #' format the coefficients, standard errors, etc. and additionally give #' significance stars if \code{signif.stars} is TRUE. @@ -72,9 +72,9 @@ # convert to HC/HAC standard errors and t-stats if specified for (i in object$asset.names) { if (se.type == "HC") { - sum[[i]]$coefficients <- coeftest(fit$asset.fit[[i]], vcovHC)[,1:4] + sum[[i]]$coefficients <- coeftest(object$asset.fit[[i]], vcovHC)[,1:4] } else if (se.type == "HAC") { - sum[[i]]$coefficients <- coeftest(fit$asset.fit[[i]], vcovHAC)[,1:4] + sum[[i]]$coefficients <- coeftest(object$asset.fit[[i]], vcovHAC)[,1:4] } } Modified: pkg/FactorAnalytics/inst/tests/test-fitTSFM.r =================================================================== --- pkg/FactorAnalytics/inst/tests/test-fitTSFM.r 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/inst/tests/test-fitTSFM.r 2014-07-03 04:56:04 UTC (rev 3461) @@ -25,7 +25,7 @@ fit.method = "OLS", variable.selection="none") - expect_that(ff.mod$beta,is_equivalent_to(t(coef(ff4)[-1,]))) + expect_that(as.matrix(ff.mod$beta),is_equivalent_to(t(coef(ff4)[-1,]))) expect_that(as.numeric(ff.mod$r2),equals(as.numeric(sapply(X = sum4, FUN = "[", "r.squared")))) }) Modified: pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd =================================================================== --- pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -50,6 +50,7 @@ theorem:\cr \code{ES.fm = sum(cES.fm) = sum(beta.star*mES.fm)} \cr } \examples{ +\dontrun{ data(managers.df) fit.macro <- fitTSFM (asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), @@ -81,6 +82,7 @@ fit.fund$beta["STI",], fit.fund$resid.variance["STI"], tail.prob=0.05,VaR.method="historical") } +} \author{ Eric Zviot and Yi-An Chen. } Modified: pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd =================================================================== --- pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -48,6 +48,7 @@ theorem:\cr \code{VaR.fm = sum(cVaR.fm) = sum(beta.star*mVaR.fm)} \cr } \examples{ +\dontrun{ data(managers.df) fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), @@ -62,6 +63,7 @@ fit.macro$resid.sd[1], tail.prob=0.05, VaR.method="historical") } +} \author{ Eric Zivot and Yi-An Chen } Modified: pkg/FactorAnalytics/man/paFM.Rd =================================================================== --- pkg/FactorAnalytics/man/paFM.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/paFM.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -33,15 +33,13 @@ returns is \code{u_t}. } \examples{ -\dontrun{ data(managers.df) -fit.ts <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), - factors.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df, fit.method="OLS") +fit <- fitTSFM(asset.names=colnames(managers.df[, (1:6)]), + factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + fit.method="OLS", variable.selection="none") # without benchmark -fm.attr <- paFM(fit.ts) +fm.attr <- paFM(fit) } -} \author{ Yi-An Chen and Sangeetha Srinivasan } Modified: pkg/FactorAnalytics/man/plot.pafm.Rd =================================================================== --- pkg/FactorAnalytics/man/plot.pafm.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/plot.pafm.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -42,10 +42,10 @@ \examples{ \dontrun{ data(managers.df) -fit.ts <- fitTimeSeriesFactorModel(assets.names=colnames(managers.df[,(1:6)]), - factors.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df,fit.method="OLS") - fm.attr <- paFM(fit.ts) +fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), + factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + fit.method="OLS", variable.selection="none") +fm.attr <- paFM(fit) # plot all plot(fm.attr,legend.loc="topleft",max.show=6) dev.off() Modified: pkg/FactorAnalytics/man/plot.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -73,7 +73,8 @@ data(managers.df) fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df,fit.method="OLS") + data=managers.df, fit.method="OLS", + variable.selection="none") # plot all assets and show only the first 4 assets. plot(fit.macro,max.show=4) # plot of an individual asset, "HAM1" Modified: pkg/FactorAnalytics/man/predict.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/predict.tsfm.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/predict.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -29,8 +29,8 @@ ret.assets = managers.df[,(1:6)] # fit the factor model with OLS fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), - factor.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df, fit.method="OLS") + factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + fit.method="OLS", variable.selection="none") pred.fit <- predict(fit) newdata <- data.frame(EDHEC.LS.EQ = rnorm(n=120), SP500.TR = rnorm(n=120) ) Modified: pkg/FactorAnalytics/man/print.pafm.Rd =================================================================== --- pkg/FactorAnalytics/man/print.pafm.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/print.pafm.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -15,17 +15,14 @@ Generic function of print method for \code{paFM}. } \examples{ -\dontrun{ # load data from the database data(managers.df) - # fit the factor model with OLS - fit.ts <- fitTimeSeriesFactorModel(assets.names=colnames(managers.df[,(1:6)]), - factors.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df,fit.method="OLS") - - fm.attr <- paFM(fit.ts) - print(fm.attr) - } +# fit the factor model with OLS +fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), + factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + fit.method="OLS", variable.selection="none") +fm.attr <- paFM(fit) +print(fm.attr) } \author{ Yi-An Chen. Modified: pkg/FactorAnalytics/man/summary.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 00:08:53 UTC (rev 3460) +++ pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) @@ -48,7 +48,7 @@ } \note{ For a more detailed printed summary for each asset, refer to -\code{\link[stats]{summary.lm}} or \code{\link[robustbase]{lmRob}}, which +\code{\link[stats]{summary.lm}} or \code{\link[robust]{lmRob}}, which include F-statistics, Multiple R-squared, Adjusted R-squared and further format the coefficients, standard errors, etc. and additionally give significance stars if \code{signif.stars} is TRUE. From noreply at r-forge.r-project.org Thu Jul 3 16:09:02 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Jul 2014 16:09:02 +0200 (CEST) Subject: [Returnanalytics-commits] r3462 - in pkg/FactorAnalytics: R inst/tests man vignettes Message-ID: <20140703140902.2A45C180016@r-forge.r-project.org> Author: pragnya Date: 2014-07-03 16:09:01 +0200 (Thu, 03 Jul 2014) New Revision: 3462 Modified: pkg/FactorAnalytics/R/covFM.r pkg/FactorAnalytics/R/factorModelEsDecomposition.R pkg/FactorAnalytics/R/factorModelMonteCarlo.R pkg/FactorAnalytics/R/factorModelVaRDecomposition.R pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/paFM.r pkg/FactorAnalytics/R/plot.pafm.r pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/R/predict.tsfm.r pkg/FactorAnalytics/R/print.pafm.r pkg/FactorAnalytics/R/print.tsfm.r pkg/FactorAnalytics/R/summary.pafm.r pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/inst/tests/test-fitTSFM.r pkg/FactorAnalytics/man/covFM.Rd pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd pkg/FactorAnalytics/man/factorModelMonteCarlo.Rd pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/paFM.Rd pkg/FactorAnalytics/man/plot.pafm.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd pkg/FactorAnalytics/man/predict.tsfm.Rd pkg/FactorAnalytics/man/print.pafm.Rd pkg/FactorAnalytics/man/print.tsfm.Rd pkg/FactorAnalytics/man/summary.pafm.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd pkg/FactorAnalytics/vignettes/fundamentalFM.Rnw Log: Market-timing factors made default for all methods in fitTSFM Modified: pkg/FactorAnalytics/R/covFM.r =================================================================== --- pkg/FactorAnalytics/R/covFM.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/covFM.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -41,7 +41,7 @@ #' factors = managers.df[, (7:9)] #' fit <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), #' factors.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, -#' fit.method="OLS") +#' add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS") #' covFM(fit) #' #' # Statistical Factor Model Modified: pkg/FactorAnalytics/R/factorModelEsDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-03 14:09:01 UTC (rev 3462) @@ -50,6 +50,7 @@ #' fit.macro <- fitTSFM (asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), #' data=managers.df, fit.method="OLS", +#' add.up.market=FALSE, add.market.sqd=FALSE, #' variable.selection="none") #' # risk factor contribution to ETL #' # combine fund returns, factor returns and residual returns for HAM1 Modified: pkg/FactorAnalytics/R/factorModelMonteCarlo.R =================================================================== --- pkg/FactorAnalytics/R/factorModelMonteCarlo.R 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/factorModelMonteCarlo.R 2014-07-03 14:09:01 UTC (rev 3462) @@ -53,8 +53,8 @@ #' data(managers.df) #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df,fit.method="OLS", -#' variable.selection="none") +#' data=managers.df, add.up.market=FALSE, add.market.sqd=FALSE, +#' fit.method="OLS", variable.selection="none") #' factorData= managers.df[,c("EDHEC.LS.EQ","SP500.TR")] #' Beta.mat=fit$beta #' residualData=as.matrix((fit$resid.sd)^2,1,6) Modified: pkg/FactorAnalytics/R/factorModelVaRDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-03 14:09:01 UTC (rev 3462) @@ -45,7 +45,8 @@ #' data(managers.df) #' fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df,fit.method="OLS", +#' add.up.market=FALSE, add.market.sqd=FALSE, +#' data=managers.df, fit.method="OLS", #' variable.selection="none") #' # risk factor contribution to VaR #' # combine fund returns, factor returns and residual returns for HAM1 Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 14:09:01 UTC (rev 3462) @@ -22,21 +22,18 @@ #' using \code{\link[leaps]{regsubsets}} that chooses the n-best performing #' subsets of any given size (specified as \code{num.factor.subsets} here). #' "lar" and "lasso" correspond to variants of least angle regression using -#' \code{\link[lars]{lars}}. If "lar" or "lasso" are chosen, \code{fit.method} -#' will be ignored. +#' \code{\link[lars]{lars}}. #' #' Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} -#' will be ignored. And, \code{fit.method="Robust"} is not truly available with -#' \code{variable.selection="all subsets"}; instead, -#' \code{variable.selection="none"} is used to include all factors. +#' will be ignored. #' -#' If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in the -#' regression, following Henriksson & Merton (1981), to account for market +#' If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in +#' the regression, following Henriksson & Merton (1981), to account for market #' timing (price movement of the general stock market relative to fixed income #' securities). The coefficient can be interpreted as the number of free put -#' options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added as -#' a factor in the regression, following Treynor-Mazuy (1966), to account for -#' market timing with respect to volatility. +#' options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added +#' as a factor in the regression, following Treynor-Mazuy (1966), to account +#' for market timing with respect to volatility. #' #' Finally, for both the "lar" and "lasso" methods, the "Cp" statistic #' (defined in page 17 of Efron et al. (2002)) is calculated using @@ -69,10 +66,10 @@ #' an option for "all subsets" variable selection. Default is 1. #' Note: nvmax >= num.factors.subset >= length(force.in). #' @param add.up.market logical; If \code{TRUE}, adds max(0, Rm-Rf) as a -#' regressor and \code{market.name} is also required. Default is \code{FALSE}. +#' regressor and \code{market.name} is also required. Default is \code{TRUE}. #' See Details. #' @param add.market.sqd logical; If \code{TRUE}, adds (Rm-Rf)^2 as a -#' regressor and \code{market.name} is also required. Default is \code{FALSE}. +#' regressor and \code{market.name} is also required. Default is \code{TRUE}. #' @param decay a scalar in (0, 1] to specify the decay factor for #' \code{fit.method="DLS"}. Default is 0.95. #' @param lars.criterion an option to assess model selection for the "lar" or @@ -148,6 +145,7 @@ #' data(managers.df) #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' add.up.market=FALSE, add.market.sqd=FALSE, #' fit.method="OLS", variable.selection="none") #' # summary of HAM1 #' summary(fit$asset.fit$HAM1) @@ -169,7 +167,7 @@ subsets.method = c("exhaustive", "backward", "forward", "seqrep"), nvmax=8, force.in=NULL, num.factors.subset=1, - add.up.market=FALSE, add.market.sqd=FALSE, + add.up.market=TRUE, add.market.sqd=TRUE, decay=0.95, lars.criterion="Cp", ...){ # get all the arguments specified by their full names @@ -285,19 +283,12 @@ for (i in asset.names){ # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) + # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 + reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, + add.up.market, add.market.sqd) # formula to pass to lm or lmRob fm.formula <- as.formula(paste(i," ~ .")) - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - if(fit.method=="Robust" && (add.up.market==TRUE | add.market.sqd==TRUE)) { - stop("This function does not support add.up.market/add.market.sqd when - variable.selection = 'stepwise' && fit.method = 'Robust'. Please - choose a different combination of options.") - } else { - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) - } - # fit based on time series regression method chosen if (fit.method == "OLS") { reg.list[[i]] <- step(lm(fm.formula, data=reg.xts), direction=direction, @@ -332,49 +323,44 @@ # loop through and estimate model for each asset to allow unequal histories for (i in asset.names){ - # formula to pass to lm or lmRob - fm.formula <- as.formula(paste(i," ~ .")) - # branch out based on time series regression method chosen - if (fit.method == "Robust") { - warning("'Robust' fit.method is not available with 'all subsets' - variable.selection. Instead, results are shown for - variable.selection='none' with fit.method='Robust' to include - all factors.") + # choose best subset of factors depending on specified number of factors + if (num.factors.subset == length(force.in)) { + reg.xts <- na.omit(dat.xts[, c(i, force.in)]) + } else if (num.factors.subset > length(force.in)) { reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) + # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, add.up.market, add.market.sqd) - asset.fit <- lmRob(fm.formula, data=reg.xts) - } - else if (fit.method == "OLS" | fit.method == "DLS") { + # formula to pass to lm or lmRob + fm.formula <- as.formula(paste(i," ~ .")) + + if (fit.method != "DLS") {decay <- 1} + # do weighted least squares if "DLS" + w <- WeightsDLS(nrow(reg.xts), decay) + # use regsubsets to find the best model with a subset of factors of size # num.factors.subset - - if (num.factors.subset == length(force.in)) { - reg.xts <- na.omit(dat.xts[, c(i, force.in)]) - } else if (num.factors.subset > length(force.in)) { - reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - if (fit.method != "DLS") {decay <- 1} - # do weighted least squares if "DLS" - w <- WeightsDLS(nrow(reg.xts), decay) - fm.subsets <- regsubsets(fm.formula, data=reg.xts, nvmax=nvmax, - force.in=force.in, method=subsets.method, - weights=w) - sum.sub <- summary(fm.subsets) - reg.xts <- na.omit(dat.xts[,c(i,names(which(sum.sub$which[ - as.character(num.factors.subset),-1]==TRUE)))]) - } else { - stop("Invalid Argument: num.factors.subset should be >= + fm.subsets <- regsubsets(fm.formula, data=reg.xts, nvmax=nvmax, + force.in=force.in, method=subsets.method, + weights=w) + sum.sub <- summary(fm.subsets) + reg.xts <- na.omit(dat.xts[,c(i,names(which(sum.sub$which[ + as.character(num.factors.subset),-1]==TRUE)))]) + } else { + stop("Invalid Argument: num.factors.subset should be >= length(force.in)") - } - - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) - # fit linear regression model for the factors chosen - reg.list[[i]] <- lm(fm.formula, data=reg.xts, weights=w) } - else { + + # fit based on time series regression method chosen + if (fit.method == "OLS") { + reg.list[[i]] <- lm(fm.formula, data=reg.xts) + } else if (fit.method == "DLS") { + w <- WeightsDLS(nrow(reg.xts), decay) + reg.list[[i]] <- lm(fm.formula, data=reg.xts, weights=w) + } else if (fit.method == "Robust") { + reg.list[[i]] <- lmRob(fm.formula, data=reg.xts) + } else { stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") } } @@ -473,7 +459,7 @@ # makePaddedDataFrame <- function(l){ DF <- do.call(rbind, lapply(lapply(l, unlist), "[", - unique(unlist(c(sapply(l,names)))))) + unique(unlist(c(sapply(l,names)))))) DF <- as.data.frame(DF) names(DF) <- unique(unlist(c(sapply(l,names)))) # as.matrix(DF) # if matrix output needed @@ -482,7 +468,7 @@ #' @param object a fit object of class \code{tsfm} which is returned by #' \code{fitTSFM} - + #' @rdname fitTSFM #' @method coef tsfm #' @export @@ -550,9 +536,9 @@ cov.fm = beta %*% factor.cov %*% t(beta) + D.e -# if (any(diag(chol(cov.fm)) == 0)) { -# warning("Covariance matrix is not positive definite!") -# } + # if (any(diag(chol(cov.fm)) == 0)) { + # warning("Covariance matrix is not positive definite!") + # } return(cov.fm) } Modified: pkg/FactorAnalytics/R/paFM.r =================================================================== --- pkg/FactorAnalytics/R/paFM.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/paFM.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -33,6 +33,7 @@ #' data(managers.df) #' fit <- fitTSFM(asset.names=colnames(managers.df[, (1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' add.up.market=FALSE, add.market.sqd=FALSE, #' fit.method="OLS", variable.selection="none") #' # without benchmark #' fm.attr <- paFM(fit) Modified: pkg/FactorAnalytics/R/plot.pafm.r =================================================================== --- pkg/FactorAnalytics/R/plot.pafm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/plot.pafm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -29,6 +29,7 @@ #' data(managers.df) #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' add.up.market=FALSE, add.market.sqd=FALSE, #' fit.method="OLS", variable.selection="none") #' fm.attr <- paFM(fit) #' # plot all Modified: pkg/FactorAnalytics/R/plot.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -59,6 +59,7 @@ #' fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), #' data=managers.df, fit.method="OLS", +#' add.up.market=FALSE, add.market.sqd=FALSE, #' variable.selection="none") #' # plot all assets and show only the first 4 assets. #' plot(fit.macro,max.show=4) Modified: pkg/FactorAnalytics/R/predict.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/predict.tsfm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -25,6 +25,7 @@ #' # fit the factor model with OLS #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' add.up.market=FALSE, add.market.sqd=FALSE, #' fit.method="OLS", variable.selection="none") #' #' pred.fit <- predict(fit) Modified: pkg/FactorAnalytics/R/print.pafm.r =================================================================== --- pkg/FactorAnalytics/R/print.pafm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/print.pafm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -13,6 +13,7 @@ #' # fit the factor model with OLS #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, +#' add.up.market=FALSE, add.market.sqd=FALSE, #' fit.method="OLS", variable.selection="none") #' fm.attr <- paFM(fit) #' print(fm.attr) Modified: pkg/FactorAnalytics/R/print.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/print.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/print.tsfm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -17,9 +17,8 @@ #' data(managers.df) #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=colnames(managers.df[,7:9]), -#' market.name="SP500.TR", -#' data=managers.df, fit.method="OLS", variable.selection="none", -#' add.up.market=TRUE, add.market.sqd=TRUE) +#' market.name="SP500.TR", data=managers.df, +#' fit.method="OLS", variable.selection="none") #' print(fit) #' #' @method print tsfm Modified: pkg/FactorAnalytics/R/summary.pafm.r =================================================================== --- pkg/FactorAnalytics/R/summary.pafm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/summary.pafm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -14,8 +14,8 @@ #' # fit the factor model with OLS #' fit.ts <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df, fit.method="OLS", -#' variable.selection="none") +#' market.name="SP500.TR", data=managers.df, +#' fit.method="OLS", variable.selection="none") #' #' fm.attr <- paFM(fit.ts) #' summary(fm.attr) Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -45,8 +45,8 @@ #' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), #' factor.names=colnames(managers.df[,7:9]), #' market.name="SP500.TR", data=managers.df, -#' fit.method="OLS", variable.selection="none", -#' add.up.market=TRUE, add.market.sqd=TRUE) +#' fit.method="OLS", variable.selection="none") +#' #' # summary of factor model fit for all assets #' summary(fit, "HAC") #' Modified: pkg/FactorAnalytics/inst/tests/test-fitTSFM.r =================================================================== --- pkg/FactorAnalytics/inst/tests/test-fitTSFM.r 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/inst/tests/test-fitTSFM.r 2014-07-03 14:09:01 UTC (rev 3462) @@ -21,6 +21,7 @@ ff.mod <- fitTSFM( asset.names = assets, factor.names = c("mktrf","smb", "hml","umd"), + add.up.market=FALSE, add.market.sqd=FALSE, data = cbind(ex.rets,carhart), fit.method = "OLS", variable.selection="none") Modified: pkg/FactorAnalytics/man/covFM.Rd =================================================================== --- pkg/FactorAnalytics/man/covFM.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/covFM.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -40,7 +40,7 @@ factors = managers.df[, (7:9)] fit <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), factors.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, - fit.method="OLS") + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS") covFM(fit) # Statistical Factor Model Modified: pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd =================================================================== --- pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -55,6 +55,7 @@ fit.macro <- fitTSFM (asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, fit.method="OLS", + add.up.market=FALSE, add.market.sqd=FALSE, variable.selection="none") # risk factor contribution to ETL # combine fund returns, factor returns and residual returns for HAM1 Modified: pkg/FactorAnalytics/man/factorModelMonteCarlo.Rd =================================================================== --- pkg/FactorAnalytics/man/factorModelMonteCarlo.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/factorModelMonteCarlo.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -72,8 +72,8 @@ data(managers.df) fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df,fit.method="OLS", - variable.selection="none") + data=managers.df, add.up.market=FALSE, add.market.sqd=FALSE, + fit.method="OLS", variable.selection="none") factorData= managers.df[,c("EDHEC.LS.EQ","SP500.TR")] Beta.mat=fit$beta residualData=as.matrix((fit$resid.sd)^2,1,6) Modified: pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd =================================================================== --- pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -52,7 +52,8 @@ data(managers.df) fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df,fit.method="OLS", + add.up.market=FALSE, add.market.sqd=FALSE, + data=managers.df, fit.method="OLS", variable.selection="none") # risk factor contribution to VaR # combine fund returns, factor returns and residual returns for HAM1 Modified: pkg/FactorAnalytics/man/fitTSFM.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -11,7 +11,7 @@ fit.method = c("OLS", "DLS", "Robust"), variable.selection = c("none", "stepwise", "all subsets", "lar", "lasso"), subsets.method = c("exhaustive", "backward", "forward", "seqrep"), nvmax = 8, force.in = NULL, - num.factors.subset = 1, add.up.market = FALSE, add.market.sqd = FALSE, + num.factors.subset = 1, add.up.market = TRUE, add.market.sqd = TRUE, decay = 0.95, lars.criterion = "Cp", ...) \method{coef}{tsfm}(object, ...) @@ -58,11 +58,11 @@ Note: nvmax >= num.factors.subset >= length(force.in).} \item{add.up.market}{logical; If \code{TRUE}, adds max(0, Rm-Rf) as a -regressor and \code{market.name} is also required. Default is \code{FALSE}. +regressor and \code{market.name} is also required. Default is \code{TRUE}. See Details.} \item{add.market.sqd}{logical; If \code{TRUE}, adds (Rm-Rf)^2 as a -regressor and \code{market.name} is also required. Default is \code{FALSE}.} +regressor and \code{market.name} is also required. Default is \code{TRUE}.} \item{decay}{a scalar in (0, 1] to specify the decay factor for \code{fit.method="DLS"}. Default is 0.95.} @@ -134,21 +134,18 @@ using \code{\link[leaps]{regsubsets}} that chooses the n-best performing subsets of any given size (specified as \code{num.factor.subsets} here). "lar" and "lasso" correspond to variants of least angle regression using -\code{\link[lars]{lars}}. If "lar" or "lasso" are chosen, \code{fit.method} -will be ignored. +\code{\link[lars]{lars}}. Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} -will be ignored. And, \code{fit.method="Robust"} is not truly available with -\code{variable.selection="all subsets"}; instead, -\code{variable.selection="none"} is used to include all factors. +will be ignored. -If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in the -regression, following Henriksson & Merton (1981), to account for market +If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in +the regression, following Henriksson & Merton (1981), to account for market timing (price movement of the general stock market relative to fixed income securities). The coefficient can be interpreted as the number of free put -options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added as -a factor in the regression, following Treynor-Mazuy (1966), to account for -market timing with respect to volatility. +options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added +as a factor in the regression, following Treynor-Mazuy (1966), to account +for market timing with respect to volatility. Finally, for both the "lar" and "lasso" methods, the "Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated using @@ -161,6 +158,7 @@ data(managers.df) fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS", variable.selection="none") # summary of HAM1 summary(fit$asset.fit$HAM1) Modified: pkg/FactorAnalytics/man/paFM.Rd =================================================================== --- pkg/FactorAnalytics/man/paFM.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/paFM.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -36,6 +36,7 @@ data(managers.df) fit <- fitTSFM(asset.names=colnames(managers.df[, (1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS", variable.selection="none") # without benchmark fm.attr <- paFM(fit) Modified: pkg/FactorAnalytics/man/plot.pafm.Rd =================================================================== --- pkg/FactorAnalytics/man/plot.pafm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/plot.pafm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -44,6 +44,7 @@ data(managers.df) fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS", variable.selection="none") fm.attr <- paFM(fit) # plot all Modified: pkg/FactorAnalytics/man/plot.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -74,6 +74,7 @@ fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, fit.method="OLS", + add.up.market=FALSE, add.market.sqd=FALSE, variable.selection="none") # plot all assets and show only the first 4 assets. plot(fit.macro,max.show=4) Modified: pkg/FactorAnalytics/man/predict.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/predict.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/predict.tsfm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -30,6 +30,7 @@ # fit the factor model with OLS fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS", variable.selection="none") pred.fit <- predict(fit) Modified: pkg/FactorAnalytics/man/print.pafm.Rd =================================================================== --- pkg/FactorAnalytics/man/print.pafm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/print.pafm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -20,6 +20,7 @@ # fit the factor model with OLS fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, + add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS", variable.selection="none") fm.attr <- paFM(fit) print(fm.attr) Modified: pkg/FactorAnalytics/man/print.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/print.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/print.tsfm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -22,9 +22,8 @@ data(managers.df) fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=colnames(managers.df[,7:9]), - market.name="SP500.TR", - data=managers.df, fit.method="OLS", variable.selection="none", - add.up.market=TRUE, add.market.sqd=TRUE) + market.name="SP500.TR", data=managers.df, + fit.method="OLS", variable.selection="none") print(fit) } \author{ Modified: pkg/FactorAnalytics/man/summary.pafm.Rd =================================================================== --- pkg/FactorAnalytics/man/summary.pafm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/summary.pafm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -22,8 +22,8 @@ # fit the factor model with OLS fit.ts <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=c("EDHEC.LS.EQ","SP500.TR"), - data=managers.df, fit.method="OLS", - variable.selection="none") + market.name="SP500.TR", data=managers.df, + fit.method="OLS", variable.selection="none") fm.attr <- paFM(fit.ts) summary(fm.attr) Modified: pkg/FactorAnalytics/man/summary.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 14:09:01 UTC (rev 3462) @@ -58,8 +58,8 @@ fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), factor.names=colnames(managers.df[,7:9]), market.name="SP500.TR", data=managers.df, - fit.method="OLS", variable.selection="none", - add.up.market=TRUE, add.market.sqd=TRUE) + fit.method="OLS", variable.selection="none") + # summary of factor model fit for all assets summary(fit, "HAC") Modified: pkg/FactorAnalytics/vignettes/fundamentalFM.Rnw =================================================================== --- pkg/FactorAnalytics/vignettes/fundamentalFM.Rnw 2014-07-03 04:56:04 UTC (rev 3461) +++ pkg/FactorAnalytics/vignettes/fundamentalFM.Rnw 2014-07-03 14:09:01 UTC (rev 3462) @@ -283,7 +283,7 @@ In this example, we will use SP500, 10 years and 3 months term spread and difference of VIX as our common factors. <>= -fit.time <- fitTSFM (asset.names=tic, +fit.time <- fitTSFM (asset.names=tic, market.name="SP500", factor.names=c("SP500","Term.Spread","dVIX"), data=ts.data, fit.method="OLS", variable.selection="none") @@ -299,7 +299,7 @@ <>= fit.time2 <- fitTSFM(asset.names=tic, factor.names=names(ts.factors), - data=ts.data, fit.method="OLS", + data=ts.data, market.name="SP500", fit.method="OLS", variable.selection = "stepwise") @ There are 5 factors chosen for asset AA for example. From noreply at r-forge.r-project.org Thu Jul 3 23:18:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 3 Jul 2014 23:18:41 +0200 (CEST) Subject: [Returnanalytics-commits] r3463 - pkg/PortfolioAnalytics Message-ID: <20140703211841.3FEC01855E9@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-03 23:18:40 +0200 (Thu, 03 Jul 2014) New Revision: 3463 Modified: pkg/PortfolioAnalytics/DESCRIPTION Log: Adding nloptr to DESCRIPTION file Modified: pkg/PortfolioAnalytics/DESCRIPTION =================================================================== --- pkg/PortfolioAnalytics/DESCRIPTION 2014-07-03 14:09:01 UTC (rev 3462) +++ pkg/PortfolioAnalytics/DESCRIPTION 2014-07-03 21:18:40 UTC (rev 3463) @@ -29,6 +29,7 @@ pso, GenSA, corpcor, - testthat + testthat, + nloptr (>= 1.0.0) License: GPL Copyright: (c) 2004-2014 From noreply at r-forge.r-project.org Fri Jul 4 00:13:53 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 4 Jul 2014 00:13:53 +0200 (CEST) Subject: [Returnanalytics-commits] r3464 - in pkg/PerformanceAnalytics: . R sandbox src Message-ID: <20140703221354.0019718473D@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-04 00:13:53 +0200 (Fri, 04 Jul 2014) New Revision: 3464 Added: pkg/PerformanceAnalytics/sandbox/testMM.R pkg/PerformanceAnalytics/src/ pkg/PerformanceAnalytics/src/momentF.f90 Modified: pkg/PerformanceAnalytics/NAMESPACE pkg/PerformanceAnalytics/R/MultivariateMoments.R Log: Adding compiled M3 and M4 functions Modified: pkg/PerformanceAnalytics/NAMESPACE =================================================================== --- pkg/PerformanceAnalytics/NAMESPACE 2014-07-03 21:18:40 UTC (rev 3463) +++ pkg/PerformanceAnalytics/NAMESPACE 2014-07-03 22:13:53 UTC (rev 3464) @@ -234,3 +234,4 @@ importFrom(stats,sd) importFrom(utils,packageDescription) importFrom(zoo,rollapply) +useDynLib(PerformanceAnalytics) Modified: pkg/PerformanceAnalytics/R/MultivariateMoments.R =================================================================== --- pkg/PerformanceAnalytics/R/MultivariateMoments.R 2014-07-03 21:18:40 UTC (rev 3463) +++ pkg/PerformanceAnalytics/R/MultivariateMoments.R 2014-07-03 22:13:53 UTC (rev 3464) @@ -16,7 +16,7 @@ ############################################################################### -M3.MM = function(R,...){ +M3.MM.old = function(R,...){ cAssets = ncol(R); T = nrow(R); if(!hasArg(mu)) mu = apply(R,2,'mean') else mu=mu=list(...)$mu M3 = matrix(rep(0,cAssets^3),nrow=cAssets,ncol=cAssets^2) @@ -28,7 +28,35 @@ return( 1/T*M3 ); } -M4.MM = function(R,...){ +#'@useDynLib PerformanceAnalytics +M3.MM = function(R, ...){ + if(!hasArg(mu)) mu = colMeans(R) else mu=list(...)$mu + + # Pass variables directly from R to the Fortran subroutine + # Note that we also need to allocate the object that the Fortran subroutine + # returns + # It is ok to allocate objects in R and then pass to the Fortran subroutine + # https://stat.ethz.ch/pipermail/r-devel/2005-September/034570.html + x <- coredata(R) + + nr <- NROW(x) + nc <- NCOL(x) + + CC <- matrix(0, nc*nc, nc) + om <- matrix(0, nc, nc*nc) + + out <- .Fortran("M3", + x=x, + mu=as.double(mu), + nr=as.integer(nr), + nc=as.integer(nc), + C=CC, + om=om, + PACKAGE="PerformanceAnalytics")$om + out +} + +M4.MM.old = function(R,...){ cAssets = ncol(R); T = nrow(R); if(!hasArg(mu)) mu = apply(R,2,'mean') else mu=list(...)$mu M4 = matrix(rep(0,cAssets^4),nrow=cAssets,ncol=cAssets^3); @@ -40,6 +68,33 @@ return( 1/T*M4 ); } +#'@useDynLib PerformanceAnalytics +M4.MM = function(R, ...){ + if(!hasArg(mu)) mu = colMeans(R) else mu=list(...)$mu + + # Pass variables directly from R to the Fortran subroutine + # Note that we also need to allocate the object that the Fortran subroutine + # returns + # It is ok to allocate objects in R and then pass to the Fortran subroutine + # https://stat.ethz.ch/pipermail/r-devel/2005-September/034570.html + x <- coredata(R) + nr <- NROW(x) + nc <- NCOL(x) + + DD <- matrix(0, nc*nc*nc, nc) + om <- matrix(0, nc, nc*nc*nc) + + out <- .Fortran("M4", + x=x, + mu=as.double(mu), + nr=as.integer(nr), + nc=as.integer(nc), + D=DD, + om=om, + PACKAGE="PerformanceAnalytics")$om + out +} + multivariate_mean = function(w,mu){ return( t(w)%*%mu ) } Added: pkg/PerformanceAnalytics/sandbox/testMM.R =================================================================== --- pkg/PerformanceAnalytics/sandbox/testMM.R (rev 0) +++ pkg/PerformanceAnalytics/sandbox/testMM.R 2014-07-03 22:13:53 UTC (rev 3464) @@ -0,0 +1,36 @@ +library(microbenchmark) + +# Test for equality +set.seed(123) +x <- matrix(rnorm(1000 * 5), 1000, 5) + +all.equal(PerformanceAnalytics:::M3.MM(x), PerformanceAnalytics:::M3.MM.old(x)) +all.equal(PerformanceAnalytics:::M4.MM(x), PerformanceAnalytics:::M4.MM.old(x)) + +data(edhec) +all.equal(PerformanceAnalytics:::M3.MM(edhec), PerformanceAnalytics:::M3.MM.old(edhec)) +all.equal(PerformanceAnalytics:::M4.MM(edhec), PerformanceAnalytics:::M4.MM.old(edhec)) + +# Do benchmarks with bigger data set +m <- 100000 +n <- 10 +set.seed(21) +r <- matrix(rnorm(m * n), m, n) + +benchM3 <- microbenchmark( + PerformanceAnalytics:::M3.MM(r), + PerformanceAnalytics:::M3.MM.old(r), + times=10 +) + +benchM3 +plot(benchM3, main="M3 Benchmarks") + +benchM4 <- microbenchmark( + PerformanceAnalytics:::M4.MM(r), + PerformanceAnalytics:::M4.MM.old(r), + times=10 +) + +benchM4 +plot(benchM4, main="M4 Benchmarks") Added: pkg/PerformanceAnalytics/src/momentF.f90 =================================================================== --- pkg/PerformanceAnalytics/src/momentF.f90 (rev 0) +++ pkg/PerformanceAnalytics/src/momentF.f90 2014-07-03 22:13:53 UTC (rev 3464) @@ -0,0 +1,189 @@ + + subroutine asVecCov1(ia, n, oa) + ! compute oa = ia * ia**T and return as an array + + ! ia : input array + ! n : length of input array + ! oa : output array of length n * n + implicit none + + ! input/output variables + integer :: n + double precision :: ia(n), oa(n*n) + + ! local variables + integer :: i, j, ii + + ! element access of a matrix in column major ordering with 1-based index + ! oa(i + (j-1) * n) = ia(i) * ia(j) + + ii = 1 + do j=1,n + do i=1,n + oa(ii) = ia(i) * ia(j) + ii = ii + 1 + end do + end do + + end subroutine asVecCov1 + + subroutine asVec(im, nr, nc, oa) + ! convert matrix to array + ! reshape might be more efficient? + + ! ia : input matrix + ! nr : number of rows of im + ! nc : number of columns of im + ! oa : output array of length nr * nc + implicit none + + ! input/output variables + integer :: nr, nc + double precision :: im(nr,nc), oa(nr * nc) + + ! local variables + integer :: i, j + + ! element access of a matrix in column major ordering with 1-based index + ! oa(i + (j-1) * n) = im(i,j) + + do j=1,nc + do i=1,nr + oa(i + (j-1) * nr) = im(i,j) + end do + end do + + end subroutine asVec + + subroutine M3(x, mu, nr, nc, C, om) + ! compute the third moment of x + + ! x : input matrix of data + ! mu : vector of means to center x + ! nr : number of rows of x + ! nc : number of columns of x + ! C : temporary matrix of dimension (nc * nc, n) + ! om : output matrix of dimension om(nc, nc * nc) + + implicit none + + ! input/output variables + integer :: nr, nc + double precision :: x(nr, nc), mu(nc), om(nc, nc*nc), C(nc*nc, nc) + + ! local variables + integer :: i + double precision :: alpha, beta + double precision :: centret(nc), tccr(nc * nc) + + alpha = 1.d0 + beta = 1.d0 + + do i=1,nr + centret = x(i,:) - mu + ! the output we care about here is tccr + ! tccr = as.vector(tcrossprod(centret)) + call asVecCov1(centret, nc, tccr) + + ! C = tccr * centret**T + C + ! (nc*nc x 1) * (1 x nc) = (nc*nc x nc) + ! C := alpha*op( A )*op( B ) + beta*C + ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! Note that TRANSB="N". B is just an array, so I specify the dimension + ! of B as 1 x nc with the arguments N, K, and LDB. + call DGEMM('N', 'N', nc*nc, nc, 1, alpha, tccr, nc*nc, centret, 1, beta, C, nc*nc) + end do + + om = transpose(C) / DBLE(nr) + + ! C := alpha*op( A )*op( B ) + beta*C + ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA : 'N' or 'n', op( A ) = A; 'T' or 't', op( A ) = A**T + ! TRANSB : 'N' or 'n', op( B ) = A; 'T' or 't', op( B ) = A**T + ! M : number of rows of the matrix op( A ) and of the matrix C. + ! N : number of columns of the matrix op( B ) and + ! the number of columns of the matrix C. + ! K : number of columns of the matrix op( A ) and the number of + ! rows of the matrix op( B ). + ! ALPHA : specifies the scalar alpha + ! A : array of DIMENSION ( LDA, ka ), where ka is k when + ! TRANSA = 'N' or 'n', and is m otherwise. + ! LDA : the first dimension of A (i.e. number of rows) + ! B : array of DIMENSION ( LDB, kb ), where kb is n when + ! TRANSB = 'N' or 'n', and is k otherwise. + ! LDB : first dimension of B (i.e. number of rows of B) + ! BETA : specifies the scalar alpha + ! C : array of DIMENSION ( LDC, n ) + ! LDC : first dimension of C + + + end subroutine M3 + + subroutine M4(x, mu, nr, nc, D, om) + ! compute the fourth moment of x + + ! x : input matrix of data + ! mu : vector of means to center x + ! nr : number of rows of x + ! nc : number of columns of x + ! D : temporary matrix of dimension (nc * nc * nc, n) + ! om : output matrix of dimension om(nc, nc * nc * nc) + + implicit none + + ! input/output variables + integer :: nr, nc + double precision :: x(nr, nc), mu(nc), om(nc, nc*nc*nc), D(nc*nc*nc, nc) + + ! local variables + integer :: i + double precision :: alpha, beta, beta1 + double precision :: centret(nc), tccr(nc * nc), tccr2(nc * nc * nc), C(nc*nc, nc) + + alpha = 1.d0 + beta = 0.d0 + beta1 = 1.d0 + + do i=1,nr + centret = x(i,:) - mu + ! the output we care about here is tccr + ! tccr is an nc^2 x 1 matrix (i.e. 1-d vector or array) + ! tccr = as.vector(tcrossprod(centret)) + call asVecCov1(centret, nc, tccr) + + ! C = tcrossprod(tccr, centret) + call DGEMM('N', 'N', nc*nc, nc, 1, alpha, tccr, nc*nc, centret, 1, beta, C, nc*nc) + + ! tccr2 is an N^3 x 1 matrix (i.e. 1-d vector or array) + ! convert C to a N^3 array and assign to variable tccr2 + call asVec(C, nc*nc, nc, tccr2) + + ! D = tccr2 * centret**T + D + call DGEMM('N', 'N', nc*nc*nc, nc, 1, alpha, tccr2, nc*nc*nc, centret, 1, beta1, D, nc*nc*nc) + end do + + om = transpose(D) / DBLE(nr) + + ! C := alpha*op( A )*op( B ) + beta*C + ! DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) + ! TRANSA : 'N' or 'n', op( A ) = A; 'T' or 't', op( A ) = A**T + ! TRANSB : 'N' or 'n', op( B ) = A; 'T' or 't', op( B ) = A**T + ! M : number of rows of the matrix op( A ) and of the matrix C. + ! N : number of columns of the matrix op( B ) and + ! the number of columns of the matrix C. + ! K : number of columns of the matrix op( A ) and the number of + ! rows of the matrix op( B ). + ! ALPHA : specifies the scalar alpha + ! A : array of DIMENSION ( LDA, ka ), where ka is k when + ! TRANSA = 'N' or 'n', and is m otherwise. + ! LDA : the first dimension of A (i.e. number of rows) + ! B : array of DIMENSION ( LDB, kb ), where kb is n when + ! TRANSB = 'N' or 'n', and is k otherwise. + ! LDB : first dimension of B (i.e. number of rows of B) + ! BETA : specifies the scalar alpha + ! C : array of DIMENSION ( LDC, n ) + ! LDC : first dimension of C + + + end subroutine M4 + \ No newline at end of file From noreply at r-forge.r-project.org Mon Jul 7 21:34:52 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 7 Jul 2014 21:34:52 +0200 (CEST) Subject: [Returnanalytics-commits] r3465 - in pkg/FactorAnalytics: R man Message-ID: <20140707193452.8145018614D@r-forge.r-project.org> Author: pragnya Date: 2014-07-07 21:34:52 +0200 (Mon, 07 Jul 2014) New Revision: 3465 Modified: pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd Log: Fixed a bug in fitTSFM for xts data objects & selection "lars" Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-03 22:13:53 UTC (rev 3464) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-07 19:34:52 UTC (rev 3465) @@ -46,7 +46,7 @@ #' @param factor.names vector containing names of the macroeconomic factors. #' @param market.name name of the column for market excess returns (Rm-Rf). #' Is required only if \code{add.up.market} or \code{add.market.sqd} -#' are \code{TRUE}. +#' are \code{TRUE}. #' @param data vector, matrix, data.frame, xts, timeSeries or zoo object #' containing column(s) named in \code{asset.names}, \code{factor.names} and #' optionally, \code{market.name}. @@ -65,11 +65,11 @@ #' @param num.factors.subset number of factors required in the factor model; #' an option for "all subsets" variable selection. Default is 1. #' Note: nvmax >= num.factors.subset >= length(force.in). -#' @param add.up.market logical; If \code{TRUE}, adds max(0, Rm-Rf) as a -#' regressor and \code{market.name} is also required. Default is \code{TRUE}. +#' @param add.up.market logical, adds max(0, Rm-Rf) as a factor. If +#' \code{TRUE}, \code{market.name} is required. Default is \code{TRUE}. #' See Details. -#' @param add.market.sqd logical; If \code{TRUE}, adds (Rm-Rf)^2 as a -#' regressor and \code{market.name} is also required. Default is \code{TRUE}. +#' @param add.market.sqd logical, adds (Rm-Rf)^2 as a factor. If \code{TRUE}, +#' \code{market.name} is required. Default is \code{TRUE}. #' @param decay a scalar in (0, 1] to specify the decay factor for #' \code{fit.method="DLS"}. Default is 0.95. #' @param lars.criterion an option to assess model selection for the "lar" or @@ -103,7 +103,7 @@ #' \item{r2}{N x 1 vector of R-squared values.} #' \item{resid.sd}{N x 1 vector of residual standard deviations.} #' \item{call}{the matched function call.} -#' \item{data}{data as input.} +#' \item{data}{xts data object containing the assets and factors.} #' \item{asset.names}{asset.names as input.} #' \item{factor.names}{factor.names as input.} #' \item{fit.method}{fit.method as input.} @@ -172,12 +172,18 @@ # get all the arguments specified by their full names call <- match.call() + + fit.method = fit.method[1] # default is OLS + variable.selection = variable.selection[1] # default is "none" + subsets.method = subsets.method[1] # default is "exhaustive" + if (!exists("direction")) {direction <- "backward"} if (!exists("steps")) {steps <- 1000} if (!exists("k")) {k <- 2} - if (!exists("market.name") && (add.up.market==TRUE | add.market.sqd==TRUE)) { - stop("Missing input: 'market.name' to include factors 'up.market' or - 'market.sqd'") + if ((missing(market.name)|is.null(market.name)) && + (add.up.market==TRUE | add.market.sqd==TRUE)) { + stop("Missing input: 'market.name' is required to include factors + 'up.market' or 'market.sqd'") } # convert data into an xts object and hereafter work with xts objects @@ -185,33 +191,52 @@ # extract columns to be used in the time series regression dat.xts <- merge(data.xts[,asset.names], data.xts[,factor.names]) - if (add.up.market == TRUE | add.market.sqd == TRUE ) { - dat.xts <- merge(dat.xts, data.xts[,market.name]) + ### When merging xts objects, the spaces in names get converted to periods + + # opt add market-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 + if(add.up.market == TRUE) { + up.market <- data.xts[,market.name] + up.market [up.market < 0] <- 0 + dat.xts <- merge.xts(dat.xts,up.market) + colnames(dat.xts)[dim(dat.xts)[2]] <- "up.market" + factor.names <- c(factor.names, "up.market") } + if(add.market.sqd == TRUE) { + market.sqd <- data.xts[,market.name]^2 + dat.xts <- merge(dat.xts, market.sqd) + colnames(dat.xts)[dim(dat.xts)[2]] <- "market.sqd" + factor.names <- c(factor.names, "market.sqd") + } + # spaces get converted to periods in colnames of xts object after merge + asset.names <- gsub(" ",".", asset.names, fixed=TRUE) + factor.names <- gsub(" ",".", factor.names, fixed=TRUE) + # Selects regression procedure based on specified variable.selection method. # Each method returns a list of fitted factor models for each asset. if (variable.selection == "none") { reg.list <- NoVariableSelection(dat.xts, asset.names, factor.names, - market.name, fit.method, add.up.market, - add.market.sqd, decay) + fit.method, add.up.market, add.market.sqd, + decay) } else if (variable.selection == "stepwise"){ reg.list <- SelectStepwise(dat.xts, asset.names, factor.names, - market.name, fit.method, - add.up.market, add.market.sqd, decay, - direction, steps, k) + fit.method, add.up.market, add.market.sqd, + decay, direction, steps, k) } else if (variable.selection == "all subsets"){ reg.list <- SelectAllSubsets(dat.xts, asset.names, factor.names, - market.name, fit.method, subsets.method, + fit.method, subsets.method, nvmax, force.in, num.factors.subset, add.up.market, add.market.sqd, decay) } else if (variable.selection == "lar" | variable.selection == "lasso"){ - result.lars <- SelectLars(dat.xts, asset.names, factor.names, market.name, + result.lars <- SelectLars(dat.xts, asset.names, factor.names, variable.selection, add.up.market, add.market.sqd, decay, lars.criterion) - result.lars <- c(result.lars, call, data, asset.names, factor.names, - fit.method, variable.selection) - return(result.lars) + input <- list(call=call, data=dat.xts, + asset.names=asset.names, factor.names=factor.names, + fit.method=fit.method, variable.selection=variable.selection) + result <- c(result.lars, input) + class(result) <- "tsfm" + return(result) } else { stop("Invalid argument: variable.selection must be either 'none', @@ -229,7 +254,7 @@ resid.sd <- sapply(reg.list, function(x) summary(x)$sigma) # create list of return values. result <- list(asset.fit=reg.list, alpha=alpha, beta=beta, r2=r2, - resid.sd=resid.sd, call=call, data=data, + resid.sd=resid.sd, call=call, data=dat.xts, asset.names=asset.names, factor.names=factor.names, fit.method=fit.method, variable.selection=variable.selection) class(result) <- "tsfm" @@ -239,9 +264,8 @@ ### method variable.selection = "none" # -NoVariableSelection <- function (dat.xts, asset.names, factor.names, - market.name, fit.method, add.up.market, - add.market.sqd, decay){ +NoVariableSelection <- function(dat.xts, asset.names, factor.names, fit.method, + add.up.market, add.market.sqd, decay){ # initialize list object to hold the fitted objects reg.list <- list() @@ -249,9 +273,7 @@ for (i in asset.names){ # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) + # formula to pass to lm or lmRob fm.formula <- as.formula(paste(i," ~ .")) @@ -273,9 +295,9 @@ ### method variable.selection = "stepwise" # -SelectStepwise <- function(dat.xts, asset.names, factor.names, - market.name, fit.method, add.up.market, - add.market.sqd, decay, direction, steps, k){ +SelectStepwise <- function(dat.xts, asset.names, factor.names, fit.method, + add.up.market, add.market.sqd, decay, + direction, steps, k){ # initialize list object to hold the fitted objects reg.list <- list() @@ -283,9 +305,7 @@ for (i in asset.names){ # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) + # formula to pass to lm or lmRob fm.formula <- as.formula(paste(i," ~ .")) @@ -310,14 +330,15 @@ ### method variable.selection = "all subsets" # -SelectAllSubsets <- function(dat.xts, asset.names, factor.names, - market.name, fit.method, subsets.method, - nvmax, force.in, num.factors.subset, - add.up.market, add.market.sqd, decay){ +SelectAllSubsets <- function(dat.xts, asset.names, factor.names, fit.method, + subsets.method, nvmax, force.in, + num.factors.subset, add.up.market, add.market.sqd, + decay){ # Check argument validity if (nvmax < num.factors.subset) { stop("Invaid Argument: nvmax should be >= num.factors.subset") } + # initialize list object to hold the fitted objects reg.list <- list() @@ -329,9 +350,7 @@ reg.xts <- na.omit(dat.xts[, c(i, force.in)]) } else if (num.factors.subset > length(force.in)) { reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) + # formula to pass to lm or lmRob fm.formula <- as.formula(paste(i," ~ .")) @@ -370,9 +389,8 @@ ### method variable.selection = "lar" or "lasso" # -SelectLars <- function(dat.xts, asset.names, factor.names, market.name, - variable.selection, add.up.market, add.market.sqd, - decay, lars.criterion) { +SelectLars <- function(dat.xts, asset.names, factor.names, variable.selection, + add.up.market, add.market.sqd, decay, lars.criterion) { # initialize list object to hold the fitted objects and, vectors and matrices # for the other results asset.fit <- list() @@ -380,19 +398,18 @@ beta <- matrix(NA, length(asset.names), length(factor.names)) r2 <- rep(NA, length(asset.names)) resid.sd <- rep(NA, length(asset.names)) + names(alpha)=names(r2)=names(resid.sd)=rownames(beta)=asset.names + colnames(beta) <- factor.names - # loop through and estimate model for each asset to allow unequal histories for (i in asset.names){ # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # optionally add factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - reg.xts <- MarketFactors(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd) + # convert to matrix reg.mat <- as.matrix(na.omit(reg.xts)) # fit lar or lasso regression model - lars.fit <- lars(reg.mat[,factor.names], reg.mat[,i], + lars.fit <- lars(reg.mat[,-1], reg.mat[,i], type=variable.selection, trace = FALSE) lars.sum <- summary(lars.fit) @@ -410,42 +427,23 @@ # get factor model coefficients & fitted values at the step obtained above coef.lars <- predict(lars.fit, s=s, type="coef", mode="step") - fitted.lars <- predict(lars.fit, reg.xts[,factor.names], s=s, type="fit", + fitted.lars <- predict(lars.fit, reg.xts[,-1], s=s, type="fit", mode="step") # extract and assign the results asset.fit[[i]] = lars.fit alpha[i] <- (fitted.lars$fit - - reg.xts[,factor.names]%*%coef.lars$coefficients)[1] + reg.xts[,-1]%*%coef.lars$coefficients)[1] beta.names <- names(coef.lars$coefficients) - beta[i,beta.names] <- coef.lars$coefficients + beta[i, beta.names] <- coef.lars$coefficients r2[i] <- lars.fit$R2[s] resid.sd[i] <- lars.sum$Rss[s]/(nrow(reg.xts)-s) } - results.lars <- list(asset.fit, alpha, beta, r2, resid.sd) + results.lars <- list(asset.fit=asset.fit, alpha=alpha, beta=beta, r2=r2, + resid.sd=resid.sd) } -### Format and add optional factors "up.market" and "market.sqd" -# -MarketFactors <- function(dat.xts, reg.xts, market.name, - add.up.market, add.market.sqd){ - if(add.up.market == TRUE) { - # up.market = max(0,Rm-Rf) - up.market <- apply(dat.xts[,market.name],1,max,0) - reg.xts <- merge(reg.xts,up.market) - colnames(reg.xts)[dim(reg.xts)[2]] <- "up.market" - } - if(add.market.sqd == TRUE) { - # market.sqd = (Rm-Rf)^2 - market.sqd <- dat.xts[,market.name]^2 - reg.xts <- merge(reg.xts,market.sqd) - colnames(reg.xts)[dim(reg.xts)[2]] <- "market.sqd" - } - reg.xts -} - - ### calculate weights for "DLS" # WeightsDLS <- function(t,d){ Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-03 22:13:53 UTC (rev 3464) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-07 19:34:52 UTC (rev 3465) @@ -9,11 +9,12 @@ #' heteroskedasticity-consistent (HC) or #' heteroskedasticity-autocorrelation-consistent (HAC) standard errors and #' t-statistics using \code{\link[lmtest]{coeftest}}. This option is meaningful -#' only if \code{fit.method = "OLS" or "DLS"}. +#' only if \code{fit.method = "OLS" or "DLS"}. This option is currently not +#' available for \code{variable.selection = "lar" or "lasso"}. #' #' @param object an object of class \code{tsfm} returned by \code{fitTSFM}. #' @param se.type one of "Default", "HC" or "HAC"; option for computing -#' HC/HAC standard errors and t-statistics. +#' HC/HAC standard errors and t-statistics. #' @param x an object of class \code{summary.tsfm}. #' @param digits number of significants digits to use when printing. #' Default is 3. @@ -70,6 +71,7 @@ sum <- lapply(object$asset.fit, summary) # convert to HC/HAC standard errors and t-stats if specified + # extract coefficients separately for "lars" variable.selection method for (i in object$asset.names) { if (se.type == "HC") { sum[[i]]$coefficients <- coeftest(object$asset.fit[[i]], vcovHC)[,1:4] @@ -78,8 +80,19 @@ } } + if (object$variable.selection=="lar" | object$variable.selection=="lasso") { + sum <- list() + for (i in object$asset.names) { + sum[[i]]$coefficients <- as.matrix(c(object$alpha[i], object$beta[i,])) + rownames(sum[[i]]$coefficients)[1]="(Intercept)" + colnames(sum[[i]]$coefficients)[1]="Estimate" + sum[[i]]$r.squared <- as.numeric(object$r2[i]) + sum[[i]]$sigma <- as.numeric(object$resid.sd[i]) + } + } + # include the call and se.type to fitTSFM - sum <- c(call=object$call, Type=se.type, sum) + sum <- c(list(call=object$call, Type=se.type), sum) class(sum) <- "summary.tsfm" return(sum) } Modified: pkg/FactorAnalytics/man/fitTSFM.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-03 22:13:53 UTC (rev 3464) +++ pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-07 19:34:52 UTC (rev 3465) @@ -57,12 +57,12 @@ an option for "all subsets" variable selection. Default is 1. Note: nvmax >= num.factors.subset >= length(force.in).} -\item{add.up.market}{logical; If \code{TRUE}, adds max(0, Rm-Rf) as a -regressor and \code{market.name} is also required. Default is \code{TRUE}. +\item{add.up.market}{logical, adds max(0, Rm-Rf) as a factor. If +\code{TRUE}, \code{market.name} is required. Default is \code{TRUE}. See Details.} -\item{add.market.sqd}{logical; If \code{TRUE}, adds (Rm-Rf)^2 as a -regressor and \code{market.name} is also required. Default is \code{TRUE}.} +\item{add.market.sqd}{logical, adds (Rm-Rf)^2 as a factor. If \code{TRUE}, +\code{market.name} is required. Default is \code{TRUE}.} \item{decay}{a scalar in (0, 1] to specify the decay factor for \code{fit.method="DLS"}. Default is 0.95.} @@ -103,7 +103,7 @@ \item{r2}{N x 1 vector of R-squared values.} \item{resid.sd}{N x 1 vector of residual standard deviations.} \item{call}{the matched function call.} -\item{data}{data as input.} +\item{data}{xts data object containing the assets and factors.} \item{asset.names}{asset.names as input.} \item{factor.names}{factor.names as input.} \item{fit.method}{fit.method as input.} Modified: pkg/FactorAnalytics/man/summary.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-03 22:13:53 UTC (rev 3464) +++ pkg/FactorAnalytics/man/summary.tsfm.Rd 2014-07-07 19:34:52 UTC (rev 3465) @@ -44,7 +44,8 @@ heteroskedasticity-consistent (HC) or heteroskedasticity-autocorrelation-consistent (HAC) standard errors and t-statistics using \code{\link[lmtest]{coeftest}}. This option is meaningful -only if \code{fit.method = "OLS" or "DLS"}. +only if \code{fit.method = "OLS" or "DLS"}. This option is currently not +available for \code{variable.selection = "lar" or "lasso"}. } \note{ For a more detailed printed summary for each asset, refer to From noreply at r-forge.r-project.org Mon Jul 7 23:08:05 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 7 Jul 2014 23:08:05 +0200 (CEST) Subject: [Returnanalytics-commits] r3466 - in pkg/FactorAnalytics: R man Message-ID: <20140707210805.1039B186EC4@r-forge.r-project.org> Author: pragnya Date: 2014-07-07 23:08:04 +0200 (Mon, 07 Jul 2014) New Revision: 3466 Modified: pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/man/fitTSFM.Rd Log: Added 2 more options for lars. Default market.name set to NULL. Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-07 19:34:52 UTC (rev 3465) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-07 21:08:04 UTC (rev 3466) @@ -21,12 +21,11 @@ #' Criterion (AIC), improves. And, "all subsets" enables subsets selection #' using \code{\link[leaps]{regsubsets}} that chooses the n-best performing #' subsets of any given size (specified as \code{num.factor.subsets} here). -#' "lar" and "lasso" correspond to variants of least angle regression using -#' \code{\link[lars]{lars}}. +#' \code{varaible.selection="lars"} corresponds to least angle regression +#' using \code{\link[lars]{lars}} with variants "lasso", "lar", +#' "forward.stagewise" or "stepwise". Note: If +#' \code{variable.selection="lars"}, \code{fit.method} will be ignored. #' -#' Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} -#' will be ignored. -#' #' If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in #' the regression, following Henriksson & Merton (1981), to account for market #' timing (price movement of the general stock market relative to fixed income @@ -46,14 +45,14 @@ #' @param factor.names vector containing names of the macroeconomic factors. #' @param market.name name of the column for market excess returns (Rm-Rf). #' Is required only if \code{add.up.market} or \code{add.market.sqd} -#' are \code{TRUE}. +#' are \code{TRUE}. Default is NULL. #' @param data vector, matrix, data.frame, xts, timeSeries or zoo object #' containing column(s) named in \code{asset.names}, \code{factor.names} and #' optionally, \code{market.name}. #' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". #' See details. #' @param variable.selection the variable selection method, one of "none", -#' "stepwise","all subsets","lar" or "lasso". See details. +#' "stepwise","all subsets","lars". See details. #' @param subsets.method one of "exhaustive", "forward", "backward" or "seqrep" #' (sequential replacement) to specify the type of subset search/selection. #' Required if "all subsets" variable selection is chosen. @@ -72,9 +71,10 @@ #' \code{market.name} is required. Default is \code{TRUE}. #' @param decay a scalar in (0, 1] to specify the decay factor for #' \code{fit.method="DLS"}. Default is 0.95. -#' @param lars.criterion an option to assess model selection for the "lar" or -#' "lasso" variable.selection methods; one of "Cp" or "cv". See details. -#' Default is "Cp". +#' @param lars.type One of "lasso", "lar", "forward.stagewise" or "stepwise". +#' The names can be abbreviated to any unique substring. Default is "lasso". +#' @param lars.criterion an option to assess model selection for the "lars" +#' method; one of "Cp" or "cv". See details. Default is "Cp". #' @param ... optional arguments passed to the \code{step} function for #' variable.selection method "stepwise", such as direction, steps and #' the penalty factor k. Note that argument k is available only for "OLS" @@ -160,22 +160,24 @@ #' #' @export -fitTSFM <- function(asset.names, factor.names, market.name, data=data, - fit.method = c("OLS","DLS","Robust"), - variable.selection = c("none","stepwise","all subsets", - "lar","lasso"), - subsets.method = c("exhaustive", "backward", "forward", - "seqrep"), +fitTSFM <- function(asset.names, factor.names, market.name=NULL, data=data, + fit.method=c("OLS","DLS","Robust"), + variable.selection=c("none","stepwise","all subsets", + "lars"), + subsets.method=c("exhaustive","backward","forward", + "seqrep"), nvmax=8, force.in=NULL, num.factors.subset=1, - add.up.market=TRUE, add.market.sqd=TRUE, - decay=0.95, lars.criterion="Cp", ...){ + add.up.market=TRUE, add.market.sqd=TRUE, decay=0.95, + lars.type=c("lasso","lar","forward.stagewise","stepwise"), + lars.criterion="Cp", ...){ # get all the arguments specified by their full names call <- match.call() - + fit.method = fit.method[1] # default is OLS variable.selection = variable.selection[1] # default is "none" subsets.method = subsets.method[1] # default is "exhaustive" + lars.type=lars.type[1] # default is "lasso" if (!exists("direction")) {direction <- "backward"} if (!exists("steps")) {steps <- 1000} @@ -227,9 +229,9 @@ fit.method, subsets.method, nvmax, force.in, num.factors.subset, add.up.market, add.market.sqd, decay) - } else if (variable.selection == "lar" | variable.selection == "lasso"){ + } else if (variable.selection == "lars"){ result.lars <- SelectLars(dat.xts, asset.names, factor.names, - variable.selection, add.up.market, add.market.sqd, + lars.type, add.up.market, add.market.sqd, decay, lars.criterion) input <- list(call=call, data=dat.xts, asset.names=asset.names, factor.names=factor.names, @@ -240,7 +242,7 @@ } else { stop("Invalid argument: variable.selection must be either 'none', - 'stepwise','all subsets','lar' or 'lasso'") + 'stepwise','all subsets','lars'") } # extract the fitted factor models, coefficients, r2 values and residual vol @@ -387,9 +389,9 @@ } -### method variable.selection = "lar" or "lasso" +### method variable.selection = "lars" # -SelectLars <- function(dat.xts, asset.names, factor.names, variable.selection, +SelectLars <- function(dat.xts, asset.names, factor.names, lars.type, add.up.market, add.market.sqd, decay, lars.criterion) { # initialize list object to hold the fitted objects and, vectors and matrices # for the other results @@ -410,7 +412,7 @@ reg.mat <- as.matrix(na.omit(reg.xts)) # fit lar or lasso regression model lars.fit <- lars(reg.mat[,-1], reg.mat[,i], - type=variable.selection, trace = FALSE) + type=lars.type, trace = FALSE) lars.sum <- summary(lars.fit) # get the step that minimizes the "Cp" statistic or the "cv" mean-sqd @@ -419,7 +421,7 @@ s <- which.min(lars.sum$Cp) } else if (lars.criterion == "cv") { lars.cv <- cv.lars(reg.mat[,factor.names], reg.mat[,i], trace=FALSE, - type=variable.selection, mode="step", plot.it=FALSE) + type=lars.type, mode="step", plot.it=FALSE) s <- which.min(lars.cv$cv) } else { stop("Invalid argument: lars.criterion must be Cp' or 'cv'") Modified: pkg/FactorAnalytics/R/summary.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-07 19:34:52 UTC (rev 3465) +++ pkg/FactorAnalytics/R/summary.tsfm.r 2014-07-07 21:08:04 UTC (rev 3466) @@ -80,7 +80,7 @@ } } - if (object$variable.selection=="lar" | object$variable.selection=="lasso") { + if (object$variable.selection=="lars") { sum <- list() for (i in object$asset.names) { sum[[i]]$coefficients <- as.matrix(c(object$alpha[i], object$beta[i,])) Modified: pkg/FactorAnalytics/man/fitTSFM.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-07 19:34:52 UTC (rev 3465) +++ pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-07 21:08:04 UTC (rev 3466) @@ -7,12 +7,13 @@ \alias{residuals.tsfm} \title{Fit a time series factor model using time series regression} \usage{ -fitTSFM(asset.names, factor.names, market.name, data = data, +fitTSFM(asset.names, factor.names, market.name = NULL, data = data, fit.method = c("OLS", "DLS", "Robust"), variable.selection = c("none", - "stepwise", "all subsets", "lar", "lasso"), subsets.method = c("exhaustive", + "stepwise", "all subsets", "lars"), subsets.method = c("exhaustive", "backward", "forward", "seqrep"), nvmax = 8, force.in = NULL, num.factors.subset = 1, add.up.market = TRUE, add.market.sqd = TRUE, - decay = 0.95, lars.criterion = "Cp", ...) + decay = 0.95, lars.type = c("lasso", "lar", "forward.stagewise", + "stepwise"), lars.criterion = "Cp", ...) \method{coef}{tsfm}(object, ...) @@ -30,7 +31,7 @@ \item{market.name}{name of the column for market excess returns (Rm-Rf). Is required only if \code{add.up.market} or \code{add.market.sqd} -are \code{TRUE}.} +are \code{TRUE}. Default is NULL.} \item{data}{vector, matrix, data.frame, xts, timeSeries or zoo object containing column(s) named in \code{asset.names}, \code{factor.names} and @@ -40,7 +41,7 @@ See details.} \item{variable.selection}{the variable selection method, one of "none", -"stepwise","all subsets","lar" or "lasso". See details.} +"stepwise","all subsets","lars". See details.} \item{subsets.method}{one of "exhaustive", "forward", "backward" or "seqrep" (sequential replacement) to specify the type of subset search/selection. @@ -67,10 +68,12 @@ \item{decay}{a scalar in (0, 1] to specify the decay factor for \code{fit.method="DLS"}. Default is 0.95.} -\item{lars.criterion}{an option to assess model selection for the "lar" or -"lasso" variable.selection methods; one of "Cp" or "cv". See details. -Default is "Cp".} +\item{lars.type}{One of "lasso", "lar", "forward.stagewise" or "stepwise". +The names can be abbreviated to any unique substring. Default is "lasso".} +\item{lars.criterion}{an option to assess model selection for the "lars" +method; one of "Cp" or "cv". See details. Default is "Cp".} + \item{...}{optional arguments passed to the \code{step} function for variable.selection method "stepwise", such as direction, steps and the penalty factor k. Note that argument k is available only for "OLS" @@ -133,12 +136,11 @@ Criterion (AIC), improves. And, "all subsets" enables subsets selection using \code{\link[leaps]{regsubsets}} that chooses the n-best performing subsets of any given size (specified as \code{num.factor.subsets} here). -"lar" and "lasso" correspond to variants of least angle regression using -\code{\link[lars]{lars}}. +\code{varaible.selection="lars"} corresponds to least angle regression +using \code{\link[lars]{lars}} with variants "lasso", "lar", +"forward.stagewise" or "stepwise". Note: If +\code{variable.selection="lars"}, \code{fit.method} will be ignored. -Note: If \code{variable.selection="lar" or "lasso"}, \code{fit.method} -will be ignored. - If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in the regression, following Henriksson & Merton (1981), to account for market timing (price movement of the general stock market relative to fixed income From noreply at r-forge.r-project.org Tue Jul 8 04:57:54 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Jul 2014 04:57:54 +0200 (CEST) Subject: [Returnanalytics-commits] r3467 - in pkg/FactorAnalytics: R man Message-ID: <20140708025754.D6E98186EC4@r-forge.r-project.org> Author: pragnya Date: 2014-07-08 04:57:54 +0200 (Tue, 08 Jul 2014) New Revision: 3467 Modified: pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/managers.df.Rd Log: Option to convert to excess returns for fitTSFM Modified: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-07 21:08:04 UTC (rev 3466) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-08 02:57:54 UTC (rev 3467) @@ -8,6 +8,10 @@ #' \code{tsfm} is returned. #' #' @details +#' Typically factor models are fit using excess returns. \code{Rf.name} gives +#' the option to supply a risk free rate variable to subtract from each asset +#' return and factor to create excess returns. +#' #' Estimation method "OLS" corresponds to ordinary least squares, "DLS" is #' discounted least squares, which is weighted least squares estimation with #' exponentially declining weights that sum to unity, and, "Robust" is robust @@ -34,9 +38,10 @@ #' as a factor in the regression, following Treynor-Mazuy (1966), to account #' for market timing with respect to volatility. #' -#' Finally, for both the "lar" and "lasso" methods, the "Cp" statistic -#' (defined in page 17 of Efron et al. (2002)) is calculated using -#' \code{\link[lars]{summary.lars}} . While, "cv" computes the K-fold +#' \code{lars.criterion} selects the criterion (one of "Cp" or "cv") to +#' determine the best fitted model for \code{variable.selection="lars"}. The +#' "Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated +#' using \code{\link[lars]{summary.lars}}. While, "cv" computes the K-fold #' cross-validated mean squared prediction error using #' \code{\link[lars]{cv.lars}}. #' @@ -46,9 +51,12 @@ #' @param market.name name of the column for market excess returns (Rm-Rf). #' Is required only if \code{add.up.market} or \code{add.market.sqd} #' are \code{TRUE}. Default is NULL. +#' @param Rf.name name of the column of risk free rate variable to calculate +#' excess returns for all assets and factors. Default is NULL, in which case, +#' the data is used as it is. #' @param data vector, matrix, data.frame, xts, timeSeries or zoo object #' containing column(s) named in \code{asset.names}, \code{factor.names} and -#' optionally, \code{market.name}. +#' optionally, \code{market.name} and \code{Rf.name}. #' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". #' See details. #' @param variable.selection the variable selection method, one of "none", @@ -97,7 +105,7 @@ #' \item{asset.fit}{list of fitted objects for each asset. Each object is of #' class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if #' the \code{fit.method="Robust"}, or class \code{lars} if -#' \code{variable.selection="lar" or "lasso"}.} +#' \code{variable.selection="lars"}.} #' \item{alpha}{N x 1 vector of estimated alphas.} #' \item{beta}{N x K matrix of estimated betas.} #' \item{r2}{N x 1 vector of R-squared values.} @@ -142,26 +150,25 @@ #' #' @examples #' # load data from the database -#' data(managers.df) -#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, -#' add.up.market=FALSE, add.market.sqd=FALSE, -#' fit.method="OLS", variable.selection="none") -#' # summary of HAM1 -#' summary(fit$asset.fit$HAM1) -#' # fitted values all 6 asset returns +#' data(managers) +#' fit <- fitTSFM(asset.names=colnames(managers[,(1:6)]), +#' factor.names=colnames(managers[,(7:9)]), +#' market.name="SP500 TR", data=managers) +#' # summary +#' summary(fit) +#' # fitted values for all assets' returns #' fitted(fit) #' # plot actual vs. fitted over time for HAM1 #' # using chart.TimeSeries() function from PerformanceAnalytics package -#' dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers.df$HAM1)) +#' dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers$HAM1)) #' colnames(dataToPlot) <- c("Fitted","Actual") #' chart.TimeSeries(dataToPlot, main="FM fit for HAM1", #' colorset=c("black","blue"), legend.loc="bottomleft") #' #' @export -fitTSFM <- function(asset.names, factor.names, market.name=NULL, data=data, - fit.method=c("OLS","DLS","Robust"), +fitTSFM <- function(asset.names, factor.names, market.name=NULL, Rf.name=NULL, + data=data, fit.method=c("OLS","DLS","Robust"), variable.selection=c("none","stepwise","all subsets", "lars"), subsets.method=c("exhaustive","backward","forward", @@ -193,8 +200,14 @@ # extract columns to be used in the time series regression dat.xts <- merge(data.xts[,asset.names], data.xts[,factor.names]) - ### When merging xts objects, the spaces in names get converted to periods + ### After merging xts objects, the spaces in names get converted to periods + # convert all asset and factor returns to excess return form if specified + if (!is.null(Rf.name)) { + dat.xts <- "[<-"(dat.xts,,vapply(dat.xts, function(x) x-data.xts[,Rf.name], + FUN.VALUE = numeric(nrow(dat.xts)))) + } + # opt add market-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 if(add.up.market == TRUE) { up.market <- data.xts[,market.name] @@ -410,7 +423,7 @@ # convert to matrix reg.mat <- as.matrix(na.omit(reg.xts)) - # fit lar or lasso regression model + # fit lars regression model lars.fit <- lars(reg.mat[,-1], reg.mat[,i], type=lars.type, trace = FALSE) lars.sum <- summary(lars.fit) Modified: pkg/FactorAnalytics/man/fitTSFM.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-07 21:08:04 UTC (rev 3466) +++ pkg/FactorAnalytics/man/fitTSFM.Rd 2014-07-08 02:57:54 UTC (rev 3467) @@ -7,13 +7,14 @@ \alias{residuals.tsfm} \title{Fit a time series factor model using time series regression} \usage{ -fitTSFM(asset.names, factor.names, market.name = NULL, data = data, - fit.method = c("OLS", "DLS", "Robust"), variable.selection = c("none", - "stepwise", "all subsets", "lars"), subsets.method = c("exhaustive", - "backward", "forward", "seqrep"), nvmax = 8, force.in = NULL, - num.factors.subset = 1, add.up.market = TRUE, add.market.sqd = TRUE, - decay = 0.95, lars.type = c("lasso", "lar", "forward.stagewise", - "stepwise"), lars.criterion = "Cp", ...) +fitTSFM(asset.names, factor.names, market.name = NULL, Rf.name = NULL, + data = data, fit.method = c("OLS", "DLS", "Robust"), + variable.selection = c("none", "stepwise", "all subsets", "lars"), + subsets.method = c("exhaustive", "backward", "forward", "seqrep"), + nvmax = 8, force.in = NULL, num.factors.subset = 1, + add.up.market = TRUE, add.market.sqd = TRUE, decay = 0.95, + lars.type = c("lasso", "lar", "forward.stagewise", "stepwise"), + lars.criterion = "Cp", ...) \method{coef}{tsfm}(object, ...) @@ -33,9 +34,13 @@ Is required only if \code{add.up.market} or \code{add.market.sqd} are \code{TRUE}. Default is NULL.} +\item{Rf.name}{name of the column of risk free rate variable to calculate +excess returns for all assets and factors. Default is NULL, in which case, +the data is used as it is.} + \item{data}{vector, matrix, data.frame, xts, timeSeries or zoo object containing column(s) named in \code{asset.names}, \code{factor.names} and -optionally, \code{market.name}.} +optionally, \code{market.name} and \code{Rf.name}.} \item{fit.method}{the estimation method, one of "OLS", "DLS" or "Robust". See details.} @@ -100,7 +105,7 @@ \item{asset.fit}{list of fitted objects for each asset. Each object is of class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if the \code{fit.method="Robust"}, or class \code{lars} if -\code{variable.selection="lar" or "lasso"}.} +\code{variable.selection="lars"}.} \item{alpha}{N x 1 vector of estimated alphas.} \item{beta}{N x K matrix of estimated betas.} \item{r2}{N x 1 vector of R-squared values.} @@ -123,6 +128,10 @@ \code{tsfm} is returned. } \details{ +Typically factor models are fit using excess returns. \code{Rf.name} gives +the option to supply a risk free rate variable to subtract from each asset +return and factor to create excess returns. + Estimation method "OLS" corresponds to ordinary least squares, "DLS" is discounted least squares, which is weighted least squares estimation with exponentially declining weights that sum to unity, and, "Robust" is robust @@ -149,26 +158,26 @@ as a factor in the regression, following Treynor-Mazuy (1966), to account for market timing with respect to volatility. -Finally, for both the "lar" and "lasso" methods, the "Cp" statistic -(defined in page 17 of Efron et al. (2002)) is calculated using -\code{\link[lars]{summary.lars}} . While, "cv" computes the K-fold +\code{lars.criterion} selects the criterion (one of "Cp" or "cv") to +determine the best fitted model for \code{variable.selection="lars"}. The +"Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated +using \code{\link[lars]{summary.lars}}. While, "cv" computes the K-fold cross-validated mean squared prediction error using \code{\link[lars]{cv.lars}}. } \examples{ # load data from the database -data(managers.df) -fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), - factor.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, - add.up.market=FALSE, add.market.sqd=FALSE, - fit.method="OLS", variable.selection="none") -# summary of HAM1 -summary(fit$asset.fit$HAM1) -# fitted values all 6 asset returns +data(managers) +fit <- fitTSFM(asset.names=colnames(managers[,(1:6)]), + factor.names=colnames(managers[,(7:9)]), + market.name="SP500 TR", data=managers) +# summary +summary(fit) +# fitted values for all assets' returns fitted(fit) # plot actual vs. fitted over time for HAM1 # using chart.TimeSeries() function from PerformanceAnalytics package -dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers.df$HAM1)) +dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers$HAM1)) colnames(dataToPlot) <- c("Fitted","Actual") chart.TimeSeries(dataToPlot, main="FM fit for HAM1", colorset=c("black","blue"), legend.loc="bottomleft") Modified: pkg/FactorAnalytics/man/managers.df.Rd =================================================================== --- pkg/FactorAnalytics/man/managers.df.Rd 2014-07-07 21:08:04 UTC (rev 3466) +++ pkg/FactorAnalytics/man/managers.df.Rd 2014-07-08 02:57:54 UTC (rev 3467) @@ -2,18 +2,23 @@ \name{managers.df} \alias{managers.df} \title{Hypothetical Alternative Asset Manager and Benchmark Data} -\description{ - a data.frame format from managers dataset from package - PerformanceAnalytics, containing columns of monthly - returns for six hypothetical asset managers (HAM1 through - HAM6), the EDHEC Long-Short Equity hedge fund index, the - S\&P 500 total returns. Monthly returns for all series - end in December 2006 and begin at different periods - starting from January 1997. +\description{ +A data.frame version of the "managers" xts data object from the +PerformanceAnalytics package. It contains columns of monthly returns for six hypothetical asset managers (HAM1 through HAM6), the EDHEC Long-Short Equity hedge fund index, the S\&P 500 total returns. Monthly returns for all series +end in December 2006 and begin at different periods starting from January 1997. + +Note that all the EDHEC indices are available in \code{\link{edhec}}. } +\usage{data(managers)} + \examples{ data(managers.df) -## maybe str(managers.df) ; plot(managers.df) ... + +# preview the data +head(managers.df) + +# get colnames of HAM fund returns +asset.names <- colnames(managers.df[,1:6]) } \keyword{datasets} From noreply at r-forge.r-project.org Wed Jul 9 08:46:28 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Jul 2014 08:46:28 +0200 (CEST) Subject: [Returnanalytics-commits] r3468 - in pkg/PerformanceAnalytics/sandbox/PAenhance: . R man Message-ID: <20140709064628.C2A8A1847FC@r-forge.r-project.org> Author: kecoli Date: 2014-07-09 08:46:28 +0200 (Wed, 09 Jul 2014) New Revision: 3468 Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/NAMESPACE pkg/PerformanceAnalytics/sandbox/PAenhance/R/table.Performance.R pkg/PerformanceAnalytics/sandbox/PAenhance/man/SharpeRatio.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/UncertaintyMeasure.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.Boxplot.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.QQPlot.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.Rd pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.cran.Rd Log: add optional argument exportXLS to table.Performance(), that one can export the Performance table to an Excel file. Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/NAMESPACE =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/NAMESPACE 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/NAMESPACE 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -# Generated by roxygen2 (4.0.1.99): do not edit by hand +# Generated by roxygen2 (4.0.0): do not edit by hand export(SharpeRatio) export(chart.Boxplot) Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/R/table.Performance.R =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/R/table.Performance.R 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/R/table.Performance.R 2014-07-09 06:46:28 UTC (rev 3468) @@ -19,8 +19,10 @@ #' @param arg.list optional argument to specify input optional argument for each metric, uses #' only interactive=FALSE #' @param digits optional argument to specify the significant digits in printed table, default is 4 -#' @param latex logical, default is FALSE, optional arguemnt to output latex code -#' @param exportFun logical, default is FALSE, optional argument to export function, see details +#' @param latex logical, default is FALSE, optional argument to output latex code +#' @param exportFun logical, default is NULL, optional argument to export function, see details +#' @param exportXLS logical, default is FALSE, optional argument to export resulting table to excel file +#' @param ExcelFileName The name of the Excel file to be created, default is "PerformanceReport.XLSX" #' @details use \code{table.Performance.pool} to check available metrics. recoded SharpeRatio. #' Both interactive and fixed input on metric set and optional arguments. Output latex code for resulting table. Export function that uses the same metrics and optional argument from interactive input. #' @author Kirk Li \email{kirkli@@stat.washington.edu} @@ -63,9 +65,15 @@ #' myfun1(R=edhec) #' # myfun1 uses res.ex5's metrics and optional arguments #' args(myfun1) +#' +#' # Example 6: Export XLSX +#' res.ex6 <- table.Performance(R=edhec,metrics=c("VaR", "ES"), interactive=FALSE, +#' arg.list=arg.list, verbose=T, digits=4, latex=TRUE, exportXLS=TRUE,ExcelFileName="PerformanceReport.xls") +#' +#' #' @export table.Performance <- - function(R,metrics=NULL,metricsNames=NULL, verbose=FALSE, interactive=TRUE, arg.list=NULL, digits=4, latex=FALSE, exportFun=NULL, flag.pre.arg.list=FALSE,...){ + function(R,metrics=NULL,metricsNames=NULL, verbose=FALSE, interactive=TRUE, arg.list=NULL, digits=4, latex=FALSE, exportFun=NULL, exportXLS=FALSE, ExcelFileName="PerformanceReport.xls",flag.pre.arg.list=FALSE,...){ # FUNCTION: 47-1 different metrics pool <- table.Performance.pool() @@ -295,6 +303,16 @@ } + if(exportXLS){ + cat("###################################","\n") + cat(paste0("Exporting to Excel file ",ExcelFileName,"\n")) + cat("###################################","\n") + require(WriteXLS) + temp <- res$resultingtable + inslib(WriteXLS) + WriteXLS("temp",row.names = TRUE,ExcelFileName=ExcelFileName ) + + } return(res) } Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/SharpeRatio.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/SharpeRatio.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/SharpeRatio.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{SharpeRatio} \alias{SharpeRatio} \alias{SharpeRatio.modified} Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/UncertaintyMeasure.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/UncertaintyMeasure.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/UncertaintyMeasure.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{var.se} \alias{var.se} \title{Uncertainty measure of Variance Estimator Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.Boxplot.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.Boxplot.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.Boxplot.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{chart.Boxplot} \alias{chart.Boxplot} \title{box whiskers plot wrapper} Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.QQPlot.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.QQPlot.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/chart.QQPlot.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{chart.QQPlot} \alias{chart.QQPlot} \title{Plot a QQ chart} Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,11 +1,12 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{table.Performance} \alias{table.Performance} \title{Generate general performance table for returns} \usage{ table.Performance(R, metrics = NULL, metricsNames = NULL, verbose = FALSE, interactive = TRUE, arg.list = NULL, digits = 4, latex = FALSE, - exportFun = NULL, flag.pre.arg.list = FALSE, ...) + exportFun = NULL, exportXLS = FALSE, + ExcelFileName = "PerformanceReport.XLSX", flag.pre.arg.list = FALSE, ...) } \arguments{ \item{R}{an xts, vector, matrix, data frame, timeSeries @@ -28,11 +29,17 @@ \item{digits}{optional argument to specify the significant digits in printed table, default is 4} - \item{latex}{logical, default is FALSE, optional arguemnt + \item{latex}{logical, default is FALSE, optional argument to output latex code} - \item{exportFun}{logical, default is FALSE, optional + \item{exportFun}{logical, default is NULL, optional argument to export function, see details} + + \item{exportXLS}{logical, default is FALSE, optional + argument to export resulting table to excel file} + + \item{ExcelFileName}{The name of the Excel file to be + created, default is "PerformanceReport.XLSX"} } \description{ Main function to produce summary table. user can choose a Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{table.Performance.pool} \alias{table.Performance.pool} \title{Print metrics from R-forge PerformanceAnalytics that compatible with table.Performance} Modified: pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.cran.Rd =================================================================== --- pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.cran.Rd 2014-07-08 02:57:54 UTC (rev 3467) +++ pkg/PerformanceAnalytics/sandbox/PAenhance/man/table.Performance.pool.cran.Rd 2014-07-09 06:46:28 UTC (rev 3468) @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.0.1.99): do not edit by hand +% Generated by roxygen2 (4.0.0): do not edit by hand \name{table.Performance.pool.cran} \alias{table.Performance.pool.cran} \title{Print metrics from R CRAN PerformanceAnalytics that compatible with table.Performance} From noreply at r-forge.r-project.org Wed Jul 9 22:49:39 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Jul 2014 22:49:39 +0200 (CEST) Subject: [Returnanalytics-commits] r3469 - in pkg/FactorAnalytics: data man sandbox Message-ID: <20140709204939.8B936185FB9@r-forge.r-project.org> Author: gyollin Date: 2014-07-09 22:49:39 +0200 (Wed, 09 Jul 2014) New Revision: 3469 Modified: pkg/FactorAnalytics/data/CommonFactors.RData pkg/FactorAnalytics/man/CommonFactors.Rd pkg/FactorAnalytics/sandbox/getCommomFactor.r Log: Data for common factors updated Modified: pkg/FactorAnalytics/data/CommonFactors.RData =================================================================== (Binary files differ) Modified: pkg/FactorAnalytics/man/CommonFactors.Rd =================================================================== --- pkg/FactorAnalytics/man/CommonFactors.Rd 2014-07-09 06:46:28 UTC (rev 3468) +++ pkg/FactorAnalytics/man/CommonFactors.Rd 2014-07-09 20:49:39 UTC (rev 3469) @@ -1,39 +1,37 @@ \name{CommonFactors} \alias{CommonFactors} -\alias{factors} +\alias{factors.M} \alias{factors.Q} \docType{data} \title{ Factor set of several commonly used factors } \description{ -10 monthly and quarterly common factors xts data from 1997-01-31 to 2013-07-31. +Collection of common factors as both monthly and quarterly time series \itemize{ -\item SP500 is SP500 returns from FRED, -\item GS10TR US Treasury 10y yields total returns from the yeild of the 10 year constant maturity from FRED, -\item USD.Index Trade Weighted U.S. Dollar Index: Major Currencies - TWEXMMTH. from FRED -\item Term.Spread Yield spread of Merrill Lynch High-Yield Corporate Master II Index minus 10-year Treasury. from FRED -\item TED.Spread 3-Month Treasury Bill: Secondary Market Rate(TB3MS) - 3-Month Eurodollar Deposit Rate (London) (MED)3. from FRED. -\item DJUBSTR DJUBS Commodities index. -\item dVIX the first difference of the end-of-month value of the CBOE Volatility Index (VIX). -\item OILPRICE ""OILPRICE" from FRED. -\item TB3MS 3-Month Treasury Bill: Secondary Market Rate(TB3MS) from FRED +\item SP500: S&P 500 composite index returns. (Yahoo) +\item GS10TR: US Treasury 10y yields total returns from the yeild of the 10 year constant maturity. (FRED) +\item USD.Index: Trade Weighted U.S. Dollar Index: Major Currencies - TWEXMMTH. (FRED) +\item Term.Spread: Yield spread of Merrill Lynch High-Yield Corporate Master II Index minus 10-year Treasury. (FRED) +\item TED.Spread: 3-Month Treasury Bill: Secondary Market Rate(TB3MS) - 3-Month Eurodollar Deposit Rate (MED3). (FRED) +\item dVIX: First difference of the end-of-month value of the CBOE Volatility Index (VIX). (Yahoo) +\item OILPRICE: Monthly returns of spot price of West Texas Intermediate. (FRED) +\item TB3MS: 3-Month Treasury Bill Secondary Market Rate (TB3MS). (FRED) } } \usage{data(CommonFactors)} \format{ - A data frame with 0 observations on the following 2 variables. + xts time series object \describe{ - \item{\code{x}}{a numeric vector} - \item{\code{y}}{a numeric vector} + \item{\code{factor.M}}{Jan-1997 through May-2014} + \item{\code{factor.Q}}{Q1-1997 through Q1-2014} } } \source{ \itemize{ -\item FRED -\item http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls -\item http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls +\item Federal Reserve Economic Data (FRED): \url{http://research.stlouisfed.org/fred2/} +\item Yahoo Finance: \url{http://finance.yahoo.com/} } } Modified: pkg/FactorAnalytics/sandbox/getCommomFactor.r =================================================================== --- pkg/FactorAnalytics/sandbox/getCommomFactor.r 2014-07-09 06:46:28 UTC (rev 3468) +++ pkg/FactorAnalytics/sandbox/getCommomFactor.r 2014-07-09 20:49:39 UTC (rev 3469) @@ -1,7 +1,8 @@ +rm(list=ls()) # Acquire data for factors # Script downloads, parses, and transforms data for a small set -# of common factors to be included as example data within +# of common factors to be included as example data within # FactorAnalytics. For more information, see the help file # for ?factors @@ -11,6 +12,7 @@ require(gdata) require(quantmod) require(RQuantLib) +require(XLConnect) ## Factor set of several commonly used factors @@ -18,8 +20,8 @@ # @TODO: Find a source for TR of SP500 # setup perl -perl = "C:/Program Files/MATLAB/R2010b/sys/perl/win32/bin/perl.exe" -setwd("C:/Users/Yi-An Chen/Documents/R-project/R FA project") +#perl = "C:/Program Files/MATLAB/R2010b/sys/perl/win32/bin/perl.exe" +#setwd("C:/Users/Yi-An Chen/Documents/R-project/R FA project") ### Equities # Get S&P price returns from FRED for now, TR later @@ -34,7 +36,7 @@ colnames(SP500.Q.R)="SP500" ### Bonds -# Calculate total returns from the yeild of the 10 year constant maturity +# Calculate total returns from the yeild of the 10 year constant maturity # index maintained by the Fed getSymbols("GS10", src="FRED") #load US Treasury 10y yields from FRED # Dates should be end of month, not beginning of the month as reported @@ -99,7 +101,8 @@ # Download the most recent file print("Downloading excel spreadsheet from DJUBS web site...") # Can't get it directly, sorry windows users -system("wget http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls") +#system("wget http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls") +download.file(url="http://www.djindexes.com/mdsidx/downloads/xlspages/ubsci_public/DJUBS_full_hist.xls",destfile="DJUBS_full_hist.xls",mode = "wb") if(!file.exists("DJUBS_full_hist.xls")) stop(paste("No spreadsheet exists. Download the spreadsheet to be processed from www.djindexes.com into ", filesroot, "/.incoming", sep="")) @@ -107,8 +110,12 @@ print("Reading sheet... This will take a moment...") -x = read.xls("DJUBS_full_hist.xls", sheet="Total Return",perl=perl) -x=x[-1:-2,] # Get rid of the headings +#x = read.xls("DJUBS_full_hist.xls", sheet="Total Return",perl=perl) +x <- readWorksheetFromFile("DJUBS_full_hist.xls", sheet = "Total Return", + header = FALSE, startCol = 1, startRow = 4, + endCol = 0, endRow = 0, check.names=FALSE) + +x=x[-1:-3,] # Get rid of the headings x=x[-dim(x)[1],] # Get rid of the last line, which contains the disclaimer ISOdates = as.Date(x[,1], "%m/%d/%Y") # Get dates @@ -123,13 +130,13 @@ # @ TODO Want to delete the last line off ONLY IF the month is incomplete # if(tail(index(x.xts),1) != as.Date(as.yearmon(tail(index(x.xts),1)), frac=1)) { # That test isn't quite right, but its close. It won't work on the first -# day of a new month when the last business day wasn't the last day of +# day of a new month when the last business day wasn't the last day of # the month. It will work for the second day. # x.m.xts = x.m.xts[-dim(x.m.xts)[1],] # } -# Index is set to last trading day of the month. -# Reset index to last day of the month to make alignment easier with other monthly series. +# Index is set to last trading day of the month. +# Reset index to last day of the month to make alignment easier with other monthly series. index(x.m.xts)=as.Date(index(x.m.xts), frac=1) index(x.q.xts)=as.Date(index(x.q.xts), frac=1) DJUBS.R = x.m.xts @@ -145,8 +152,11 @@ # Daily from 1990-2003 -x= read.xls( "http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls", - perl = perl) +#x= read.xls( "http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls",perl = perl) +download.file(url="http://www.cboe.com/publish/ScheduledTask/MktData/datahouse/vixarchive.xls",destfile="vixarchive.xls",mode = "wb") +x <- readWorksheetFromFile("vixarchive.xls", sheet = 1, + header = FALSE, startCol = 1, startRow = 3, + endCol = 0, endRow = 0, check.names=FALSE) ISOdates = as.Date(x[,1], "%m/%d/%y") # Get dates x.xts = as.xts(as.numeric(as.vector(x[,5])), order.by=ISOdates) x.m.xts = to.monthly(x.xts) @@ -183,11 +193,16 @@ index(OIL.Q.R) = as.Date(as.yearqtr(index(OIL.Q.R)), frac=1) ### PUT -system("wget https://www.cboe.com/micro/put/PUT_86-06.xls") -setwd("C:/Users/Yi-An Chen/Documents/R-project/R FA project") -x = read.xls("PUT_86-06.xls",perl=perl) -x=na.omit(x[-1:-4,1:2]) -ISOdates = as.Date(x[,1], "%d-%b-%Y") # Get dates +#system("wget https://www.cboe.com/micro/put/PUT_86-06.xls") +download.file(url="http://www.cboe.com/micro/put/PUT_86-06.xls",destfile="PUT_86-06.xls",mode="wb") +#setwd("C:/Users/Yi-An Chen/Documents/R-project/R FA project") +#x = read.xls("PUT_86-06.xls",perl=perl) +#x = read.xls("PUT_86-06.xls",perl=perl) +x <- readWorksheetFromFile("PUT_86-06.xls", sheet = 1, + header = FALSE, startCol = 1, startRow = 7, + endCol = 2, endRow = 0, check.names=FALSE) +#x=na.omit(x[-1:-4,1:2]) +ISOdates = as.Date(x[,1], "%Y-%m-%d") # Get dates PUT1 = xts(as.numeric(as.vector(x[,2])), order.by=ISOdates) # link fails @@ -206,10 +221,10 @@ lastquarter=format(as.Date(as.yearqtr(Sys.Date())-.25, frac=1), "%Y-%m") -factors=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) -factors=factors["1997::",] -factors.Q=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) -factors.Q=factors.Q[paste("1997::",lastquarter,sep=""),] +factorsM=cbind(SP500.R, GS10.R, USDI.R, TERM, CREDIT, DJUBS.R, dVIX, TED, OIL.R, TB3MS/100) +factorsM=factorsM["1997::",] +factorsQ=cbind(SP500.Q.R, GS10.Q.R, USDI.Q.R, TERM.Q, CREDIT.Q, DJUBS.Q.R, dVIX.Q, TED.Q, OIL.Q.R, TB3MS[endpoints(TB3MS, on="quarters"),]/100) +factorsQ=factorsQ[paste("1997::",lastquarter,sep=""),] setwd("C:/Users/Yi-An Chen/Documents/R-project/returnanalytics/pkg/FactorAnalytics/data") -save(factors,factors.Q,file="CommomFactors.RData") \ No newline at end of file +save(factors,factorsQ,file="CommomFactors.RData") From noreply at r-forge.r-project.org Mon Jul 14 03:31:39 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 14 Jul 2014 03:31:39 +0200 (CEST) Subject: [Returnanalytics-commits] r3470 - in pkg/PortfolioAnalytics: . R man sandbox Message-ID: <20140714013139.7CD79187581@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-14 03:31:38 +0200 (Mon, 14 Jul 2014) New Revision: 3470 Added: pkg/PortfolioAnalytics/sandbox/opt_parallel.R Modified: pkg/PortfolioAnalytics/NAMESPACE pkg/PortfolioAnalytics/R/generics.R pkg/PortfolioAnalytics/R/optimize.portfolio.R pkg/PortfolioAnalytics/R/random_portfolios.R pkg/PortfolioAnalytics/man/optimize.portfolio.parallel.Rd Log: Adding support for analyzing uncertainty of optimizations Modified: pkg/PortfolioAnalytics/NAMESPACE =================================================================== --- pkg/PortfolioAnalytics/NAMESPACE 2014-07-09 20:49:39 UTC (rev 3469) +++ pkg/PortfolioAnalytics/NAMESPACE 2014-07-14 01:31:38 UTC (rev 3470) @@ -55,6 +55,7 @@ S3method(print,optimize.portfolio.DEoptim) S3method(print,optimize.portfolio.GenSA) S3method(print,optimize.portfolio.ROI) +S3method(print,optimize.portfolio.parallel) S3method(print,optimize.portfolio.pso) S3method(print,optimize.portfolio.random) S3method(print,optimize.portfolio.rebalancing) @@ -65,6 +66,7 @@ S3method(print,summary.optimize.portfolio.rebalancing) S3method(summary,efficient.frontier) S3method(summary,optimize.portfolio) +S3method(summary,optimize.portfolio.parallel) S3method(summary,optimize.portfolio.rebalancing) S3method(summary,portfolio) S3method(update,constraint) Modified: pkg/PortfolioAnalytics/R/generics.R =================================================================== --- pkg/PortfolioAnalytics/R/generics.R 2014-07-09 20:49:39 UTC (rev 3469) +++ pkg/PortfolioAnalytics/R/generics.R 2014-07-14 01:31:38 UTC (rev 3470) @@ -1009,3 +1009,49 @@ print(portf[[i]]) } } + +#' @method summary optimize.portfolio.parallel +#' @S3method summary optimize.portfolio.parallel +#' @export +summary.optimize.portfolio.parallel <- function(object, ...){ + out <- list() + out$call <- object$call + out$elapsed_time <- object$elapsed_time + out$n_optimizations <- length(object$optimizations) + xx <- lapply(object$optimizations, function(x) { + tmp <- extractStats(x) + out <- tmp[which.min(tmp[,"out"]),] + out}) + stats <- do.call(rbind, xx) + out$stats <- stats + out$obj_val <- stats[,"out"] + class(out) <- "summary.optimize.portfolio.parallel" + return(out) +} + +#' @method print optimize.portfolio.parallel +#' @S3method print optimize.portfolio.parallel +#' @export +print.optimize.portfolio.parallel <- function(x, ..., probs = c(0.025, 0.975)){ + cat(rep("*", 35) ,"\n", sep="") + cat("PortfolioAnalytics Optimization\n") + cat(rep("*", 35) ,"\n", sep="") + + cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), + "\n\n", sep = "") + + # call the summary method + xx <- summary(x) + + cat("Number of Optimizations:\n") + print(xx$n_optimizations) + + cat("Objective Value Estimate:\n") + print(mean(xx$obj_val)) + + cat("Objective Value Estimate Percentiles:\n") + print(quantile(xx$obj_val, probs = probs)) + + cat("Elapsed Time:\n") + print(xx$elapsed_time) +} Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-09 20:49:39 UTC (rev 3469) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-14 01:31:38 UTC (rev 3470) @@ -1518,10 +1518,8 @@ return(out) } -#'execute multiple optimize.portfolio calls, presumably in parallel +#' Execute multiple optimize.portfolio calls, presumably in parallel #' -#' TODO write function to check sensitivity of optimal results by using optimize.portfolio.parallel results -#' #' This function will not speed up optimization! #' #' This function exists to run multiple copies of optimize.portfolio, presumabley in parallel using foreach. @@ -1536,33 +1534,56 @@ #' this function. #' #' @param R an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns -#' @param constraints an object of type "constraints" specifying the constraints for the optimization, see \code{\link{constraint}} -#' @param optimize_method one of "DEoptim" or "random" +#' @param portfolio an object of type "portfolio" specifying the constraints and objectives for the optimization +#' @param optimize_method one of "DEoptim", "random", "pso", "GenSA". #' @param search_size integer, how many portfolios to test, default 20,000 #' @param trace TRUE/FALSE if TRUE will attempt to return additional information on the path or portfolios searched #' @param \dots any other passthru parameters +#' @param rp matrix of random portfolio weights, default NULL, mostly for automated use by rebalancing optimization or repeated tests on same portfolios +#' @param momentFUN the name of a function to call to set portfolio moments, default \code{\link{set.portfolio.moments_v2}} +#' @param message TRUE/FALSE. The default is message=FALSE. Display messages if TRUE. #' @param nodes how many processes to run in the foreach loop, default 4 #' #' @return a list containing the optimal weights, some summary statistics, the function call, and optionally trace information #' @author Kris Boudt, Peter Carl, Brian G. Peterson #' @export -optimize.portfolio.parallel <- function(R,constraints,optimize_method=c("DEoptim","random"), search_size=20000, trace=FALSE, ..., nodes=4) +optimize.portfolio.parallel <- function(R, + portfolio, + optimize_method=c("DEoptim","random","ROI","pso","GenSA"), + search_size=20000, + trace=FALSE, ..., + rp=NULL, + momentFUN='set.portfolio.moments', + message=FALSE, + nodes=4) { stopifnot("package:foreach" %in% search() || require("foreach",quietly=TRUE)) optimize_method=optimize_method[1] - start_t<-Sys.time() + start_t <- Sys.time() #store the call for later call <- match.call() - opt_out_list<-foreach(1:nodes, packages='PortfolioAnalytics') %dopar% optimize.portfolio(R=R,constraints=constraints,optimize_method=optimize_method, search_size=search_size, trace=trace, ...) + opt_out_list <- foreach(1:nodes, .errorhandling='pass', .packages='PortfolioAnalytics') %dopar% { + optimize.portfolio(R=R, portfolio=portfolio, + optimize_method=optimize_method, + search_size=search_size, trace=trace, + rp=rp, momentFUN=momentFUN, parallel=FALSE, + ...=...) + } - end_t<-Sys.time() - message(c("overall elapsed time:",end_t-start_t)) - class(opt_out_list)<-c("optimize.portfolio.parallel") - return(opt_out_list) + end_t <- Sys.time() + elapsed_t <- end_t - start_t + if(message) message(c("overall elapsed time:", elapsed_t)) + out <- list() + out$optimizations <- opt_out_list + out$call <- call + out$elapsed_time <- elapsed_t + + class(out) <- c("optimize.portfolio.parallel") + return(out) } Modified: pkg/PortfolioAnalytics/R/random_portfolios.R =================================================================== --- pkg/PortfolioAnalytics/R/random_portfolios.R 2014-07-09 20:49:39 UTC (rev 3469) +++ pkg/PortfolioAnalytics/R/random_portfolios.R 2014-07-14 01:31:38 UTC (rev 3470) @@ -390,11 +390,19 @@ ) if(eliminate){ # eliminate portfolios that do not satisfy constraints - stopifnot("package:foreach" %in% search() || require("foreach",quietly = TRUE)) - check <- foreach(i=1:nrow(rp), .combine=c) %dopar% { - # check_constraint returns TRUE if all constraints are satisfied - check_constraints(weights=rp[i,], portfolio=portfolio) + check <- vector("numeric", nrow(rp)) + for(i in 1:nrow(rp)){ + check[i] <- check_constraints(weights=rp[i,], portfolio=portfolio) } + # We probably don't need or want to do this part in parallel. It could + # also interfere with optimize.portfolio.parallel since this function + # will likely be called. Not sure how foreach handles nested loops + # in parallel so it is best to avoid that altogether. + #stopifnot("package:foreach" %in% search() || require("foreach",quietly = TRUE)) + #check <- foreach(i=1:nrow(rp), .combine=c) %dopar% { + # # check_constraint returns TRUE if all constraints are satisfied + # check_constraints(weights=rp[i,], portfolio=portfolio) + #} rp <- rp[which(check==TRUE),] } return(rp) Modified: pkg/PortfolioAnalytics/man/optimize.portfolio.parallel.Rd =================================================================== --- pkg/PortfolioAnalytics/man/optimize.portfolio.parallel.Rd 2014-07-09 20:49:39 UTC (rev 3469) +++ pkg/PortfolioAnalytics/man/optimize.portfolio.parallel.Rd 2014-07-14 01:31:38 UTC (rev 3470) @@ -1,17 +1,19 @@ % Generated by roxygen2 (4.0.1): do not edit by hand \name{optimize.portfolio.parallel} \alias{optimize.portfolio.parallel} -\title{execute multiple optimize.portfolio calls, presumably in parallel} +\title{Execute multiple optimize.portfolio calls, presumably in parallel} \usage{ -optimize.portfolio.parallel(R, constraints, optimize_method = c("DEoptim", - "random"), search_size = 20000, trace = FALSE, ..., nodes = 4) +optimize.portfolio.parallel(R, portfolio, optimize_method = c("DEoptim", + "random", "ROI", "pso", "GenSA"), search_size = 20000, trace = FALSE, ..., + rp = NULL, momentFUN = "set.portfolio.moments", message = FALSE, + nodes = 4) } \arguments{ \item{R}{an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns} -\item{constraints}{an object of type "constraints" specifying the constraints for the optimization, see \code{\link{constraint}}} +\item{portfolio}{an object of type "portfolio" specifying the constraints and objectives for the optimization} -\item{optimize_method}{one of "DEoptim" or "random"} +\item{optimize_method}{one of "DEoptim", "random", "pso", "GenSA".} \item{search_size}{integer, how many portfolios to test, default 20,000} @@ -19,17 +21,21 @@ \item{\dots}{any other passthru parameters} +\item{rp}{matrix of random portfolio weights, default NULL, mostly for automated use by rebalancing optimization or repeated tests on same portfolios} + +\item{momentFUN}{the name of a function to call to set portfolio moments, default \code{\link{set.portfolio.moments_v2}}} + +\item{message}{TRUE/FALSE. The default is message=FALSE. Display messages if TRUE.} + \item{nodes}{how many processes to run in the foreach loop, default 4} } \value{ a list containing the optimal weights, some summary statistics, the function call, and optionally trace information } \description{ -TODO write function to check sensitivity of optimal results by using optimize.portfolio.parallel results +This function will not speed up optimization! } \details{ -This function will not speed up optimization! - This function exists to run multiple copies of optimize.portfolio, presumabley in parallel using foreach. This is typically done to test your parameter settings, specifically Added: pkg/PortfolioAnalytics/sandbox/opt_parallel.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/opt_parallel.R (rev 0) +++ pkg/PortfolioAnalytics/sandbox/opt_parallel.R 2014-07-14 01:31:38 UTC (rev 3470) @@ -0,0 +1,74 @@ +library(PortfolioAnalytics) + +data(edhec) +R <- edhec[, 1:5] +funds <- colnames(R) + +# Construct initial portfolio +init.portf <- portfolio.spec(assets=funds) +init.portf <- add.constraint(portfolio=init.portf, type="weight_sum", + min_sum=0.99, max_sum=1.01) +init.portf <- add.constraint(portfolio=init.portf, type="long_only") +init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") + +# Run optimization with DEoptim +minStdDev.DE <- optimize.portfolio(R=R, portfolio=init.portf, + optimize_method="DEoptim", + search_size=2000, + traceDE=0, + trace=TRUE) +xtract.DE <- extractStats(minStdDev.DE) + +# Here we extract the objective value returned from the optimizer of each +# iteration. I'm not sure how useful this information is. +obj.DE <- xtract.DE[,"out"] +hist(obj.DE) +rug(obj.DE) +plot(density(obj.DE)) +qqnorm(obj.DE) +boxplot(obj.DE) + +# Run optimization with random portfolios +minStdDev.RP <- optimize.portfolio(R=R, portfolio=init.portf, + optimize_method="random", + search_size=2000, + trace=TRUE) +xtract.RP <- extractStats(minStdDev.RP) +obj.RP <- xtract.RP[,"out"] +hist(obj.RP) +rug(obj.RP) +plot(density(obj.RP)) +qqnorm(obj.RP) +boxplot(obj.RP) + +# I think the best way is to do a sort of bootstrap by running several +# hundred or thousand (depending on your resources) optimizations and +# analyze the objective value from each optimal portfolio +opt <- optimize.portfolio.parallel(R=R, + nodes=50, + portfolio=init.portf, + optimize_method="random", + search_size=2000, + trace=TRUE) +opt +xx <- summary(opt) +obj_val <- xx$obj_val + +# estimate of the objective measures, objective value, and weights from the +# optimal portfolio of each optimization +apply(xx$stats, 2, mean) + +# plot the objective values from each optimization +hist(obj_val) +rug(obj_val) +plot(density(obj_val)) +qqnorm(obj_val) +qqline(obj_val) +boxplot(obj_val) + +# These should match the print method +# estimated objective value +mean(obj_val) +# percentile confidence interval estimate +quantile(obj_val, probs = c(0.025, 0.975)) + From noreply at r-forge.r-project.org Tue Jul 15 03:00:59 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 15 Jul 2014 03:00:59 +0200 (CEST) Subject: [Returnanalytics-commits] r3471 - in pkg/FactorAnalytics: . R data inst/tests man sandbox vignettes Message-ID: <20140715010059.C2EFF1875C0@r-forge.r-project.org> Author: pragnya Date: 2014-07-15 03:00:58 +0200 (Tue, 15 Jul 2014) New Revision: 3471 Added: pkg/FactorAnalytics/R/covFm.R pkg/FactorAnalytics/R/fitTsfm.R pkg/FactorAnalytics/R/paFm.r pkg/FactorAnalytics/man/covFm.Rd pkg/FactorAnalytics/man/fitTsfm.Rd pkg/FactorAnalytics/man/paFm.Rd Removed: pkg/FactorAnalytics/R/covFM.r pkg/FactorAnalytics/R/fitTSFM.R pkg/FactorAnalytics/R/paFM.r pkg/FactorAnalytics/data/factors.rda pkg/FactorAnalytics/data/managers.df.rda pkg/FactorAnalytics/man/covFM.Rd pkg/FactorAnalytics/man/fitTSFM.Rd pkg/FactorAnalytics/man/managers.df.Rd pkg/FactorAnalytics/man/paFM.Rd Modified: pkg/FactorAnalytics/NAMESPACE pkg/FactorAnalytics/R/factorModelEsDecomposition.R pkg/FactorAnalytics/R/factorModelMonteCarlo.R pkg/FactorAnalytics/R/factorModelVaRDecomposition.R pkg/FactorAnalytics/R/plot.pafm.r pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/R/predict.tsfm.r pkg/FactorAnalytics/R/print.pafm.r pkg/FactorAnalytics/R/print.tsfm.r pkg/FactorAnalytics/R/summary.pafm.r pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/inst/tests/test-fitTSFM.r pkg/FactorAnalytics/man/factorModelEsDecomposition.Rd pkg/FactorAnalytics/man/factorModelMonteCarlo.Rd pkg/FactorAnalytics/man/factorModelVaRDecomposition.Rd pkg/FactorAnalytics/man/plot.pafm.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd pkg/FactorAnalytics/man/predict.tsfm.Rd pkg/FactorAnalytics/man/print.pafm.Rd pkg/FactorAnalytics/man/print.tsfm.Rd pkg/FactorAnalytics/man/summary.pafm.Rd pkg/FactorAnalytics/man/summary.tsfm.Rd pkg/FactorAnalytics/sandbox/test.vignette.r pkg/FactorAnalytics/vignettes/fundamentalFM.Rnw Log: Argument and function name changes in fitTsfm, covFm, paFm Modified: pkg/FactorAnalytics/NAMESPACE =================================================================== --- pkg/FactorAnalytics/NAMESPACE 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/NAMESPACE 2014-07-15 01:00:58 UTC (rev 3471) @@ -1,7 +1,7 @@ # Generated by roxygen2 (4.0.1): do not edit by hand S3method(coef,tsfm) -S3method(covFM,tsfm) +S3method(covFm,tsfm) S3method(fitted,tsfm) S3method(plot,FundamentalFactorModel) S3method(plot,StatFactorModel) @@ -20,7 +20,7 @@ S3method(summary,StatFactorModel) S3method(summary,pafm) S3method(summary,tsfm) -export(covFM) +export(covFm) export(dCornishFisher) export(factorModelEsDecomposition) export(factorModelMonteCarlo) @@ -28,8 +28,8 @@ export(factorModelVaRDecomposition) export(fitFundamentalFactorModel) export(fitStatisticalFactorModel) -export(fitTSFM) +export(fitTsfm) export(pCornishFisher) -export(paFM) +export(paFm) export(qCornishFisher) export(rCornishFisher) Deleted: pkg/FactorAnalytics/R/covFM.r =================================================================== --- pkg/FactorAnalytics/R/covFM.r 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/R/covFM.r 2014-07-15 01:00:58 UTC (rev 3471) @@ -1,79 +0,0 @@ -#' @title Covariance Matrix for assets' returns from fitted factor model. -#' -#' @description Computes the covariance matrix for assets' returns based on a -#' fitted factor model. This is a generic function with methods for classes -#' \code{tsfm}, \code{sfm} and \code{ffm}. -#' -#' @details \code{R(i, t)}, the return on asset \code{i} at time \code{t}, -#' is assumed to follow a factor model of the form, \cr \cr -#' \code{R(i,t) = alpha(i) + beta*F(t) + e(i,t)}, \cr \cr -#' where, \code{alpha(i)} is the intercept, \code{F(t)} is a {K x 1} vector of -#' the \code{K} factor values at time \code{t}, \code{beta} is a \code{1 x K} -#' vector of factor exposures and the error terms \code{e(i,t)} are serially -#' uncorrelated across time and contemporaneously uncorrelated across assets -#' so that \code{e(i,t) ~ iid(0,sig(i)^2)}. Thus, the variance of asset -#' \code{i}'s return is given by \cr \cr -#' \code{var(R(i,t)) = beta*var(F(t))*tr(beta) + sig(i)^2}. \cr \cr -#' And, the \code{N x N} covariance matrix of N asset returns is \cr \cr -#' \code{var(R) = B*var(F(t))*tr(B) + D}, \cr \cr -#' where, B is the \code{N x K} matrix of factor betas and \code{D} is a -#' diagonal matrix with \code{sig(i)^2} along the diagonal. -#' -#' @param object fit object of class \code{tsfm}, \code{sfm} or \code{ffm}. -#' -#' @return The computed \code{N x N} covariance matrix for asset returns based -#' on the fitted factor model. -#' -#' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. -#' -#' @references -#' \enumerate{ -#' \item Zivot, Eric, and W. A. N. G. Jia-hui. "Modeling Financial Time Series -#' with S-Plus Springer-Verlag." (2006). -#' } -#' -#' @seealso \code{\link{fitTSFM}}, \code{\link{fitSFM}}, \code{\link{fitFFM}} -#' -#' @examples -#' \dontrun{ -#' # Time Series Factor model -#' data(managers.df) -#' factors = managers.df[, (7:9)] -#' fit <- fitTSFM(assets.names=colnames(managers.df[, (1:6)]), -#' factors.names=c("EDHEC.LS.EQ","SP500.TR"), data=managers.df, -#' add.up.market=FALSE, add.market.sqd=FALSE, fit.method="OLS") -#' covFM(fit) -#' -#' # Statistical Factor Model -#' data(stat.fm.data) -#' sfm.pca.fit <- fitStatisticalFactorModel(sfm.dat, k=2) -#' #' covFM(t(sfm.pca.fit$loadings), var(sfm.pca.fit$factors), -#' sfm.pca.fit$resid.sd) -#' -#' sfm.apca.fit <- fitSFM(sfm.apca.dat, k=2) -#' -#' covFM(t(sfm.apca.fit$loadings), var(sfm.apca.fit$factors), -#' sfm.apca.fit$resid.sd) -#' -#' # Fundamental Factor Model -#' data(stock) -#' # there are 447 assets -#' exposure.names <- c("BOOK2MARKET", "LOG.MARKETCAP") -#' beta.mat <- subset(stock, DATE=="2003-12-31")[, exposure.names] -#' beta.mat1 <- cbind(rep(1, 447), beta.mat1) -#' # FM return covariance -#' fit.fund <- fitFFM(exposure.names=c("BOOK2MARKET", "LOG.MARKETCAP"), -#' data=stock, returnsvar="RETURN", datevar="DATE", -#' assetvar="TICKER", wls=TRUE, regression="classic", -#' covariance="classic", full.resid.cov=FALSE) -#' ret.cov.fundm <- covFM(beta.mat1, fit.fund$factor.cov$cov, -#' fit.fund$resid.sd) -#' fit.fund$returns.cov$cov == ret.cov.fundm -#' } -#' -#' @rdname covFM -#' @export - -covFM <- function(object){ -UseMethod("covFM") -} Added: pkg/FactorAnalytics/R/covFm.R =================================================================== --- pkg/FactorAnalytics/R/covFm.R (rev 0) +++ pkg/FactorAnalytics/R/covFm.R 2014-07-15 01:00:58 UTC (rev 3471) @@ -0,0 +1,77 @@ +#' @title Covariance Matrix for assets' returns from fitted factor model. +#' +#' @description Computes the covariance matrix for assets' returns based on a +#' fitted factor model. This is a generic function with methods for classes +#' \code{tsfm}, \code{sfm} and \code{ffm}. +#' +#' @details \code{R(i, t)}, the return on asset \code{i} at time \code{t}, +#' is assumed to follow a factor model of the form, \cr \cr +#' \code{R(i,t) = alpha(i) + beta*F(t) + e(i,t)}, \cr \cr +#' where, \code{alpha(i)} is the intercept, \code{F(t)} is a {K x 1} vector of +#' the \code{K} factor values at time \code{t}, \code{beta} is a \code{1 x K} +#' vector of factor exposures and the error terms \code{e(i,t)} are serially +#' uncorrelated across time and contemporaneously uncorrelated across assets +#' so that \code{e(i,t) ~ iid(0,sig(i)^2)}. Thus, the variance of asset +#' \code{i}'s return is given by \cr \cr +#' \code{var(R(i,t)) = beta*var(F(t))*tr(beta) + sig(i)^2}. \cr \cr +#' And, the \code{N x N} covariance matrix of N asset returns is \cr \cr +#' \code{var(R) = B*var(F(t))*tr(B) + D}, \cr \cr +#' where, B is the \code{N x K} matrix of factor betas and \code{D} is a +#' diagonal matrix with \code{sig(i)^2} along the diagonal. +#' +#' @param object fit object of class \code{tsfm}, \code{sfm} or \code{ffm}. +#' +#' @return The computed \code{N x N} covariance matrix for asset returns based +#' on the fitted factor model. +#' +#' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. +#' +#' @references +#' \enumerate{ +#' \item Zivot, Eric, and W. A. N. G. Jia-hui. "Modeling Financial Time Series +#' with S-Plus Springer-Verlag." (2006). +#' } +#' +#' @seealso \code{\link{fitTsfm}}, \code{\link{fitSfm}}, \code{\link{fitFfm}} +#' +#' @examples +#' \dontrun{ +#' # Time Series Factor model +#' data(managers) +#' factors = managers[, (7:9)] +#' fit <- fitTsfm(asset.names=colnames(managers[, (1:6)]), +#' factor.names=c("EDHEC LS EQ","SP500 TR"), data=managers) +#' covFm(fit) +#' +#' # Statistical Factor Model +#' data(stat.fm.data) +#' sfm.pca.fit <- fitSfm(sfm.dat, k=2) +#' #' covFm(t(sfm.pca.fit$loadings), var(sfm.pca.fit$factors), +#' sfm.pca.fit$resid.sd) +#' +#' sfm.apca.fit <- fitSfm(sfm.apca.dat, k=2) +#' +#' covFm(t(sfm.apca.fit$loadings), var(sfm.apca.fit$factors), +#' sfm.apca.fit$resid.sd) +#' +#' # Fundamental Factor Model +#' data(stock) +#' # there are 447 assets +#' exposure.names <- c("BOOK2MARKET", "LOG.MARKETCAP") +#' beta.mat <- subset(stock, DATE=="2003-12-31")[, exposure.names] +#' beta.mat1 <- cbind(rep(1, 447), beta.mat1) +#' # FM return covariance +#' fit.fund <- fitFfm(exposure.names=c("BOOK2MARKET", "LOG.MARKETCAP"), +#' data=stock, returnsvar="RETURN", datevar="DATE", +#' assetvar="TICKER", wls=TRUE, regression="classic", +#' covariance="classic", full.resid.cov=FALSE) +#' ret.cov.fundm <- covFm(beta.mat1,fit.fund$factor.cov$cov,fit.fund$resid.sd) +#' fit.fund$returns.cov$cov == ret.cov.fundm +#' } +#' +#' @rdname covFm +#' @export + +covFm <- function(object){ + UseMethod("covFm") +} Modified: pkg/FactorAnalytics/R/factorModelEsDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/R/factorModelEsDecomposition.R 2014-07-15 01:00:58 UTC (rev 3471) @@ -7,9 +7,10 @@ #' equal to its value-at-risk (VaR). VaR is compute as the sample quantile of #' the historic or simulated data. #' -#' The factor model has the form \cr \code{R(t) = beta'F(t) + e(t) = beta.star'F.star(t)}\cr +#' The factor model has the form \cr +#' \code{R(t) = beta'F(t) + e(t) = beta.star'F.star(t)}\cr #' where beta.star = (beta, sig.e)' and F.star(t) = (F(t)', z(t))' By Euler's -#' theorem:\cr \code{ES.fm = sum(cES.fm) = sum(beta.star*mES.fm)} \cr +#' theorem: \cr \code{ES.fm = sum(cES.fm) = sum(beta.star*mES.fm)} \cr #' #' @param Data \code{B x (k+2)} matrix of historic or simulated data. The first #' column contains the fund returns, the second through \code{k+1}st columns @@ -20,8 +21,8 @@ #' @param tail.prob scalar, tail probability for VaR quantile. Typically 0.01 #' or 0.05. #' @param VaR.method character, method for computing VaR. Valid choices are -#' one of "modified","gaussian","historical", "kernel". computation is done with the \code{VaR} -#' in the PerformanceAnalytics package. +#' one of "modified","gaussian","historical", "kernel". computation is done +#' with the \code{VaR} in the PerformanceAnalytics package. #' #' #' @return A list with the following components: @@ -30,31 +31,31 @@ #' positive number.} #' \item{n.exceed} Scalar, number of observations beyond VaR. #' \item{idx.exceed} n.exceed x 1 vector giving index values of exceedences. -#' \item{ES.fm} Scalar. nonparametric ES value for fund reported as a positive number. +#' \item{ES.fm} Scalar. nonparametric ES value for fund reported as a positive +#' number. #' \item{mES.fm} (K+1) x 1 vector of factor marginal contributions to ES. #' \item{cES.fm} (K+1) x 1 vector of factor component contributions to ES. -#' \item{pcES.fm} (K+1) x 1 vector of factor percentage component contributions to ES. +#' \item{pcES.fm} (K+1) x 1 vector of factor percentage component contributions +#' to ES. #' } #' @author Eric Zviot and Yi-An Chen. #' @references \enumerate{ #' \item Hallerback (2003), "Decomposing Portfolio Value-at-Risk: A #' General Analysis", The Journal of Risk 5/2. -#' \item Yamai and Yoshiba (2002)."Comparative Analyses of Expected Shortfall and Value-at-Risk: Their +#' \item Yamai and Yoshiba (2002)."Comparative Analyses of Expected Shortfall +#' and Value-at-Risk: Their #' Estimation Error, Decomposition, and Optimization Bank of Japan. -#' \item Meucci (2007). "Risk Contributions from Generic User-Defined Factors," Risk. +#' \item Meucci (2007). "Risk Contributions from Generic User-Defined Factors". #' \item Epperlein and Smillie (2006) "Cracking VAR with Kernels," Risk. #' } #' @examples #' \dontrun{ -#' data(managers.df) -#' fit.macro <- fitTSFM (asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df, fit.method="OLS", -#' add.up.market=FALSE, add.market.sqd=FALSE, -#' variable.selection="none") +#' data(managers) +#' fit.macro <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=c("EDHEC LS EQ","SP500 TR"),data=managers) #' # risk factor contribution to ETL #' # combine fund returns, factor returns and residual returns for HAM1 -#' tmpData = cbind(managers.df[,1],managers.df[,c("EDHEC.LS.EQ","SP500.TR")] , +#' tmpData = cbind(managers[,1],managers[,c("EDHEC LS EQ","SP500 TR")] , #' residuals(fit.macro$asset.fit$HAM1)/sqrt(fit.macro$resid.sd[1])) #' colnames(tmpData)[c(1,4)] = c("HAM1", "residual") #' factor.es.decomp.HAM1 = factorModelEsDecomposition(tmpData, fit.macro$beta[1,], Modified: pkg/FactorAnalytics/R/factorModelMonteCarlo.R =================================================================== --- pkg/FactorAnalytics/R/factorModelMonteCarlo.R 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/R/factorModelMonteCarlo.R 2014-07-15 01:00:58 UTC (rev 3471) @@ -50,12 +50,11 @@ #' @examples #' #' # load data from the database -#' data(managers.df) -#' fit <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' data=managers.df, add.up.market=FALSE, add.market.sqd=FALSE, -#' fit.method="OLS", variable.selection="none") -#' factorData= managers.df[,c("EDHEC.LS.EQ","SP500.TR")] +#' \dontrun{ +#' data(managers) +#' fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=c("EDHEC LS EQ","SP500 TR"), data=managers) +#' factorData= managers[,c("EDHEC LS EQ","SP500 TR")] #' Beta.mat=fit$beta #' residualData=as.matrix((fit$resid.sd)^2,1,6) #' n.boot=1000 @@ -68,7 +67,7 @@ #' # build different residualData matrix #' residualData <- cbind(c(1,2,1,3,0.1,0.5),rnorm(6),c(2,3,1,2,1,0)) #' colnames(residualData) <- c("var","skew","ekurt") -#' rownames(residualData) <- colnames(managers.df[,(1:6)]) +#' rownames(residualData) <- colnames(managers[,(1:6)]) #' bootData <- factorModelMonteCarlo(n.boot, factorData,Beta.mat, residual.dist="Cornish-Fisher", #' residualData, Alpha.mat=NULL, boot.method="random", #' seed = 123, return.factors = "TRUE", return.residuals = @@ -79,11 +78,12 @@ #' # build residualData matrix #' residualData <- cbind(rnorm(6),c(1,2,1,3,0.1,0.5),rnorm(6),c(2,3,1,6,10,100)) #' colnames(residualData) <- c("xi","omega","alpha","nu") -#' rownames(residualData) <- colnames(managers.df[,(1:6)]) +#' rownames(residualData) <- colnames(managers[,(1:6)]) #' bootData <- factorModelMonteCarlo(n.boot, factorData,Beta.mat, residual.dist="skew-t", #' residualData, Alpha.mat=NULL, boot.method="random", #' seed = 123, return.factors = "TRUE", return.residuals = #' "TRUE") +#' } #' factorModelMonteCarlo <- function (n.boot = 1000, factorData, Beta.mat, Alpha.mat = NULL, Modified: pkg/FactorAnalytics/R/factorModelVaRDecomposition.R =================================================================== --- pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/R/factorModelVaRDecomposition.R 2014-07-15 01:00:58 UTC (rev 3471) @@ -42,15 +42,12 @@ #' } #' @examples #' \dontrun{ -#' data(managers.df) -#' fit.macro <- fitTSFM(asset.names=colnames(managers.df[,(1:6)]), -#' factor.names=c("EDHEC.LS.EQ","SP500.TR"), -#' add.up.market=FALSE, add.market.sqd=FALSE, -#' data=managers.df, fit.method="OLS", -#' variable.selection="none") +#' data(managers) +#' fit.macro <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=c("EDHEC LS EQ","SP500 TR"), data=managers) #' # risk factor contribution to VaR #' # combine fund returns, factor returns and residual returns for HAM1 -#' tmpData = cbind(managers.df[,1],managers.df[,c("EDHEC.LS.EQ","SP500.TR")] , +#' tmpData = cbind(managers[,1], managers[,c("EDHEC LS EQ","SP500 TR")] , #' residuals(fit.macro$asset.fit$HAM1)/fit.macro$resid.sd[1]) #' colnames(tmpData)[c(1,4)] = c("HAM1", "residual") #' factor.VaR.decomp.HAM1 = factorModelVaRDecomposition(tmpData, fit.macro$beta[1,], Deleted: pkg/FactorAnalytics/R/fitTSFM.R =================================================================== --- pkg/FactorAnalytics/R/fitTSFM.R 2014-07-14 01:31:38 UTC (rev 3470) +++ pkg/FactorAnalytics/R/fitTSFM.R 2014-07-15 01:00:58 UTC (rev 3471) @@ -1,557 +0,0 @@ -#' @title Fit a time series factor model using time series regression -#' -#' @description Fits a time series (or, macroeconomic) factor model for single -#' or multiple asset returns or excess returns using time series regression. -#' Users can choose between ordinary least squares-OLS, discounted least -#' squares-DLS (or) robust regression. Several variable selection options -#' including Stepwise, Subsets, Lars are available as well. An object of class -#' \code{tsfm} is returned. -#' -#' @details -#' Typically factor models are fit using excess returns. \code{Rf.name} gives -#' the option to supply a risk free rate variable to subtract from each asset -#' return and factor to create excess returns. -#' -#' Estimation method "OLS" corresponds to ordinary least squares, "DLS" is -#' discounted least squares, which is weighted least squares estimation with -#' exponentially declining weights that sum to unity, and, "Robust" is robust -#' regression (uses \code{\link[robust]{lmRob}}). -#' -#' If \code{variable.selection="none"}, all chosen factors are used in the -#' factor model. Whereas, "stepwise" performs traditional forward/backward -#' stepwise OLS regression (using \code{\link[stats]{step}}), that starts from -#' the initial set of factors and adds factors only if the regression fit, as -#' measured by the Bayesian Information Criterion (BIC) or Akaike Information -#' Criterion (AIC), improves. And, "all subsets" enables subsets selection -#' using \code{\link[leaps]{regsubsets}} that chooses the n-best performing -#' subsets of any given size (specified as \code{num.factor.subsets} here). -#' \code{varaible.selection="lars"} corresponds to least angle regression -#' using \code{\link[lars]{lars}} with variants "lasso", "lar", -#' "forward.stagewise" or "stepwise". Note: If -#' \code{variable.selection="lars"}, \code{fit.method} will be ignored. -#' -#' If \code{add.up.market=TRUE}, \code{max(0, Rm-Rf)} is added as a factor in -#' the regression, following Henriksson & Merton (1981), to account for market -#' timing (price movement of the general stock market relative to fixed income -#' securities). The coefficient can be interpreted as the number of free put -#' options. Similarly, if \code{add.market.sqd=TRUE}, \code{(Rm-Rf)^2} is added -#' as a factor in the regression, following Treynor-Mazuy (1966), to account -#' for market timing with respect to volatility. -#' -#' \code{lars.criterion} selects the criterion (one of "Cp" or "cv") to -#' determine the best fitted model for \code{variable.selection="lars"}. The -#' "Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated -#' using \code{\link[lars]{summary.lars}}. While, "cv" computes the K-fold -#' cross-validated mean squared prediction error using -#' \code{\link[lars]{cv.lars}}. -#' -#' @param asset.names vector containing names of assets, whose returns or -#' excess returns are the dependent variable. -#' @param factor.names vector containing names of the macroeconomic factors. -#' @param market.name name of the column for market excess returns (Rm-Rf). -#' Is required only if \code{add.up.market} or \code{add.market.sqd} -#' are \code{TRUE}. Default is NULL. -#' @param Rf.name name of the column of risk free rate variable to calculate -#' excess returns for all assets and factors. Default is NULL, in which case, -#' the data is used as it is. -#' @param data vector, matrix, data.frame, xts, timeSeries or zoo object -#' containing column(s) named in \code{asset.names}, \code{factor.names} and -#' optionally, \code{market.name} and \code{Rf.name}. -#' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". -#' See details. -#' @param variable.selection the variable selection method, one of "none", -#' "stepwise","all subsets","lars". See details. -#' @param subsets.method one of "exhaustive", "forward", "backward" or "seqrep" -#' (sequential replacement) to specify the type of subset search/selection. -#' Required if "all subsets" variable selection is chosen. -#' @param nvmax the maximum size of subsets to examine; an option for -#' "all subsets" variable selection. Default is 8. -#' @param force.in vector containing the names of factors that should always -#' be included in the model; an option for "all subsets" variable selection. -#' Default is NULL. -#' @param num.factors.subset number of factors required in the factor model; -#' an option for "all subsets" variable selection. Default is 1. -#' Note: nvmax >= num.factors.subset >= length(force.in). -#' @param add.up.market logical, adds max(0, Rm-Rf) as a factor. If -#' \code{TRUE}, \code{market.name} is required. Default is \code{TRUE}. -#' See Details. -#' @param add.market.sqd logical, adds (Rm-Rf)^2 as a factor. If \code{TRUE}, -#' \code{market.name} is required. Default is \code{TRUE}. -#' @param decay a scalar in (0, 1] to specify the decay factor for -#' \code{fit.method="DLS"}. Default is 0.95. -#' @param lars.type One of "lasso", "lar", "forward.stagewise" or "stepwise". -#' The names can be abbreviated to any unique substring. Default is "lasso". -#' @param lars.criterion an option to assess model selection for the "lars" -#' method; one of "Cp" or "cv". See details. Default is "Cp". -#' @param ... optional arguments passed to the \code{step} function for -#' variable.selection method "stepwise", such as direction, steps and -#' the penalty factor k. Note that argument k is available only for "OLS" -#' and "DLS" fits. Scope argument is not available presently. Also plan to -#' include other controls passed to \code{lmRob} soon. -#' -#' @return fitTSFM returns an object of class \code{tsfm}. -#' -#' The generic functions \code{summary}, \code{predict} and \code{plot} are -#' used to obtain and print a summary, predicted asset returns for new factor -#' data and plot selected characteristics for one or more assets. The generic -#' accessor functions \code{coefficients}, \code{fitted} and \code{residuals} -#' extract various useful features of the fit object. \code{coef.tsfm} extracts -#' coefficients from the fitted factor model and returns an N x (K+1) matrix of -#' all coefficients, \code{fitted.tsfm} gives an N x T data object of fitted -#' values and \code{residuals.tsfm} gives an N x T data object of residuals. -#' -#' An object of class \code{tsfm} is a list containing the following -#' components: -#' \item{asset.fit}{list of fitted objects for each asset. Each object is of -#' class \code{lm} if \code{fit.method="OLS" or "DLS"}, class \code{lmRob} if -#' the \code{fit.method="Robust"}, or class \code{lars} if -#' \code{variable.selection="lars"}.} -#' \item{alpha}{N x 1 vector of estimated alphas.} -#' \item{beta}{N x K matrix of estimated betas.} -#' \item{r2}{N x 1 vector of R-squared values.} -#' \item{resid.sd}{N x 1 vector of residual standard deviations.} -#' \item{call}{the matched function call.} -#' \item{data}{xts data object containing the assets and factors.} -#' \item{asset.names}{asset.names as input.} -#' \item{factor.names}{factor.names as input.} -#' \item{fit.method}{fit.method as input.} -#' \item{variable.selection}{variable.selection as input.} -#' Where N is the number of assets, K is the number of factors and T is the -#' number of time periods. -#' -#' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. -#' -#' @references -#' \enumerate{ -#' \item Christopherson, Jon A., David R. Carino, and Wayne E. Ferson. -#' Portfolio performance measurement and benchmarking. McGraw Hill -#' Professional, 2009. -#' \item Efron, Bradley, Trevor Hastie, Iain Johnstone, and Robert Tibshirani. -#' "Least angle regression." The Annals of statistics 32, no. 2 (2004): 407-499. -#' \item Hastie, Trevor, Robert Tibshirani, Jerome Friedman, T. Hastie, J. -#' Friedman, and R. Tibshirani. The elements of statistical learning. Vol. 2, -#' no. 1. New York: Springer, 2009. -#' \item Henriksson, Roy D., and Robert C. Merton. "On market timing and -#' investment performance. II. Statistical procedures for evaluating -#' forecasting skills." Journal of business (1981): 513-533. -#' \item Treynor, Jack, and Kay Mazuy. "Can mutual funds outguess the market." -#' Harvard business review 44, no. 4 (1966): 131-136. -#' } -#' -#' @seealso The \code{tsfm} methods for generic functions: -#' \code{\link{plot.tsfm}}, \code{\link{predict.tsfm}}, -#' \code{\link{print.tsfm}} and \code{\link{summary.tsfm}}. -#' -#' And, the following extractor functions: \code{\link[stats]{coef}}, -#' \code{\link{covFM}}, \code{\link[stats]{fitted}} and -#' \code{\link[stats]{residuals}}. -#' -#' \code{\link{paFM}} for Performance Attribution. -#' -#' @examples -#' # load data from the database -#' data(managers) -#' fit <- fitTSFM(asset.names=colnames(managers[,(1:6)]), -#' factor.names=colnames(managers[,(7:9)]), -#' market.name="SP500 TR", data=managers) -#' # summary -#' summary(fit) -#' # fitted values for all assets' returns -#' fitted(fit) -#' # plot actual vs. fitted over time for HAM1 -#' # using chart.TimeSeries() function from PerformanceAnalytics package -#' dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers$HAM1)) -#' colnames(dataToPlot) <- c("Fitted","Actual") -#' chart.TimeSeries(dataToPlot, main="FM fit for HAM1", -#' colorset=c("black","blue"), legend.loc="bottomleft") -#' -#' @export - -fitTSFM <- function(asset.names, factor.names, market.name=NULL, Rf.name=NULL, - data=data, fit.method=c("OLS","DLS","Robust"), - variable.selection=c("none","stepwise","all subsets", - "lars"), - subsets.method=c("exhaustive","backward","forward", - "seqrep"), - nvmax=8, force.in=NULL, num.factors.subset=1, - add.up.market=TRUE, add.market.sqd=TRUE, decay=0.95, - lars.type=c("lasso","lar","forward.stagewise","stepwise"), - lars.criterion="Cp", ...){ - - # get all the arguments specified by their full names - call <- match.call() - - fit.method = fit.method[1] # default is OLS - variable.selection = variable.selection[1] # default is "none" - subsets.method = subsets.method[1] # default is "exhaustive" - lars.type=lars.type[1] # default is "lasso" - - if (!exists("direction")) {direction <- "backward"} - if (!exists("steps")) {steps <- 1000} - if (!exists("k")) {k <- 2} - if ((missing(market.name)|is.null(market.name)) && - (add.up.market==TRUE | add.market.sqd==TRUE)) { - stop("Missing input: 'market.name' is required to include factors - 'up.market' or 'market.sqd'") - } - - # convert data into an xts object and hereafter work with xts objects - data.xts <- checkData(data) - - # extract columns to be used in the time series regression - dat.xts <- merge(data.xts[,asset.names], data.xts[,factor.names]) - ### After merging xts objects, the spaces in names get converted to periods - - # convert all asset and factor returns to excess return form if specified - if (!is.null(Rf.name)) { - dat.xts <- "[<-"(dat.xts,,vapply(dat.xts, function(x) x-data.xts[,Rf.name], - FUN.VALUE = numeric(nrow(dat.xts)))) - } - - # opt add market-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 - if(add.up.market == TRUE) { - up.market <- data.xts[,market.name] - up.market [up.market < 0] <- 0 - dat.xts <- merge.xts(dat.xts,up.market) - colnames(dat.xts)[dim(dat.xts)[2]] <- "up.market" - factor.names <- c(factor.names, "up.market") - } - if(add.market.sqd == TRUE) { - market.sqd <- data.xts[,market.name]^2 - dat.xts <- merge(dat.xts, market.sqd) - colnames(dat.xts)[dim(dat.xts)[2]] <- "market.sqd" - factor.names <- c(factor.names, "market.sqd") - } - - # spaces get converted to periods in colnames of xts object after merge - asset.names <- gsub(" ",".", asset.names, fixed=TRUE) - factor.names <- gsub(" ",".", factor.names, fixed=TRUE) - - # Selects regression procedure based on specified variable.selection method. - # Each method returns a list of fitted factor models for each asset. - if (variable.selection == "none") { - reg.list <- NoVariableSelection(dat.xts, asset.names, factor.names, - fit.method, add.up.market, add.market.sqd, - decay) - } else if (variable.selection == "stepwise"){ - reg.list <- SelectStepwise(dat.xts, asset.names, factor.names, - fit.method, add.up.market, add.market.sqd, - decay, direction, steps, k) - } else if (variable.selection == "all subsets"){ - reg.list <- SelectAllSubsets(dat.xts, asset.names, factor.names, - fit.method, subsets.method, - nvmax, force.in, num.factors.subset, - add.up.market, add.market.sqd, decay) - } else if (variable.selection == "lars"){ - result.lars <- SelectLars(dat.xts, asset.names, factor.names, - lars.type, add.up.market, add.market.sqd, - decay, lars.criterion) - input <- list(call=call, data=dat.xts, - asset.names=asset.names, factor.names=factor.names, - fit.method=fit.method, variable.selection=variable.selection) - result <- c(result.lars, input) - class(result) <- "tsfm" - return(result) - } - else { - stop("Invalid argument: variable.selection must be either 'none', - 'stepwise','all subsets','lars'") - } - - # extract the fitted factor models, coefficients, r2 values and residual vol - # from returned factor model fits above - coef.mat <- makePaddedDataFrame(lapply(reg.list, coef)) - alpha <- coef.mat[, 1, drop=FALSE] - # to make class of alpha numeric instead of matrix - # aplha <- coef.mat[,1] - beta <- coef.mat[, -1, drop=FALSE] - r2 <- sapply(reg.list, function(x) summary(x)$r.squared) - resid.sd <- sapply(reg.list, function(x) summary(x)$sigma) - # create list of return values. - result <- list(asset.fit=reg.list, alpha=alpha, beta=beta, r2=r2, - resid.sd=resid.sd, call=call, data=dat.xts, - asset.names=asset.names, factor.names=factor.names, - fit.method=fit.method, variable.selection=variable.selection) - class(result) <- "tsfm" - return(result) -} - - -### method variable.selection = "none" -# -NoVariableSelection <- function(dat.xts, asset.names, factor.names, fit.method, - add.up.market, add.market.sqd, decay){ - # initialize list object to hold the fitted objects - reg.list <- list() - - # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ - # completely remove NA cases - reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - - # formula to pass to lm or lmRob - fm.formula <- as.formula(paste(i," ~ .")) - - # fit based on time series regression method chosen - if (fit.method == "OLS") { - reg.list[[i]] <- lm(fm.formula, data=reg.xts) - } else if (fit.method == "DLS") { - w <- WeightsDLS(nrow(reg.xts), decay) - reg.list[[i]] <- lm(fm.formula, data=reg.xts, weights=w) - } else if (fit.method == "Robust") { - reg.list[[i]] <- lmRob(fm.formula, data=reg.xts) - } else { - stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") - } - } - reg.list -} - - -### method variable.selection = "stepwise" -# -SelectStepwise <- function(dat.xts, asset.names, factor.names, fit.method, - add.up.market, add.market.sqd, decay, - direction, steps, k){ - # initialize list object to hold the fitted objects - reg.list <- list() - - # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ - # completely remove NA cases - reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - - # formula to pass to lm or lmRob - fm.formula <- as.formula(paste(i," ~ .")) - - # fit based on time series regression method chosen - if (fit.method == "OLS") { - reg.list[[i]] <- step(lm(fm.formula, data=reg.xts), direction=direction, - steps=steps, k=k, trace=0) - } else if (fit.method == "DLS") { - w <- WeightsDLS(nrow(reg.xts), decay) - reg.list[[i]] <- step(lm(fm.formula, data=reg.xts, weights=w), - direction=direction, steps=steps, k=k, trace=0) - } else if (fit.method == "Robust") { - reg.list[[i]] <- step.lmRob(lmRob(fm.formula, data=reg.xts), trace=FALSE, - direction=direction, steps=steps) - } else { - stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") - } - } - reg.list -} - - -### method variable.selection = "all subsets" -# -SelectAllSubsets <- function(dat.xts, asset.names, factor.names, fit.method, - subsets.method, nvmax, force.in, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3471 From noreply at r-forge.r-project.org Fri Jul 18 03:35:17 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 18 Jul 2014 03:35:17 +0200 (CEST) Subject: [Returnanalytics-commits] r3472 - pkg/PortfolioAnalytics/demo Message-ID: <20140718013517.EAF131876D0@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-18 03:35:16 +0200 (Fri, 18 Jul 2014) New Revision: 3472 Modified: pkg/PortfolioAnalytics/demo/backwards_compat.R pkg/PortfolioAnalytics/demo/chart_concentration.R pkg/PortfolioAnalytics/demo/constrained_optim.R pkg/PortfolioAnalytics/demo/demo_DEoptim.R pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R pkg/PortfolioAnalytics/demo/demo_factor_exposure.R pkg/PortfolioAnalytics/demo/demo_group_constraints.R pkg/PortfolioAnalytics/demo/demo_leverage_exposure_constraint.R pkg/PortfolioAnalytics/demo/demo_max_STARR.R pkg/PortfolioAnalytics/demo/demo_max_Sharpe.R pkg/PortfolioAnalytics/demo/demo_max_quadratic_utility.R pkg/PortfolioAnalytics/demo/demo_max_return.R pkg/PortfolioAnalytics/demo/demo_min_StdDev.R pkg/PortfolioAnalytics/demo/demo_min_expected_shortfall.R pkg/PortfolioAnalytics/demo/demo_opt_combine.R pkg/PortfolioAnalytics/demo/demo_proportional_cost.R pkg/PortfolioAnalytics/demo/demo_return_target.R pkg/PortfolioAnalytics/demo/demo_risk_budgets.R pkg/PortfolioAnalytics/demo/demo_roi_solvers.R pkg/PortfolioAnalytics/demo/demo_weight_concentration.R pkg/PortfolioAnalytics/demo/higher_moments_boudt.R pkg/PortfolioAnalytics/demo/meucci_ffv.R pkg/PortfolioAnalytics/demo/multi_layer_optimization.R pkg/PortfolioAnalytics/demo/regime_switching.R pkg/PortfolioAnalytics/demo/relative_ranking.R pkg/PortfolioAnalytics/demo/sortino.R pkg/PortfolioAnalytics/demo/testing_GenSA.R pkg/PortfolioAnalytics/demo/testing_ROI.R pkg/PortfolioAnalytics/demo/testing_pso.R Log: Editing demos so they compile to Rstudio notebooks Modified: pkg/PortfolioAnalytics/demo/backwards_compat.R =================================================================== --- pkg/PortfolioAnalytics/demo/backwards_compat.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/backwards_compat.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,3 +1,14 @@ +#' --- +#' title: "Backwards Compatibility Demo" +#' author: "Ross Bennett" +#' date: "7/17/2014" +#' --- + +#' This script demonstrates how to solve optimization problems using what is +#' referred to as the v1 specification. The v1 specification was used in +#' before PortfolioAnalytics version 0.8.3 to define the optimization problem +#' with constraints and objectives. + library(PortfolioAnalytics) library(DEoptim) library(ROI) @@ -7,28 +18,28 @@ ret <- edhec[, 1:4] funds <- colnames(ret) -# Set up constraint object using v1 specification +#' Set up constraint object using v1 specification gen.constr <- constraint(assets=funds, min=0, max=0.55, min_sum=0.99, max_sum=1.01, weight_seq=generatesequence(min=0, max=0.55, by=0.002)) class(gen.constr) -# Add an objective to the gen.constr object +#' Add an objective to the gen.constr object gen.constr <- add.objective(constraints=gen.constr, type="return", name="mean", enabled=TRUE) -# Run the optimization -# optimize.portfolio will detect that a v1_constraint object has been passed in -# and will update to the v2 specification using a portfolio object with -# constraints and objectives from the v1_constraint object. +#' Here we run the optimization. Note that optimize.portfolio will detect +#' that a v1_constraint object has been passed in and will update to the +#' v2 specification using a portfolio object with constraints and objectives +#' from the v1_constraint object. -# Random Portfolios +#' Solve the problem using the random portfolios optimization engine optrpv1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="random", search_size=2000) optrpv1 -# DEoptim +#' Solve the problem using the DEoption (Differential Evolution) optimization engine optdev1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="DEoptim", search_size=2000) optdev1 -# ROI +#' Solve the problem using the ROI (R Optimization Infrastructure) optimization engine optroiv1 <- optimize.portfolio(R=ret, constraints=gen.constr, optimize_method="ROI") optroiv1 Modified: pkg/PortfolioAnalytics/demo/chart_concentration.R =================================================================== --- pkg/PortfolioAnalytics/demo/chart_concentration.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/chart_concentration.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,11 +1,20 @@ +#' --- +#' title: "chart.Concentration Demo" +#' author: "Ross Bennett" +#' date: "7/17/2014" +#' --- +#' This script demonstrates how to use chart.Concentration to visualize +#' the concentration of the portfolio. + + library(PortfolioAnalytics) data(edhec) R <- edhec[, 1:8] funds <- colnames(R) -# Construct initial portfolio +#' Construct initial portfolio init.portf <- portfolio.spec(assets=funds) init.portf <- add.constraint(portfolio=init.portf, type="leverage", @@ -26,13 +35,14 @@ type="risk", name="ES") +#' Construct a risk budget portfolio. rb.portf <- add.objective(portfolio=init.portf, type="risk_budget", name="ES", max_prisk=0.4, arguments=list(p=0.92)) -# Use DEoptim for optimization +#' Use random portfolios for optimization. opt <- optimize.portfolio(R=R, portfolio=init.portf, optimize_method="random", @@ -45,19 +55,19 @@ search_size=2000, trace=TRUE) -# This won't work because opt is not a risk budget optimization -# This should result in an error and not plot anything -chart.Concentration(opt, conc.type="pct_contrib") +#' This won't work because opt is not a risk budget optimization. +#' This should result in an error and not plot anything. +#chart.Concentration(opt, conc.type="pct_contrib") -# opt is minimum ES optimization so we can still chart it using weights as -# the measure of concentration +#' `opt` is minimum ES optimization so we can still chart it using weights as +#' the measure of concentration. chart.Concentration(opt, conc.type="weights", chart.assets=TRUE, col=heat.colors(10)) chart.Concentration(opt, conc.type="weights", chart.assets=TRUE, col=bluemono) -# The concentration is based on the HHI of the percentage component -# contribution to risk +#' Here we plot the concentration based on the HHI of the percentage component +#' contribution to risk. chart.Concentration(opt_rb, conc.type="pct_contrib") -# The concentration is based on the HHI of the weights +#' Here we plot the concentration is based on the HHI of the weights. chart.Concentration(opt_rb, conc.type="weights") Modified: pkg/PortfolioAnalytics/demo/constrained_optim.R =================================================================== --- pkg/PortfolioAnalytics/demo/constrained_optim.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/constrained_optim.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,11 +1,17 @@ +#' --- +#' title: "Constrained Optimization Demo" +#' --- +#' This script demonstrates how to set up and solve constrained optimization +#' problems. Note that this script using the pre version 0.8.3 syntax. + library(PortfolioAnalytics) require(DEoptim) -# Load the data +#' Load the data data(edhec) -#constraints +#' Set up the constraints and objectives to define the optimization problem constraints <- constraint(assets = colnames(edhec[, 1:10]), min = 0.01, max = 0.4, min_sum=0.99, max_sum=1.01, weight_seq = generatesequence()) @@ -21,12 +27,12 @@ max_prisk=.15, target=0.05) -print("We'll use a search_size parameter of 1000 for this demo, but realistic - portfolios will likely require search_size parameters much larger, the - default is 20000 which is almost always large enough for any realistic - portfolio and constraints, but will take substantially longer to run.") +#' We'll use a search_size parameter of 1000 for this demo, but realistic +#' portfolios will likely require search_size parameters much larger, the +#' default is 20000 which is almost always large enough for any realistic +#' portfolio and constraints, but will take substantially longer to run. -# look for a solution using both DEoptim and random portfolios +#' Look for a solution using both DEoptim and random portfolios opt_out <- optimize.portfolio(R=edhec[,1:10], constraints=constraints, optimize_method="DEoptim", @@ -39,7 +45,7 @@ search_size=1000, trace=TRUE) -# Optimize a portfolio that rebalances quarterly +#' Optimize a portfolio that rebalances quarterly opt_out_rebalancing <- optimize.portfolio.rebalancing(R=edhec[,1:10], constraints=constraints, optimize_method="random", @@ -47,11 +53,12 @@ trace=FALSE, rebalance_on='quarters') +#' Extract the optimal weights at each rebalance date and compute the returns rebalancing_weights <- extractWeights(opt_out_rebalancing) rebalancing_returns <- Return.rebalancing(R=edhec,weights=rebalancing_weights) charts.PerformanceSummary(rebalancing_returns) -# Optimize a portfolio that rebalances quarterly with 48 mo trailing +#' Optimize a portfolio that rebalances quarterly with 48 month trailing opt_out_trailing <- optimize.portfolio.rebalancing(R=edhec[,1:10], constraints=constraints, optimize_method="random", Modified: pkg/PortfolioAnalytics/demo/demo_DEoptim.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_DEoptim.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/demo_DEoptim.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,59 +1,61 @@ +#' --- +#' title: "Differential Evolution Optimization Demo" +#' date: "7/17/2014" +#' --- -# The following optimization problems will be run -# mean-mETL -# - maximize mean-to-ETL (i.e. reward-to-risk) -# MinSD -# - minimize annualized standard deviation -# eqStdDev -# - equal risk (volatility) -# MeanRL -# - maximize mean with mETL risk limits +#' This script demonstrates several optimization problems using Differential +#' Evolution as the optimization engine. This script is based heavily on +#' http://www.rinfinance.com/agenda/2012/workshop/Carl+Peterson.pdf. -# Include optimizer and multi-core packages +#' The following optimization problems will be run +#' * mean-mETL: maximize mean-to-ETL (i.e. reward-to-risk) +#' * MinSD: minimize annualized standard deviation +#' * eqStdDev: equal risk (volatility) +#' * MeanRL: maximize mean with mETL risk limits + +#' Include optimizer and multi-core packages library(PortfolioAnalytics) -require(quantmod) require(DEoptim) require(foreach) -# The multicore package, and therefore registerDoMC, should not be used in a -# GUI environment, because multiple processes then share the same GUI. Only use -# when running from the command line. +#' The multicore package, and therefore registerDoMC, should not be used in a +#' GUI environment, because multiple processes then share the same GUI. Only use +#' when running from the command line. # require(doMC) # registerDoMC(3) +#' Load the data data(edhec) - -# Drop some indexes and reorder edhec.R <- edhec[,c("Convertible Arbitrage", "Equity Market Neutral", "Fixed Income Arbitrage", "Event Driven", "CTA Global", "Global Macro", "Long/Short Equity")] -# Annualized standard deviation +#' Define function to compute annualized standard deviation pasd <- function(R, weights){ as.numeric(StdDev(R=R, weights=weights)*sqrt(12)) # hardcoded for monthly data # as.numeric(StdDev(R=R, weights=weights)*sqrt(4)) # hardcoded for quarterly data } -# Set some parameters +#' Set some parameters rebalance_period = 'quarters' # uses endpoints identifiers from xts clean = "none" #"boudt" permutations = 4000 -# Create initial portfolio object used to initialize ALL the bouy portfolios +#' Create initial portfolio object used to initialize ALL the bouy portfolios init.portf <- portfolio.spec(assets=colnames(edhec.R), weight_seq=generatesequence(by=0.005)) -# Add leverage constraint +#' Add leverage constraint init.portf <- add.constraint(portfolio=init.portf, type="leverage", min_sum=0.99, max_sum=1.01) -# Add box constraint +#' Add box constraint init.portf <- add.constraint(portfolio=init.portf, type="box", min=0.05, max=0.3) -#Add measure 1, mean return +#' Add measure 1, mean return init.portf <- add.objective(portfolio=init.portf, type="return", # the kind of objective this is name="mean", # name of the function @@ -61,7 +63,7 @@ multiplier=0 # calculate it but don't use it in the objective ) -# Add measure 2, annualized standard deviation +#' Add measure 2, annualized standard deviation init.portf <- add.objective(portfolio=init.portf, type="risk", # the kind of objective this is name="pasd", # to minimize from the sample @@ -69,8 +71,7 @@ multiplier=0 # calculate it but don't use it in the objective ) -# Add measure 3, ES with p=(1-1/12) -# set confidence for ES +#' Add measure 3, ES with confidence level p=(1-1/12) p <- 1-1/12 # for monthly init.portf <- add.objective(portfolio=init.portf, @@ -81,26 +82,27 @@ arguments=list(p=p) ) -# Set up portfolio for Mean-mETL +#' Set up portfolio for Mean-mETL MeanmETL.portf <- init.portf MeanmETL.portf$objectives[[1]]$multiplier=-1 # mean MeanmETL.portf$objectives[[3]]$enabled=TRUE # mETL MeanmETL.portf$objectives[[3]]$multiplier=1 # mETL -# Set up portfolio for min pasd +#' Set up portfolio for min pasd MinSD.portf <- init.portf MinSD.portf$objectives[[2]]$multiplier=1 -# Set up portfolio for eqStdDev +#' Set up portfolio for eqStdDev EqSD.portf <- add.objective(portfolio=init.portf, type="risk_budget", name="StdDev", min_concentration=TRUE, arguments = list(p=(1-1/12))) -# Without a sub-objective, we get a somewhat undefined result, since there are (potentially) many Equal SD contribution portfolios. +#' Without a sub-objective, we get a somewhat undefined result, since +#' there are (potentially) many Equal SD contribution portfolios. EqSD.portf$objectives[[2]]$multiplier=1 # min pasd -# Set up portfolio to maximize mean with mETL risk limit +#' Set up portfolio to maximize mean with mETL risk limit MeanRL.portf <- add.objective(portfolio=init.portf, type='risk_budget', name="ES", @@ -108,15 +110,17 @@ max_prisk=0.4, arguments=list(method="modified", p=p)) MeanRL.portf$objectives[[1]]$multiplier=-1 # mean -# Change box constraints max to vector of 1s +#' Change box constraints max to vector of 1s MeanRL.portf$constraints[[2]]$max=rep(1, 7) -# Set the 'R' variable +#' Set the 'R' variable R <- edhec.R +#' Start the optimizations start_time<-Sys.time() print(paste('Starting optimization at',Sys.time())) +#' Run the optimization ##### mean-mETL ##### MeanmETL.DE <- optimize.portfolio(R=R, portfolio=MeanmETL.portf, @@ -145,7 +149,7 @@ print(paste('Completed MeanmETL optimization at',Sys.time(),'moving on to MinSD')) - +#' Run the optimization ##### min pasd ##### MinSD.DE <- optimize.portfolio(R=R, portfolio=MinSD.portf, @@ -161,6 +165,7 @@ print(paste('Completed MinSD optimization at',Sys.time(),'moving on to EqSD')) +#' Run the optimization ##### EqSD ##### EqSD.DE <- optimize.portfolio(R=R, portfolio=EqSD.portf, @@ -179,6 +184,7 @@ print(paste('Completed EqSD optimization at',Sys.time(),'moving on to MeanRL')) +#' Run the optimization ##### MeanRL.DE ##### MeanRL.DE <- optimize.portfolio(R=R, portfolio=MeanRL.portf, Modified: pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/demo_efficient_frontier.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,24 +1,30 @@ -# Script to test efficient frontiers +#' --- +#' title: "Efficient Frontier Demo" +#' date: "7/17/2014" +#' --- -# Efficient frontiers can be plotted two ways -# 1. Run optimize.portfolio with trace=TRUE and then chart that object -# 2. create an efficient frontier and then chart that object +#' This script demonstrates how to compute and plot the efficient frontier +#' given different constraints and objectives. +#' Efficient frontiers can be plotted two ways +#' 1. Run optimize.portfolio with trace=TRUE and then chart that object. +#' 2. create an efficient frontier and then chart that object. + +#' Load required packages library(PortfolioAnalytics) library(DEoptim) library(ROI) require(ROI.plugin.quadprog) require(ROI.plugin.glpk) +#' Load the data and change the column names for better legends in plotting. data(edhec) R <- edhec[, 1:5] -# change the column names for better legends in plotting colnames(R) <- c("CA", "CTAG", "DS", "EM", "EQM") funds <- colnames(R) -# initial portfolio object +#' Set up the initial portfolio object with some basic constraints. init <- portfolio.spec(assets=funds) -# initial constraints init <- add.constraint(portfolio=init, type="full_investment") init <- add.constraint(portfolio=init, type="box", min=0.15, max=0.45) init <- add.constraint(portfolio=init, type="group", @@ -27,101 +33,105 @@ group_min=0.05, group_max=0.7) -# create mean-etl portfolio +#' Add objectives for mean-ES (Expected Shortfall) portfolio. meanetl.portf <- add.objective(portfolio=init, type="risk", name="ES") meanetl.portf <- add.objective(portfolio=meanetl.portf, type="return", name="mean") -# create mean-var portfolio +#' Add objectives for mean-variance portfolio. meanvar.portf <- add.objective(portfolio=init, type="risk", name="var", risk_aversion=10) meanvar.portf <- add.objective(portfolio=meanvar.portf, type="return", name="mean") -# create efficient frontiers - -# mean-var efficient frontier +#' Compute the mean-variance efficient frontier. meanvar.ef <- create.EfficientFrontier(R=R, portfolio=init, type="mean-StdDev") meanvar.ef summary(meanvar.ef, digits=2) meanvar.ef$frontier -# The RAR.text argument can be used for the risk-adjusted-return name on the legend, -# by default it is 'Modified Sharpe Ratio' -chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="l", RAR.text="Sharpe Ratio", pch=4) +#' The RAR.text argument can be used for the risk-adjusted-return name on the +#' legend, by default it is 'Modified Sharpe Ratio'. +chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="l", + RAR.text="Sharpe Ratio", pch=4) -# The tangency portfolio and line are plotted by default, these can be ommitted -# by setting rf=NULL +#' The tangency portfolio and line are plotted by default, these can be +#' ommitted by setting rf=NULL. chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="b", rf=NULL) -# The tangency line can be omitted with tangent.line=FALSE. The tangent portfolio, -# risk-free rate and Sharpe Ratio are still included in the plot +#' The tangency line can be omitted with tangent.line=FALSE. The tangent +#' portfolio, risk-free rate and Sharpe Ratio are still included in the plot. chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="l", tangent.line=FALSE) -# The assets can be omitted with chart.assets=FALSE +#' The assets can be omitted with chart.assets=FALSE. chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="l", tangent.line=FALSE, chart.assets=FALSE) -# Just the names of the assets can be omitted with labels.assets=FALSE and the -# plotting character can be changed with pch.assets +#' Just the names of the assets can be omitted with labels.assets=FALSE and the +#' plotting character can be changed with pch.assets. chart.EfficientFrontier(meanvar.ef, match.col="StdDev", type="l", tangent.line=FALSE, labels.assets=FALSE, pch.assets=1) -# Chart the asset weights along the efficient frontier +#' Chart the asset weights along the efficient frontier. chart.Weights.EF(meanvar.ef, colorset=bluemono, match.col="StdDev") -# Chart the group weights along the efficient frontier +#' Chart the group weights along the efficient frontier. chart.Weights.EF(meanvar.ef, colorset=bluemono, by.groups=TRUE, match.col="StdDev") -# The labels for Mean, Weight, and StdDev can be increased or decreased with -# the cex.lab argument. The default is cex.lab=0.8 +#' The labels for Mean, Weight, and StdDev can be increased or decreased with +#' the cex.lab argument. The default is cex.lab=0.8. chart.Weights.EF(meanvar.ef, colorset=bluemono, match.col="StdDev", main="", cex.lab=1) -# If you have a lot of assets and they don't fit with the default legend, you -# can set legend.loc=NULL and customize the plot. +#' If you have a lot of assets and they don't fit with the default legend, you +#' can set legend.loc=NULL and customize the plot. par(mar=c(8, 4, 4, 2)+0.1, xpd=TRUE) chart.Weights.EF(meanvar.ef, colorset=bluemono, match.col="StdDev", legend.loc=NULL) legend("bottom", legend=colnames(R), inset=-1, fill=bluemono, bty="n", ncol=3, cex=0.8) par(mar=c(5, 4, 4, 2)+0.1, xpd=FALSE) -# run optimize.portfolio and chart the efficient frontier for that object -opt_meanvar <- optimize.portfolio(R=R, portfolio=meanvar.portf, optimize_method="ROI", trace=TRUE) +#' Run optimize.portfolio and chart the efficient frontier of the optimal +#' portfolio object. +opt_meanvar <- optimize.portfolio(R=R, portfolio=meanvar.portf, + optimize_method="ROI", trace=TRUE) -# The efficient frontier is created from the 'opt_meanvar' object by getting -# The portfolio and returns objects and then passing those to create.EfficientFrontier +#' The efficient frontier is created from the 'opt_meanvar' object by getting. +#' The portfolio and returns objects and then passing those to create.EfficientFrontier. chart.EfficientFrontier(opt_meanvar, match.col="StdDev", n.portfolios=25, type="l") -# Rerun the optimization with a new risk aversion parameter to change where the -# portfolio is along the efficient frontier. The 'optimal' portfolio plotted on -# the efficient frontier is the optimal portfolio returned by optimize.portfolio. +#' Rerun the optimization with a new risk aversion parameter to change where +#' the portfolio is along the efficient frontier. The 'optimal' portfolio +#' plotted on the efficient frontier is the optimal portfolio returned by +#' optimize.portfolio. meanvar.portf$objectives[[2]]$risk_aversion=0.25 opt_meanvar <- optimize.portfolio(R=R, portfolio=meanvar.portf, optimize_method="ROI", trace=TRUE) chart.EfficientFrontier(opt_meanvar, match.col="StdDev", n.portfolios=25, type="l") -# The weights along the efficient frontier can be plotted by passing in the -# optimize.portfolio output object +#' The weights along the efficient frontier can be plotted by passing in the +#' optimize.portfolio output object. chart.Weights.EF(opt_meanvar, match.col="StdDev") chart.Weights.EF(opt_meanvar, match.col="StdDev", by.groups=TRUE) -# Extract the efficient frontier and then plot it -# Note that if you want to do multiple charts of the efficient frontier from -# the optimize.portfolio object, it is best to extractEfficientFrontier as shown -# below +#' Extract the efficient frontier and then plot it. +#' Note that if you want to do multiple charts of the efficient frontier from +#' the optimize.portfolio object, it is best to extractEfficientFrontier as +#' shown below. ef <- extractEfficientFrontier(object=opt_meanvar, match.col="StdDev", n.portfolios=15) ef summary(ef, digits=5) chart.Weights.EF(ef, match.col="StdDev", colorset=bluemono) chart.Weights.EF(ef, match.col="StdDev", colorset=bluemono, by.groups=TRUE) -# mean-etl efficient frontier +#' Compute the mean-ES efficient frontier. meanetl.ef <- create.EfficientFrontier(R=R, portfolio=init, type="mean-ES") meanetl.ef summary(meanetl.ef) meanetl.ef$frontier +#' Chart the mean-ES efficient frontier. chart.EfficientFrontier(meanetl.ef, match.col="ES", main="mean-ETL Efficient Frontier", type="l", col="blue", RAR.text="STARR") chart.Weights.EF(meanetl.ef, colorset=bluemono, match.col="ES") chart.Weights.EF(meanetl.ef, by.groups=TRUE, colorset=bluemono, match.col="ES") -# mean-etl efficient frontier using random portfolios +#' Compute the mean-ES efficient frontier using random portfolios to solve +#' the optimization problem. meanetl.rp.ef <- create.EfficientFrontier(R=R, portfolio=meanetl.portf, type="random", match.col="ES") chart.EfficientFrontier(meanetl.rp.ef, match.col="ES", main="mean-ETL RP Efficient Frontier", type="l", col="blue", rf=0) chart.Weights.EF(meanetl.rp.ef, colorset=bluemono, match.col="ES") @@ -130,36 +140,39 @@ opt_meanetl <- optimize.portfolio(R=R, portfolio=meanetl.portf, optimize_method="random", search_size=2000, trace=TRUE) chart.EfficientFrontier(meanetl.rp.ef, match.col="ES", main="mean-ETL RP Efficient Frontier", type="l", col="blue", rf=0, RAR.text="STARR") -##### overlay efficient frontiers of multiple portfolios ##### -# Create a mean-var efficient frontier for multiple portfolios and overlay the efficient frontier lines -# set up an initial portfolio with the full investment constraint and mean and var objectives +#' Create a mean-var efficient frontier for multiple portfolios and overlay +#' the efficient frontier lines. Set up an initial portfolio with the full +#' investment constraint and mean and var objectives. init.portf <- portfolio.spec(assets=funds) init.portf <- add.constraint(portfolio=init.portf, type="full_investment") -# long only constraints +#' Portfolio with long only constraints. lo.portf <- add.constraint(portfolio=init.portf, type="long_only") -# box constraints +#' Portfolio with box constraints. box.portf <- add.constraint(portfolio=init.portf, type="box", min=0.05, max=0.65) -# group constraints (also add long only constraints to the group portfolio) +#' Portfolio with group constraints (also add long only constraints to the +#' group portfolio). group.portf <- add.constraint(portfolio=init.portf, type="group", groups=list(groupA=c(1, 3), groupB=c(2, 4, 5)), group_min=c(0.25, 0.15), group_max=c(0.75, 0.55)) group.portf <- add.constraint(portfolio=group.portf, type="long_only") -# optimize.portfolio(R=R, portfolio=group.portf, optimize_method="ROI") +#' Combine the portfolios into a list. portf.list <- combine.portfolios(list(lo.portf, box.portf, group.portf)) + +#' Plot the efficient frontier overlay of the portfolios with varying constraints. legend.labels <- c("Long Only", "Box", "Group + Long Only") chart.EfficientFrontierOverlay(R=R, portfolio_list=portf.list, type="mean-StdDev", match.col="StdDev", legend.loc="topleft", legend.labels=legend.labels, cex.legend=0.6, labels.assets=FALSE, pch.assets=18) -# Efficient frontier in mean-ES space with varying confidence leves for -# ES calculation +#' Efficient frontier in mean-ES space with varying confidence leves for +#' ES calculation. ES90 <- add.objective(portfolio=lo.portf, type="risk", name="ES", arguments=list(p=0.9)) @@ -169,7 +182,11 @@ ES95 <- add.objective(portfolio=lo.portf, type="risk", name="ES", arguments=list(p=0.95)) +#' Combine the portfolios into a list. portf.list <- combine.portfolios(list(ES.90=ES90, ES.92=ES92, ES.95=ES95)) + +#' Plot the efficient frontier overlay of the portfolios with varying +#' confidence levels fot he ES calculation. legend.labels <- c("ES (p=0.9)", "ES (p=0.92)", "ES (p=0.95)") chart.EfficientFrontierOverlay(R=R, portfolio_list=portf.list, type="mean-ES", match.col="ES", legend.loc="topleft", Modified: pkg/PortfolioAnalytics/demo/demo_factor_exposure.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_factor_exposure.R 2014-07-15 01:00:58 UTC (rev 3471) +++ pkg/PortfolioAnalytics/demo/demo_factor_exposure.R 2014-07-18 01:35:16 UTC (rev 3472) @@ -1,3 +1,13 @@ +#' --- +#' title: "Factor Exposure Demo" +#' author: Ross Bennett +#' date: "7/17/2014" +#' --- + +#' This script demonstrates how to solve a portfolio optimization problem with +#' factor exposure constraints. + +#' Load the required packages library(PortfolioAnalytics) library(ROI) require(ROI.plugin.quadprog) @@ -5,91 +15,114 @@ library(Rglpk) library(DEoptim) +#' Load the data data(edhec) ret <- edhec[, 1:4] -# Create portfolio object +#' Create portfolio object pspec <- portfolio.spec(assets=colnames(ret)) -# Leverage constraint + +#' Here we define individual constraint objects. +#' Leverage constraint. lev_constr <- weight_sum_constraint(min_sum=1, max_sum=1) -# box constraint + +#' Box constraint lo_constr <- box_constraint(assets=pspec$assets, min=c(0.01, 0.02, 0.03, 0.04), max=0.65) -# group constraint + +#' Group constraint' grp_constr <- group_constraint(assets=pspec$assets, groups=list(1:2, 3, 4), group_min=0.1, group_max=0.4) -# position limit constraint + +#' Position limit constraint pl_constr <- position_limit_constraint(assets=pspec$assets, max_pos=4) -# Make up a B matrix for an industry factor model -# dummyA, dummyB, and dummyC could be industries, sectors, etc. +#' Make up a B matrix for an industry factor model. +#' dummyA, dummyB, and dummyC could be industries, sectors, etc. B <- cbind(c(1, 1, 0, 0), c(0, 0, 1, 0), c(0, 0, 0, 1)) rownames(B) <- colnames(ret) colnames(B) <- c("dummyA", "dummyB", "dummyC") -print(B) lower <- c(0.1, 0.1, 0.1) upper <- c(0.4, 0.4, 0.4) -# Industry exposure constraint -# The exposure constraint and group constraint are equivalent to test that they -# result in the same solution +#' Industry exposure constraint. +#' The exposure constraint and group constraint are equivalent to test that +#' they result in the same solution. exp_constr <- factor_exposure_constraint(assets=pspec$assets, B=B, lower=lower, upper=upper) -# objective to minimize variance +#' Here we define objectives. +#' +#' Objective to minimize variance. var_obj <- portfolio_risk_objective(name="var") -# objective to maximize return + +#' Objective to maximize return. ret_obj <- return_objective(name="mean") -# objective to minimize ETL + +#' Objective to minimize ETL. etl_obj <- portfolio_risk_objective(name="ETL") -# group constraint and exposure constraint should result in same solution - -##### minimize var objective ##### +#' Run optimization on minimum variance portfolio with leverage, long only, +#' and group constraints. opta <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, grp_constr), objectives=list(var_obj), optimize_method="ROI") opta +#' Run optimization on minimum variance portfolio with leverage, long only, +#' and factor exposure constraints. optb <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, exp_constr), objectives=list(var_obj), optimize_method="ROI") optb +#' Note that the portfolio with the group constraint and exposure constraint +#' should result in same solution. all.equal(opta$weights, optb$weights) -##### maximize return objective ##### +#' Run optimization on maximum return portfolio with leverage, long only, +#' and group constraints. optc <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, grp_constr), objectives=list(ret_obj), optimize_method="ROI") optc +#' Run optimization on maximum return portfolio with leverage, long only, +#' and factor exposure constraints. optd <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, exp_constr), objectives=list(ret_obj), optimize_method="ROI") optd +#' Note that the portfolio with the group constraint and exposure constraint +#' should result in same solution. all.equal(optc$weights, optd$weights) -##### minimize ETL objective ##### +#' Run optimization on minimum expected tail loss portfolio with leverage, +#' long only, and group constraints. opte <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, grp_constr), objectives=list(etl_obj), optimize_method="ROI") opte +#' Run optimization on minimum expected tail loss portfolio with leverage, +#' long only, and factor exposure constraints. optf <- optimize.portfolio(R=ret, portfolio=pspec, constraints=list(lev_constr, lo_constr, exp_constr), objectives=list(etl_obj), optimize_method="ROI") optf +#' Note that the portfolio with the group constraint and exposure constraint +#' should result in same solution. all.equal(opte$weights, optf$weights) -##### maximize return objective with DEoptim ##### +#' Run optimization on maximum return portfolio with leverage, long only, +#' and group constraints using DEoptim as the optimization engine. set.seed(123) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3472 From noreply at r-forge.r-project.org Fri Jul 18 03:40:26 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 18 Jul 2014 03:40:26 +0200 (CEST) Subject: [Returnanalytics-commits] r3473 - pkg/PortfolioAnalytics/demo Message-ID: <20140718014026.776761848FF@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-18 03:40:25 +0200 (Fri, 18 Jul 2014) New Revision: 3473 Removed: pkg/PortfolioAnalytics/demo/demo_ROI.R pkg/PortfolioAnalytics/demo/demo_group_ROI.R pkg/PortfolioAnalytics/demo/demo_maxret_ROI.R pkg/PortfolioAnalytics/demo/risk_budget_backtesting.R Modified: pkg/PortfolioAnalytics/demo/00Index Log: Removing a few of the demos that are redundant Modified: pkg/PortfolioAnalytics/demo/00Index =================================================================== --- pkg/PortfolioAnalytics/demo/00Index 2014-07-18 01:35:16 UTC (rev 3472) +++ pkg/PortfolioAnalytics/demo/00Index 2014-07-18 01:40:25 UTC (rev 3473) @@ -3,12 +3,9 @@ testing_ROI Demonstrate creating constraint object and solve five basic convex portfolio optimization problems with ROI using the 'edhec' dataset. testing_pso Demonstrate creating constraint object and solve portfolio optimization problems with pso using the 'edhec' dataset. These sample problems are similar to those used in testing_ROI, so that one can compare solutions easily. testing_GenSA Demonstrate creating the constraint object and solve portfolio optimization problems with GenSA using the 'edhec' datset. These sample problems are similar to those used in testing_ROI, so that one can compare solutions easily. -demo_ROI Demonstrate constraints and objectives that can be solved with ROI. demo_DEoptim Demonstrate solving portfolio optimization problems using DEoptim as the solver. The demo solvers 4 problems: 1) Maximize mean return per unit mETL 2) Minimize annualized standard deviation 3) Minimize annualized standard deviation with equal contribution to risk using standard deviation as the risk measure 4) Maximize mean return with equal contribution to risk using modified ETL as the risk measure. demo_efficient_frontier Demonstrate how to create and chart efficient frontiers. demo_factor_exposure Demonstrate how to use the factor_exposure constraint. -demo_group_ROI Demonstrate how to use group constraints using the ROI solver. -demo_maxret_ROI Demonstrate maximizing return using the ROI solver. demo_opt_combine Demonstrate how to combine and chart the optimal weights for multiple optimizations. demo_weight_concentration Demonstrate how to use the weight concentration objective. backwards_compat Demonstrate how to solve optimization problems using v1 specification with a v1_constraint object. @@ -25,7 +22,6 @@ demo_min_expected_shortfall Demonstrate objective to minimize expected shortfall. demo_risk_budgets Demonstrate using risk budget objectives. demo_roi_solvers Demonstrate specifying a solver using ROI. -risk_budget_backtesting Demonstrate optimize.portfolio.rebalancing with standard deviation risk budget objective. chart_concentration Demonstrate chart.Concentration multiple_portfolio_optimization Demonstrate passing a list of portfolios to optimize.portfolio and optimize.portfolio.rebalancing regime_switching Demonstrate optimization with support for regime switching to switch portfolios based on the regime. Deleted: pkg/PortfolioAnalytics/demo/demo_ROI.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_ROI.R 2014-07-18 01:35:16 UTC (rev 3472) +++ pkg/PortfolioAnalytics/demo/demo_ROI.R 2014-07-18 01:40:25 UTC (rev 3473) @@ -1,220 +0,0 @@ -# ROI examples - -# The following objectives can be solved with optimize_method=ROI -# maximize return -# minimum variance -# maximize quadratic utility -# minimize ETL - -library(PortfolioAnalytics) -library(ROI) -library(Rglpk) -require(ROI.plugin.glpk) -require(ROI.plugin.quadprog) - -# Load the returns data -data(edhec) -ret <- edhec[, 1:4] -funds <- colnames(ret) - -# Create portfolio specification -pspec <- portfolio.spec(assets=funds) - -##### Constraints ##### -# Constraints will be specified as separate objects, but could also be added to -# the portfolio object (see the portfolio vignette for examples of specifying -# constraints) - -# Full investment constraint -fi_constr <- weight_sum_constraint(min_sum=1, max_sum=1) - -# Long only constraint -lo_constr <- box_constraint(assets=pspec$assets, min=0, max=1) - -# Box constraints -box_constr <- box_constraint(assets=pspec$assets, - min=c(0.05, 0.04, 0.1, 0.03), - max=c(0.65, 0.45, 0.7, 0.6)) - -# Position limit constraint -pl_constr <- position_limit_constraint(assets=pspec$assets, max_pos=2) - -# Target mean return constraint -ret_constr <- return_constraint(return_target=0.007) - -# Group constraint -group_constr <- group_constraint(assets=pspec$assets, groups=list(1, 2:3, 4), - group_min=0, group_max=0.5) - -# Factor exposure constraint -# Industry exposures are used in this example, but other factors could be used as well -# Note that exposures to industry factors are similar to group constraints -facexp_constr <- factor_exposure_constraint(assets=pspec$assets, - B=cbind(c(1, 0, 0, 0), - c(0, 1, 1, 0), - c(0, 0, 0, 1)), - lower=c(0.1, 0.15, 0.05), - upper=c(0.45, 0.65, 0.60)) - -##### Objectives ##### -# Return objective -ret_obj <- return_objective(name="mean") - -# Variance objective -var_obj <- portfolio_risk_objective(name="var") - -# ETL objective -etl_obj <- portfolio_risk_objective(name="ETL") - -##### Maximize Return Optimization ##### -# The ROI solver uses the glpk plugin to interface to the Rglpk package for -# objectives to maximimize mean return - -# Full investment and long only constraints -opt_maxret <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr), - objectives=list(ret_obj), - optimize_method="ROI") -opt_maxret - -# Full investment, box, and target return constraints -opt_maxret <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, ret_constr), - objectives=list(ret_obj), - optimize_method="ROI") -opt_maxret - -# Full investment, box, and position_limit constraints -opt_maxret <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, pl_constr), - objectives=list(ret_obj), - optimize_method="ROI") -opt_maxret - -# Full investment, box, and group constraints -opt_maxret <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, group_constr), - objectives=list(ret_obj), - optimize_method="ROI") -opt_maxret - -# Full investment, box, and factor exposure constraints -opt_maxret <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, facexp_constr), - objectives=list(ret_obj), - optimize_method="ROI") -opt_maxret - -##### Minimize Variance Optimization ##### -# The ROI solver uses the quadprog plugin to interface to the quadprog package for -# objectives to minimize variance - -# Global minimum variance portfolio. Only specify the full investment constraint -opt_minvar <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr), - objectives=list(var_obj), - optimize_method="ROI") -opt_minvar - -# Full investment, box, and target mean_return constraints -opt_minvar <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, ret_constr), - objectives=list(var_obj), - optimize_method="ROI") -opt_minvar - -# Full investment, box, and group constraints -opt_minvar <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, group_constr), - objectives=list(var_obj), - optimize_method="ROI") -opt_minvar - -# Full investment, box, and exposure constraints -opt_minvar <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr, facexp_constr), - objectives=list(var_obj), - optimize_method="ROI") -opt_minvar - -##### Maximize Quadratic Utility Optimization ##### -# The ROI solver uses the quadprog plugin to interface to the guadprog package for -# objectives to maximimize quadratic utility - -# Create the variance objective with a large risk_aversion paramater -# A large risk_aversion parameter will approximate the global minimum variance portfolio -var_obj <- portfolio_risk_objective(name="var", risk_aversion=1e4) - -# Full investment and box constraints -opt_qu <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, box_constr), - objectives=list(ret_obj, var_obj), - optimize_method="ROI") -opt_qu - -# Change the risk_aversion parameter in the variance objective to a small number -# A small risk_aversion parameter will approximate the maximum portfolio -var_obj$risk_aversion <- 1e-4 - -# Full investment and long only constraints -opt_qu <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr), - objectives=list(ret_obj, var_obj), - optimize_method="ROI") -opt_qu - -# Change the risk_aversion parameter to a more reasonable value -var_obj$risk_aversion <- 0.25 -# Full investment, long only, and factor exposure constraints -opt_qu <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr, facexp_constr), - objectives=list(ret_obj, var_obj), - optimize_method="ROI") -opt_qu - -# Full investment, long only, target return, and group constraints -# opt_qu <- optimize.portfolio(R=ret, portfolio=pspec, -# constraints=list(fi_constr, lo_constr, ret_constr, group_constr), -# objectives=list(ret_obj, var_obj), -# optimize_method="ROI") -# opt_qu - -##### Minimize ETL Optimization ##### -# The ROI solver uses the glpk plugin to interface to the Rglpk package for -# objectives to minimimize expected tail loss - -# Full investment and long only constraints -opt_minetl <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr), - objectives=list(etl_obj), - optimize_method="ROI") -opt_minetl - -# Full investment, box, and target return constraints -opt_minetl <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr, ret_constr), - objectives=list(etl_obj), - optimize_method="ROI") -opt_minetl - -# Full investment, long only, and position limit constraints -opt_minetl <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr, pl_constr), - objectives=list(etl_obj), - optimize_method="ROI") -opt_minetl - -# Full investment, long only, and group constraints -opt_minetl <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr, group_constr), - objectives=list(etl_obj), - optimize_method="ROI") -opt_minetl - -# Full investment, long only, and factor exposure constraints -opt_minetl <- optimize.portfolio(R=ret, portfolio=pspec, - constraints=list(fi_constr, lo_constr, facexp_constr), - objectives=list(etl_obj), - optimize_method="ROI") -opt_minetl - Deleted: pkg/PortfolioAnalytics/demo/demo_group_ROI.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_group_ROI.R 2014-07-18 01:35:16 UTC (rev 3472) +++ pkg/PortfolioAnalytics/demo/demo_group_ROI.R 2014-07-18 01:40:25 UTC (rev 3473) @@ -1,42 +0,0 @@ - -library(PortfolioAnalytics) -library(ROI) -library(ROI.plugin.quadprog) -library(ROI.plugin.glpk) - - -data(edhec) -R <- edhec[, 1:4] -colnames(R) <- c("CA", "CTAG", "DS", "EM") -funds <- colnames(R) - -# set up portfolio with objectives and constraints -pspec <- portfolio.spec(assets=funds) -pspec <- add.constraint(portfolio=pspec, type="full_investment") -pspec <- add.constraint(portfolio=pspec, type="long_only") -# add two levels of grouping -pspec <- add.constraint(portfolio=pspec, type="group", - groups=list(groupA=c(1, 3), - groupB=c(2, 4), - geoA=c(1, 2, 4), - geoB=3), - group_min=c(0.15, 0.25, 0.15, 0.2), - group_max=c(0.4, 0.7, 0.8, 0.62)) -pspec - -maxret <- add.objective(portfolio=pspec, type="return", name="mean") -opt_maxret <- optimize.portfolio(R=R, portfolio=maxret, optimize_method="ROI") -summary(opt_maxret) - -minvar <- add.objective(portfolio=pspec, type="risk", name="var") -opt_minvar <- optimize.portfolio(R=R, portfolio=minvar, optimize_method="ROI") -summary(opt_minvar) - -minetl <- add.objective(portfolio=pspec, type="risk", name="ETL") -opt_minetl <- optimize.portfolio(R=R, portfolio=minetl, optimize_method="ROI") -summary(opt_minetl) - -maxqu <- add.objective(portfolio=pspec, type="return", name="mean") -maxqu <- add.objective(portfolio=maxqu, type="risk", name="var", risk_aversion=0.25) -opt_maxqu <- optimize.portfolio(R=R, portfolio=maxqu, optimize_method="ROI") -summary(opt_maxqu) Deleted: pkg/PortfolioAnalytics/demo/demo_maxret_ROI.R =================================================================== --- pkg/PortfolioAnalytics/demo/demo_maxret_ROI.R 2014-07-18 01:35:16 UTC (rev 3472) +++ pkg/PortfolioAnalytics/demo/demo_maxret_ROI.R 2014-07-18 01:40:25 UTC (rev 3473) @@ -1,56 +0,0 @@ -library(PortfolioAnalytics) -library(foreach) -library(iterators) -library(quadprog) -library(Rglpk) -library(ROI) -require(ROI.plugin.glpk) -require(ROI.plugin.quadprog) - - -data(edhec) -ret <- edhec[, 1:4] -funds <- colnames(ret) - -##### Method 1 ##### -# Set up portfolio object with constraints and objectives to maximize return -# using the portfolio object to add constraints and objectives -pspec1 <- portfolio.spec(assets=funds) -pspec1 <- add.constraint(portfolio=pspec1, type="full_investment") -pspec1 <- add.constraint(portfolio=pspec1, type="box", min=0, max=0.65) -pspec1 <- add.objective(portfolio=pspec1, type="return", name="mean") - -opt1 <- optimize.portfolio(R=ret, portfolio=pspec1, optimize_method="ROI") - -##### Method 2 ##### -# Set up portfolio object with constraints and objective to maximize return -# using separate constraint and objective objects -pspec2 <- portfolio.spec(assets=funds) -weight_constr <- weight_sum_constraint(min_sum=1, max_sum=1) -box_constr <- box_constraint(assets=pspec2$assets, min=0, max=0.65) -ret_obj <- return_objective(name="mean") -cset <- list(weight_constr, box_constr) -obj <- list(ret_obj) - -opt2 <- optimize.portfolio(R=ret, portfolio=pspec2, constraints=cset, - objectives=obj, optimize_method="ROI") - -all.equal(extractWeights(opt1), extractWeights(opt2)) - -##### Method 1 Backtesting ##### -opt_rebal1 <- optimize.portfolio.rebalancing(R=ret, portfolio=pspec1, - optimize_method="ROI", - rebalance_on="months") -class(opt_rebal1) -inherits(opt_rebal1, "optimize.portfolio.rebalancing") -wts1 <- extractWeights(opt_rebal1) - -##### Method 2 Backtesting ##### -opt_rebal2 <- optimize.portfolio.rebalancing(R=ret, portfolio=pspec2, - constraints=cset, - objectives=obj, - optimize_method="ROI", - rebalance_on="months") -wts2 <- extractWeights(opt_rebal2) -all.equal(wts1, wts2) - Deleted: pkg/PortfolioAnalytics/demo/risk_budget_backtesting.R =================================================================== --- pkg/PortfolioAnalytics/demo/risk_budget_backtesting.R 2014-07-18 01:35:16 UTC (rev 3472) +++ pkg/PortfolioAnalytics/demo/risk_budget_backtesting.R 2014-07-18 01:40:25 UTC (rev 3473) @@ -1,59 +0,0 @@ - -library(PortfolioAnalytics) -data(edhec) - -# Use first four columns of edhec data set -R <- edhec[, 1:4] -funds <- colnames(R) - -# Initialize portfolio and add basic constraints -init.portf <- portfolio.spec(funds, weight_seq=generatesequence(min=0, max=1, by=0.002)) -init.portf <- add.constraint(init.portf, "weight_sum")#, min_sum=0.99, max_sum=1.01) -init.portf <- add.constraint(init.portf, "box", min=0, max=0.65) - -# Add mean return objective with multiplier=0 so it is calculated, but does -# not affect optimization -init.portf <- add.objective(init.portf, type="return", name="mean", multiplier=0) - -# Add objective to minimize portfolio standard deviation -SDRB.portf <- add.objective(init.portf, type="risk", name="StdDev") - -# Add StdDev risk budget objective for maximum percentage risk -SDRB.portf <- add.objective(SDRB.portf, type="risk_budget", name="StdDev", max_prisk=0.4) - -# Generate random portfolios -rp <- random_portfolios(init.portf, 5000) - -# Run out of sample backtest with yearly rebalancing -SDRB.opt.bt <- optimize.portfolio.rebalancing(R, SDRB.portf, - optimize_method="random", - rp=rp, - trace=TRUE, - rebalance_on="years", - training_period=100, - trailing_periods=60) - -# print method for optimize.portfolio.rebalancing objects -SDRB.opt.bt - -# summary method for optimize.portfolio.rebalancing objects -tmp_summary <- summary(SDRB.opt.bt) -names(tmp_summary) - -# print method for summary.optimize.portfolio.rebalancing objects -tmp_summary - -# Extractor functions for summary.optimize.portfolio.rebalancing objects -extractWeights(tmp_summary) -extractObjectiveMeasures(tmp_summary) - -# Extractor functions for optimize.portfolio.rebalancing objects -tmp_stats <- extractStats(SDRB.opt.bt) -head(tmp_stats[[1]]) -tmp_weights <- extractWeights(SDRB.opt.bt) -tmp_obj <- extractObjectiveMeasures(SDRB.opt.bt) - -# chart functions for optimize.portfolio.rebalancing -chart.Weights(SDRB.opt.bt) -chart.RiskBudget(SDRB.opt.bt, match.col="StdDev", risk.type="percent") - From noreply at r-forge.r-project.org Mon Jul 21 10:10:52 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Jul 2014 10:10:52 +0200 (CEST) Subject: [Returnanalytics-commits] r3474 - in pkg/FactorAnalytics: . R man Message-ID: <20140721081052.1EC9C1833AE@r-forge.r-project.org> Author: pragnya Date: 2014-07-21 10:10:51 +0200 (Mon, 21 Jul 2014) New Revision: 3474 Added: pkg/FactorAnalytics/R/fitTsfm.control.R pkg/FactorAnalytics/man/fitTsfm.control.Rd Modified: pkg/FactorAnalytics/NAMESPACE pkg/FactorAnalytics/R/fitTsfm.R pkg/FactorAnalytics/man/fitTsfm.Rd Log: Add fitTsfm.control function Modified: pkg/FactorAnalytics/NAMESPACE =================================================================== --- pkg/FactorAnalytics/NAMESPACE 2014-07-18 01:40:25 UTC (rev 3473) +++ pkg/FactorAnalytics/NAMESPACE 2014-07-21 08:10:51 UTC (rev 3474) @@ -29,6 +29,7 @@ export(fitFundamentalFactorModel) export(fitStatisticalFactorModel) export(fitTsfm) +export(fitTsfm.control) export(pCornishFisher) export(paFm) export(qCornishFisher) Modified: pkg/FactorAnalytics/R/fitTsfm.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.R 2014-07-18 01:40:25 UTC (rev 3473) +++ pkg/FactorAnalytics/R/fitTsfm.R 2014-07-21 08:10:51 UTC (rev 3474) @@ -12,22 +12,23 @@ #' the option to supply a risk free rate variable to subtract from each asset #' return and factor to create excess returns. #' -#' Estimation method "OLS" corresponds to ordinary least squares, "DLS" is -#' discounted least squares (weighted least squares with exponentially -#' declining weights that sum to unity), and, "Robust" is robust -#' regression (uses \code{\link[robust]{lmRob}}). +#' Estimation method "OLS" corresponds to ordinary least squares using +#' \code{\link[stats]{lm}}, "DLS" is discounted least squares (weighted least +#' squares with exponentially declining weights that sum to unity), and, +#' "Robust" is robust regression (useing \code{\link[robust]{lmRob}}). #' #' If \code{variable.selection="none"}, all chosen factors are used in the #' factor model. Whereas, "stepwise" performs traditional forward/backward -#' stepwise OLS regression (using \code{\link[stats]{step}}), that starts from -#' the initial set of factors and adds factors only if the regression fit, as -#' measured by the Bayesian Information Criterion (BIC) or Akaike Information -#' Criterion (AIC), improves. And, "all subsets" enables subsets selection -#' using \code{\link[leaps]{regsubsets}} that chooses the n-best performing -#' subsets of any given size (specified as \code{num.factor.subsets} here). -#' \code{varaible.selection="lars"} corresponds to least angle regression -#' using \code{\link[lars]{lars}} with variants "lasso", "lar", -#' "forward.stagewise" or "stepwise". Note: If +#' stepwise OLS regression (using \code{\link[stats]{step}} or +#' \code{\link[robust]{step.lmRob}}), that starts from the initial set of +#' factors and adds factors only if the regression fit, as measured by the +#' Bayesian Information Criterion (BIC) or Akaike Information Criterion (AIC), +#' improves. And, "subsets" enables subsets selection using +#' \code{\link[leaps]{regsubsets}}; chooses the best performing subset of any +#' given size. See \code{\link{fitTsfm.control}} for more details on the +#' control arguments. \code{varaible.selection="lars"} corresponds to least +#' angle regression using \code{\link[lars]{lars}} with variants "lasso", +#' "lar", "forward.stagewise" or "stepwise". Note: If #' \code{variable.selection="lars"}, \code{fit.method} will be ignored. #' #' \code{mkt.timing} allows for market-timing factors to be added to any of the @@ -40,13 +41,15 @@ #' volatility, and \code{market.sqd = (Rm-Rf)^2} is added as a factor in the #' regression. Option "both" adds both of these factors. #' -#' \code{lars.criterion} selects the criterion (one of "Cp" or "cv") to -#' determine the best fitted model for \code{variable.selection="lars"}. The -#' "Cp" statistic (defined in page 17 of Efron et al. (2002)) is calculated -#' using \code{\link[lars]{summary.lars}}. While, "cv" computes the K-fold -#' cross-validated mean squared prediction error using -#' \code{\link[lars]{cv.lars}}. +#' Note about NAs: Before model fitting, incomplete cases are removed for +#' every asset (return data combined with respective factors' return data) +#' using \code{\link[stats]{na.omit}}. Otherwise, all observations in +#' \code{data} are included. #' +#' Note about spaces in asset/factor names: Spaces in column names of the data +#' object will be converetd to periods as the function works with \code{xts} +#' objects internally and hence column names can't be retained as such. +#' #' @param asset.names vector containing names of assets, whose returns or #' excess returns are the dependent variable. #' @param factor.names vector containing names of the macroeconomic factors. @@ -62,32 +65,13 @@ #' @param fit.method the estimation method, one of "OLS", "DLS" or "Robust". #' See details. Default is "OLS". #' @param variable.selection the variable selection method, one of "none", -#' "stepwise","all subsets","lars". See details. Default is "none". -#' @param subsets.method one of "exhaustive", "forward", "backward" or "seqrep" -#' (sequential replacement) to specify the type of subset search/selection. -#' Required if "all subsets" variable selection is chosen. Default is -#' "exhaustive". -#' @param nvmax the maximum size of subsets to examine; an option for -#' "all subsets" variable selection. Default is 8. -#' @param force.in vector containing the names of factors that should always -#' be included in the model; an option for "all subsets" variable selection. -#' Default is NULL. -#' @param num.factors.subset number of factors required in the factor model; -#' an option for "all subsets" variable selection. Default is 1. -#' Note: nvmax >= num.factors.subset >= length(force.in). +#' "stepwise","subsets","lars". See details. Default is "none". #' @param mkt.timing one of "HM", "TM" or "both". Default is NULL. See Details. #' \code{mkt.name} is required if any of these options are specified. -#' @param decay a scalar in (0, 1] to specify the decay factor for -#' \code{fit.method="DLS"}. Default is 0.95. -#' @param lars.type One of "lasso", "lar", "forward.stagewise" or "stepwise". -#' The names can be abbreviated to any unique substring. Default is "lasso". -#' @param lars.criterion an option to assess model selection for the "lars" -#' method; one of "Cp" or "cv". See details. Default is "Cp". -#' @param ... optional arguments passed to the \code{step} function for -#' variable.selection method "stepwise", such as direction, steps and -#' the penalty factor k. Note that argument k is available only for "OLS" -#' and "DLS" fits. Scope argument is not available presently. Also plan to -#' include other controls passed to \code{lmRob} soon. +#' @param control list of control parameters. The default is constructed by +#' the function \code{\link{fitTsfm.control}}. See the documentation for +#' \code{\link{fitTsfm.control}} for details. +#' @param ... arguments passed to \code{\link{fitTsfm.control}} #' #' @return fitTsfm returns an object of class \code{tsfm}. #' @@ -112,7 +96,7 @@ #' \item{beta}{N x K matrix of estimated betas.} #' \item{r2}{N x 1 vector of R-squared values.} #' \item{resid.sd}{N x 1 vector of residual standard deviations.} -#' \item{fitted}{xts data object of fitted values; if and only if +#' \item{fitted}{xts data object of fitted values; iff #' \code{variable.selection="lars"}} #' \item{call}{the matched function call.} #' \item{data}{xts data object containing the assets and factors.} @@ -173,31 +157,51 @@ fitTsfm <- function(asset.names, factor.names, mkt.name=NULL, rf.name=NULL, data=data, fit.method=c("OLS","DLS","Robust"), - variable.selection=c("none","stepwise","all subsets", + variable.selection=c("none","stepwise","subsets", "lars"), - subsets.method=c("exhaustive","backward","forward", - "seqrep"), - nvmax=8, force.in=NULL, num.factors.subset=1, - mkt.timing=NULL, decay=0.95, - lars.type=c("lasso","lar","forward.stagewise","stepwise"), - lars.criterion="Cp", ...){ + mkt.timing=NULL, control=fitTsfm.control(...), ...) { - # get all the arguments specified by their full names + # record the call as an element to be returned call <- match.call() - fit.method = fit.method[1] # default is OLS - variable.selection = variable.selection[1] # default is "none" - subsets.method = subsets.method[1] # default is "exhaustive" - lars.type=lars.type[1] # default is "lasso" - - if (!exists("direction")) {direction <- "backward"} - if (!exists("steps")) {steps <- 1000} - if (!exists("k")) {k <- 2} + # set defaults and check input vailidity + fit.method = fit.method[1] + if (!(fit.method %in% c("OLS","DLS","Robust"))) { + stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") + } + variable.selection = variable.selection[1] + if (!(variable.selection %in% c("none","stepwise","subsets","lars"))) { + stop("Invalid argument: variable.selection must be either 'none', + 'stepwise','subsets' or 'lars'") + } if (xor(is.null(mkt.name), is.null(mkt.timing))) { stop("Missing argument: 'mkt.name' and 'mkt.timing' are both required to include market-timing factors.") } + # extract arguments to pass to different fit and variable selection functions + decay <- control$decay + subset.size <- control$subset.size + lars.criterion <- control$lars.criterion + m1 <- match(c("weights","method","model","x","y","qr"), + names(control), 0L) + lm.args <- control[m1, drop=TRUE] + m2 <- match(c("weights","model","x","y","nrep"), + names(control), 0L) + lmRob.args <- control[m2, drop=TRUE] + m3 <- match(c("scope","scale","direction","trace","steps","k"), + names(control), 0L) + step.args <- control[m3, drop=TRUE] + m4 <- match(c("weights","nbest","nvmax","force.in","force.out","method", + "really.big"), names(control), 0L) + regsubsets.args <- control[m4, drop=TRUE] + m5 <- match(c("type","normalize","eps","max.steps","trace"), + names(control), 0L) + lars.args <- control[m5, drop=TRUE] + m6 <- match(c("K","type","mode","normalize","eps","max.steps","trace"), + names(control), 0L) + cv.lars.args <- control[m6, drop=TRUE] + # convert data into an xts object and hereafter work with xts objects data.xts <- checkData(data) @@ -207,12 +211,15 @@ # convert all asset and factor returns to excess return form if specified if (!is.null(rf.name)) { - cat("Excess returns were used for all assets and factors.") + cat("Excess returns were computed and used for all assets and factors.") dat.xts <- "[<-"(dat.xts,,vapply(dat.xts, function(x) x-data.xts[,rf.name], FUN.VALUE = numeric(nrow(dat.xts)))) + } else { + cat("Note: fitTsfm was NOT asked to compute EXCESS returns. Input returns + data was used as it is for all factors and assets.") } - # opt add market-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 + # opt add mkt-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 if (!is.null(mkt.timing)) { if(mkt.timing=="HM" | mkt.timing=="both") { up.market <- data.xts[,mkt.name] @@ -237,17 +244,17 @@ # Each method returns a list of fitted factor models for each asset. if (variable.selection == "none") { reg.list <- NoVariableSelection(dat.xts, asset.names, factor.names, - fit.method, decay) - } else if (variable.selection == "stepwise"){ - reg.list <- SelectStepwise(dat.xts, asset.names, factor.names, - fit.method, decay, direction, steps, k) - } else if (variable.selection == "all subsets"){ - reg.list <- SelectAllSubsets(dat.xts, asset.names, factor.names, - fit.method, subsets.method, - nvmax, force.in, num.factors.subset, decay) - } else if (variable.selection == "lars"){ - result.lars <- SelectLars(dat.xts, asset.names, factor.names, - lars.type, decay, lars.criterion) + fit.method, lm.args, lmRob.args, decay) + } else if (variable.selection == "stepwise") { + reg.list <- SelectStepwise(dat.xts, asset.names, factor.names, fit.method, + lm.args, lmRob.args, step.args, decay) + } else if (variable.selection == "subsets") { + reg.list <- SelectAllSubsets(dat.xts, asset.names, factor.names,fit.method, + lm.args, lmRob.args, regsubsets.args, + subset.size, decay) + } else if (variable.selection == "lars") { + result.lars <- SelectLars(dat.xts, asset.names, factor.names, lars.args, + cv.lars.args, lars.criterion) input <- list(call=call, data=dat.xts, asset.names=asset.names, factor.names=factor.names, fit.method=fit.method, variable.selection=variable.selection) @@ -255,10 +262,6 @@ class(result) <- "tsfm" return(result) } - else { - stop("Invalid argument: variable.selection must be either 'none', - 'stepwise','all subsets','lars'") - } # extract the fitted factor models, coefficients, r2 values and residual vol # from returned factor model fits above @@ -282,12 +285,12 @@ ### method variable.selection = "none" # NoVariableSelection <- function(dat.xts, asset.names, factor.names, fit.method, - decay){ + lm.args, lmRob.args, decay){ # initialize list object to hold the fitted objects reg.list <- list() # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ + for (i in asset.names) { # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) @@ -296,15 +299,16 @@ # fit based on time series regression method chosen if (fit.method == "OLS") { - reg.list[[i]] <- lm(fm.formula, data=reg.xts) + reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "DLS") { - w <- WeightsDLS(nrow(reg.xts), decay) - reg.list[[i]] <- lm(fm.formula, data=reg.xts, weights=w) + if(!"weights" %in% names(lm.args)) { + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) + } + reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "Robust") { - reg.list[[i]] <- lmRob(fm.formula, data=reg.xts) - } else { - stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") - } + reg.list[[i]] <- do.call(lmRob, c(list(fm.formula,data=reg.xts), + lmRob.args)) + } } reg.list } @@ -313,12 +317,12 @@ ### method variable.selection = "stepwise" # SelectStepwise <- function(dat.xts, asset.names, factor.names, fit.method, - decay, direction, steps, k){ + lm.args, lmRob.args, step.args, decay) { # initialize list object to hold the fitted objects reg.list <- list() # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ + for (i in asset.names) { # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) @@ -327,76 +331,63 @@ # fit based on time series regression method chosen if (fit.method == "OLS") { - reg.list[[i]] <- step(lm(fm.formula, data=reg.xts), direction=direction, - steps=steps, k=k, trace=0) + lm.fit <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) + reg.list[[i]] <- do.call(step, c(list(lm.fit),step.args)) } else if (fit.method == "DLS") { - w <- WeightsDLS(nrow(reg.xts), decay) - reg.list[[i]] <- step(lm(fm.formula, data=reg.xts, weights=w), - direction=direction, steps=steps, k=k, trace=0) + if(!"weights" %in% names(lm.args)) { + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) + } + lm.fit <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) + reg.list[[i]] <- do.call(step, c(list(lm.fit),step.args)) } else if (fit.method == "Robust") { - reg.list[[i]] <- step.lmRob(lmRob(fm.formula, data=reg.xts), trace=FALSE, - direction=direction, steps=steps) - } else { - stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") - } + lmRob.fit <- do.call(lmRob, c(list(fm.formula,data=reg.xts),lmRob.args)) + reg.list[[i]] <- do.call(step.lmRob, c(list(lmRob.fit),step.args)) + } } reg.list } -### method variable.selection = "all subsets" +### method variable.selection = "subsets" # SelectAllSubsets <- function(dat.xts, asset.names, factor.names, fit.method, - subsets.method, nvmax, force.in, - num.factors.subset, decay){ - # Check argument validity - if (nvmax < num.factors.subset) { - stop("Invaid Argument: nvmax should be >= num.factors.subset") - } + lm.args, lmRob.args, regsubsets.args, subset.size, + decay) { # initialize list object to hold the fitted objects reg.list <- list() # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ + for (i in asset.names) { + # completely remove NA cases + reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # choose best subset of factors depending on specified number of factors - if (num.factors.subset == length(force.in)) { - reg.xts <- na.omit(dat.xts[, c(i, force.in)]) - } else if (num.factors.subset > length(force.in)) { - reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - - # formula to pass to lm or lmRob - fm.formula <- as.formula(paste(i," ~ .")) - - if (fit.method != "DLS") {decay <- 1} - # do weighted least squares if "DLS" - w <- WeightsDLS(nrow(reg.xts), decay) - - # use regsubsets to find the best model with a subset of factors of size - # num.factors.subset - fm.subsets <- regsubsets(fm.formula, data=reg.xts, nvmax=nvmax, - force.in=force.in, method=subsets.method, - weights=w) - sum.sub <- summary(fm.subsets) - reg.xts <- na.omit(dat.xts[,c(i,names(which(sum.sub$which[ - as.character(num.factors.subset),-1]==TRUE)))]) - } else { - stop("Invalid Argument: num.factors.subset should be >= - length(force.in)") + # formula to pass to lm or lmRob + fm.formula <- as.formula(paste(i," ~ .")) + + if (fit.method == "DLS" && !"weights" %in% names(regsubsets.args)) { + regsubsets.args$weights <- WeightsDLS(nrow(reg.xts), decay) } + # choose best subset of factors depending on specified subset size + fm.subsets <- do.call(regsubsets, c(list(fm.formula,data=reg.xts), + regsubsets.args)) + sum.sub <- summary(fm.subsets) + names.sub <- names(which(sum.sub$which[as.character(subset.size),-1]==TRUE)) + reg.xts <- na.omit(dat.xts[,c(i,names.sub)]) + # fit based on time series regression method chosen if (fit.method == "OLS") { - reg.list[[i]] <- lm(fm.formula, data=reg.xts) + reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "DLS") { - w <- WeightsDLS(nrow(reg.xts), decay) - reg.list[[i]] <- lm(fm.formula, data=reg.xts, weights=w) + if(!"weights" %in% names(lm.args)) { + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) + } + reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "Robust") { - reg.list[[i]] <- lmRob(fm.formula, data=reg.xts) - } else { - stop("Invalid argument: fit.method must be 'OLS', 'DLS' or 'Robust'") - } + reg.list[[i]] <- do.call(lmRob, c(list(fm.formula,data=reg.xts), + lmRob.args)) + } } reg.list } @@ -404,8 +395,8 @@ ### method variable.selection = "lars" # -SelectLars <- function(dat.xts, asset.names, factor.names, lars.type, - decay, lars.criterion) { +SelectLars <- function(dat.xts, asset.names, factor.names, lars.args, + cv.lars.args, lars.criterion) { # initialize list object to hold the fitted objects and, vectors and matrices # for the other results asset.fit <- list() @@ -418,38 +409,33 @@ colnames(beta) <- factor.names # loop through and estimate model for each asset to allow unequal histories - for (i in asset.names){ + for (i in asset.names) { # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) # convert to matrix reg.mat <- as.matrix(reg.xts) # fit lars regression model - lars.fit <- lars(reg.mat[,-1], reg.mat[,i], - type=lars.type, trace = FALSE) + lars.fit <- do.call(lars, c(x=list(reg.mat[,-1],y=reg.mat[,i]),lars.args)) lars.sum <- summary(lars.fit) + cv.error <- do.call(cv.lars, c(x=list(reg.mat[,-1],y=reg.mat[,i], + plot.it=FALSE),cv.lars.args)) - # get the step that minimizes the "Cp" statistic or the "cv" mean-sqd - # prediction error + # get the step that minimizes the "Cp" statistic or + # the K-fold "cv" mean-squared prediction error if (lars.criterion == "Cp") { s <- which.min(lars.sum$Cp) - } else if (lars.criterion == "cv") { - lars.cv <- cv.lars(reg.mat[,factor.names], reg.mat[,i], trace=FALSE, - type=lars.type, mode="step", plot.it=FALSE) - s <- which.min(lars.cv$cv) } else { - stop("Invalid argument: lars.criterion must be Cp' or 'cv'") + s <- which.min(cv.error$cv) } # get factor model coefficients & fitted values at the step obtained above coef.lars <- predict(lars.fit, s=s, type="coef", mode="step") - fitted.lars <- predict(lars.fit, reg.xts[,-1], s=s, type="fit", - mode="step") + fitted.lars <- predict(lars.fit, reg.xts[,-1], s=s, type="fit",mode="step") fitted.list[[i]] <- xts(fitted.lars$fit, index(reg.xts)) # extract and assign the results asset.fit[[i]] = lars.fit - alpha[i] <- (fitted.lars$fit - - reg.xts[,-1]%*%coef.lars$coefficients)[1] + alpha[i] <- (fitted.lars$fit - reg.xts[,-1]%*%coef.lars$coefficients)[1] beta.names <- names(coef.lars$coefficients) beta[i, beta.names] <- coef.lars$coefficients r2[i] <- lars.fit$R2[s] @@ -459,21 +445,24 @@ fitted.xts <- do.call(merge, fitted.list) results.lars <- list(asset.fit=asset.fit, alpha=alpha, beta=beta, r2=r2, resid.sd=resid.sd, fitted=fitted.xts) + # As a special case for variable.selection="lars", fitted values are also + # returned by fitTsfm. Else, shrinkage s from the best fit is needed to get + # fitted values & residuals. } ### calculate weights for "DLS" # -WeightsDLS <- function(t,d){ +WeightsDLS <- function(t,d) { # more weight given to more recent observations w <- d^seq((t-1),0,-1) # ensure that the weights sum to unity w/sum(w) } -### make a data frame (padded with NAs) from columns of unequal length +### make a data frame (padded with NAs) from unequal vectors with named rows # -makePaddedDataFrame <- function(l){ +makePaddedDataFrame <- function(l) { DF <- do.call(rbind, lapply(lapply(l, unlist), "[", unique(unlist(c(sapply(l,names)))))) DF <- as.data.frame(DF) @@ -489,12 +478,12 @@ #' @method coef tsfm #' @export -coef.tsfm <- function(object,...){ +coef.tsfm <- function(object,...) { if (object$variable.selection=="lars") { coef.mat <- cbind(object$alpha, object$beta) colnames(coef.mat)[1] <- "(Intercept)" } else { - coef.mat <- t(sapply(object$asset.fit, coef)) + coef.mat <- t(sapply(object$asset.fit, coef, ...)) } return(coef.mat) } @@ -503,13 +492,14 @@ #' @method fitted tsfm #' @export -fitted.tsfm <- function(object,...){ +fitted.tsfm <- function(object,...) { if (object$variable.selection=="lars") { fitted.xts <- object$fitted } else { # get fitted values from each linear factor model fit # and convert them into xts/zoo objects - fitted.list = sapply(object$asset.fit, function(x) checkData(fitted(x))) + fitted.list = sapply(object$asset.fit, + function(x) checkData(fitted(x,...))) # this is a list of xts objects, indexed by the asset name # merge the objects in the list into one xts object fitted.xts <- do.call(merge, fitted.list) @@ -528,7 +518,8 @@ } else { # get residuals from each linear factor model fit # and convert them into xts/zoo objects - residuals.list = sapply(object$asset.fit, function(x) checkData(residuals(x))) + residuals.list = sapply(object$asset.fit, + function(x) checkData(residuals(x,...))) # this is a list of xts objects, indexed by the asset name # merge the objects in the list into one xts object residuals.xts <- do.call(merge, residuals.list) Added: pkg/FactorAnalytics/R/fitTsfm.control.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.control.R (rev 0) +++ pkg/FactorAnalytics/R/fitTsfm.control.R 2014-07-21 08:10:51 UTC (rev 3474) @@ -0,0 +1,194 @@ +#' @title List of control parameters for \code{fitTsfm} +#' +#' @description Creates a list of control parameters for \code{\link{fitTsfm}}. +#' All control parameters that are not passed to this function are set to +#' default values. +#' +#' @details This control function is primarily used to pass optional arguments +#' to \code{\link[stats]{lm}}, \code{\link[robust]{lmRob}}, +#' \code{\link[stats]{step}}, \code{\link[leaps]{regsubsets}}, +#' \code{\link[lars]{lars}} and \code{\link[lars]{cv.lars}} within +#' \code{fitTsfm}. See their respective help files for more details. The +#' arguments to each of these functions are listed approximately in the same +#' order for user convenience. +#' +#' The scalar \code{decay} is used by \code{\link{fitTsfm}} to compute +#' exponentially decaying weights for \code{fit.method="DLS"}. Optionally, one +#' can directly specify \code{weights}, a weights vector, to be used with +#' "OLS" or "Robust". +#' +#' \code{lars.criterion} selects the criterion (one of "Cp" or "cv") to +#' determine the best fitted model for \code{variable.selection="lars"}. The +#' "Cp" statistic (defined in page 17 of Efron et al. (2004)) is calculated +#' using \code{\link[lars]{summary.lars}}. While, "cv" computes the K-fold +#' cross-validated mean squared prediction error using +#' \code{\link[lars]{cv.lars}}. +#' +#' @param decay a scalar in (0, 1] to specify the decay factor for "DLS". +#' Default is 0.95. +#' @param weights an optional vector of weights to be used in the fitting +#' process for \code{fit.method="OLS","Robust"}, or +#' \code{variable.selection="subsets"}. Should be \code{NULL} or a numeric +#' vector. If non-\code{NULL}, weighted least squares is performed with weights +#' given by \code{weights} (i.e., minimizing sum(w*e^2)). The length of +#' \code{weights} must be the same as the number of observations. The weights +#' must be nonnegative and strongly recommended to be strictly positive. +#' @param model,x,y,qr logicals passed to \code{lm} for +#' \code{fit.method="OLS"}. If \code{TRUE} the corresponding components of the +#' fit (the model frame, the model matrix, the response, the QR decomposition) +#' are returned. +#' @param nrep the number of random subsamples to be drawn for +#' \code{fit.method="Robust"}. If the data set is small and "Exhaustive" +#' resampling is being used, the value of \code{nrep} is ignored. +#' @param scope defines the range of models examined in the \code{"stepwise"} +#' search. This should be either a single formula, or a list containing +#' components \code{upper} and \code{lower}, both formulae. See +#' \code{\link[stats]{step}} for how to specify the formulae and usage. +#' @param scale optional parameter for \code{variable.selection="stepwise"}. +#' The argument is passed to \code{\link[stats]{step}} or +#' \code{\link[robust]{step.lmRob}} as appropriate. +#' @param direction the mode of \code{"stepwise"} search, can be one of "both", +#' "backward", or "forward", with a default of "both". If the \code{scope} +#' argument is missing the default for \code{direction} is "backward". +#' @param trace If positive (or, not \code{FALSE}), info is printed during the +#' running of \code{\link[stats]{step}}, \code{\link[robust]{step.lmRob}}, +#' \code{\link[lars]{lars}} or \code{\link[lars]{cv.lars}} as relevant. Larger +#' values may give more detailed information. Default is \code{FALSE}. +#' @param steps the maximum number of steps to be considered for +#' \code{"stepwise"}. Default is 1000 (essentially as many as required). It is +#' typically used to stop the process early. +#' @param k the multiple of the number of degrees of freedom used for the +#' penalty in \code{"stepwise"}. Only \code{k = 2} gives the genuine AIC. +#' \code{k = log(n)} is sometimes referred to as BIC or SBC. Default is 2. +#' @param nbest number of subsets of each size to record for \code{"subsets"}. +#' Default is 1. +#' @param nvmax maximum size of subsets to examine for \code{"subsets"}. +#' Default is 8. +#' @param force.in index to columns of design matrix that should be in all +#' models for \code{"subsets"}. Default is \code{NULL}. +#' @param force.out index to columns of design matrix that should be in no +#' models for \code{"subsets"}. Default is \code{NULL}. +#' @param method one of "exhaustive", "forward", "backward" or "seqrep" +#' (sequential replacement) to specify the type of subset search/selection. +#' Required if \code{variable selection="subsets"} is chosen. Default is +#' "exhaustive". +#' @param really.big option for \code{"subsets"}; Must be \code{TRUE} to +#' perform exhaustive search on more than 50 variables. +#' @param subset.size number of factors required in the factor model; +#' an option for \code{"subsets"} variable selection. Default is 1. +#' Note: \code{nvmax >= subset.size >= length(force.in)}. +#' @param type option for \code{"lars"}. One of "lasso", "lar", +#' "forward.stagewise" or "stepwise". The names can be abbreviated to any +#' unique substring. Default is "lasso". +#' @param normalize option for \code{"lars"}. If \code{TRUE}, each variable is +#' standardized to have unit L2 norm, otherwise they are left alone. Default +#' is \code{TRUE}. +#' @param eps option for \code{"lars"}; An effective zero. +#' @param max.steps Limit the number of steps taken for \code{"lars"}; the +#' default is \code{8 * min(m, n-intercept)}, with \code{m} the number of +#' variables, and \code{n} the number of samples. For \code{type="lar"} or +#' \code{type="stepwise"}, the maximum number of steps is +#' \code{min(m,n-intercept)}. For \code{type="lasso"} and especially +#' \code{type="forward.stagewise"}, there can be many more terms, because +#' although no more than \code{min(m,n-intercept)} variables can be active +#' during any step, variables are frequently droppped and added as the +#' algorithm proceeds. Although the default usually guarantees that the +#' algorithm has proceeded to the saturated fit, users should check. +#' @param lars.criterion an option to assess model selection for the +#' \code{"lars"} method; one of "Cp" or "cv". See details. Default is "Cp". +#' @param K number of folds for computing the K-fold cross-validated mean +#' squared prediction error for \code{"lars"}. Default is 10. +#' @param mode This refers to the index that is used for cross-validation. The +#' default is "fraction" for \code{type="lasso"} or +#' \code{type="forward.stagewise"}. For \code{type="lar"} or +#' \code{type="stepwise"} the default is "step". +#' +#' @return A list of the above components. This is only meant to be used by +#' \code{fitTsfm}. +#' +#' @author Sangeetha Srinivasan +#' +#' @references +#' \enumerate{ +#' \item Efron, Bradley, Trevor Hastie, Iain Johnstone, and Robert Tibshirani. +#' "Least angle regression." The Annals of statistics 32, no.2 (2004): 407-499. +#' } +#' +#' @seealso \code{\link{fitTsfm}}, \code{\link[stats]{lm}}, +#' \code{\link[robust]{lmRob}}, \code{\link[stats]{step}}, +#' \code{\link[leaps]{regsubsets}}, \code{\link[lars]{lars}} and +#' \code{\link[lars]{cv.lars}} +#' +#' @examples +#' +#' # check argument list passed by fitTsfm.control +#' tsfm.ctrl <- fitTsfm.control(method="exhaustive", nbest=2) +#' print(tsfm.ctrl) +#' +#' # used internally by fitTsfm +#' data(managers) +#' fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=colnames(managers[,(7:9)]), +#' data=managers, variable.selection="subsets", +#' method="exhaustive", nbest=2) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3474 From noreply at r-forge.r-project.org Mon Jul 21 12:24:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Jul 2014 12:24:01 +0200 (CEST) Subject: [Returnanalytics-commits] r3475 - in pkg/FactorAnalytics: R man Message-ID: <20140721102401.78B95185875@r-forge.r-project.org> Author: pragnya Date: 2014-07-21 12:24:00 +0200 (Mon, 21 Jul 2014) New Revision: 3475 Modified: pkg/FactorAnalytics/R/fitTsfm.R pkg/FactorAnalytics/R/fitTsfm.control.R pkg/FactorAnalytics/man/fitTsfm.Rd pkg/FactorAnalytics/man/fitTsfm.control.Rd Log: Fixed handling of NULL in fitTsfm.control, deleted the mode argument for lars, fixed typos in passing arguments to fitTsfm, added more examples to fitTsfm Modified: pkg/FactorAnalytics/R/fitTsfm.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.R 2014-07-21 08:10:51 UTC (rev 3474) +++ pkg/FactorAnalytics/R/fitTsfm.R 2014-07-21 10:24:00 UTC (rev 3475) @@ -152,6 +152,18 @@ #' colnames(dataToPlot) <- c("Fitted","Actual") #' chart.TimeSeries(dataToPlot, main="FM fit for HAM1", #' colorset=c("black","blue"), legend.loc="bottomleft") +#' +#' # example using "subsets" variable selection +#' fit.sub <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=colnames(managers[,(7:9)]), +#' data=managers, variable.selection="subsets", +#' method="exhaustive", subset.size=2) +#' +#' # example using "lars" variable selection and subtracting risk-free rate +#' fit.lar <- fitTsfm(asset.names=colnames(managers[,(1:6)]), +#' factor.names=colnames(managers[,(7:9)]), +#' rf.name="US 3m TR", data=managers, +#' variable.selection="lars", lars.criterion="cv") #' #' @export @@ -183,7 +195,7 @@ decay <- control$decay subset.size <- control$subset.size lars.criterion <- control$lars.criterion - m1 <- match(c("weights","method","model","x","y","qr"), + m1 <- match(c("weights","model","x","y","qr"), names(control), 0L) lm.args <- control[m1, drop=TRUE] m2 <- match(c("weights","model","x","y","nrep"), @@ -198,7 +210,7 @@ m5 <- match(c("type","normalize","eps","max.steps","trace"), names(control), 0L) lars.args <- control[m5, drop=TRUE] - m6 <- match(c("K","type","mode","normalize","eps","max.steps","trace"), + m6 <- match(c("K","type","normalize","eps","max.steps","trace"), names(control), 0L) cv.lars.args <- control[m6, drop=TRUE] @@ -416,10 +428,11 @@ # convert to matrix reg.mat <- as.matrix(reg.xts) # fit lars regression model - lars.fit <- do.call(lars, c(x=list(reg.mat[,-1],y=reg.mat[,i]),lars.args)) + lars.fit <- do.call(lars, c(list(x=reg.mat[,-1],y=reg.mat[,i]),lars.args)) lars.sum <- summary(lars.fit) - cv.error <- do.call(cv.lars, c(x=list(reg.mat[,-1],y=reg.mat[,i], - plot.it=FALSE),cv.lars.args)) + cv.error <- + do.call(cv.lars, c(list(x=reg.mat[,-1],y=reg.mat[,i],plot.it=FALSE, + mode="step"),cv.lars.args)) # get the step that minimizes the "Cp" statistic or # the K-fold "cv" mean-squared prediction error @@ -439,14 +452,14 @@ beta.names <- names(coef.lars$coefficients) beta[i, beta.names] <- coef.lars$coefficients r2[i] <- lars.fit$R2[s] - resid.sd[i] <- lars.sum$Rss[s]/(nrow(reg.xts)-s) + resid.sd[i] <- sqrt(lars.sum$Rss[s]/(nrow(reg.xts)-s)) } fitted.xts <- do.call(merge, fitted.list) results.lars <- list(asset.fit=asset.fit, alpha=alpha, beta=beta, r2=r2, resid.sd=resid.sd, fitted=fitted.xts) # As a special case for variable.selection="lars", fitted values are also - # returned by fitTsfm. Else, shrinkage s from the best fit is needed to get + # returned by fitTsfm. Else, step s from the best fit is needed to get # fitted values & residuals. } Modified: pkg/FactorAnalytics/R/fitTsfm.control.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.control.R 2014-07-21 08:10:51 UTC (rev 3474) +++ pkg/FactorAnalytics/R/fitTsfm.control.R 2014-07-21 10:24:00 UTC (rev 3475) @@ -98,10 +98,6 @@ #' \code{"lars"} method; one of "Cp" or "cv". See details. Default is "Cp". #' @param K number of folds for computing the K-fold cross-validated mean #' squared prediction error for \code{"lars"}. Default is 10. -#' @param mode This refers to the index that is used for cross-validation. The -#' default is "fraction" for \code{type="lasso"} or -#' \code{type="forward.stagewise"}. For \code{type="lar"} or -#' \code{type="stepwise"} the default is "step". #' #' @return A list of the above components. This is only meant to be used by #' \code{fitTsfm}. @@ -122,7 +118,7 @@ #' @examples #' #' # check argument list passed by fitTsfm.control -#' tsfm.ctrl <- fitTsfm.control(method="exhaustive", nbest=2) +#' tsfm.ctrl <- fitTsfm.control(method="exhaustive", subset.size=2) #' print(tsfm.ctrl) #' #' # used internally by fitTsfm @@ -130,7 +126,7 @@ #' fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), #' factor.names=colnames(managers[,(7:9)]), #' data=managers, variable.selection="subsets", -#' method="exhaustive", nbest=2) +#' method="exhaustive", subset.size=2) #' #' @export @@ -140,14 +136,19 @@ force.in=NULL, force.out=NULL, method, really.big=FALSE, subset.size=1, type, normalize=TRUE, eps=.Machine$double.eps, max.steps, - lars.criterion="Cp", K = 10, mode) { + lars.criterion="Cp", K = 10) { # get the user-specified arguments (that have no defaults) - c <- match.call() + call <- match.call() m <- match(c("weights","scope","scale","direction","method","type", - "max.steps","mode"), names(c), 0L) + "max.steps"), names(call), 0L) + # drop unused levels - result <- as.list(c[m, drop=TRUE]) + if (!is.null(call) && sum(m>0) == 0) { + args <- list() + } else { + args <- as.list(call[m, drop=TRUE]) + } # check input validity for some of the arguments if (decay<=0 || decay>1) { @@ -184,11 +185,11 @@ } # return list of arguments with defaults if they are unspecified - result <- c(result, list(decay=decay, model=model, x=x, y=y, qr=qr, - nrep=nrep, trace=trace, steps=steps, k=k, - nbest=nbest, nvmax=nvmax, force.in=force.in, - force.out=force.out, really.big=really.big, - subset.size=subset.size, normalize=normalize, - eps=eps, lars.criterion=lars.criterion, K=K)) + result <- c(args, list(decay=decay, model=model, x=x, y=y, qr=qr, nrep=nrep, + trace=trace, steps=steps, k=k, nbest=nbest, + nvmax=nvmax, force.in=force.in, force.out=force.out, + really.big=really.big, subset.size=subset.size, + normalize=normalize, eps=eps, + lars.criterion=lars.criterion, K=K)) return(result) } Modified: pkg/FactorAnalytics/man/fitTsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTsfm.Rd 2014-07-21 08:10:51 UTC (rev 3474) +++ pkg/FactorAnalytics/man/fitTsfm.Rd 2014-07-21 10:24:00 UTC (rev 3475) @@ -158,6 +158,18 @@ colnames(dataToPlot) <- c("Fitted","Actual") chart.TimeSeries(dataToPlot, main="FM fit for HAM1", colorset=c("black","blue"), legend.loc="bottomleft") + +# example using "subsets" variable selection +fit.sub <- fitTsfm(asset.names=colnames(managers[,(1:6)]), + factor.names=colnames(managers[,(7:9)]), + data=managers, variable.selection="subsets", + method="exhaustive", subset.size=2) + +# example using "lars" variable selection and subtracting risk-free rate +fit.lar <- fitTsfm(asset.names=colnames(managers[,(1:6)]), + factor.names=colnames(managers[,(7:9)]), + rf.name="US 3m TR", data=managers, + variable.selection="lars", lars.criterion="cv") } \author{ Eric Zivot, Yi-An Chen and Sangeetha Srinivasan. Modified: pkg/FactorAnalytics/man/fitTsfm.control.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTsfm.control.Rd 2014-07-21 08:10:51 UTC (rev 3474) +++ pkg/FactorAnalytics/man/fitTsfm.control.Rd 2014-07-21 10:24:00 UTC (rev 3475) @@ -8,7 +8,7 @@ trace = FALSE, steps = 1000, k = 2, nbest = 1, nvmax = 8, force.in = NULL, force.out = NULL, method, really.big = FALSE, subset.size = 1, type, normalize = TRUE, eps = .Machine$double.eps, - max.steps, lars.criterion = "Cp", K = 10, mode) + max.steps, lars.criterion = "Cp", K = 10) } \arguments{ \item{decay}{a scalar in (0, 1] to specify the decay factor for "DLS". @@ -107,11 +107,6 @@ \item{K}{number of folds for computing the K-fold cross-validated mean squared prediction error for \code{"lars"}. Default is 10.} - -\item{mode}{This refers to the index that is used for cross-validation. The -default is "fraction" for \code{type="lasso"} or -\code{type="forward.stagewise"}. For \code{type="lar"} or -\code{type="stepwise"} the default is "step".} } \value{ A list of the above components. This is only meant to be used by @@ -145,7 +140,7 @@ } \examples{ # check argument list passed by fitTsfm.control -tsfm.ctrl <- fitTsfm.control(method="exhaustive", nbest=2) +tsfm.ctrl <- fitTsfm.control(method="exhaustive", subset.size=2) print(tsfm.ctrl) # used internally by fitTsfm @@ -153,7 +148,7 @@ fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), factor.names=colnames(managers[,(7:9)]), data=managers, variable.selection="subsets", - method="exhaustive", nbest=2) + method="exhaustive", subset.size=2) } \author{ Sangeetha Srinivasan From noreply at r-forge.r-project.org Mon Jul 21 23:13:28 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 21 Jul 2014 23:13:28 +0200 (CEST) Subject: [Returnanalytics-commits] r3476 - in pkg/PortfolioAnalytics: R man Message-ID: <20140721211328.860AD184D26@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-21 23:13:28 +0200 (Mon, 21 Jul 2014) New Revision: 3476 Modified: pkg/PortfolioAnalytics/R/constraints.R pkg/PortfolioAnalytics/man/add.constraint.Rd pkg/PortfolioAnalytics/man/diversification_constraint.Rd pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd pkg/PortfolioAnalytics/man/turnover_constraint.Rd Log: updating documentation for constraints Modified: pkg/PortfolioAnalytics/R/constraints.R =================================================================== --- pkg/PortfolioAnalytics/R/constraints.R 2014-07-21 10:24:00 UTC (rev 3475) +++ pkg/PortfolioAnalytics/R/constraints.R 2014-07-21 21:13:28 UTC (rev 3476) @@ -197,10 +197,11 @@ #' \item{\code{position_limit}}{ Specify the number of non-zero, long, and/or short positions, see \code{\link{position_limit_constraint}} } #' \item{\code{return}}{ Specify the target mean return, see \code{\link{return_constraint}}} #' \item{\code{factor_exposure}}{ Specify risk factor exposures, see \code{\link{factor_exposure_constraint}}} +#' \item{\code{leverage_exposure}}{ Specify a maximum leverage exposure, see \code{\link{leverage_exposure_constraint}}} #' } #' #' @param portfolio an object of class 'portfolio' to add the constraint to, specifying the constraints for the optimization, see \code{\link{portfolio.spec}} -#' @param type character type of the constraint to add or update, currently 'weight_sum' (also 'leverage' or 'weight'), 'box', 'group', 'turnover', 'diversification', 'position_limit', 'return', or 'factor_exposure' +#' @param type character type of the constraint to add or update, currently 'weight_sum' (also 'leverage' or 'weight'), 'box', 'group', 'turnover', 'diversification', 'position_limit', 'return', 'factor_exposure', or 'leverage_exposure' #' @param enabled TRUE/FALSE. The default is enabled=TRUE. #' @param message TRUE/FALSE. The default is message=FALSE. Display messages if TRUE. #' @param \dots any other passthru parameters to specify constraints @@ -215,7 +216,8 @@ #' \code{\link{diversification_constraint}}, #' \code{\link{position_limit_constraint}}, #' \code{\link{return_constraint}}, -#' \code{\link{factor_exposure_constraint}} +#' \code{\link{factor_exposure_constraint}}, +#' \code{\link{leverage_exposure_constraint}} #' @examples #' data(edhec) #' returns <- edhec[, 1:4] @@ -791,7 +793,9 @@ #' #' The turnover constraint specifies a target turnover value. #' This function is called by add.constraint when type="turnover" is specified, see \code{\link{add.constraint}}. -#' Turnover is calculated from a set of initial weights. +#' Turnover is calculated from a set of initial weights. Turnover is +#' computed as \code{sum(abs(initial_weights - weights)) / N} where \code{N} is +#' the number of assets. #' #' Note that with the ROI solvers, turnover constraint is currently only #' supported for the global minimum variance and quadratic utility problems @@ -822,7 +826,9 @@ #' constructor for diversification_constraint #' #' The diversification constraint specifies a target diversification value. -#' This function is called by add.constraint when type="diversification" is specified, see \code{\link{add.constraint}}. +#' This function is called by add.constraint when type="diversification" is +#' specified, see \code{\link{add.constraint}}. Diversification is computed +#' as \code{1 - sum(weights^2)}. #' #' @param type character type of the constraint #' @param div_target diversification target value @@ -1049,11 +1055,16 @@ #' constructor for leverage_exposure_constraint #' -#' The leverage_exposure constraint specifies a maximum leverage. This should -#' be used for constructing, for example, 130/30 portfolios or dollar neutral -#' portfolios with 2:1 leverage. For the ROI solvers, this is implemented -#' as a MILP problem and is not supported for problems formulated as a -#' quadratic programming problem. This ma changed in the future if a MIQP +#' The leverage_exposure constraint specifies a maximum leverage where +#' leverage is defined as the sum of the absolute value of the weights. +#' Leverage exposure is computed as the sum of the absolute value of the +#' weights, \code{sum(abs(weights))}. +#' +#' +#' This should be used for constructing, for example, 130/30 portfolios or +#' dollar neutral portfolios with 2:1 leverage. For the ROI solvers, this is +#' implemented as a MILP problem and is not supported for problems formulated +#' as a quadratic programming problem. This may change in the future if a MIQP #' solver is added. #' #' This function is called by add.constraint when type="leverage_exposure" Modified: pkg/PortfolioAnalytics/man/add.constraint.Rd =================================================================== --- pkg/PortfolioAnalytics/man/add.constraint.Rd 2014-07-21 10:24:00 UTC (rev 3475) +++ pkg/PortfolioAnalytics/man/add.constraint.Rd 2014-07-21 21:13:28 UTC (rev 3476) @@ -9,7 +9,7 @@ \arguments{ \item{portfolio}{an object of class 'portfolio' to add the constraint to, specifying the constraints for the optimization, see \code{\link{portfolio.spec}}} -\item{type}{character type of the constraint to add or update, currently 'weight_sum' (also 'leverage' or 'weight'), 'box', 'group', 'turnover', 'diversification', 'position_limit', 'return', or 'factor_exposure'} +\item{type}{character type of the constraint to add or update, currently 'weight_sum' (also 'leverage' or 'weight'), 'box', 'group', 'turnover', 'diversification', 'position_limit', 'return', 'factor_exposure', or 'leverage_exposure'} \item{enabled}{TRUE/FALSE. The default is enabled=TRUE.} @@ -36,6 +36,7 @@ \item{\code{position_limit}}{ Specify the number of non-zero, long, and/or short positions, see \code{\link{position_limit_constraint}} } \item{\code{return}}{ Specify the target mean return, see \code{\link{return_constraint}}} \item{\code{factor_exposure}}{ Specify risk factor exposures, see \code{\link{factor_exposure_constraint}}} +\item{\code{leverage_exposure}}{ Specify a maximum leverage exposure, see \code{\link{leverage_exposure_constraint}}} } } \examples{ @@ -113,6 +114,7 @@ \code{\link{diversification_constraint}}, \code{\link{position_limit_constraint}}, \code{\link{return_constraint}}, -\code{\link{factor_exposure_constraint}} +\code{\link{factor_exposure_constraint}}, +\code{\link{leverage_exposure_constraint}} } Modified: pkg/PortfolioAnalytics/man/diversification_constraint.Rd =================================================================== --- pkg/PortfolioAnalytics/man/diversification_constraint.Rd 2014-07-21 10:24:00 UTC (rev 3475) +++ pkg/PortfolioAnalytics/man/diversification_constraint.Rd 2014-07-21 21:13:28 UTC (rev 3476) @@ -20,7 +20,9 @@ } \description{ The diversification constraint specifies a target diversification value. -This function is called by add.constraint when type="diversification" is specified, see \code{\link{add.constraint}}. +This function is called by add.constraint when type="diversification" is +specified, see \code{\link{add.constraint}}. Diversification is computed +as \code{1 - sum(weights^2)}. } \examples{ data(edhec) Modified: pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd =================================================================== --- pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd 2014-07-21 10:24:00 UTC (rev 3475) +++ pkg/PortfolioAnalytics/man/leverage_exposure_constraint.Rd 2014-07-21 21:13:28 UTC (rev 3476) @@ -19,14 +19,18 @@ an object of class 'diversification_constraint'} } \description{ -The leverage_exposure constraint specifies a maximum leverage. This should -be used for constructing, for example, 130/30 portfolios or dollar neutral -portfolios with 2:1 leverage. For the ROI solvers, this is implemented -as a MILP problem and is not supported for problems formulated as a -quadratic programming problem. This ma changed in the future if a MIQP -solver is added. +The leverage_exposure constraint specifies a maximum leverage where +leverage is defined as the sum of the absolute value of the weights. +Leverage exposure is computed as the sum of the absolute value of the +weights, \code{sum(abs(weights))}. } \details{ +This should be used for constructing, for example, 130/30 portfolios or +dollar neutral portfolios with 2:1 leverage. For the ROI solvers, this is +implemented as a MILP problem and is not supported for problems formulated +as a quadratic programming problem. This may change in the future if a MIQP +solver is added. + This function is called by add.constraint when type="leverage_exposure" is specified, see \code{\link{add.constraint}}. } Modified: pkg/PortfolioAnalytics/man/turnover_constraint.Rd =================================================================== --- pkg/PortfolioAnalytics/man/turnover_constraint.Rd 2014-07-21 10:24:00 UTC (rev 3475) +++ pkg/PortfolioAnalytics/man/turnover_constraint.Rd 2014-07-21 21:13:28 UTC (rev 3476) @@ -23,7 +23,9 @@ \description{ The turnover constraint specifies a target turnover value. This function is called by add.constraint when type="turnover" is specified, see \code{\link{add.constraint}}. -Turnover is calculated from a set of initial weights. +Turnover is calculated from a set of initial weights. Turnover is +computed as \code{sum(abs(initial_weights - weights)) / N} where \code{N} is +the number of assets. } \details{ Note that with the ROI solvers, turnover constraint is currently only From noreply at r-forge.r-project.org Wed Jul 23 00:24:11 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 23 Jul 2014 00:24:11 +0200 (CEST) Subject: [Returnanalytics-commits] r3477 - pkg/PortfolioAnalytics/sandbox Message-ID: <20140722222412.1410B18680F@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-23 00:24:11 +0200 (Wed, 23 Jul 2014) New Revision: 3477 Added: pkg/PortfolioAnalytics/sandbox/rp_transform2.R Log: Adding test version of rp_transform2 to sandbox for improved algorithm to handle more complex constraints for random portfolios Added: pkg/PortfolioAnalytics/sandbox/rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/rp_transform2.R (rev 0) +++ pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-22 22:24:11 UTC (rev 3477) @@ -0,0 +1,164 @@ + + +rp_transform2 <- function(weights, + min_sum=NULL, + max_sum=NULL, + min_box=NULL, + max_box=NULL, + max_pos=NULL, + leverage=NULL, + max_permutations=200){ + tmp_w <- weights + + # Set some reasonable default values + if(is.null(min_sum)) min_sum <- 0.99 + if(is.null(max_sum)) max_sum <- 1.01 + if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w)) + if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w)) + if(is.null(max_pos)) max_pos <- length(tmp_w) + if(is.null(leverage)) leverage <- Inf + + # Generate a weight sequence, we should check for portfolio$weight_seq + weight_seq <- generatesequence(min=min(min_box), max=max(max_box), by=0.002) + + # tolerance for "non-zero" definition + tolerance <- .Machine$double.eps^0.5 + + # initialize the outer while loop + permutations <- 1 + + # while we have not reached max_permutations and the following constraints + # are violated: + # - min_sum/max_sum + # - leverage + # - max_pos + + + + # Do we want to check all constraints in here? + # Box constraints should be satisfied by construction so we should not need + # to check those here + while (( (sum(tmp_w) < min_sum) | + (sum(tmp_w) > max_sum) | + (sum(abs(tmp_w)) > leverage) | + (sum(abs(tmp_w) > tolerance)) | + (sum(abs(tmp_w) > tolerance) > max_pos) ) & + (permutations < max_permutations)) { + + permutations <- permutations+1 + # check our box constraints on total portfolio weight + # reduce(increase) total portfolio size till you get a match + # 1> check to see which bound you've failed on, brobably set this as a pair of while loops + # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function + # 3> check and repeat + + # reset the random index + random_index <- sample(1:length(tmp_w), length(tmp_w)) + + # randomly permute and increase a random portfolio element if the sum of + # the weights is less than min_sum + # set counter to 1 for increase loop + i <- 1 + while (sum(tmp_w) <= min_sum & i <= length(tmp_w)) { + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + # randomly sample one of the larger weights + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # print(paste("new val:",tmp_w[cur_index])) + } else { + if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + } + i <- i + 1 # increment our counter + } # end increase loop + + # randomly permute and decrease a random portfolio element if the sum of + # the weights is greater than max_sum + # set counter to 1 for decrease loop + i <- 1 + while (sum(tmp_w) >= max_sum & i <= length(tmp_w)) { + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1) { + # randomly sample one of the smaller weights + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else { + if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + } + i <- i + 1 # increment our counter + } # end decrease loop + + # set counter to 1 for leverage violation loop + i <- 1 + while (sum(abs(tmp_w)) >= leverage & i <= length(tmp_w)) { + # randomly permute and increae decrease a random portfolio element + # according to leverage exposure + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + + # check the sign of the current value + if(cur_val < 0){ + # if the current value is negative, we want to increase to lower + # sum(abs(weights)) while respecting uppper bound box constraint + tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] + } else if(cur_val > 0){ + # if the current value is positive, we want to decrease to lower + # sum(abs(weights)) while respecting lower bound box constraint + tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] + } + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1) { + # randomly sample one of the weights + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else { + if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + } + i <- i + 1 # increment our counter + } # end leverage violation loop + + # set counter to 1 for position limit violation loop + i <- 1 + while (sum(abs(tmp_w) > tolerance) >= max_pos & i <= length(tmp_w)) { + # TODO + # check for positive weights for max_pos_long + # check for negative weights for max_pos_short + + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + + # Can I just force a weight to 0? + tmp_w[cur_index] <- 0 + + i <- i + 1 # increment our counter + } # end position limit violation loop + + cat("permutations:", permutations, "\n") + cat("weights:", tmp_w, "\n") + cat("sum(weights):", sum(tmp_w), "\n") + cat("sum(abs(weights)):", sum(abs(tmp_w)), "\n") + } # end final walk towards the edges + portfolio <- tmp_w + + colnames(portfolio) <- colnames(weights) + + # checks for infeasible portfolio + # Stop execution and return an error if an infeasible portfolio is created + # This will be useful in fn_map so that we can catch the error and take + # action (try again with more permutations, relax constraints, different + # method to normalize, etc.) + if (sum(portfolio) < min_sum | sum(portfolio) > max_sum){ + portfolio <- weights + stop("Infeasible portfolio created, perhaps increase max_permutations and/or adjust your parameters.") + } + return(portfolio) +} \ No newline at end of file From noreply at r-forge.r-project.org Wed Jul 23 04:50:59 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 23 Jul 2014 04:50:59 +0200 (CEST) Subject: [Returnanalytics-commits] r3478 - pkg/PortfolioAnalytics/sandbox Message-ID: <20140723025059.3CC0D185DDB@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-23 04:50:58 +0200 (Wed, 23 Jul 2014) New Revision: 3478 Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R Log: Adding logic for position limit constraints to rp_transform2 Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-22 22:24:11 UTC (rev 3477) +++ pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-23 02:50:58 UTC (rev 3478) @@ -6,22 +6,28 @@ min_box=NULL, max_box=NULL, max_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, leverage=NULL, max_permutations=200){ tmp_w <- weights # Set some reasonable default values + # Maybe I should leave these as NULL values and incorporate that into the + # checks if(is.null(min_sum)) min_sum <- 0.99 if(is.null(max_sum)) max_sum <- 1.01 if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w)) if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w)) if(is.null(max_pos)) max_pos <- length(tmp_w) + if(is.null(max_pos)) max_pos_long <- length(tmp_w) + if(is.null(max_pos)) max_pos_short <- length(tmp_w) if(is.null(leverage)) leverage <- Inf # Generate a weight sequence, we should check for portfolio$weight_seq weight_seq <- generatesequence(min=min(min_box), max=max(max_box), by=0.002) - # tolerance for "non-zero" definition + # Tolerance for "non-zero" definition for position limit constraints tolerance <- .Machine$double.eps^0.5 # initialize the outer while loop @@ -38,28 +44,43 @@ # Do we want to check all constraints in here? # Box constraints should be satisfied by construction so we should not need # to check those here - while (( (sum(tmp_w) < min_sum) | - (sum(tmp_w) > max_sum) | - (sum(abs(tmp_w)) > leverage) | - (sum(abs(tmp_w) > tolerance)) | - (sum(abs(tmp_w) > tolerance) > max_pos) ) & + while (( (sum(tmp_w) < min_sum) | + (sum(tmp_w) > max_sum) | + (sum(abs(tmp_w)) > leverage) | + (sum(abs(tmp_w) > tolerance) > max_pos) ) & (permutations < max_permutations)) { + cat("permutation #:", permutations, "\n") permutations <- permutations+1 + # check our box constraints on total portfolio weight # reduce(increase) total portfolio size till you get a match # 1> check to see which bound you've failed on, brobably set this as a pair of while loops # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function # 3> check and repeat - # reset the random index - random_index <- sample(1:length(tmp_w), length(tmp_w)) + # Reset tmp_w to original weights vector + # I'm not sure we want to do this here because it puts us back to where we + # started, but it seems to help with the position limit constraint + # tmp_w <- weights + # Reset the random index based on the maximum position constraint + # This basically allows us to generate a portfolio of max_pos assets + # with the given constraints and then add assets with zero weight + random_index <- sample(1:length(tmp_w), max_pos) + + # Get the index values that are not in random_index and set them equal to 0 + full_index <- 1:length(tmp_w) + not_index <- setdiff(full_index, random_index) + tmp_w[not_index] <- 0 + # randomly permute and increase a random portfolio element if the sum of # the weights is less than min_sum # set counter to 1 for increase loop i <- 1 while (sum(tmp_w) <= min_sum & i <= length(tmp_w)) { + print("Entering min_sum violation loop") + cur_index <- random_index[i] cur_val <- tmp_w[cur_index] tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] @@ -81,6 +102,8 @@ # set counter to 1 for decrease loop i <- 1 while (sum(tmp_w) >= max_sum & i <= length(tmp_w)) { + print("Entering max_sum violation loop") + cur_index <- random_index[i] cur_val <- tmp_w[cur_index] tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] @@ -99,6 +122,7 @@ # set counter to 1 for leverage violation loop i <- 1 while (sum(abs(tmp_w)) >= leverage & i <= length(tmp_w)) { + print("Entering leverage violation loop") # randomly permute and increae decrease a random portfolio element # according to leverage exposure cur_index <- random_index[i] @@ -128,21 +152,69 @@ # set counter to 1 for position limit violation loop i <- 1 - while (sum(abs(tmp_w) > tolerance) >= max_pos & i <= length(tmp_w)) { - # TODO - # check for positive weights for max_pos_long - # check for negative weights for max_pos_short + while (((sum(abs(tmp_w) > tolerance) > max_pos) | + (sum(tmp_w >= 0) > max_pos_long) | + (sum(tmp_w >= 0) > max_pos_long)) & + i <= length(tmp_w)) { + print("Entering position limit violation loop") cur_index <- random_index[i] cur_val <- tmp_w[cur_index] - # Can I just force a weight to 0? - tmp_w[cur_index] <- 0 + # Check if max_pos_long is violated + # If max_pos_long is violated, we we grab a positive weight and set it + # to be between min_box and 0 + if(sum(tmp_w > tolerance) > max_pos_long){ + if(cur_val > tolerance){ + # subset such that min_box_i <= weight_i <= 0 + tmp_seq <- weight_seq[(weight_seq <= 0) & (weight_seq >= min_box[cur_index])] + } + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + } # end max_pos_long violation loop + # Check if max_pos_short is violated + # If max_pos_short is violated, we we grab a negative weight and set it + # to be between 0 and max_box + if(sum(tmp_w < tolerance) > max_pos_short){ + if(cur_val < tolerance){ + # subset such that 0 <= weight_i <= max_box_i + tmp_seq <- weight_seq[(weight_seq >= 0) & (weight_seq <= max_box[cur_index])] + } + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + } # end max_pos_short violation loop + i <- i + 1 # increment our counter } # end position limit violation loop - cat("permutations:", permutations, "\n") +# while(any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) & i <= length(tmp_w)){ +# n_groups <- length(groups) +# for(j in 1:n_groups){ +# # sum of the weights for a given group +# tmp_group_w <- tmp_w[groups[[j]]] +# +# # treat this as if min_sum were violated +# if(sum(tmp_group_w) < cLO[j]){ +# +# } +# +# # treat this as if max_sum were violated +# if(sum(tmp_group_w) > cup[j]){ +# +# } +# } +# i <- i + 1 # increment our counter +# } + cat("weights:", tmp_w, "\n") cat("sum(weights):", sum(tmp_w), "\n") cat("sum(abs(weights)):", sum(abs(tmp_w)), "\n") From noreply at r-forge.r-project.org Thu Jul 24 01:15:28 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Jul 2014 01:15:28 +0200 (CEST) Subject: [Returnanalytics-commits] r3479 - in pkg/PortfolioAnalytics: R sandbox Message-ID: <20140723231529.085B218459B@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-24 01:15:28 +0200 (Thu, 24 Jul 2014) New Revision: 3479 Modified: pkg/PortfolioAnalytics/R/constraint_fn_map.R pkg/PortfolioAnalytics/sandbox/rp_transform2.R Log: refactor rp_transform2 code to modularize handling the constraint types Modified: pkg/PortfolioAnalytics/R/constraint_fn_map.R =================================================================== --- pkg/PortfolioAnalytics/R/constraint_fn_map.R 2014-07-23 02:50:58 UTC (rev 3478) +++ pkg/PortfolioAnalytics/R/constraint_fn_map.R 2014-07-23 23:15:28 UTC (rev 3479) @@ -58,6 +58,7 @@ max_pos <- constraints$max_pos max_pos_long <- constraints$max_pos_long max_pos_short <- constraints$max_pos_short + leverage <- constraints$leverage tolerance <- .Machine$double.eps^0.5 # We will modify the weights vector so create a temporary copy @@ -70,6 +71,7 @@ tmp_max_pos <- max_pos tmp_max_pos_long <- max_pos_long tmp_max_pos_short <- max_pos_short + tmp_leverage <- leverage # step 2: check that the vector of weights satisfies the constraints, # transform weights if constraint is violated @@ -86,7 +88,8 @@ groups=NULL, cLO=NULL, cUP=NULL, max_pos=NULL, group_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ # Default to initial weights tmp_weights <- weights @@ -104,7 +107,8 @@ groups=NULL, cLO=NULL, cUP=NULL, max_pos=NULL, group_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ # Default to initial weights tmp_weights <- weights @@ -132,7 +136,8 @@ groups=NULL, cLO=NULL, cUP=NULL, max_pos=NULL, group_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing # Default to original weights if this fails again if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 @@ -159,7 +164,8 @@ groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, max_pos=NULL, group_pos=group_pos, max_pos_long=NULL, max_pos_short=NULL, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ # Default to initial weights tmp_weights <- weights @@ -183,7 +189,8 @@ groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, max_pos=NULL, group_pos=group_pos, max_pos_long=NULL, max_pos_short=NULL, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 } @@ -209,7 +216,8 @@ groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, max_pos=tmp_max_pos, group_pos=group_pos, max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ # Default to initial weights tmp_weights <- weights @@ -227,7 +235,8 @@ groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, max_pos=tmp_max_pos, group_pos=group_pos, max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - max_permutations=500), silent=TRUE) # FALSE for testing + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 } @@ -235,6 +244,43 @@ } # end try-error recovery } # end check for position limit constraint violation } # end check for NULL arguments + + # check leverage constraints + if(!is.null(tmp_leverage)){ + if(sum(abs(tmp_weights)) > tmp_leverage){ + # Try to transform only considering weight_sum, box, group, position_limit, and leverage exposure constraints + tmp_weights <- try(rp_transform(w=tmp_weights, + min_sum=min_sum, max_sum=max_sum, + min=tmp_min, max=tmp_max, + groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, + max_pos=tmp_max_pos, group_pos=group_pos, + max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing + if(inherits(tmp_weights, "try-error")){ + # Default to initial weights + tmp_weights <- weights + if(relax){ + i <- 1 + while(sum(abs(tmp_weights)) > tmp_leverage & (i <= 5)){ + # increment tmp_leverage by 1% + tmp_leverage <- tmp_leverage * 1.01 + # Now try the transformation again + tmp_weights <- try(rp_transform(w=tmp_weights, + min_sum=min_sum, max_sum=max_sum, + min=tmp_min, max=tmp_max, + groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, + max_pos=tmp_max_pos, group_pos=group_pos, + max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, max_permutations=500), + silent=TRUE) # FALSE for testing + if(inherits(tmp_weights, "try-error")) tmp_weights <- weights + i <- i + 1 + } + } # end if(relax) statement + } # end try-error recovery + } # end check for leverage exposure violation + } # end check for NULL arguments names(tmp_weights) <- names(weights) return(list(weights=tmp_weights, @@ -244,16 +290,20 @@ cUP=tmp_cUP, max_pos=tmp_max_pos, max_pos_long=tmp_max_pos_long, - max_pos_short=tmp_max_pos_short)) + max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage)) } -#' Transform a weights vector to satisfy leverage, box, group, and position_limit constraints using logic from \code{randomize_portfolio} +#' Transform a weights vector to satisfy constraints #' #' This function uses a block of code from \code{\link{randomize_portfolio}} #' to transform the weight vector if either the weight_sum (leverage) -#' constraints, box constraints, group constraints, or position_limit constraints are violated. +#' constraints, box constraints, group constraints, position_limit constraints, +#' or leverage exposure constraints are violated. The logic from +#' \code{randomize_portfolio} is heavily utilized here with some modifications +#' to handle more complex constraints. #' The resulting weights vector might be quite different from the original weights vector. #' #' @param w weights vector to be transformed @@ -268,11 +318,25 @@ #' @param group_pos vector specifying maximum number assets with non-zero weights per group #' @param max_pos_long maximum number of assets with long (i.e. buy) positions #' @param max_pos_short maximum number of assets with short (i.e. sell) positions +#' @param leverage maximum leverage exposure where leverage is defined as \code{sum(abs(weights))} #' @param max_permutations integer: maximum number of iterations to try for a valid portfolio, default 200 #' @return named weighting vector #' @author Peter Carl, Brian G. Peterson, Ross Bennett (based on an idea by Pat Burns) #' @export -rp_transform <- function(w, min_sum=0.99, max_sum=1.01, min, max, groups, cLO, cUP, max_pos=NULL, group_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, max_permutations=200){ +rp_transform <- function(w, + min_sum=0.99, + max_sum=1.01, + min, + max, + groups, + cLO, + cUP, + max_pos=NULL, + group_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=NULL, + max_permutations=200){ # Uses logic from randomize_portfolio to "normalize" a weights vector to # satisfy min_sum and max_sum while accounting for box and group constraints # Modified from randomize_portfolio to trigger the while loops if any weights @@ -286,6 +350,9 @@ # Set value for max_pos if it is not specified if(is.null(max_pos)) max_pos <- length(w) + # Set value for leverage if it is not specified + if(is.null(leverage)) leverage <- Inf + # Determine maximum number of non-zero weights if(!is.null(group_pos)) { max_group_pos <- sum(group_pos) @@ -315,7 +382,8 @@ if((sum(w) >= min_sum & sum(w) <= max_sum) & (all(w >= tmp_min) & all(w <= max)) & (all(!group_fail(w, groups, cLO, cUP, group_pos))) & - !pos_limit_fail(w, max_pos, max_pos_long, max_pos_short)){ + !pos_limit_fail(w, max_pos, max_pos_long, max_pos_short) & + (sum(abs(w)) <= leverage)){ return(w) } @@ -330,8 +398,15 @@ # create a temporary weights vector that will be modified in the while loops tmp_w <- w - # while portfolio is outside min_sum/max_sum or tmp_min/max or group or postion_limit constraints and we have not reached max_permutations - while ((sum(tmp_w) < min_sum | sum(tmp_w) > max_sum | any(tmp_w < tmp_min) | any(tmp_w > max) | any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | (pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short))) & permutations <= max_permutations) { + # while any constraint is violated and we have not reached max_permutations + while ((sum(tmp_w) < min_sum | + sum(tmp_w) > max_sum | + any(tmp_w < tmp_min) | + any(tmp_w > max) | + any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | + pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | + sum(abs(w)) > leverage) & + permutations <= max_permutations) { permutations = permutations + 1 # check our box constraints on total portfolio weight # reduce(increase) total portfolio size till you get a match @@ -399,8 +474,15 @@ } i = 1 - # while sum of weights is less than min_sum or tmp_min/max box or group constraint is violated - while ((sum(tmp_w) < min_sum | any(tmp_w < tmp_min) | any(tmp_w > max) | any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | (pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short))) & i <= length(tmp_w)) { + # We increase elements here if the sum of the weights exceeds max_sum or + # any of the other constraints are violated + while ((sum(tmp_w) < min_sum | + any(tmp_w < tmp_min) | + any(tmp_w > max) | + any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | + pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | + sum(abs(tmp_w)) > leverage) & + i <= length(tmp_w)) { # randomly permute and increase a random portfolio element cur_index <- random_index[i] cur_val <- tmp_w[cur_index] @@ -422,8 +504,15 @@ # need to reset i here otherwise the decreasing loop will be ignored # group_fail does not test for direction of violation, just that group constraints were violated i = 1 - # while sum of weights is greater than max_sum or tmp_min/max box or group constraint is violated - while ((sum(tmp_w) > max_sum | any(tmp_w < tmp_min) | any(tmp_w > max) | any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | (pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short))) & i <= length(tmp_w)) { + # We decrease elements here if the sum of the weights exceeds max_sum or + # any of the other constraints are violated + while ((sum(tmp_w) > max_sum | + any(tmp_w < tmp_min) | + any(tmp_w > max) | + any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | + pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | + sum(abs(tmp_w)) > leverage) & + i <= length(tmp_w)) { # randomly permute and decrease a random portfolio element cur_index <- random_index[i] cur_val <- tmp_w[cur_index] @@ -441,6 +530,10 @@ } i=i+1 # increment our counter } # end decrease loop + #cat("permutations:", permutations, "\n") + #cat("weights:", tmp_w, "\n") + #cat("sum(weights):", sum(tmp_w), "\n") + #cat("sum(abs(weights)):", sum(abs(tmp_w)), "\n") } # end final walk towards the edges portfolio <- tmp_w @@ -541,6 +634,30 @@ return(FALSE) } +min_sum_fail <- function(weights, min_sum){ + # return FALSE if min_sum is null + if(is.null(min_sum)) return(FALSE) + + # sum of weights violate min_sum constraint + return(sum(weights) < min_sum) +} + +max_sum_fail <- function(weights, max_sum){ + # return FALSE if max_sum is null + if(is.null(max_sum)) return(FALSE) + + # sum of weights violate max_sum constraint + return(sum(weights) > max_sum) +} + +leverage_fail <- function(weights, leverage){ + # return FALSE if leverage is null + if(is.null(leverage)) return(FALSE) + + # sum of absolute value of weight violates leverage constraint + return(sum(abs(weights)) > leverage) +} + # test # w <- c(0.1, 0.25, 0.3, 0.15, 0.05, 0.15) # min <- rep(0.1, length(w)) Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-23 02:50:58 UTC (rev 3478) +++ pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-23 23:15:28 UTC (rev 3479) @@ -1,28 +1,32 @@ -rp_transform2 <- function(weights, - min_sum=NULL, - max_sum=NULL, - min_box=NULL, - max_box=NULL, - max_pos=NULL, - max_pos_long=NULL, - max_pos_short=NULL, - leverage=NULL, +rp_transform2 <- function(weights, + min_sum, + max_sum, + min_box, + max_box, + groups=NULL, + cLO=NULL, + cUP=NULL, + max_pos=NULL, + group_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=NULL, max_permutations=200){ tmp_w <- weights # Set some reasonable default values # Maybe I should leave these as NULL values and incorporate that into the # checks - if(is.null(min_sum)) min_sum <- 0.99 - if(is.null(max_sum)) max_sum <- 1.01 - if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w)) - if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w)) + #if(is.null(min_sum)) min_sum <- 0.99 + #if(is.null(max_sum)) max_sum <- 1.01 + #if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w)) + #if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w)) if(is.null(max_pos)) max_pos <- length(tmp_w) - if(is.null(max_pos)) max_pos_long <- length(tmp_w) - if(is.null(max_pos)) max_pos_short <- length(tmp_w) - if(is.null(leverage)) leverage <- Inf + #if(is.null(max_poslong)) max_pos_long <- length(tmp_w) + #if(is.null(max_pos_short)) max_pos_short <- length(tmp_w) + #if(is.null(leverage)) leverage <- Inf # Generate a weight sequence, we should check for portfolio$weight_seq weight_seq <- generatesequence(min=min(min_box), max=max(max_box), by=0.002) @@ -35,30 +39,25 @@ # while we have not reached max_permutations and the following constraints # are violated: - # - min_sum/max_sum + # - min_sum + # - max_sum # - leverage - # - max_pos + # - max_pos, max_pos_long, max_pos_short + # - group - - # Do we want to check all constraints in here? # Box constraints should be satisfied by construction so we should not need # to check those here - while (( (sum(tmp_w) < min_sum) | - (sum(tmp_w) > max_sum) | - (sum(abs(tmp_w)) > leverage) | - (sum(abs(tmp_w) > tolerance) > max_pos) ) & + while (( min_sum_fail(tmp_w, min_sum) | + max_sum_fail(tmp_w, max_sum) | + leverage_fail(tmp_w, leverage) | + pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | + any(group_fail(tmp_w, groups, cLO, cUP)) ) & (permutations < max_permutations)) { - cat("permutation #:", permutations, "\n") + # cat("permutation #:", permutations, "\n") permutations <- permutations+1 - # check our box constraints on total portfolio weight - # reduce(increase) total portfolio size till you get a match - # 1> check to see which bound you've failed on, brobably set this as a pair of while loops - # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function - # 3> check and repeat - # Reset tmp_w to original weights vector # I'm not sure we want to do this here because it puts us back to where we # started, but it seems to help with the position limit constraint @@ -77,90 +76,322 @@ # randomly permute and increase a random portfolio element if the sum of # the weights is less than min_sum # set counter to 1 for increase loop - i <- 1 - while (sum(tmp_w) <= min_sum & i <= length(tmp_w)) { - print("Entering min_sum violation loop") - - cur_index <- random_index[i] - cur_val <- tmp_w[cur_index] - tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1){ - # randomly sample one of the larger weights - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - # print(paste("new val:",tmp_w[cur_index])) - } else { - if(n_tmp_seq == 1){ - tmp_w[cur_index] <- tmp_seq - } - } - i <- i + 1 # increment our counter - } # end increase loop + # i <- 1 + # while (sum(tmp_w) < min_sum & i <= length(tmp_w)) { + # print("min_sum violation loop") + # + # cur_index <- random_index[i] + # cur_val <- tmp_w[cur_index] + # tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] + # n_tmp_seq <- length(tmp_seq) + # if(n_tmp_seq > 1){ + # # randomly sample one of the larger weights + # tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # # print(paste("new val:",tmp_w[cur_index])) + # } else { + # if(n_tmp_seq == 1){ + # tmp_w[cur_index] <- tmp_seq + # } + # } + # i <- i + 1 # increment our counter + # } # end increase loop + # min_sum violation + if(min_sum_fail(tmp_w, min_sum)){ + tmp_w <- rp_increase(weights=tmp_w, + min_sum=min_sum, + max_box=max_box, + weight_seq=weight_seq) + } + # randomly permute and decrease a random portfolio element if the sum of # the weights is greater than max_sum # set counter to 1 for decrease loop - i <- 1 - while (sum(tmp_w) >= max_sum & i <= length(tmp_w)) { - print("Entering max_sum violation loop") - - cur_index <- random_index[i] - cur_val <- tmp_w[cur_index] - tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1) { - # randomly sample one of the smaller weights - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - } else { - if(n_tmp_seq == 1){ - tmp_w[cur_index] <- tmp_seq - } - } - i <- i + 1 # increment our counter - } # end decrease loop + # i <- 1 + # while (sum(tmp_w) > max_sum & i <= length(tmp_w)) { + # print("max_sum violation loop") + # + # cur_index <- random_index[i] + # cur_val <- tmp_w[cur_index] + # tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] + # n_tmp_seq <- length(tmp_seq) + # if(n_tmp_seq > 1) { + # # randomly sample one of the smaller weights + # tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # } else { + # if(n_tmp_seq == 1){ + # tmp_w[cur_index] <- tmp_seq + # } + # } + # i <- i + 1 # increment our counter + # } # end decrease loop + # max_sum violation + if(max_sum_fail(tmp_w, max_sum)){ + tmp_w <- rp_decrease(weights=tmp_w, + max_sum=max_sum, + min_box=min_box, + weight_seq=weight_seq) + } + # set counter to 1 for leverage violation loop - i <- 1 - while (sum(abs(tmp_w)) >= leverage & i <= length(tmp_w)) { - print("Entering leverage violation loop") - # randomly permute and increae decrease a random portfolio element - # according to leverage exposure - cur_index <- random_index[i] - cur_val <- tmp_w[cur_index] - - # check the sign of the current value - if(cur_val < 0){ - # if the current value is negative, we want to increase to lower - # sum(abs(weights)) while respecting uppper bound box constraint - tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] - } else if(cur_val > 0){ - # if the current value is positive, we want to decrease to lower - # sum(abs(weights)) while respecting lower bound box constraint - tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] - } - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1) { - # randomly sample one of the weights - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - } else { - if(n_tmp_seq == 1){ - tmp_w[cur_index] <- tmp_seq + # i <- 1 + # while (sum(abs(tmp_w)) > leverage & i <= length(tmp_w)) { + # print("leverage violation loop") + # # randomly permute and increae decrease a random portfolio element + # # according to leverage exposure + # cur_index <- random_index[i] + # cur_val <- tmp_w[cur_index] + # + # # check the sign of the current value + # if(cur_val < 0){ + # # if the current value is negative, we want to increase to lower + # # sum(abs(weights)) while respecting uppper bound box constraint + # tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max_box[cur_index])] + # } else if(cur_val > 0){ + # # if the current value is positive, we want to decrease to lower + # # sum(abs(weights)) while respecting lower bound box constraint + # tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min_box[cur_index])] + # } + # n_tmp_seq <- length(tmp_seq) + # if(n_tmp_seq > 1) { + # # randomly sample one of the weights + # tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # } else { + # if(n_tmp_seq == 1){ + # tmp_w[cur_index] <- tmp_seq + # } + # } + # i <- i + 1 # increment our counter + # } # end leverage violation loop + + # leverage violation + if(leverage_fail(tmp_w, leverage)){ + tmp_w <- rp_decrease_leverage(weights=tmp_w, + max_box=max_box, + min_box=min_box, + leverage=leverage, + weight_seq=weight_seq) + } + + # set counter to 1 for position limit violation loop + # i <- 1 + # while (((sum(abs(tmp_w) > tolerance) > max_pos) | + # (sum(tmp_w >= 0) > max_pos_long) | + # (sum(tmp_w >= 0) > max_pos_long)) & + # i <= length(tmp_w)) { + # print("position limit violation loop") + # + # cur_index <- random_index[i] + # cur_val <- tmp_w[cur_index] + # + # # Check if max_pos_long is violated + # # If max_pos_long is violated, we we grab a positive weight and set it + # # to be between min_box and 0 + # if(sum(tmp_w > tolerance) > max_pos_long){ + # if(cur_val > tolerance){ + # # subset such that min_box_i <= weight_i <= 0 + # tmp_seq <- weight_seq[(weight_seq <= 0) & (weight_seq >= min_box[cur_index])] + # } + # n_tmp_seq <- length(tmp_seq) + # if(n_tmp_seq > 1){ + # tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # } else if(n_tmp_seq == 1){ + # tmp_w[cur_index] <- tmp_seq + # } + # } # end max_pos_long violation loop + # + # # Check if max_pos_short is violated + # # If max_pos_short is violated, we grab a negative weight and set it + # # to be between 0 and max_box + # if(sum(tmp_w < tolerance) > max_pos_short){ + # if(cur_val < tolerance){ + # # subset such that 0 <= weight_i <= max_box_i + # tmp_seq <- weight_seq[(weight_seq >= 0) & (weight_seq <= max_box[cur_index])] + # } + # n_tmp_seq <- length(tmp_seq) + # if(n_tmp_seq > 1){ + # tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + # } else if(n_tmp_seq == 1){ + # tmp_w[cur_index] <- tmp_seq + # } + # } # end max_pos_short violation loop + # + # i <- i + 1 # increment our counter + # } # end position limit violation loop + + # position limit violation + if(pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short)){ + tmp_w <- rp_position_limit(weights=tmp_w, + min_box=min_box, + max_box=max_box, + max_pos=max_pos, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short, + weight_seq=weight_seq) + } + + # group violation + if(any(group_fail(tmp_w, groups, cLO, cUP, group_pos))){ + n_groups <- length(groups) + for(j in 1:n_groups){ + # index of the weights vector belonging to the jth group + j_idx <- groups[[j]] + # weights of the jth group + tmp_group_w <- tmp_w[j_idx] + + # treat this as if min_sum were violated + if(sum(tmp_group_w) < cLO[j]){ + tmp_w[j_idx] <- rp_increase(weights=tmp_group_w, + min_sum=cLO[j], + max_box=max_box[j_idx], + weight_seq=weight_seq) } + + # treat this as if max_sum were violated + if(sum(tmp_group_w) > cup[j]){ + tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w, + max_sum=cUp[j], + min_box=min_box[j_idx], + weight_seq=weight_seq) + } } - i <- i + 1 # increment our counter - } # end leverage violation loop + } # end group violation loop - # set counter to 1 for position limit violation loop - i <- 1 - while (((sum(abs(tmp_w) > tolerance) > max_pos) | - (sum(tmp_w >= 0) > max_pos_long) | - (sum(tmp_w >= 0) > max_pos_long)) & - i <= length(tmp_w)) { - print("Entering position limit violation loop") - - cur_index <- random_index[i] - cur_val <- tmp_w[cur_index] - + cat("weights:", tmp_w, "\n") + #cat("sum(weights):", sum(tmp_w), "\n") + #cat("sum(abs(weights)):", sum(abs(tmp_w)), "\n") + } # end final walk towards the edges + portfolio <- tmp_w + + colnames(portfolio) <- colnames(weights) + + # checks for infeasible portfolio + # Stop execution and return an error if an infeasible portfolio is created + # This will be useful in fn_map so that we can catch the error and take + # action (try again with more permutations, relax constraints, different + # method to normalize, etc.) + if (sum(portfolio) < min_sum | sum(portfolio) > max_sum){ + portfolio <- weights + stop("Infeasible portfolio created, perhaps increase max_permutations and/or adjust your parameters.") + } + return(portfolio) +} + +rp_increase <- function(weights, min_sum, max_box, weight_seq){ + # randomly permute and increase a random portfolio element if the sum of + # the weights is less than min_sum while respecting box constraints + + if(sum(weights) >= min_sum) return(weights) + + tmp_w <- weights + n_weights <- length(weights) + # random_index <- sample(1:length(weights), max_pos) + random_index <- sample(1:n_weights, n_weights) + i <- 1 + while (sum(tmp_w) < min_sum & i <= n_weights) { + # print("min_sum violation loop") + + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + tmp_seq <- weight_seq[(weight_seq > cur_val) & (weight_seq <= max_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + # randomly sample one of the larger weights + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + i <- i + 1 # increment our counter + } # end increase loop + return(tmp_w) +} + +rp_decrease <- function(weights, max_sum, min_box, weight_seq){ + # randomly permute and decrease a random portfolio element if the sum of + # the weights is greater than max_sum while respecting box constraints + + if(sum(weights) <= max_sum) return(weights) + + tmp_w <- weights + n_weights <- length(weights) + # random_index <- sample(1:length(weights), max_pos) + random_index <- sample(1:n_weights, n_weights) + + i <- 1 + while (sum(tmp_w) > max_sum & i <= n_weights) { + # print("max_sum violation loop") + + cur_index <- random_index[i] + cur_val <- tmp_w[cur_index] + tmp_seq <- weight_seq[(weight_seq < cur_val) & (weight_seq >= min_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } + i <- i + 1 # increment our counter + } # end decrease loop + return(tmp_w) +} + +rp_decrease_leverage <- function(weights, max_box, min_box, leverage, weight_seq){ [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3479 From noreply at r-forge.r-project.org Thu Jul 24 04:42:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 24 Jul 2014 04:42:01 +0200 (CEST) Subject: [Returnanalytics-commits] r3480 - pkg/PortfolioAnalytics/sandbox Message-ID: <20140724024201.6B75E184C73@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-24 04:42:00 +0200 (Thu, 24 Jul 2014) New Revision: 3480 Added: pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R Log: fixing bugs rp_transform2 and adding test script Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-23 23:15:28 UTC (rev 3479) +++ pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-24 02:42:00 UTC (rev 3480) @@ -249,9 +249,9 @@ } # treat this as if max_sum were violated - if(sum(tmp_group_w) > cup[j]){ + if(sum(tmp_group_w) > cUP[j]){ tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w, - max_sum=cUp[j], + max_sum=cUP[j], min_box=min_box[j_idx], weight_seq=weight_seq) } @@ -399,13 +399,13 @@ if(cur_val > tolerance){ # subset such that min_box_i <= weight_i <= 0 tmp_seq <- weight_seq[(weight_seq <= 0) & (weight_seq >= min_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } } - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1){ - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - } else if(n_tmp_seq == 1){ - tmp_w[cur_index] <- tmp_seq - } } # end max_pos_long violation loop } @@ -417,13 +417,13 @@ if(cur_val < tolerance){ # subset such that 0 <= weight_i <= max_box_i tmp_seq <- weight_seq[(weight_seq >= 0) & (weight_seq <= max_box[cur_index])] + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1){ + tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] + } else if(n_tmp_seq == 1){ + tmp_w[cur_index] <- tmp_seq + } } - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1){ - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - } else if(n_tmp_seq == 1){ - tmp_w[cur_index] <- tmp_seq - } } # end max_pos_short violation loop } Added: pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R (rev 0) +++ pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R 2014-07-24 02:42:00 UTC (rev 3480) @@ -0,0 +1,168 @@ + +min_sum <- 0.99 +max_sum <- 1.01 +min_box <- rep(-0.15, length(weights)) +max_box <- rep(0.6, length(weights)) + +# violate min_sum and box constraint +weights <- c(0.2, -0.2, 0.4, 0.5) +sum(weights) + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box) + + +# violate max_sum and box constraints +weights <- c(0.35, 0.05, 0.7, 0.1) +sum(weights) + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box) + + +# violate box constraints and leverage +weights <- c(-0.45, 0.45, 0.55, 0.45) +sum(weights) +sum(abs(weights)) +leverage <- 1.6 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + leverage=leverage) + + +# violate max position limit constraint +weights <- c(0.15, 0.25, 0.4, 0.2) +sum(weights) +max_pos <- 3 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + max_pos=max_pos) + +# violate position limit constraint +weights <- c(-0.05, -0.05, 0.4, 0.7) +sum(weights) + +max_pos_short <- 1 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + max_pos_short=max_pos_short) + +# violate position limit constraint +weights <- c(-0.05, -0.05, 0.4, 0.7) +sum(weights) + +max_pos_long <- 3 +max_pos_short <- 1 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short) + + +# violate position limit constraint +weights <- c(-0.05, -0.05, 0.4, 0.7) +sum(weights) + +max_pos_long <- 3 +max_pos_short <- 1 +max_pos <- 3 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + max_pos=max_pos, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short) + +# violate position limit constraint +weights <- c(-0.25, -0.15, 0.4, 0.7) +sum(weights) +sum(abs(weights)) + +max_pos_long <- 3 +max_pos_short <- 1 +max_pos <- 3 +leverage <- 1.3 + +rp_transform2(weights=weights, + min_sum=min_sum, + max_sum=max_sum, + min_box=min_box, + max_box=max_box, + max_pos=max_pos, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short, + leverage=leverage) + +# The second group is above cUP and the fourth group is below cLO +weights <- c(0.06, 0.1, 0.07, 0.2, 0.22, 0.10, 0.05, 0.08, 0.05, 0.04, 0.03) +sum(weights[1:2]) +sum(weights[3:6]) +sum(weights[7:10]) +sum(weights[10:11]) +sum(weights) + +groups <- list(1:2, + 3:6, + 7:10, + 10:11) +# group_pos <- c(2, 3, 2, 2) +group_pos <- NULL +cLO <- c(0.05, 0.10, 0.05, 0.08) +cUP <- c(0.4, 0.55, 0.65, 0.45) +min_sum <- 0.99 +max_sum <- 1.01 +min_box <- rep(0.05, length(weights)) +max_box <- rep(0.65, length(weights)) + +group_fail(weights, groups, cLO, cUP, group_pos) + +rp_transform2(weights, min_sum, max_sum, min_box, max_box, groups, cLO, cUP) + + + +# Note that this was typically not working with max_permutations=200 +# Relax constraints or increase max_permutations + +# max_pos <- 3 +# max_pos_long <- 4 +# max_pos_short <- 4 +# leverage <- Inf +# max_permutations <- 200 +# +# rp_transform2(weights=weights, +# min_sum=min_sum, +# max_sum=max_sum, +# min_box=min_box, +# max_box=max_box, +# max_pos=max_pos, +# max_pos_long=max_pos_long, +# max_pos_short=max_pos_short, +# leverage=leverage, +# max_permutations=max_permutations) + + From noreply at r-forge.r-project.org Fri Jul 25 00:23:30 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Jul 2014 00:23:30 +0200 (CEST) Subject: [Returnanalytics-commits] r3481 - pkg/PortfolioAnalytics/sandbox Message-ID: <20140724222330.B7B9A185D26@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-25 00:23:29 +0200 (Fri, 25 Jul 2014) New Revision: 3481 Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R Log: Fixing a few bugs in rp_transform2 Modified: pkg/PortfolioAnalytics/sandbox/rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-24 02:42:00 UTC (rev 3480) +++ pkg/PortfolioAnalytics/sandbox/rp_transform2.R 2014-07-24 22:23:29 UTC (rev 3481) @@ -240,21 +240,30 @@ # weights of the jth group tmp_group_w <- tmp_w[j_idx] - # treat this as if min_sum were violated - if(sum(tmp_group_w) < cLO[j]){ - tmp_w[j_idx] <- rp_increase(weights=tmp_group_w, + # May be easier to just make a recursive call and treat each group + # as a portfolio of weight vectors + tmp_w[j_idx] <- rp_transform2(weights=tmp_group_w, min_sum=cLO[j], - max_box=max_box[j_idx], - weight_seq=weight_seq) - } + max_sum=cUP[j], + min_box=min_box[j_idx], + max_box=max_box[j_idx], + group_pos=group_pos[j]) + # treat this as if min_sum were violated + # if(sum(tmp_group_w) < cLO[j]){ + # tmp_w[j_idx] <- rp_increase(weights=tmp_group_w, + # min_sum=cLO[j], + # max_box=max_box[j_idx], + # weight_seq=weight_seq) + # } + # treat this as if max_sum were violated - if(sum(tmp_group_w) > cUP[j]){ - tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w, - max_sum=cUP[j], - min_box=min_box[j_idx], - weight_seq=weight_seq) - } + # if(sum(tmp_group_w) > cUP[j]){ + # tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w, + # max_sum=cUP[j], + # min_box=min_box[j_idx], + # weight_seq=weight_seq) + # } } } # end group violation loop @@ -353,6 +362,7 @@ cur_index <- random_index[i] cur_val <- tmp_w[cur_index] + tmp_seq <- NULL # check the sign of the current value if(cur_val < 0){ # if the current value is negative, we want to increase to lower @@ -363,7 +373,10 @@ # sum(abs(weights)) while respecting lower bound box constraint tmp_seq <- weight_seq[(weight_seq < cur_val) & (weight_seq >= min_box[cur_index])] } - n_tmp_seq <- length(tmp_seq) + # tmp_seq can be NULL if cur_val is zero + if(!is.null(tmp_seq)) + n_tmp_seq <- length(tmp_seq) + if(n_tmp_seq > 1) { # randomly sample one of the weights tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] Modified: pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R 2014-07-24 02:42:00 UTC (rev 3480) +++ pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R 2014-07-24 22:23:29 UTC (rev 3481) @@ -98,7 +98,7 @@ max_pos_long=max_pos_long, max_pos_short=max_pos_short) -# violate position limit constraint +# violate position limit and leverage constraint weights <- c(-0.25, -0.15, 0.4, 0.7) sum(weights) sum(abs(weights)) From noreply at r-forge.r-project.org Fri Jul 25 21:40:33 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Jul 2014 21:40:33 +0200 (CEST) Subject: [Returnanalytics-commits] r3482 - in pkg/PortfolioAnalytics: R man sandbox Message-ID: <20140725194034.00C2C18447B@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-25 21:40:32 +0200 (Fri, 25 Jul 2014) New Revision: 3482 Modified: pkg/PortfolioAnalytics/R/constraint_fn_map.R pkg/PortfolioAnalytics/man/fn_map.Rd pkg/PortfolioAnalytics/man/rp_transform.Rd pkg/PortfolioAnalytics/sandbox/rp_transform2.R pkg/PortfolioAnalytics/sandbox/test2_rp_transform2.R pkg/PortfolioAnalytics/sandbox/testing_fn_map.R Log: moving rp_transform into fn_map Modified: pkg/PortfolioAnalytics/R/constraint_fn_map.R =================================================================== --- pkg/PortfolioAnalytics/R/constraint_fn_map.R 2014-07-24 22:23:29 UTC (rev 3481) +++ pkg/PortfolioAnalytics/R/constraint_fn_map.R 2014-07-25 19:40:32 UTC (rev 3482) @@ -21,6 +21,7 @@ #' @param weights vector of weights #' @param portfolio object of class \code{portfolio} #' @param relax TRUE/FALSE, default FALSE. Enable constraints to be relaxed. +#' @param verbose print error messages for debuggin purposes #' @param \dots any other passthru parameters #' @return #' \itemize{ @@ -32,7 +33,7 @@ #' } #' @author Ross Bennett #' @export -fn_map <- function(weights, portfolio, relax=FALSE, ...){ +fn_map <- function(weights, portfolio, relax=FALSE, verbose=FALSE, ...){ if(!is.portfolio(portfolio)) stop("portfolio passed in is not of class 'portfolio'") nassets <- length(portfolio$assets) @@ -47,6 +48,13 @@ min_sum <- min_sum - 0.01 max_sum <- max_sum + 0.01 } + + weight_seq <- portfolio$weight_seq + if(is.null(weight_seq)){ + weight_seq <- generatesequence(min=min(constraints$min), max=max(constraints$max), by=0.002) + } + weight_seq <- as.vector(weight_seq) + min <- constraints$min max <- constraints$max groups <- constraints$groups @@ -73,6 +81,10 @@ tmp_max_pos_short <- max_pos_short tmp_leverage <- leverage + # Do we need to step through each constraint type sequentially or can we just + # call rp_transform once now that it has been modified to handle constraint + # types seperately? + # step 2: check that the vector of weights satisfies the constraints, # transform weights if constraint is violated # TRUE if the weights vector is in compliance with the constraints @@ -81,14 +93,23 @@ # check leverage constraints if(!is.null(min_sum) & !is.null(max_sum)){ if(!(sum(tmp_weights) >= min_sum & sum(tmp_weights) <= max_sum)){ + print("foo") # Try to transform only considering leverage and box constraints tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=NULL, cLO=NULL, cUP=NULL, - max_pos=NULL, group_pos=NULL, - max_pos_long=NULL, max_pos_short=NULL, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=NULL, + cLO=NULL, + cUP=NULL, + max_pos=NULL, + group_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ # Default to initial weights @@ -102,14 +123,23 @@ if(!(all(tmp_weights >= tmp_min) & all(tmp_weights <= tmp_max))){ # Try to transform only considering leverage and box constraints tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=NULL, cLO=NULL, cUP=NULL, - max_pos=NULL, group_pos=NULL, - max_pos_long=NULL, max_pos_short=NULL, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=NULL, + cLO=NULL, + cUP=NULL, + max_pos=NULL, + group_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ + if(verbose) message(tmp_weights) # Default to initial weights tmp_weights <- weights # Try to relax constraints if relax=TRUE @@ -131,12 +161,20 @@ # Now try the transformation again tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=NULL, cLO=NULL, cUP=NULL, - max_pos=NULL, group_pos=NULL, - max_pos_long=NULL, max_pos_short=NULL, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=NULL, + cLO=NULL, + cUP=NULL, + max_pos=NULL, + group_pos=NULL, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing # Default to original weights if this fails again if(inherits(tmp_weights, "try-error")) tmp_weights <- weights @@ -159,14 +197,23 @@ if(any(group_fail(tmp_weights, groups, tmp_cLO, tmp_cUP, group_pos))){ # Try to transform only considering leverage, box, and group constraints tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=NULL, group_pos=group_pos, - max_pos_long=NULL, max_pos_short=NULL, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=NULL, + group_pos=group_pos, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ + if(verbose) message(tmp_weights) # Default to initial weights tmp_weights <- weights # Try to relax constraints if relax=TRUE @@ -184,12 +231,20 @@ } # Now try the transformation again tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=NULL, group_pos=group_pos, - max_pos_long=NULL, max_pos_short=NULL, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=NULL, + group_pos=group_pos, + max_pos_long=NULL, + max_pos_short=NULL, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 @@ -211,14 +266,23 @@ if(pos_limit_fail(tmp_weights, tmp_max_pos, tmp_max_pos_long, tmp_max_pos_short)){ # Try to transform only considering leverage, box, group, and position_limit constraints tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=tmp_max_pos, group_pos=group_pos, - max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=tmp_max_pos, + group_pos=group_pos, + max_pos_long=tmp_max_pos_long, + max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ + if(verbose) message(tmp_weights) # Default to initial weights tmp_weights <- weights if(relax){ @@ -230,12 +294,20 @@ if(!is.null(tmp_max_pos_short)) tmp_max_pos_short <- min(nassets, tmp_max_pos_short + 1) # Now try the transformation again tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=tmp_max_pos, group_pos=group_pos, - max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=tmp_max_pos, + group_pos=group_pos, + max_pos_long=tmp_max_pos_long, + max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 @@ -250,14 +322,23 @@ if(sum(abs(tmp_weights)) > tmp_leverage){ # Try to transform only considering weight_sum, box, group, position_limit, and leverage exposure constraints tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=tmp_max_pos, group_pos=group_pos, - max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=tmp_max_pos, + group_pos=group_pos, + max_pos_long=tmp_max_pos_long, + max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")){ + if(verbose) message(tmp_weights) # Default to initial weights tmp_weights <- weights if(relax){ @@ -267,12 +348,20 @@ tmp_leverage <- tmp_leverage * 1.01 # Now try the transformation again tmp_weights <- try(rp_transform(w=tmp_weights, - min_sum=min_sum, max_sum=max_sum, - min=tmp_min, max=tmp_max, - groups=groups, cLO=tmp_cLO, cUP=tmp_cUP, - max_pos=tmp_max_pos, group_pos=group_pos, - max_pos_long=tmp_max_pos_long, max_pos_short=tmp_max_pos_short, - leverage=tmp_leverage, max_permutations=500), + min_sum=min_sum, + max_sum=max_sum, + min_box=tmp_min, + max_box=tmp_max, + groups=groups, + cLO=tmp_cLO, + cUP=tmp_cUP, + max_pos=tmp_max_pos, + group_pos=group_pos, + max_pos_long=tmp_max_pos_long, + max_pos_short=tmp_max_pos_short, + leverage=tmp_leverage, + weight_seq=weight_seq, + max_permutations=500), silent=TRUE) # FALSE for testing if(inherits(tmp_weights, "try-error")) tmp_weights <- weights i <- i + 1 @@ -302,15 +391,15 @@ #' to transform the weight vector if either the weight_sum (leverage) #' constraints, box constraints, group constraints, position_limit constraints, #' or leverage exposure constraints are violated. The logic from -#' \code{randomize_portfolio} is heavily utilized here with some modifications -#' to handle more complex constraints. +#' \code{randomize_portfolio} is heavily utilized here with extensions to +#' handle more complex constraints. #' The resulting weights vector might be quite different from the original weights vector. #' #' @param w weights vector to be transformed #' @param min_sum minimum sum of all asset weights, default 0.99 #' @param max_sum maximum sum of all asset weights, default 1.01 -#' @param min numeric or named vector specifying minimum weight box constraints -#' @param max numeric or named vector specifying maximum weight box constraints +#' @param min_box numeric or named vector specifying minimum weight box constraints +#' @param max_box numeric or named vector specifying maximum weight box constraints #' @param groups vector specifying the groups of the assets #' @param cLO numeric or vector specifying minimum weight group constraints #' @param cUP numeric or vector specifying minimum weight group constraints @@ -324,221 +413,158 @@ #' @author Peter Carl, Brian G. Peterson, Ross Bennett (based on an idea by Pat Burns) #' @export rp_transform <- function(w, - min_sum=0.99, - max_sum=1.01, - min, - max, - groups, - cLO, - cUP, + min_sum, + max_sum, + min_box, + max_box, + groups=NULL, + cLO=NULL, + cUP=NULL, max_pos=NULL, group_pos=NULL, max_pos_long=NULL, max_pos_short=NULL, leverage=NULL, + weight_seq=NULL, max_permutations=200){ - # Uses logic from randomize_portfolio to "normalize" a weights vector to - # satisfy min_sum and max_sum while accounting for box and group constraints - # Modified from randomize_portfolio to trigger the while loops if any weights - # violate min or max box constraints. A weights vector would not be transformed - # in randomize_portfolio if min_sum and max_sum were satisfied, but the - # min/max constraints were violated. + tmp_w <- w - # Set the tolerance to determine non-zero weights - tolerance=.Machine$double.eps^0.5 + # Set some reasonable default values + # Maybe I should leave these as NULL values and incorporate that into the + # checks + #if(is.null(min_sum)) min_sum <- 0.99 + #if(is.null(max_sum)) max_sum <- 1.01 + #if(is.null(min_box)) min_box <- rep(-Inf, length(tmp_w)) + #if(is.null(max_box)) max_box <- rep(Inf, length(tmp_w)) + if(is.null(max_pos)) max_pos <- length(tmp_w) + #if(is.null(max_poslong)) max_pos_long <- length(tmp_w) + #if(is.null(max_pos_short)) max_pos_short <- length(tmp_w) + #if(is.null(leverage)) leverage <- Inf - # Set value for max_pos if it is not specified - if(is.null(max_pos)) max_pos <- length(w) + # Generate a weight sequence, we should check for portfolio$weight_seq + if(is.null(weight_seq)) + weight_seq <- generatesequence(min=min(min_box), max=max(max_box), by=0.002) - # Set value for leverage if it is not specified - if(is.null(leverage)) leverage <- Inf + # make sure there is a 0 in weight_seq if we have a position limit constraint + if((!is.null(max_pos) | !is.null(group_pos) | !is.null(max_pos_long) | !is.null(max_pos_short)) & !is.element(0, weight_seq)) weight_seq <- c(0, weight_seq) - # Determine maximum number of non-zero weights - if(!is.null(group_pos)) { - max_group_pos <- sum(group_pos) - } else { - max_group_pos <- length(w) - } + # Tolerance for "non-zero" definition for position limit constraints + tolerance <- .Machine$double.eps^0.5 - # Set maximum number of assets based on max_pos and group_pos - max_assets <- min(max_pos, max_group_pos) - - # Create a temporary min vector that will be modified, because a feasible - # portfolio is rarely created if all(min > 0). This is due to the while - # loop that checks any(tmp_w < min). - tmp_min <- min - - # If weight_i = 0 and min_i > 0, then this will violate box constraints - # even though weight_i = 0 to satisfy position_limit constraints. Modify - # the tmp_min vector and set tmp_min_i equal to zero where weights_i = 0. - # If w is less than or equal to tolerance then it is essentially 0 - if(any(abs(w) <= tolerance)){ - if(any(tmp_min[which(abs(w) <= tolerance)] > 0)){ - tmp_min[which(abs(w) <= tolerance)] <- -tolerance - } - } - - # return w if all constraints are satisfied - if((sum(w) >= min_sum & sum(w) <= max_sum) & - (all(w >= tmp_min) & all(w <= max)) & - (all(!group_fail(w, groups, cLO, cUP, group_pos))) & - !pos_limit_fail(w, max_pos, max_pos_long, max_pos_short) & - (sum(abs(w)) <= leverage)){ - return(w) - } - - # generate a sequence of weights based on min/max box constraints - weight_seq <- generatesequence(min=min(min), max=max(max), by=0.002) - # make sure there is a 0 in weight_seq - if((!is.null(max_pos) | !is.null(group_pos) | !is.null(max_pos_long) | !is.null(max_pos_short)) & !is.element(0, weight_seq)) weight_seq <- c(0, weight_seq) - - # start the permutations counter + # initialize the outer while loop permutations <- 1 - # create a temporary weights vector that will be modified in the while loops - tmp_w <- w + # while we have not reached max_permutations and the following constraints + # are violated: + # - min_sum + # - max_sum + # - leverage + # - max_pos, max_pos_long, max_pos_short + # - group - # while any constraint is violated and we have not reached max_permutations - while ((sum(tmp_w) < min_sum | - sum(tmp_w) > max_sum | - any(tmp_w < tmp_min) | - any(tmp_w > max) | - any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | - pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | - sum(abs(w)) > leverage) & - permutations <= max_permutations) { - permutations = permutations + 1 - # check our box constraints on total portfolio weight - # reduce(increase) total portfolio size till you get a match - # 1> check to see which bound you've failed on, probably set this as a pair of while loops - # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function - # 3> check and repeat + # Do we want to check all constraints in here? + # Box constraints should be satisfied by construction so we should not need + # to check those here + while (( min_sum_fail(tmp_w, min_sum) | + max_sum_fail(tmp_w, max_sum) | + leverage_fail(tmp_w, leverage) | + pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | + any(group_fail(tmp_w, groups, cLO, cUP)) ) & + (permutations < max_permutations)) { - # reset tmp_w and tmp_min to their original values - tmp_w <- w - tmp_min <- min + # cat("permutation #:", permutations, "\n") + permutations <- permutations+1 - random_index <- sample(1:length(tmp_w), max_assets) + # Reset tmp_w to original weights vector + # I'm not sure we want to do this here because it puts us back to where we + # started, but it seems to help with the position limit constraint + # tmp_w <- weights + # Reset the random index based on the maximum position constraint + # This basically allows us to generate a portfolio of max_pos assets + # with the given constraints and then add assets with zero weight + random_index <- sample(1:length(tmp_w), max_pos) + # Get the index values that are not in random_index and set them equal to 0 full_index <- 1:length(tmp_w) not_index <- setdiff(full_index, random_index) tmp_w[not_index] <- 0 - # set some tmp_min values equal to zero so the while loops do not see a - # violation of any(tmp_w < tmp_min). This tends to force weights to 0 and - # works well for long only, but we may want to allow negative weights. - # tmp_min[not_index] <- 0 - # Only set values of tmp_min that are greater than 0 to 0 - tmp_min[not_index[which(tmp_min[not_index] > 0)]] <- 0 + # min_sum violation + if(min_sum_fail(tmp_w, min_sum)){ + tmp_w <- rp_increase(weights=tmp_w, + min_sum=min_sum, + max_box=max_box, + weight_seq=weight_seq) + } - # Transform weights to satisfy max_pos_long and max_pos_short before being - # passed into the main loops - # Both max_pos_long and max_pos_short should be specified - if(!is.null(max_pos_long)){ - pos_idx <- which(tmp_w > 0) - neg_idx <- which(tmp_w < 0) - - # Check if number of positive weights exceeds max_pos_long - if(length(pos_idx) > max_pos_long){ - # Randomly sample positive weights that cause violation of max_pos_long - # and replace with randomly sampled negative weights from weight_seq - make_neg_idx <- sample(pos_idx, length(pos_idx) - max_pos_long) - for(i in make_neg_idx){ - tmp_idx <- weight_seq[weight_seq < 0 & weight_seq >= min[i]] - if(length(tmp_idx) > 0){ - tmp_w[i] <- sample(tmp_idx, 1) - } else { - # This should never happen if the correct weight_seq and min is specified - tmp_w[i] <- -tmp_w[i] - } - } - } + # max_sum violation + if(max_sum_fail(tmp_w, max_sum)){ + tmp_w <- rp_decrease(weights=tmp_w, + max_sum=max_sum, + min_box=min_box, + weight_seq=weight_seq) } - if(!is.null(max_pos_short)){ - # Check if number of negative weights exceeds max_pos_short - if(length(neg_idx) > max_pos_short){ - # Randomly sample negative weights that cause violation of max_pos_short - # and replace with randomly sampled positive weights from weight_seq - make_pos_idx <- sample(neg_idx, length(neg_idx) - max_pos_short) - for(i in make_pos_idx){ - tmp_seq <- weight_seq[weight_seq > 0 & weight_seq <= max[i]] - if(length(tmp_seq) > 0){ - tmp_w[i] <- sample(tmp_seq, 1) - } else { - # This should never happen if the correct weight_seq and max is specified - tmp_w[i] <- -tmp_w[i] - } - } - } + + # leverage violation + if(leverage_fail(tmp_w, leverage)){ + tmp_w <- rp_decrease_leverage(weights=tmp_w, + max_box=max_box, + min_box=min_box, + leverage=leverage, + weight_seq=weight_seq) } - i = 1 - # We increase elements here if the sum of the weights exceeds max_sum or - # any of the other constraints are violated - while ((sum(tmp_w) < min_sum | - any(tmp_w < tmp_min) | - any(tmp_w > max) | - any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | - pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | - sum(abs(tmp_w)) > leverage) & - i <= length(tmp_w)) { - # randomly permute and increase a random portfolio element - cur_index <- random_index[i] - cur_val <- tmp_w[cur_index] - tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max[cur_index])] - n_tmp_seq <- length(tmp_seq) - if (n_tmp_seq > 1) { - # randomly sample an element from weight_seq that is greater than cur_val and less than max - # tmp_w[cur_index] <- sample(weight_seq[(weight_seq >= cur_val) & (weight_seq <= max[cur_index])], 1) - tmp_w[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - # print(paste("new val:",tmp_w[cur_index])) - } else { - if (n_tmp_seq == 1) { - # tmp_w[cur_index] <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max[cur_index])] - tmp_w[cur_index] <- tmp_seq - } + # position limit violation + if(pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short)){ + tmp_w <- rp_position_limit(weights=tmp_w, + min_box=min_box, + max_box=max_box, + max_pos=max_pos, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short, + weight_seq=weight_seq) + } + + # group violation + if(any(group_fail(tmp_w, groups, cLO, cUP, group_pos))){ + n_groups <- length(groups) + for(j in 1:n_groups){ + # index of the weights vector belonging to the jth group + j_idx <- groups[[j]] + # weights of the jth group + tmp_group_w <- tmp_w[j_idx] + + # May be easier to just make a recursive call and treat each group + # as a portfolio of weight vectors + tmp_w[j_idx] <- rp_transform(w=tmp_group_w, + min_sum=cLO[j], + max_sum=cUP[j], + min_box=min_box[j_idx], + max_box=max_box[j_idx], + group_pos=group_pos[j]) + + # treat this as if min_sum were violated + # if(sum(tmp_group_w) < cLO[j]){ + # tmp_w[j_idx] <- rp_increase(weights=tmp_group_w, + # min_sum=cLO[j], + # max_box=max_box[j_idx], + # weight_seq=weight_seq) + # } + + # treat this as if max_sum were violated + # if(sum(tmp_group_w) > cUP[j]){ + # tmp_w[j_idx] <- rp_decrease(weights=tmp_group_w, + # max_sum=cUP[j], + # min_box=min_box[j_idx], + # weight_seq=weight_seq) + # } } - i=i+1 # increment our counter - } # end increase loop - # need to reset i here otherwise the decreasing loop will be ignored - # group_fail does not test for direction of violation, just that group constraints were violated - i = 1 - # We decrease elements here if the sum of the weights exceeds max_sum or - # any of the other constraints are violated - while ((sum(tmp_w) > max_sum | - any(tmp_w < tmp_min) | - any(tmp_w > max) | - any(group_fail(tmp_w, groups, cLO, cUP, group_pos)) | - pos_limit_fail(tmp_w, max_pos, max_pos_long, max_pos_short) | - sum(abs(tmp_w)) > leverage) & - i <= length(tmp_w)) { - # randomly permute and decrease a random portfolio element - cur_index <- random_index[i] [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3482 From noreply at r-forge.r-project.org Fri Jul 25 22:46:27 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Jul 2014 22:46:27 +0200 (CEST) Subject: [Returnanalytics-commits] r3483 - in pkg/PortfolioAnalytics: R inst/tests man Message-ID: <20140725204628.0002E18596C@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-25 22:46:27 +0200 (Fri, 25 Jul 2014) New Revision: 3483 Added: pkg/PortfolioAnalytics/inst/tests/test_rp_sample.R Modified: pkg/PortfolioAnalytics/R/random_portfolios.R pkg/PortfolioAnalytics/man/random_portfolios.Rd Log: Modifying randomize_portfolio to use rp_transform code for handling of more complex constraints. Adding test script for rp_sample method Modified: pkg/PortfolioAnalytics/R/random_portfolios.R =================================================================== --- pkg/PortfolioAnalytics/R/random_portfolios.R 2014-07-25 19:40:32 UTC (rev 3482) +++ pkg/PortfolioAnalytics/R/random_portfolios.R 2014-07-25 20:46:27 UTC (rev 3483) @@ -237,8 +237,28 @@ weight_seq <- generatesequence(min=min(constraints$min), max=max(constraints$max), by=0.002) } weight_seq <- as.vector(weight_seq) + + # box constraints max <- constraints$max min <- constraints$min + + # If any of the constraints below do not exist in the constraints object, + # then they are NULL values which rp_transform can handle in its checks. + + # group constraints + groups <- constraints$groups + cLO <- constraints$cLO + cUP <- constraints$cUP + group_pos <- constraints$group_pos + + # position limit constraints + max_pos <- constraints$max_pos + max_pos_long <- constraints$max_pos_long + max_pos_short <- constraints$max_pos_short + + # leverage constraint + leverage <- constraints$leverage + # initial portfolio iportfolio <- as.vector(seed) rownames(iportfolio) <- NULL @@ -257,53 +277,69 @@ tportfolio[cur_index] <- sample(weight_seq[(weight_seq >= cur_val * min_mult[cur_index]) & (weight_seq <= cur_val * max_mult[cur_index]) & (weight_seq <= max[cur_index]) & (weight_seq >= min[cur_index])], 1) } - #while portfolio is outside min/max sum and we have not reached max_permutations - while ((sum(tportfolio) <= min_sum | sum(tportfolio) >= max_sum) & permutations <= max_permutations) { - permutations <- permutations+1 - # check our box constraints on total portfolio weight - # reduce(increase) total portfolio size till you get a match - # 1> check to see which bound you've failed on, brobably set this as a pair of while loops - # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function - # 3> check and repeat - random_index <- sample(1:length(tportfolio), length(tportfolio)) - i <- 1 - while (sum(tportfolio) <= min_sum & i <= length(tportfolio)) { - # randomly permute and increase a random portfolio element - cur_index <- random_index[i] - cur_val <- tportfolio[cur_index] - tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max[cur_index])] - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1){ - # randomly sample one of the larger weights - tportfolio[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - # print(paste("new val:",tportfolio[cur_index])) - } else { - if(n_tmp_seq == 1){ - tportfolio[cur_index] <- tmp_seq - } - } - i <- i + 1 # increment our counter - } # end increase loop - while (sum(tportfolio) >= max_sum & i <= length(tportfolio)) { - # randomly permute and decrease a random portfolio element - cur_index <- random_index[i] - cur_val <- tportfolio[cur_index] - tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min[cur_index])] - n_tmp_seq <- length(tmp_seq) - if(n_tmp_seq > 1) { - # randomly sample one of the smaller weights - tportfolio[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] - } else { - if(n_tmp_seq == 1){ - tportfolio[cur_index] <- tmp_seq - } - } - i <- i + 1 # increment our counter - } # end decrease loop - } # end final walk towards the edges + # random portfolios algorithm designed to handle multiple constraint types + fportfolio <- rp_transform(w=tportfolio, + min_sum=min_sum, + max_sum=max_sum, + min_box=min, + max_box=max, + groups=groups, + cLO=cLO, + cUP=cUP, + max_pos=max_pos, + group_pos=group_pos, + max_pos_long=max_pos_long, + max_pos_short=max_pos_short, + leverage=leverage, + weight_seq=weight_seq, + max_permutations=max_permutations) - # final portfolio - fportfolio <- fn_map(weights=tportfolio, portfolio=portfolio, relax=FALSE)$weights +# #while portfolio is outside min/max sum and we have not reached max_permutations +# while ((sum(tportfolio) <= min_sum | sum(tportfolio) >= max_sum) & permutations <= max_permutations) { +# permutations <- permutations+1 +# # check our box constraints on total portfolio weight +# # reduce(increase) total portfolio size till you get a match +# # 1> check to see which bound you've failed on, brobably set this as a pair of while loops +# # 2> randomly select a column and move only in the direction *towards the bound*, maybe call a function inside a function +# # 3> check and repeat +# random_index <- sample(1:length(tportfolio), length(tportfolio)) +# i <- 1 +# while (sum(tportfolio) <= min_sum & i <= length(tportfolio)) { +# # randomly permute and increase a random portfolio element +# cur_index <- random_index[i] +# cur_val <- tportfolio[cur_index] +# tmp_seq <- weight_seq[(weight_seq >= cur_val) & (weight_seq <= max[cur_index])] +# n_tmp_seq <- length(tmp_seq) +# if(n_tmp_seq > 1){ +# # randomly sample one of the larger weights +# tportfolio[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] +# # print(paste("new val:",tportfolio[cur_index])) +# } else { +# if(n_tmp_seq == 1){ +# tportfolio[cur_index] <- tmp_seq +# } +# } +# i <- i + 1 # increment our counter +# } # end increase loop +# while (sum(tportfolio) >= max_sum & i <= length(tportfolio)) { +# # randomly permute and decrease a random portfolio element +# cur_index <- random_index[i] +# cur_val <- tportfolio[cur_index] +# tmp_seq <- weight_seq[(weight_seq <= cur_val) & (weight_seq >= min[cur_index])] +# n_tmp_seq <- length(tmp_seq) +# if(n_tmp_seq > 1) { +# # randomly sample one of the smaller weights +# tportfolio[cur_index] <- tmp_seq[sample.int(n=n_tmp_seq, size=1L, replace=FALSE, prob=NULL)] +# } else { +# if(n_tmp_seq == 1){ +# tportfolio[cur_index] <- tmp_seq +# } +# } +# i <- i + 1 # increment our counter +# } # end decrease loop +# } # end final walk towards the edges +# # final portfolio +# fportfolio <- fn_map(weights=tportfolio, portfolio=portfolio, relax=FALSE)$weights colnames(fportfolio) <- colnames(seed) if (sum(fportfolio) < min_sum | sum(fportfolio) > max_sum){ @@ -333,7 +369,7 @@ #' \item{sample: }{The 'sample' method to generate random portfolios is based #' on an idea pioneerd by Pat Burns. This is the most flexible method, but #' also the slowest, and can generate portfolios to satisfy leverage, box, -#' group, and position limit constraints.} +#' group, position limit, and leverage exposure constraints.} #' \item{simplex: }{The 'simplex' method to generate random portfolios is #' based on a paper by W. T. Shaw. The simplex method is useful to generate #' random portfolios with the full investment constraint, where the sum of the @@ -351,7 +387,8 @@ #' penalized in \code{constrained_objective}.} #' } #' -#' The constraint types checked are leverage, box, group, and position limit. Any +#' The constraint types checked are leverage, box, group, position limit, and +#' leverage exposure. Any #' portfolio that does not satisfy all these constraints will be eliminated. This #' function is particularly sensitive to \code{min_sum} and \code{max_sum} #' leverage constraints. For the sample method, there should be some Added: pkg/PortfolioAnalytics/inst/tests/test_rp_sample.R =================================================================== --- pkg/PortfolioAnalytics/inst/tests/test_rp_sample.R (rev 0) +++ pkg/PortfolioAnalytics/inst/tests/test_rp_sample.R 2014-07-25 20:46:27 UTC (rev 3483) @@ -0,0 +1,65 @@ + +require(testthat) +require(PortfolioAnalytics) + +context("random portfolios sample method") + +data(edhec) +ret <- edhec[, 1:4] +funds <- colnames(ret) + +init.portf <- portfolio.spec(assets=funds) +init.portf <- add.constraint(init.portf, type="weight_sum", + min_sum=0.99, max_sum=1.01) +init.portf <- add.constraint(init.portf, type="box", + min=-0.3, max=0.65) + +# generate portfolios to satisfy weight_sum and box constraints +rp1 <- random_portfolios(init.portf, 1000, eliminate=FALSE) +test_that("we have created at least 1 feasible portfolio to satisfy weight_sum and box constraints", { + expect_that(any(apply(rp1, 1, PortfolioAnalytics:::check_constraints, portfolio=group.portf)), is_true()) +}) + +# portfolio with group constraints +group.portf <- add.constraint(init.portf, type="group", + groups=list(1:2,3:4), + group_min=c(0.08, 0.05), + group_max=c(0.55, 0.85), + group_pos=c(2,2)) + +# generate portfolios to satisfy weight_sum, box, and group constraints +rp2 <- random_portfolios(group.portf, 1000, eliminate=FALSE) +test_that("we have created at least 1 feasible portfolio to satisfy weight_sum, box, and group constraints", { + expect_that(any(apply(rp2, 1, PortfolioAnalytics:::check_constraints, portfolio=group.portf)), is_true()) +}) + +# add leverage exposure constraint +lev.portf <- add.constraint(init.portf, type="leverage_exposure", + leverage=1.6) + +# generate portfolios to satisfy weight_sum, box, and leverage constraints +rp3 <- random_portfolios(lev.portf, 1000, eliminate=FALSE) +test_that("we have created at least 1 feasible portfolio to satisfy weight_sum, box, and leverage constraints", { + expect_that(any(apply(rp3, 1, PortfolioAnalytics:::check_constraints, portfolio=group.portf)), is_true()) +}) + +# add position limit constraint +pos1.portf <- add.constraint(init.portf, type="position_limit", + max_pos=3) + +# generate portfolios to satisfy weight_sum, box, and position limit constraints +rp4 <- random_portfolios(pos1.portf, 1000, eliminate=FALSE) +test_that("we have created at least 1 feasible portfolio to satisfy weight_sum, box, and position limit constraints", { + expect_that(any(apply(rp4, 1, PortfolioAnalytics:::check_constraints, portfolio=group.portf)), is_true()) +}) + +# add position limit constraint with long and short position limits +pos2.portf <- add.constraint(init.portf, type="position_limit", + max_pos_long=3, max_pos_short=1) + +# generate portfolios to satisfy weight_sum, box, and position limit constraints +rp5 <- random_portfolios(pos2.portf, 1000, eliminate=FALSE) +test_that("we have created at least 1 feasible portfolio to satisfy weight_sum, box, and long/short position limit constraints", { + expect_that(any(apply(rp5, 1, PortfolioAnalytics:::check_constraints, portfolio=group.portf)), is_true()) +}) + Modified: pkg/PortfolioAnalytics/man/random_portfolios.Rd =================================================================== --- pkg/PortfolioAnalytics/man/random_portfolios.Rd 2014-07-25 19:40:32 UTC (rev 3482) +++ pkg/PortfolioAnalytics/man/random_portfolios.Rd 2014-07-25 20:46:27 UTC (rev 3483) @@ -31,7 +31,7 @@ \item{sample: }{The 'sample' method to generate random portfolios is based on an idea pioneerd by Pat Burns. This is the most flexible method, but also the slowest, and can generate portfolios to satisfy leverage, box, - group, and position limit constraints.} + group, position limit, and leverage exposure constraints.} \item{simplex: }{The 'simplex' method to generate random portfolios is based on a paper by W. T. Shaw. The simplex method is useful to generate random portfolios with the full investment constraint, where the sum of the @@ -49,7 +49,8 @@ penalized in \code{constrained_objective}.} } -The constraint types checked are leverage, box, group, and position limit. Any +The constraint types checked are leverage, box, group, position limit, and +leverage exposure. Any portfolio that does not satisfy all these constraints will be eliminated. This function is particularly sensitive to \code{min_sum} and \code{max_sum} leverage constraints. For the sample method, there should be some From noreply at r-forge.r-project.org Fri Jul 25 23:56:37 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 25 Jul 2014 23:56:37 +0200 (CEST) Subject: [Returnanalytics-commits] r3484 - pkg/PortfolioAnalytics/R Message-ID: <20140725215638.130291869CB@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-25 23:56:36 +0200 (Fri, 25 Jul 2014) New Revision: 3484 Modified: pkg/PortfolioAnalytics/R/optFUN.R Log: Fixing bug related to selecting default solver for max mean/sd and mean/etl optimization with ROI solvers Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2014-07-25 20:46:27 UTC (rev 3483) +++ pkg/PortfolioAnalytics/R/optFUN.R 2014-07-25 21:56:36 UTC (rev 3484) @@ -1177,13 +1177,13 @@ # Find the maximum return max_ret <- maxret_opt(R=R, moments=moments, constraints=constraints, - target=NA, solver=solver, control=control) + target=NA, solver="glpk", control=control) max_mean <- as.numeric(-max_ret$out) # Find the minimum return tmp_moments$mean <- -1 * moments$mean min_ret <- maxret_opt(R=R, moments=tmp_moments, constraints=constraints, - target=NA, solver=solver, control=control) + target=NA, solver="glpk", control=control) min_mean <- as.numeric(min_ret$out) # use optimize() to find the target return value that maximizes sharpe ratio From noreply at r-forge.r-project.org Sun Jul 27 19:47:00 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 27 Jul 2014 19:47:00 +0200 (CEST) Subject: [Returnanalytics-commits] r3485 - pkg/PerformanceAnalytics/src Message-ID: <20140727174700.A77E1184C53@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-27 19:46:59 +0200 (Sun, 27 Jul 2014) New Revision: 3485 Added: pkg/PerformanceAnalytics/src/Makevars.win Log: Adding Makevars.win file to link against BLAS and LAPACK libraries Added: pkg/PerformanceAnalytics/src/Makevars.win =================================================================== --- pkg/PerformanceAnalytics/src/Makevars.win (rev 0) +++ pkg/PerformanceAnalytics/src/Makevars.win 2014-07-27 17:46:59 UTC (rev 3485) @@ -0,0 +1 @@ +PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) \ No newline at end of file From noreply at r-forge.r-project.org Tue Jul 29 09:26:18 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Jul 2014 09:26:18 +0200 (CEST) Subject: [Returnanalytics-commits] r3486 - in pkg/FactorAnalytics: . R man Message-ID: <20140729072618.88174186858@r-forge.r-project.org> Author: pragnya Date: 2014-07-29 09:26:18 +0200 (Tue, 29 Jul 2014) New Revision: 3486 Modified: pkg/FactorAnalytics/DESCRIPTION pkg/FactorAnalytics/R/covFm.R pkg/FactorAnalytics/R/fitTsfm.R pkg/FactorAnalytics/R/fitTsfm.control.R pkg/FactorAnalytics/R/paFm.r pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/R/summary.tsfm.r pkg/FactorAnalytics/man/covFm.Rd pkg/FactorAnalytics/man/fitTsfm.Rd pkg/FactorAnalytics/man/fitTsfm.control.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd Log: Update, edit and expand plot.tsfm. Fixed a few related issues in fitTsfm Modified: pkg/FactorAnalytics/DESCRIPTION =================================================================== --- pkg/FactorAnalytics/DESCRIPTION 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/DESCRIPTION 2014-07-29 07:26:18 UTC (rev 3486) @@ -1,8 +1,8 @@ Package: factorAnalytics Type: Package Title: Factor Analytics -Version: 1.0 -Date: 2014-06-18 +Version: 2.0.0.99 +Date: 2014-07-21 Author: Eric Zivot, Yi-An Chen and Sangeetha Srinivasan Maintainer: Sangeetha Srinivasan Description: An R package for the estimation and risk analysis of linear factor @@ -21,12 +21,12 @@ leaps, lars, lmtest, - PerformanceAnalytics, + PerformanceAnalytics (>= 1.1.0), sn, tseries, strucchange, - ellipse, - doParallel + ellipse +Imports: corrplot Suggests: testthat, quantmod LazyLoad: yes Modified: pkg/FactorAnalytics/R/covFm.R =================================================================== --- pkg/FactorAnalytics/R/covFm.R 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/R/covFm.R 2014-07-29 07:26:18 UTC (rev 3486) @@ -19,7 +19,13 @@ #' where, B is the \code{N x K} matrix of factor betas and \code{D} is a #' diagonal matrix with \code{sig(i)^2} along the diagonal. #' +#' Though method for handling NAs and the method for computing covariance can +#' be specified via the \dots arguments. As a reasonable default, +#' \code{use="pairwise.complete.obs"} is used, which restricts the method to +#' "pearson". +#' #' @param object fit object of class \code{tsfm}, \code{sfm} or \code{ffm}. +#' @param ... optional arguments passed to \code{\link[stats]{cov}}. #' #' @return The computed \code{N x N} covariance matrix for asset returns based #' on the fitted factor model. @@ -72,6 +78,6 @@ #' @rdname covFm #' @export -covFm <- function(object){ +covFm <- function(object, ...){ UseMethod("covFm") } Modified: pkg/FactorAnalytics/R/fitTsfm.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.R 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/R/fitTsfm.R 2014-07-29 07:26:18 UTC (rev 3486) @@ -41,20 +41,23 @@ #' volatility, and \code{market.sqd = (Rm-Rf)^2} is added as a factor in the #' regression. Option "both" adds both of these factors. #' +#' \subsection{Data Processing}{ +#' #' Note about NAs: Before model fitting, incomplete cases are removed for #' every asset (return data combined with respective factors' return data) #' using \code{\link[stats]{na.omit}}. Otherwise, all observations in #' \code{data} are included. #' -#' Note about spaces in asset/factor names: Spaces in column names of the data -#' object will be converetd to periods as the function works with \code{xts} -#' objects internally and hence column names can't be retained as such. +#' Note about \code{asset.names} and \code{factor.names}: Spaces in column +#' names of \code{data} will be converted to periods as \code{fitTsfm} works +#' with \code{xts} objects internally and colnames won't be left as they are. +#' } #' #' @param asset.names vector containing names of assets, whose returns or #' excess returns are the dependent variable. #' @param factor.names vector containing names of the macroeconomic factors. #' @param mkt.name name of the column for market excess returns (Rm-Rf). -#' Is required only if \code{add.up.market} or \code{add.market.sqd} +#' Is required if \code{mkt.timing} or \code{add.market.sqd} #' are \code{TRUE}. Default is NULL. #' @param rf.name name of the column of risk free rate variable to calculate #' excess returns for all assets (in \code{asset.names}) and factors (in @@ -216,6 +219,8 @@ # convert data into an xts object and hereafter work with xts objects data.xts <- checkData(data) + # convert index to 'Date' format for uniformity + time(data.xts) <- as.Date(time(data.xts)) # extract columns to be used in the time series regression dat.xts <- merge(data.xts[,asset.names], data.xts[,factor.names]) @@ -233,14 +238,14 @@ # opt add mkt-timing factors: up.market=max(0,Rm-Rf), market.sqd=(Rm-Rf)^2 if (!is.null(mkt.timing)) { - if(mkt.timing=="HM" | mkt.timing=="both") { + if(mkt.timing=="HM" || mkt.timing=="both") { up.market <- data.xts[,mkt.name] up.market [up.market < 0] <- 0 dat.xts <- merge.xts(dat.xts,up.market) colnames(dat.xts)[dim(dat.xts)[2]] <- "up.market" factor.names <- c(factor.names, "up.market") } - if(mkt.timing=="TM" | mkt.timing=="both") { + if(mkt.timing=="TM" || mkt.timing=="both") { market.sqd <- data.xts[,mkt.name]^2 dat.xts <- merge(dat.xts, market.sqd) colnames(dat.xts)[dim(dat.xts)[2]] <- "market.sqd" @@ -268,7 +273,7 @@ result.lars <- SelectLars(dat.xts, asset.names, factor.names, lars.args, cv.lars.args, lars.criterion) input <- list(call=call, data=dat.xts, asset.names=asset.names, - factor.names=factor.names, fit.method=fit.method, + factor.names=factor.names, fit.method=NULL, variable.selection=variable.selection) result <- c(result.lars, input) class(result) <- "tsfm" @@ -313,9 +318,7 @@ if (fit.method == "OLS") { reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "DLS") { - if(!"weights" %in% names(lm.args)) { - lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) - } + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "Robust") { reg.list[[i]] <- do.call(lmRob, c(list(fm.formula,data=reg.xts), @@ -346,9 +349,7 @@ lm.fit <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) reg.list[[i]] <- do.call(step, c(list(lm.fit),step.args)) } else if (fit.method == "DLS") { - if(!"weights" %in% names(lm.args)) { - lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) - } + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) lm.fit <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) reg.list[[i]] <- do.call(step, c(list(lm.fit),step.args)) } else if (fit.method == "Robust") { @@ -377,7 +378,7 @@ # formula to pass to lm or lmRob fm.formula <- as.formula(paste(i," ~ .")) - if (fit.method == "DLS" && !"weights" %in% names(regsubsets.args)) { + if (fit.method=="DLS" && !"weights" %in% names(regsubsets.args)) { regsubsets.args$weights <- WeightsDLS(nrow(reg.xts), decay) } @@ -392,9 +393,7 @@ if (fit.method == "OLS") { reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "DLS") { - if(!"weights" %in% names(lm.args)) { - lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) - } + lm.args$weights <- WeightsDLS(nrow(reg.xts), decay) reg.list[[i]] <- do.call(lm, c(list(fm.formula,data=reg.xts),lm.args)) } else if (fit.method == "Robust") { reg.list[[i]] <- do.call(lmRob, c(list(fm.formula,data=reg.xts), @@ -424,38 +423,45 @@ for (i in asset.names) { # completely remove NA cases reg.xts <- na.omit(dat.xts[, c(i, factor.names)]) - # convert to matrix reg.mat <- as.matrix(reg.xts) # fit lars regression model - lars.fit <- do.call(lars, c(list(x=reg.mat[,-1],y=reg.mat[,i]),lars.args)) + lars.fit <- + do.call(lars, c(list(x=reg.mat[,factor.names],y=reg.mat[,i]),lars.args)) lars.sum <- summary(lars.fit) - cv.error <- - do.call(cv.lars, c(list(x=reg.mat[,-1],y=reg.mat[,i],plot.it=FALSE, - mode="step"),cv.lars.args)) + lars.cv <- do.call(cv.lars, c(list(x=reg.mat[,factor.names],y=reg.mat[,i], + mode="step"),cv.lars.args)) + # including plot.it=FALSE to cv.lars strangely gives an error: "Argument s + # out of range". And, specifying index=seq(nrow(lars.fit$beta)-1) resolves + # the issue, but care needs to be taken for small N # get the step that minimizes the "Cp" statistic or # the K-fold "cv" mean-squared prediction error - if (lars.criterion == "Cp") { - s <- which.min(lars.sum$Cp) + if (lars.criterion=="Cp") { + s <- which.min(lars.sum$Cp)-1 # 2nd row is "step 1" } else { - s <- which.min(cv.error$cv) + s <- which.min(lars.cv$cv)-1 } - # get factor model coefficients & fitted values at the step obtained above coef.lars <- predict(lars.fit, s=s, type="coef", mode="step") - fitted.lars <- predict(lars.fit, reg.xts[,-1], s=s, type="fit",mode="step") + fitted.lars <- predict(lars.fit, reg.mat[,factor.names], s=s, type="fit", + mode="step") fitted.list[[i]] <- xts(fitted.lars$fit, index(reg.xts)) # extract and assign the results asset.fit[[i]] = lars.fit - alpha[i] <- (fitted.lars$fit - reg.xts[,-1]%*%coef.lars$coefficients)[1] + alpha[i] <- (fitted.lars$fit - + reg.xts[,factor.names]%*%coef.lars$coefficients)[1] beta.names <- names(coef.lars$coefficients) beta[i, beta.names] <- coef.lars$coefficients - r2[i] <- lars.fit$R2[s] - resid.sd[i] <- sqrt(lars.sum$Rss[s]/(nrow(reg.xts)-s)) + r2[i] <- lars.fit$R2[s+1] + resid.sd[i] <- sqrt(lars.sum$Rss[s+1]/(nrow(reg.xts)-lars.sum$Df[s+1])) } - fitted.xts <- do.call(merge, fitted.list) + if (length(asset.names)>1) { + fitted.xts <- do.call(merge, fitted.list) + } else { + fitted.xts <- fitted.list[[1]] + } results.lars <- list(asset.fit=asset.fit, alpha=alpha, beta=beta, r2=r2, resid.sd=resid.sd, fitted=fitted.xts) # As a special case for variable.selection="lars", fitted values are also @@ -464,7 +470,8 @@ } -### calculate weights for "DLS" +### calculate exponentially decaying weights for fit.method="DLS" +## t = number of observations; d = decay factor # WeightsDLS <- function(t,d) { # more weight given to more recent observations @@ -474,6 +481,7 @@ } ### make a data frame (padded with NAs) from unequal vectors with named rows +## l = list of unequal vectors # makePaddedDataFrame <- function(l) { DF <- do.call(rbind, lapply(lapply(l, unlist), "[", @@ -491,8 +499,10 @@ #' @method coef tsfm #' @export -coef.tsfm <- function(object,...) { +coef.tsfm <- function(object, ...) { if (object$variable.selection=="lars") { + # generic method 'coef' does not exist for "lars" fit objects + # so, use cbind to form coef matrix coef.mat <- cbind(object$alpha, object$beta) colnames(coef.mat)[1] <- "(Intercept)" } else { @@ -505,18 +515,26 @@ #' @method fitted tsfm #' @export -fitted.tsfm <- function(object,...) { +fitted.tsfm <- function(object, ...) { if (object$variable.selection=="lars") { + # generic method 'fitted' does not exist for "lars" fit objects + # so, use fitted values returned by 'fitTsfm' fitted.xts <- object$fitted } else { - # get fitted values from each linear factor model fit - # and convert them into xts/zoo objects - fitted.list = sapply(object$asset.fit, - function(x) checkData(fitted(x,...))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - fitted.xts <- do.call(merge, fitted.list) + if (length(object$asset.names)>1) { + # get fitted values from each linear factor model fit + # and convert them into xts/zoo objects + fitted.list = sapply(object$asset.fit, + function(x) checkData(fitted(x,...))) + # this is a list of xts objects, indexed by the asset name + # merge the objects in the list into one xts object + fitted.xts <- do.call(merge, fitted.list) + } else { + fitted.xts <- checkData(fitted(object$asset.fit[[1]],...)) + colnames(fitted.xts) <- object$asset.names + } } + time(fitted.xts) <- as.Date(time(fitted.xts)) return(fitted.xts) } @@ -525,18 +543,26 @@ #' @method residuals tsfm #' @export -residuals.tsfm <- function(object ,...) { +residuals.tsfm <- function(object, ...) { if (object$variable.selection=="lars") { + # generic method 'residuals' does not exist for "lars" fit objects + # so, calculate them from the actual and fitted values residuals.xts <- object$data[,object$asset.names] - object$fitted } else { - # get residuals from each linear factor model fit - # and convert them into xts/zoo objects - residuals.list = sapply(object$asset.fit, - function(x) checkData(residuals(x,...))) - # this is a list of xts objects, indexed by the asset name - # merge the objects in the list into one xts object - residuals.xts <- do.call(merge, residuals.list) + if (length(object$asset.names)>1) { + # get residuals from each linear factor model fit + # and convert them into xts/zoo objects + residuals.list = sapply(object$asset.fit, + function(x) checkData(residuals(x,...))) + # this is a list of xts objects, indexed by the asset name + # merge the objects in the list into one xts object + residuals.xts <- do.call(merge, residuals.list) + } else { + residuals.xts <- checkData(residuals(object$asset.fit[[1]],...)) + colnames(residuals.xts) <- object$asset.names + } } + time(residuals.xts) <- as.Date(time(residuals.xts)) return(residuals.xts) } @@ -544,7 +570,7 @@ #' @method covFm tsfm #' @export -covFm.tsfm <- function(object) { +covFm.tsfm <- function(object, ...) { # check input object validity if (!inherits(object, c("tsfm", "sfm", "ffm"))) { @@ -555,10 +581,11 @@ beta <- as.matrix(object$beta) beta[is.na(beta)] <- 0 sig2.e = object$resid.sd^2 - factor <- as.matrix(object$data[, colnames(object$beta)]) + factor <- as.matrix(object$data[, object$factor.names]) + if (!exists("use")) {use="pairwise.complete.obs"} # factor covariance matrix - factor.cov = var(factor, use="na.or.complete") + factor.cov = cov(factor, use=use, ...) # residual covariance matrix D if (length(sig2.e) > 1) { Modified: pkg/FactorAnalytics/R/fitTsfm.control.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.control.R 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/R/fitTsfm.control.R 2014-07-29 07:26:18 UTC (rev 3486) @@ -4,18 +4,22 @@ #' All control parameters that are not passed to this function are set to #' default values. #' -#' @details This control function is primarily used to pass optional arguments -#' to \code{\link[stats]{lm}}, \code{\link[robust]{lmRob}}, +#' @details This control function is used to process optional arguments passed +#' via \code{...} to \code{fitTsfm}. These arguments are validated and defaults +#' are set if necessary before being passed internally to one of the following +#' functions: \code{\link[stats]{lm}}, \code{\link[robust]{lmRob}}, #' \code{\link[stats]{step}}, \code{\link[leaps]{regsubsets}}, -#' \code{\link[lars]{lars}} and \code{\link[lars]{cv.lars}} within -#' \code{fitTsfm}. See their respective help files for more details. The -#' arguments to each of these functions are listed approximately in the same -#' order for user convenience. +#' \code{\link[lars]{lars}} and \code{\link[lars]{cv.lars}}. See their +#' respective help files for more details. The arguments to each of these +#' functions are listed above in approximately the same order for user +#' convenience. #' #' The scalar \code{decay} is used by \code{\link{fitTsfm}} to compute -#' exponentially decaying weights for \code{fit.method="DLS"}. Optionally, one +#' exponentially decaying weights for \code{fit.method="DLS"}. Alternately, one #' can directly specify \code{weights}, a weights vector, to be used with -#' "OLS" or "Robust". +#' "OLS" or "Robust". Especially when fitting multiple assets, care should be +#' taken to ensure that the length of the weights vector matches the number of +#' observations (excluding cases ignored due to NAs). #' #' \code{lars.criterion} selects the criterion (one of "Cp" or "cv") to #' determine the best fitted model for \code{variable.selection="lars"}. The @@ -29,10 +33,9 @@ #' @param weights an optional vector of weights to be used in the fitting #' process for \code{fit.method="OLS","Robust"}, or #' \code{variable.selection="subsets"}. Should be \code{NULL} or a numeric -#' vector. If non-\code{NULL}, weighted least squares is performed with weights -#' given by \code{weights} (i.e., minimizing sum(w*e^2)). The length of -#' \code{weights} must be the same as the number of observations. The weights -#' must be nonnegative and strongly recommended to be strictly positive. +#' vector. The length of \code{weights} must be the same as the number of +#' observations. The weights must be nonnegative and it is strongly +#' recommended that they be strictly positive. #' @param model,x,y,qr logicals passed to \code{lm} for #' \code{fit.method="OLS"}. If \code{TRUE} the corresponding components of the #' fit (the model frame, the model matrix, the response, the QR decomposition) @@ -179,7 +182,6 @@ if (!is.logical(normalize) || length(normalize) != 1) { stop("Invalid argument: control parameter 'normalize' must be logical") } - lars.criterion <- lars.criterion[1] # default is "Cp" if (!(lars.criterion %in% c("Cp","cv"))) { stop("Invalid argument: lars.criterion must be 'Cp' or 'cv'.") } Modified: pkg/FactorAnalytics/R/paFm.r =================================================================== --- pkg/FactorAnalytics/R/paFm.r 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/R/paFm.r 2014-07-29 07:26:18 UTC (rev 3486) @@ -90,7 +90,7 @@ # specific returns spec.ret.xts <- actual.xts - - xts(as.matrix(fit.lm$model[, -1])%*%as.matrix(fit.lm$coef[-1]), + xts(as.matrix(fit.lm$model[, factorNames])%*%as.matrix(fit.lm$coef[-1]), dates) cum.spec.ret[k,1] <- cum.ret - Return.cumulative(actual.xts - spec.ret.xts) attr.list[[k]] <- merge(attr.ret.xts.all, spec.ret.xts) Modified: pkg/FactorAnalytics/R/plot.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-27 17:46:59 UTC (rev 3485) +++ pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-29 07:26:18 UTC (rev 3486) @@ -3,31 +3,48 @@ #' @description Generic \code{plot} method for object of class \code{tsfm}. #' Plots chosen characteristic(s) for one or more assets. #' +#' @details +#' If the plot type argument is not specified, a menu prompts for user input +#' and the corresponding plot is output. And, the menu is repeated for +#' user convenience in plotting multiple characteristics. Selecting '0' from +#' the menu exits the current \code{plot.tsfm} call. Alternately, setting +#' \code{loop=FALSE} will exit after plotting any one chosen characteristic. +#' +#' For group plots (the default), the first \code{max.show} assets are plotted. +#' For individual plots, \code{asset.name} is necessary if multiple assets +#' were modeled in \code{x} and \code{plot.single=TRUE}. However, if the +#' \code{fitTsfm} object \code{x} only contains one asset's factor model fit, +#' \code{plot.tsfm} can infer this automatically, without user input. +#' +#' CUSUM plots (individual asset plot options 10, 11 and 12) are applicable +#' only for \code{fit.method="OLS"}. +#' +#' Rolling estimates (individual asset plot option 13) is not applicable for +#' \code{variable.slection="lars"}. +#' #' @param x an object of class \code{tsfm} produced by \code{fitTsfm}. -#' @param colorset a vector of colors for the bars or bar components. Argument -#' is used by \code{\link[graphics]{barplot}}. Default is c(1:12). -#' @param legend.loc places a legend into one of nine locations on the chart: -#' bottomright, bottom, bottomleft, left, topleft, top, topright, right, or -#' center. Argument is used by -#' \code{\link[PerformanceAnalytics]{chart.TimeSeries}}. Default is \code{NULL}. -#' @param which.plot a number to indicate the type of group plot for multiple -#' assets. Default is NULL; which brings up the following menu: \cr -#' 1 = "Actual and Fitted asset returns", \cr -#' 2 = "R-squared", \cr -#' 3 = "Residual Volatility",\cr -#' 4 = "Factor Model Correlation",\cr -#' 5 = "Factors' Contribution to SD",\cr -#' 6 = "Factors' Contribution to ES",\cr -#' 7 = "Factors' Contribution to VaR" -#' @param max.show maximum number of assets in a plot. Default is 6. -#' @param plot.single a logical value. If \code{TRUE}, plots an individual -#' asset's linear factor model trait selected by \code{which.plot.single}. -#' Default is \code{FALSE}. +#' @param which.plot.group a number to indicate the type of group plot for +#' multiple assets. If \code{NULL} (default), the following menu appears: \cr +#' 1 = Factor model coefficients: Alpha, \cr +#' 2 = Factor model coefficients: Betas, \cr +#' 3 = Actual and Fitted asset returns, \cr +#' 4 = R-squared, \cr +#' 5 = Residual Volatility,\cr +#' 6 = Factor Model Residual Correlation \cr +#' 7 = Factor Model Correlation,\cr +#' 8 = Factor Contribution to SD,\cr +#' 9 = Factor Contribution to ES,\cr +#' 10 = Factor Contribution to VaR +#' @param max.show maximum number of assets in a given plot. Default is 6. +#' @param plot.single a logical value. \code{TRUE} plots the characteristics of +#' an individual asset's factor model. The type of plot is given by +#' \code{which.plot.single}. Default is \code{FALSE}. #' @param asset.name name of the individual asset to be plotted. Is necessary -#' if \code{plot.single=TRUE} +#' if multiple assets factor model fits exist in \code{x} and +#' \code{plot.single=TRUE}. #' @param which.plot.single a number to indicate the type of group plot for an -#' individual asset. Default is NULL; which brings up the following menu: \cr -#' 1 = Time series plot of actual and fitted factor returns,\cr +#' individual asset. If \code{NULL} (default), the following menu appears: \cr +#' 1 = Time series plot of actual and fitted asset returns,\cr #' 2 = Time series plot of residuals with standard error bands, \cr #' 3 = Time series plot of squared residuals, \cr #' 4 = Time series plot of absolute residuals,\cr @@ -36,19 +53,47 @@ #' 7 = SACF and PACF of absolute residuals,\cr #' 8 = Histogram of residuals with normal curve overlayed,\cr #' 9 = Normal qq-plot of residuals,\cr -#' 10= CUSUM plot of recursive residuals,\cr -#' 11= CUSUM plot of OLS residuals,\cr -#' 12= CUSUM plot of recursive estimates relative to full sample estimates,\cr -#' 13= Rolling estimates over a 24-period observation window +#' 10 = CUSUM test-Recursive residuals,\cr +#' 11 = CUSUM test-OLS residuals,\cr +#' 12 = Recursive estimates (RE) test of OLS regression coefficients,\cr +#' 13 = Rolling estimates over a 24-period observation window +#' @param colorset color palette to use for all the plots. Default is +#' \code{c(1:12)}. The 1st element will be used for individual time series +#' plots or the 1st series plotted, the 2nd element for the 2nd object in the +#' plot and so on. +#' @param legend.loc places a legend into one of nine locations on the chart: +#' "bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", +#' "right", or "center". Default is "bottomright". Use \code{legend.loc=NULL} +#' to suppress the legend. +#' @param las one of {0, 1, 2, 3} to set the direction of axis labels, same as +#' in \code{plot}. Default here is 1. #' @param VaR.method a method for computing VaR; one of "modified", "gaussian", #' "historical" or "kernel". VaR is computed using #' \code{\link[PerformanceAnalytics]{VaR}}. Default is "historical". -#' @param ... further arguments passed to or from other methods. +#' @param loop logical to indicate if the plot menu should be repeated. Default +#' is \code{TRUE}. +#' @param ... further arguments to be passed to other plotting functions. #' #' @author Eric Zivot, Yi-An Chen and Sangeetha Srinivasan #' -#' @seealso \code{\link{fitTsfm}}, \code{\link{summary.tsfm}} +#' @seealso \code{\link{fitTsfm}} and \code{\link{summary.tsfm}} for details +#' about the time series factor model fit, extractor functions and summary +#' statistics. #' +#' \code{\link[strucchange]{efp}} for CUSUM tests. +#' +#' \code{\link[xts]{plot.xts}}, +#' \code{\link[PerformanceAnalytics]{chart.TimeSeries}}, +#' \code{\link[PerformanceAnalytics]{chart.ACFplus}}, +#' \code{\link[PerformanceAnalytics]{chart.Histogram}}, +#' \code{\link[PerformanceAnalytics]{chart.QQPlot}}, +#' \code{\link[graphics]{barplot}} and +#' \code{\link[ellipse]{plotcorr}} for plotting methods used. +#' +#' \code{\link{factorModelSDDecomposition}}, +#' \code{\link{factorModelEsDecomposition}}, +#' \code{\link{factorModelVaRDecomposition}} for factor model risk measures. +#' #' @examples #' #' \dontrun{ @@ -57,7 +102,7 @@ #' fit.macro <- fitTsfm(asset.names=colnames(managers[,(1:6)]), #' factor.names=colnames(managers[,(7:8)]), #' rf.name="US 3m TR", data=managers) -#' # plot all assets and show only the first 4 assets. +#' # plot the 1st 4 assets fitted above. #' plot(fit.macro, max.show=4) #' # plot of an individual asset, "HAM1" #' plot(fit.macro, plot.single=TRUE, asset.name="HAM1") @@ -66,413 +111,398 @@ #' @method plot tsfm #' @export -plot.tsfm <- function(x, colorset=c(1:12), legend.loc=NULL, which.plot=NULL, - max.show=6, plot.single=FALSE, asset.name, - which.plot.single=NULL, VaR.method = "historical", ...){ +plot.tsfm <- function(x, which.plot.group=NULL, max.show=6, plot.single=FALSE, + asset.name, which.plot.single=NULL, colorset=(1:12), + legend.loc="bottomright", las=1, + VaR.method="historical", loop=TRUE, ...) { - # get all the arguments specified by their full names - call <- match.call() - if (plot.single==TRUE) { - if (!exists("asset.name")) { - stop("Missing input: asset.name is required if plot.single is TRUE.") + if (missing(asset.name) && length(x$asset.names)>1) { + stop("Missing input: 'asset.name' is required if plot.single is TRUE and + multiple assets factor model fits exist in 'x'.") + } else if (length(x$asset.names)==1) { + i <- x$asset.names[1] + } else { + i <- asset.name } + # extract info from the fitTsfm object + plotData <- merge.xts(x$data[,i], fitted(x)[,i]) + colnames(plotData) <- c("Actual","Fitted") + Residuals <- residuals(x)[,i] + fit <- x$asset.fit[[i]] + par(las=las) # default horizontal axis labels - # extract the lm, lmRob or lars fit object for that asset - fit.lm = x$asset.fit[[asset.name]] - - if (x$variable.selection == "none") { - - ## extract information from lm object - - factorNames = colnames(fit.lm$model)[-1] - fit.formula = as.formula(paste(asset.name,"~", paste(factorNames, collapse="+"), sep=" ")) - residuals.z = zoo(residuals(fit.lm), as.Date(names(residuals(fit.lm)))) - fitted.z = zoo(fitted(fit.lm), as.Date(names(fitted(fit.lm)))) - actual.z = zoo(fit.lm$model[,1], as.Date(rownames(fit.lm$model))) - tmp.summary = summary(fit.lm) - - + # plot selection + repeat { if (is.null(which.plot.single)) { - which.plot.single <- menu(c("Time series plot of actual and fitted values", - "time series plot of residuals with standard error bands", - "time series plot of squared residuals", - "time series plot of absolute residuals", - "SACF and PACF of residuals", - "SACF and PACF of squared residuals", - "SACF and PACF of absolute residuals", - "histogram of residuals with normal curve overlayed", - "normal qq-plot of residuals", - "CUSUM plot of recursive residuals", - "CUSUM plot of OLS residuals", - "CUSUM plot of recursive estimates relative to full sample estimates", - "rolling estimates over a 24-period observation window"), - title="\nMake a plot selection (or 0 to exit):\n") + which.plot.single <- + menu(c("Time series plot of actual and fitted asset returns", + "Time series plot of residuals with standard error bands", + "Time series plot of squared residuals", + "Time series plot of absolute residuals", + "SACF and PACF of residuals", + "SACF and PACF of squared residuals", + "SACF and PACF of absolute residuals", + "Histogram of residuals with normal curve overlayed", + "Normal qq-plot of residuals", + "CUSUM test-Recursive residuals", + "CUSUM test-OLS residuals", + "Recursive estimates (RE) test of OLS regression coefficients", + "Rolling estimates over a 24-period observation window"), + title="\nMake a plot selection (or 0 to exit):") } + par(las=las) # default horizontal axis labels + switch(which.plot.single, "1L" = { - ## time series plot of actual and fitted values - plot(actual.z, main=asset.name, ylab="Monthly performance", lwd=2, col="black") - lines(fitted.z, lwd=2, col="blue") - abline(h=0) - legend(x="bottomleft", legend=c("Actual", "Fitted"), lwd=2, col=c("black","blue")) - }, - - "2L" = { + ## time series plot of actual and fitted asset returns + chart.TimeSeries(plotData, main=paste("Returns:",i), + colorset=colorset, xlab="", + ylab="Actual and fitted asset returns", + legend.loc=legend.loc, pch=NULL, las=las, ...) + }, "2L" = { ## time series plot of residuals with standard error bands - plot(residuals.z, main=asset.name, ylab="Monthly performance", lwd=2, col="black") - abline(h=0) - abline(h=2*tmp.summary$sigma, lwd=2, lty="dotted", col="red") - abline(h=-2*tmp.summary$sigma, lwd=2, lty="dotted", col="red") - legend(x="bottomleft", legend=c("Residual", "+/ 2*SE"), lwd=2, - lty=c("solid","dotted"), col=c("black","red")) - }, - "3L" = { + if(!exists("lwd")) {lwd=2} + if(!exists("lty")) {lty="solid"} + chart.TimeSeries(Residuals, main=paste("Residuals:",i), lty=lty, + colorset=colorset, xlab="", + ylab="Residuals", lwd=lwd, las=las, ...) + abline(h=1.96*x$resid.sd[i], lwd=lwd, lty="dotted", col="red") + abline(h=-1.96*x$resid.sd[i], lwd=lwd, lty="dotted", col="red") + legend(x=legend.loc, lty=c(lty,"dotted"), + col=c(colorset[1],"red"), lwd=lwd, + legend=c("Residuals",expression("\u00b1 1.96"*sigma))) + }, "3L" = { ## time series plot of squared residuals - plot(residuals.z^2, main=asset.name, ylab="Squared residual", lwd=2, col="black") - abline(h=0) - legend(x="topleft", legend="Squared Residuals", lwd=2, col="black") - }, - "4L" = { + if (!is.null(legend.loc)) {legend.loc="topright"} + chart.TimeSeries(Residuals^2, colorset=colorset, xlab="", + ylab=" Squared Residuals", + main=paste("Squared Residuals:",i), + legend.loc=legend.loc, pch=NULL, las=las, ...) + }, "4L" = { ## time series plot of absolute residuals - plot(abs(residuals.z), main=asset.name, ylab="Absolute residual", lwd=2, col="black") - abline(h=0) - legend(x="topleft", legend="Absolute Residuals", lwd=2, col="black") - }, - "5L" = { + if (!is.null(legend.loc)) {legend.loc="topright"} + chart.TimeSeries(abs(Residuals), colorset=colorset, xlab="", + ylab="Absolute Residuals", + main=paste("Absolute Residuals:",i), + legend.loc=legend.loc, pch=NULL, las=las, ...) + }, "5L" = { [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/returnanalytics -r 3486 From noreply at r-forge.r-project.org Tue Jul 29 20:22:40 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Jul 2014 20:22:40 +0200 (CEST) Subject: [Returnanalytics-commits] r3487 - in pkg/PortfolioAnalytics: R man Message-ID: <20140729182240.6FCBC186CF0@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-29 20:22:40 +0200 (Tue, 29 Jul 2014) New Revision: 3487 Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R pkg/PortfolioAnalytics/man/optimize.portfolio.rebalancing.Rd Log: Changing argument from training_periods to rolling_window in optimize.portfolio.rebalancing Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-29 07:26:18 UTC (rev 3486) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-29 18:22:40 UTC (rev 3487) @@ -1318,7 +1318,7 @@ #' #' This function is a essentially a wrapper around \code{optimize.portfolio} #' and thus the discussion in the Details section of the -#' \code{optimize.portfolio} help file is valid here as well. +#' \code{\link{optimize.portfolio}} help file is valid here as well. #' #' This function is massively parallel and requires the 'foreach' package. It #' is suggested to register a parallel backend. @@ -1338,9 +1338,9 @@ #' \code{\link[xts]{endpoints}} for valid names. #' @param training_period an integer of the number of periods to use as #' a training data in the front of the returns data -#' @param trailing_periods an integer with the number of periods to roll over -#' (i.e. width of the moving or rolling window), the default is NULL will -#' run using the returns data from inception +#' @param rolling_window an integer of the width (i.e. number of periods) +#' of the rolling window, the default of NULL will run the optimization +#' using the data from inception. #' @return a list containing the following elements #' \itemize{ #' \item{\code{portfolio}:}{ The portfolio object.} @@ -1372,15 +1372,15 @@ #' rebalance_on="quarters", #' training_period=60) #' -#' # Monthly rebalancing with 5 year training period and 4 year trailing (moving window) +#' # Monthly rebalancing with 5 year training period and 4 year rolling window #' bt.opt2 <- optimize.portfolio.rebalancing(R, portf, #' optimize_method="ROI", #' rebalance_on="months", #' training_period=60, -#' trailing_period=48) +#' rolling_window=48) #' } #' @export -optimize.portfolio.rebalancing <- function(R, portfolio=NULL, constraints=NULL, objectives=NULL, optimize_method=c("DEoptim","random","ROI"), search_size=20000, trace=FALSE, ..., rp=NULL, rebalance_on=NULL, training_period=NULL, trailing_periods=NULL) +optimize.portfolio.rebalancing <- function(R, portfolio=NULL, constraints=NULL, objectives=NULL, optimize_method=c("DEoptim","random","ROI"), search_size=20000, trace=FALSE, ..., rp=NULL, rebalance_on=NULL, training_period=NULL, rolling_window=NULL) { stopifnot("package:foreach" %in% search() || require("foreach",quietly=TRUE)) stopifnot("package:iterators" %in% search() || require("iterators",quietly=TRUE)) @@ -1410,7 +1410,7 @@ rp=rp, rebalance_on=rebalance_on, training_period=training_period, - trailing_periods=trailing_periods) + rolling_window=rolling_window) } out <- combine.optimizations(opt.list) class(out) <- "opt.rebal.list" @@ -1442,6 +1442,14 @@ if(hasArg(message)) message=match.call(expand.dots=TRUE)$message else message=FALSE + # check for trailing_periods argument and set rolling_window equal to + # trailing_periods for backwards compatibility + if(hasArg(trailing_periods)) { + trailing_periods=match.call(expand.dots=TRUE)$trailing_periods + rolling_window <- trailing_periods + } + + # Check for constraints and objectives passed in separately outside of the portfolio object if(!is.null(constraints)){ if(inherits(constraints, "v1_constraint")){ @@ -1483,7 +1491,7 @@ } if(is.null(training_period)) {if(nrow(R)<36) training_period=nrow(R) else training_period=36} - if (is.null(trailing_periods)){ + if (is.null(rolling_window)){ # define the index endpoints of our periods ep.i<-endpoints(R,on=rebalance_on)[which(endpoints(R, on = rebalance_on)>=training_period)] # now apply optimize.portfolio to the periods, in parallel if available @@ -1495,7 +1503,7 @@ ep.i<-endpoints(R,on=rebalance_on)[which(endpoints(R, on = rebalance_on)>=training_period)] # now apply optimize.portfolio to the periods, in parallel if available out_list<-foreach(ep=iter(ep.i), .errorhandling='pass', .packages='PortfolioAnalytics') %dopar% { - optimize.portfolio(R[(ifelse(ep-trailing_periods>=1,ep-trailing_periods,1)):ep,], portfolio=portfolio, optimize_method=optimize_method, search_size=search_size, trace=trace, rp=rp, parallel=FALSE, ...=...) + optimize.portfolio(R[(ifelse(ep-rolling_window>=1,ep-rolling_window,1)):ep,], portfolio=portfolio, optimize_method=optimize_method, search_size=search_size, trace=trace, rp=rp, parallel=FALSE, ...=...) } } # out_list is a list where each element is an optimize.portfolio object Modified: pkg/PortfolioAnalytics/man/optimize.portfolio.rebalancing.Rd =================================================================== --- pkg/PortfolioAnalytics/man/optimize.portfolio.rebalancing.Rd 2014-07-29 07:26:18 UTC (rev 3486) +++ pkg/PortfolioAnalytics/man/optimize.portfolio.rebalancing.Rd 2014-07-29 18:22:40 UTC (rev 3487) @@ -12,7 +12,7 @@ optimize.portfolio.rebalancing(R, portfolio = NULL, constraints = NULL, objectives = NULL, optimize_method = c("DEoptim", "random", "ROI"), search_size = 20000, trace = FALSE, ..., rp = NULL, - rebalance_on = NULL, training_period = NULL, trailing_periods = NULL) + rebalance_on = NULL, training_period = NULL, rolling_window = NULL) } \arguments{ \item{R}{an xts, vector, matrix, data frame, timeSeries or zoo object of asset returns} @@ -41,9 +41,9 @@ \item{training_period}{an integer of the number of periods to use as a training data in the front of the returns data} -\item{trailing_periods}{an integer with the number of periods to roll over -(i.e. width of the moving or rolling window), the default is NULL will -run using the returns data from inception} +\item{rolling_window}{an integer of the width (i.e. number of periods) +of the rolling window, the default of NULL will run the optimization +using the data from inception.} } \value{ a list containing the following elements @@ -69,7 +69,7 @@ This function is a essentially a wrapper around \code{optimize.portfolio} and thus the discussion in the Details section of the -\code{optimize.portfolio} help file is valid here as well. +\code{\link{optimize.portfolio}} help file is valid here as well. This function is massively parallel and requires the 'foreach' package. It is suggested to register a parallel backend. @@ -91,12 +91,12 @@ rebalance_on="quarters", training_period=60) -# Monthly rebalancing with 5 year training period and 4 year trailing (moving window) +# Monthly rebalancing with 5 year training period and 4 year rolling window bt.opt2 <- optimize.portfolio.rebalancing(R, portf, optimize_method="ROI", rebalance_on="months", training_period=60, -trailing_period=48) +rolling_window=48) } } \author{ From noreply at r-forge.r-project.org Tue Jul 29 21:25:10 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 29 Jul 2014 21:25:10 +0200 (CEST) Subject: [Returnanalytics-commits] r3488 - pkg/PortfolioAnalytics/R Message-ID: <20140729192510.178EF186CF0@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-29 21:25:09 +0200 (Tue, 29 Jul 2014) New Revision: 3488 Modified: pkg/PortfolioAnalytics/R/generics.R Log: slimming down output of print method for portfolio objects Modified: pkg/PortfolioAnalytics/R/generics.R =================================================================== --- pkg/PortfolioAnalytics/R/generics.R 2014-07-29 18:22:40 UTC (rev 3487) +++ pkg/PortfolioAnalytics/R/generics.R 2014-07-29 19:25:09 UTC (rev 3488) @@ -156,12 +156,12 @@ cat(rep("*", 50) ,"\n", sep="") cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), - "\n", sep = "") + "\n\n", sep = "") # Assets - cat("\nAssets\n") + #cat("\nAssets\n") nassets <- length(x$assets) - cat("Number of assets:", nassets, "\n\n") + cat("Number of assets:", nassets, "\n") cat("Asset Names\n") print(head(names(x$assets), 10)) if(nassets > 10){ @@ -184,9 +184,9 @@ } # Constraints - cat("\nConstraints\n") nconstraints <- length(x$constraints) if(nconstraints > 0){ + cat("\nConstraints\n") # logical vector of enabled constraints enabled.constraints <- which(sapply(x$constraints, function(x) x$enabled)) n.enabled.constraints <- ifelse(length(enabled.constraints) > 0, length(enabled.constraints), 0) @@ -196,8 +196,8 @@ } # character vector of constraint types names.constraints <- sapply(x$constraints, function(x) x$type) - cat("Number of constraints:", nconstraints, "\n") - cat("Number of enabled constraints:", n.enabled.constraints, "\n") + #cat("Number of constraints:", nconstraints, "\n") + #cat("Number of enabled constraints:", n.enabled.constraints, "\n") if(length(enabled.constraints) > 0){ cat("Enabled constraint types\n") constraints <- x$constraints @@ -224,8 +224,9 @@ } } } - cat("Number of disabled constraints:", nconstraints - n.enabled.constraints, "\n") + if((nconstraints - n.enabled.constraints) > 0){ + #cat("Number of disabled constraints:", nconstraints - n.enabled.constraints, "\n") cat("Disabled constraint types\n") constraints <- x$constraints nconstraints <- length(constraints) @@ -253,9 +254,9 @@ } # Objectives - cat("\nObjectives\n") nobjectives <- length(x$objectives) if(nobjectives > 0){ + cat("\nObjectives:\n") # logical vector of enabled objectives enabled.objectives <- which(sapply(x$objectives, function(x) x$enabled)) n.enabled.objectives <- ifelse(length(enabled.objectives) > 0, length(enabled.objectives), 0) @@ -265,17 +266,18 @@ } # character vector of objective names names.objectives <- sapply(x$objectives, function(x) x$name) - cat("Number of objectives:", nobjectives, "\n") - cat("Number of enabled objectives:", n.enabled.objectives, "\n") + #cat("Number of objectives:", nobjectives, "\n") + #cat("Number of enabled objectives:", n.enabled.objectives, "\n") if(n.enabled.objectives > 0){ cat("Enabled objective names\n") for(name in names.objectives[enabled.objectives]) { cat("\t\t-", name, "\n") } } - cat("Number of disabled objectives:", nobjectives - n.enabled.objectives, "\n") + if((nobjectives - n.enabled.objectives) > 0){ - cat("Disabled objective types\n") + #cat("Number of disabled objectives:", nobjectives - n.enabled.objectives, "\n") + cat("Disabled objective names\n") for(name in setdiff(names.objectives, names.objectives[enabled.objectives])) { cat("\t\t-", name, "\n") } From noreply at r-forge.r-project.org Wed Jul 30 00:55:03 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 30 Jul 2014 00:55:03 +0200 (CEST) Subject: [Returnanalytics-commits] r3489 - in pkg/PortfolioAnalytics: R sandbox Message-ID: <20140729225504.1F6BE185831@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-30 00:55:01 +0200 (Wed, 30 Jul 2014) New Revision: 3489 Added: pkg/PortfolioAnalytics/sandbox/leverageQP.R Modified: pkg/PortfolioAnalytics/R/optFUN.R pkg/PortfolioAnalytics/R/optimize.portfolio.R Log: adding qp formulation for leverage constraint Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2014-07-29 19:25:09 UTC (rev 3488) +++ pkg/PortfolioAnalytics/R/optFUN.R 2014-07-29 22:55:01 UTC (rev 3489) @@ -965,6 +965,162 @@ return(out) } +##### minimize variance or maximize quadratic utility with leverage constraints ##### +#' GMV/QU QP Optimization with Turnover Constraint +#' +#' This function is called by optimize.portfolio to solve minimum variance or +#' maximum quadratic utility problems with a leverage constraint +#' +#' @param R xts object of asset returns +#' @param constraints object of constraints in the portfolio object extracted with \code{get_constraints} +#' @param moments object of moments computed based on objective functions +#' @param lambda risk_aversion parameter +#' @param target target return value +#' @param solver solver to use +#' @param control list of solver control parameters +#' @author Ross Bennett +gmv_opt_leverage <- function(R, constraints, moments, lambda, target, solver="quadprog", control=NULL){ + # function for minimum variance or max quadratic utility problems + stopifnot("package:corpcor" %in% search() || require("corpcor",quietly = TRUE)) + stopifnot("package:ROI" %in% search() || require("ROI", quietly = TRUE)) + plugin <- paste0("ROI.plugin.", solver) + stopifnot(paste0("package:", plugin) %in% search() || require(plugin, quietly=TRUE, character.only=TRUE)) + + # Check for cleaned returns in moments + if(!is.null(moments$cleanR)) R <- moments$cleanR + + # Modify the returns matrix. This is done because there are 3 sets of + # variables 1) w.initial, 2) w.buy, and 3) w.sell + R0 <- matrix(0, ncol=ncol(R), nrow=nrow(R)) + returns <- cbind(R, R0, R0) + V <- cov(returns) + + # number of assets + N <- ncol(R) + + # check for a target return constraint + if(!is.na(target)) { + # If var is the only objective specified, then moments$mean won't be calculated + if(all(moments$mean==0)){ + tmp_means <- colMeans(R) + } else { + tmp_means <- moments$mean + } + } else { + tmp_means <- rep(0, N) + target <- 0 + } + Amat <- c(tmp_means, rep(0, 2*N)) + dir <- "==" + rhs <- target + meq <- N + 1 + + # separate the weights into w, w+, and w- + # w - w+ + w- = 0 + Amat <- rbind(Amat, cbind(diag(N), -1*diag(N), diag(N))) + rhs <- c(rhs, rep(0, N)) + dir <- c(dir, rep("==", N)) + + # Amat for leverage constraints + Amat <- rbind(Amat, c(rep(0, N), rep(-1, N), rep(-1, N))) + rhs <- c(rhs, -constraints$leverage) + dir <- c(dir, ">=") + + # Amat for positive weights + Amat <- rbind(Amat, cbind(matrix(0, nrow=N, ncol=N), diag(N), matrix(0, nrow=N, ncol=N))) + rhs <- c(rhs, rep(0, N)) + dir <- c(dir, rep(">=", N)) + + # Amat for negative weights + Amat <- rbind(Amat, cbind(matrix(0, nrow=N, ncol=2*N), diag(N))) + rhs <- c(rhs, rep(0, N)) + dir <- c(dir, rep(">=", N)) + + # Amat for full investment constraint + Amat <- rbind(Amat, rbind(c(rep(1, N), rep(0,2*N)), + c(rep(-1, N), rep(0,2*N)))) + rhs <- c(rhs, constraints$min_sum, -constraints$max_sum) + dir <- c(dir, ">=", ">=") + + # Amat for lower box constraints + Amat <- rbind(Amat, cbind(diag(N), diag(0, N), diag(0, N))) + rhs <- c(rhs, constraints$min) + dir <- c(dir, rep(">=", N)) + + # Amat for upper box constraints + Amat <- rbind(Amat, cbind(-diag(N), diag(0, N), diag(0, N))) + rhs <- c(rhs, -constraints$max) + dir <- c(dir, rep(">=", N)) + + # include group constraints + if(try(!is.null(constraints$groups), silent=TRUE)){ + n.groups <- length(constraints$groups) + Amat.group <- matrix(0, nrow=n.groups, ncol=N) + zeros <- matrix(0, nrow=n.groups, ncol=N) + for(i in 1:n.groups){ + Amat.group[i, constraints$groups[[i]]] <- 1 + } + if(is.null(constraints$cLO)) cLO <- rep(-Inf, n.groups) + if(is.null(constraints$cUP)) cUP <- rep(Inf, n.groups) + Amat <- rbind(Amat, cbind(Amat.group, zeros, zeros)) + Amat <- rbind(Amat, cbind(-Amat.group, zeros, zeros)) + dir <- c(dir, rep(">=", (n.groups + n.groups))) + rhs <- c(rhs, constraints$cLO, -constraints$cUP) + } + + # Add the factor exposures to Amat, dir, and rhs + if(!is.null(constraints$B)){ + t.B <- t(constraints$B) + zeros <- matrix(0, nrow=nrow(t.B), ncol=ncol(t.B)) + Amat <- rbind(Amat, cbind(t.B, zeros, zeros)) + Amat <- rbind(Amat, cbind(-t.B, zeros, zeros)) + dir <- c(dir, rep(">=", 2 * nrow(t.B))) + rhs <- c(rhs, constraints$lower, -constraints$upper) + } + + # Remove the rows of Amat and elements of rhs.vec where rhs is Inf or -Inf + Amat <- Amat[!is.infinite(rhs), ] + rhs <- rhs[!is.infinite(rhs)] + dir <- dir[!is.infinite(rhs)] + + ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V), + L=rep(-tmp_means, 3)) + + opt.prob <- OP(objective=ROI_objective, + constraints=L_constraint(L=Amat, dir=dir, rhs=rhs)) + + roi.result <- try(ROI_solve(x=opt.prob, solver=solver, control=control), silent=TRUE) + if(inherits(roi.result, "try-error")) stop(paste("No solution found:", roi.result)) + + wts <- roi.result$solution + wts.final <- wts[1:N] + + weights <- wts.final + names(weights) <- colnames(R) + out <- list() + out$weights <- weights + out$out <- roi.result$objval + obj_vals <- list() + # Calculate the objective values here so that we can use the moments$mean + # and moments$var that might be passed in by the user. + if(!all(moments$mean == 0)){ + port.mean <- as.numeric(sum(weights * moments$mean)) + names(port.mean) <- "mean" + obj_vals[["mean"]] <- port.mean + # faster and more efficient way to compute t(w) %*% Sigma %*% w + port.sd <- sqrt(sum(crossprod(weights, moments$var) * weights)) + names(port.sd) <- "StdDev" + obj_vals[["StdDev"]] <- port.sd + } else { + # faster and more efficient way to compute t(w) %*% Sigma %*% w + port.sd <- sqrt(sum(crossprod(weights, moments$var) * weights)) + names(port.sd) <- "StdDev" + obj_vals[["StdDev"]] <- port.sd + } + out$obj_vals <- obj_vals + return(out) +} + # This function uses optimize() to find the target return value that # results in the maximum starr ratio (mean / ES). # returns the target return value Modified: pkg/PortfolioAnalytics/R/optimize.portfolio.R =================================================================== --- pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-29 19:25:09 UTC (rev 3488) +++ pkg/PortfolioAnalytics/R/optimize.portfolio.R 2014-07-29 22:55:01 UTC (rev 3489) @@ -887,11 +887,12 @@ } # Minimize variance if the only objective specified is variance # Maximize Quadratic Utility if var and mean are specified as objectives - if(!is.null(constraints$turnover_target) | !is.null(constraints$ptc)){ + if(!is.null(constraints$turnover_target) | !is.null(constraints$ptc) | !is.null(constraints$leverage)){ if(!is.null(constraints$turnover_target) & !is.null(constraints$ptc)){ warning("Turnover and proportional transaction cost constraints detected, only running optimization for turnover constraint.") constraints$ptc <- NULL } + # turnover constraint if(!is.null(constraints$turnover_target) & is.null(constraints$ptc)){ qp_result <- gmv_opt_toc(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, init_weights=portfolio$assets, solver=solver, control=control) weights <- qp_result$weights @@ -899,6 +900,7 @@ obj_vals <- qp_result$obj_vals out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=qp_result$out, call=call) } + # proportional transaction costs constraint if(!is.null(constraints$ptc) & is.null(constraints$turnover_target)){ qp_result <- gmv_opt_ptc(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, init_weights=portfolio$assets, solver=solver, control=control) weights <- qp_result$weights @@ -906,6 +908,14 @@ obj_vals <- qp_result$obj_vals out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=qp_result$out, call=call) } + # leverage constraint + if(!is.null(constraints$leverage)){ + qp_result <- gmv_opt_leverage(R=R, constraints=constraints, moments=moments, lambda=lambda, target=target, solver=solver, control=control) + weights <- qp_result$weights + # obj_vals <- constrained_objective(w=weights, R=R, portfolio, trace=TRUE, normalize=FALSE)$objective_measures + obj_vals <- qp_result$obj_vals + out <- list(weights=weights, objective_measures=obj_vals, opt_values=obj_vals, out=qp_result$out, call=call) + } } else { # if(hasArg(ef)) ef=match.call(expand.dots=TRUE)$ef else ef=FALSE if(hasArg(maxSR)) maxSR=match.call(expand.dots=TRUE)$maxSR else maxSR=FALSE Added: pkg/PortfolioAnalytics/sandbox/leverageQP.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/leverageQP.R (rev 0) +++ pkg/PortfolioAnalytics/sandbox/leverageQP.R 2014-07-29 22:55:01 UTC (rev 3489) @@ -0,0 +1,83 @@ + +# leverage constrained minimum variance QP + +library(PortfolioAnalytics) +library(corpcor) +library(quadprog) + +data(edhec) +R <- edhec[, 1:10] + +N <- ncol(R) +leverage <- 1.6 +min_sum <- 0.99 +max_sum <- 1.01 +min_box <- rep(-0.3, N) +max_box <- rep(1, N) + +R0 <- matrix(0, ncol=ncol(R), nrow=nrow(R)) +returns <- cbind(R, R0, R0) +V <- corpcor::make.positive.definite(cov(returns)) + +# separate the weights into w, w+, and w- +# w - w+ + w- = 0 +Amat <- cbind(diag(N), -diag(N), diag(N)) +rhs <- rep(0, N) + +# leverage constraint +# w+ + w- <= leverage +Amat <- rbind(Amat, c(rep(0, N), rep(-1, N), rep(-1, N))) +rhs <- c(rhs, -leverage) + +# w+ >= 0 +Amat <- rbind(Amat, cbind(diag(0, N), diag(N), diag(0, N))) +rhs <- c(rhs, rep(0, N)) + +# w- >= 0 +Amat <- rbind(Amat, cbind(diag(0, N), diag(0, N), diag(N))) +rhs <- c(rhs, rep(0, N)) + +# w^T 1 >= min_sum +Amat <- rbind(Amat, c(rep(1, N), rep(0, N), rep(0, N))) +rhs <- c(rhs, min_sum) + +# w^T 1 <= max_sum +Amat <- rbind(Amat, c(rep(-1, N), rep(0, N), rep(0, N))) +rhs <- c(rhs, -max_sum) + +# lower box constraints +Amat <- rbind(Amat, cbind(diag(N), diag(0, N), diag(0, N))) +rhs <- c(rhs, min_box) + +# upper box constraints +Amat <- rbind(Amat, cbind(-diag(N), diag(0, N), diag(0, N))) +rhs <- c(rhs, -max_box) + +sol <- solve.QP(Dmat=V, dvec=rep(0, 3*N), Amat=t(Amat), bvec=rhs, meq=N) +sol + +weights <- sol$solution[1:N] +weights +sum(weights) +sum(abs(weights)) <= leverage + + +#' This script demonstrates how to solve a constrained portfolio optimization +#' problem to minimize standard deviation. + +#' Load the package and data +library(PortfolioAnalytics) +data(edhec) +R <- edhec[, 1:10] +funds <- colnames(R) + +#' Construct initial portfolio with basic constraints. +init.portf <- portfolio.spec(assets=funds) +init.portf <- add.constraint(portfolio=init.portf, type="full_investment") +init.portf <- add.constraint(portfolio=init.portf, type="box", min=-0.3, max=1) +init.portf <- add.constraint(portfolio=init.portf, type="leverage_exposure", leverage=1.6) +init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") + +opt <- optimize.portfolio(R, init.portf, optimize_method="ROI") +opt$weights + From noreply at r-forge.r-project.org Wed Jul 30 02:15:15 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 30 Jul 2014 02:15:15 +0200 (CEST) Subject: [Returnanalytics-commits] r3490 - in pkg/FactorAnalytics: . R man Message-ID: <20140730001515.AE376185F71@r-forge.r-project.org> Author: pragnya Date: 2014-07-30 02:15:14 +0200 (Wed, 30 Jul 2014) New Revision: 3490 Modified: pkg/FactorAnalytics/DESCRIPTION pkg/FactorAnalytics/R/covFm.R pkg/FactorAnalytics/R/fitTsfm.R pkg/FactorAnalytics/R/plot.tsfm.r pkg/FactorAnalytics/man/covFm.Rd pkg/FactorAnalytics/man/fitTsfm.Rd pkg/FactorAnalytics/man/plot.tsfm.Rd Log: Edits to defaults, arguments passed to plot.tsfm, covFm Modified: pkg/FactorAnalytics/DESCRIPTION =================================================================== --- pkg/FactorAnalytics/DESCRIPTION 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/DESCRIPTION 2014-07-30 00:15:14 UTC (rev 3490) @@ -21,7 +21,7 @@ leaps, lars, lmtest, - PerformanceAnalytics (>= 1.1.0), + PerformanceAnalytics (>= 1.1.3), sn, tseries, strucchange, Modified: pkg/FactorAnalytics/R/covFm.R =================================================================== --- pkg/FactorAnalytics/R/covFm.R 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/R/covFm.R 2014-07-30 00:15:14 UTC (rev 3490) @@ -19,12 +19,16 @@ #' where, B is the \code{N x K} matrix of factor betas and \code{D} is a #' diagonal matrix with \code{sig(i)^2} along the diagonal. #' -#' Though method for handling NAs and the method for computing covariance can -#' be specified via the \dots arguments. As a reasonable default, -#' \code{use="pairwise.complete.obs"} is used, which restricts the method to -#' "pearson". +#' The method for computing covariance can be specified via the \dots +#' argument. Note that the default of \code{use="pairwise.complete.obs"} for +#' handling NAs restricts the method to "pearson". #' #' @param object fit object of class \code{tsfm}, \code{sfm} or \code{ffm}. +#' @param use an optional character string giving a method for computing +#' covariances in the presence of missing values. This must be (an +#' abbreviation of) one of the strings "everything", "all.obs", +#' "complete.obs", "na.or.complete", or "pairwise.complete.obs". Default is +#' "pairwise.complete.obs". #' @param ... optional arguments passed to \code{\link[stats]{cov}}. #' #' @return The computed \code{N x N} covariance matrix for asset returns based @@ -40,6 +44,9 @@ #' #' @seealso \code{\link{fitTsfm}}, \code{\link{fitSfm}}, \code{\link{fitFfm}} #' +#' \code{\link[stats]{cov}} for more details on arguments \code{use} and +#' \code{method}. +#' #' @examples #' \dontrun{ #' # Time Series Factor model @@ -81,3 +88,39 @@ covFm <- function(object, ...){ UseMethod("covFm") } + +#' @rdname covFm +#' @method covFm tsfm +#' @export + +covFm.tsfm <- function(object, use="pairwise.complete.obs", ...) { + + # check input object validity + if (!inherits(object, c("tsfm", "sfm", "ffm"))) { + stop("Invalid argument: Object should be of class 'tsfm', 'sfm' or 'ffm'.") + } + + # get parameters and factors from factor model + beta <- as.matrix(object$beta) + beta[is.na(beta)] <- 0 + sig2.e = object$resid.sd^2 + factor <- as.matrix(object$data[, object$factor.names]) + + # factor covariance matrix + factor.cov = cov(factor, use=use, ...) + + # residual covariance matrix D + if (length(sig2.e) > 1) { + D.e = diag(sig2.e) + } else { + D.e = as.vector(sig2.e) + } + + cov.fm = beta %*% factor.cov %*% t(beta) + D.e + + if (any(diag(chol(cov.fm))==0)) { + warning("Covariance matrix is not positive definite!") + } + + return(cov.fm) +} Modified: pkg/FactorAnalytics/R/fitTsfm.R =================================================================== --- pkg/FactorAnalytics/R/fitTsfm.R 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/R/fitTsfm.R 2014-07-30 00:15:14 UTC (rev 3490) @@ -74,7 +74,9 @@ #' @param control list of control parameters. The default is constructed by #' the function \code{\link{fitTsfm.control}}. See the documentation for #' \code{\link{fitTsfm.control}} for details. -#' @param ... arguments passed to \code{\link{fitTsfm.control}} +#' @param ... For \code{fitTsfm}: arguments passed to +#' \code{\link{fitTsfm.control}}. \cr +#' For S3 methods: further arguments passed to or from other methods #' #' @return fitTsfm returns an object of class \code{tsfm}. #' @@ -145,16 +147,13 @@ #' fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), #' factor.names=colnames(managers[,(7:9)]), #' mkt.name="SP500 TR", mkt.timing="both", data=managers) -#' # summary #' summary(fit) -#' # fitted values for all assets' returns #' fitted(fit) -#' # plot actual vs. fitted over time for HAM1 -#' # using chart.TimeSeries() function from PerformanceAnalytics package -#' dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers$HAM1)) -#' colnames(dataToPlot) <- c("Fitted","Actual") -#' chart.TimeSeries(dataToPlot, main="FM fit for HAM1", -#' colorset=c("black","blue"), legend.loc="bottomleft") +#' # plot actual returns vs. fitted factor model returns for HAM1 +#' plot(fit, plot.single=TRUE, asset.name="HAM1", which.plot.single=1, +#' loop=FALSE) +#' # group plot; type selected from menu prompt; auto-looped for multiple plots +#' # plot(fit) #' #' # example using "subsets" variable selection #' fit.sub <- fitTsfm(asset.names=colnames(managers[,(1:6)]), @@ -565,40 +564,3 @@ time(residuals.xts) <- as.Date(time(residuals.xts)) return(residuals.xts) } - -#' @rdname fitTsfm -#' @method covFm tsfm -#' @export - -covFm.tsfm <- function(object, ...) { - - # check input object validity - if (!inherits(object, c("tsfm", "sfm", "ffm"))) { - stop("Invalid argument: Object should be of class 'tsfm', 'sfm' or 'ffm'.") - } - - # get parameters and factors from factor model - beta <- as.matrix(object$beta) - beta[is.na(beta)] <- 0 - sig2.e = object$resid.sd^2 - factor <- as.matrix(object$data[, object$factor.names]) - - if (!exists("use")) {use="pairwise.complete.obs"} - # factor covariance matrix - factor.cov = cov(factor, use=use, ...) - - # residual covariance matrix D - if (length(sig2.e) > 1) { - D.e = diag(sig2.e) - } else { - D.e = as.vector(sig2.e) - } - - cov.fm = beta %*% factor.cov %*% t(beta) + D.e - - # if (any(diag(chol(cov.fm)) == 0)) { - # warning("Covariance matrix is not positive definite!") - # } - - return(cov.fm) -} Modified: pkg/FactorAnalytics/R/plot.tsfm.r =================================================================== --- pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/R/plot.tsfm.r 2014-07-30 00:15:14 UTC (rev 3490) @@ -8,7 +8,8 @@ #' and the corresponding plot is output. And, the menu is repeated for #' user convenience in plotting multiple characteristics. Selecting '0' from #' the menu exits the current \code{plot.tsfm} call. Alternately, setting -#' \code{loop=FALSE} will exit after plotting any one chosen characteristic. +#' \code{loop=FALSE} will exit after plotting any one chosen characteristic +#' without the need for menu selection. #' #' For group plots (the default), the first \code{max.show} assets are plotted. #' For individual plots, \code{asset.name} is necessary if multiple assets @@ -96,24 +97,30 @@ #' #' @examples #' -#' \dontrun{ #' # load data from the database #' data(managers) #' fit.macro <- fitTsfm(asset.names=colnames(managers[,(1:6)]), #' factor.names=colnames(managers[,(7:8)]), #' rf.name="US 3m TR", data=managers) -#' # plot the 1st 4 assets fitted above. -#' plot(fit.macro, max.show=4) -#' # plot of an individual asset, "HAM1" -#' plot(fit.macro, plot.single=TRUE, asset.name="HAM1") -#' } +#' +#' # plot the factor betas of 1st 4 assets fitted above. +#' plot(fit.macro, max.show=4, which.plot.group=2, loop=FALSE) +#' # plot the factor model return correlation, order = hierarchical clustering +#' plot(fit.macro, which.plot.group=7, loop=FALSE, order="hclust", addrect=3) #' +#' # histogram of residuals from an individual asset's factor model fit +#' plot(fit.macro, plot.single=TRUE, asset.name="HAM1", which.plot.single=8, +#' loop=FALSE) +#' +#' # group plot; type selected from menu prompt; auto-looped for multiple plots +#' # plot(fit.macro) +#' #' @method plot tsfm #' @export plot.tsfm <- function(x, which.plot.group=NULL, max.show=6, plot.single=FALSE, asset.name, which.plot.single=NULL, colorset=(1:12), - legend.loc="bottomright", las=1, + legend.loc="topleft", las=1, VaR.method="historical", loop=TRUE, ...) { if (plot.single==TRUE) { @@ -131,7 +138,6 @@ colnames(plotData) <- c("Actual","Fitted") Residuals <- residuals(x)[,i] fit <- x$asset.fit[[i]] - par(las=las) # default horizontal axis labels # plot selection repeat { @@ -164,26 +170,22 @@ legend.loc=legend.loc, pch=NULL, las=las, ...) }, "2L" = { ## time series plot of residuals with standard error bands - if(!exists("lwd")) {lwd=2} - if(!exists("lty")) {lty="solid"} - chart.TimeSeries(Residuals, main=paste("Residuals:",i), lty=lty, - colorset=colorset, xlab="", - ylab="Residuals", lwd=lwd, las=las, ...) - abline(h=1.96*x$resid.sd[i], lwd=lwd, lty="dotted", col="red") - abline(h=-1.96*x$resid.sd[i], lwd=lwd, lty="dotted", col="red") - legend(x=legend.loc, lty=c(lty,"dotted"), - col=c(colorset[1],"red"), lwd=lwd, + chart.TimeSeries(Residuals, main=paste("Residuals:",i), + colorset=colorset, xlab="", ylab="Residuals", + lwd=2, lty="solid", las=las, ...) + abline(h=1.96*x$resid.sd[i], lwd=2, lty="dotted", col="red") + abline(h=-1.96*x$resid.sd[i], lwd=2, lty="dotted", col="red") + legend(x=legend.loc, lty=c("solid","dotted"), + col=c(colorset[1],"red"), lwd=2, legend=c("Residuals",expression("\u00b1 1.96"*sigma))) }, "3L" = { ## time series plot of squared residuals - if (!is.null(legend.loc)) {legend.loc="topright"} chart.TimeSeries(Residuals^2, colorset=colorset, xlab="", ylab=" Squared Residuals", main=paste("Squared Residuals:",i), legend.loc=legend.loc, pch=NULL, las=las, ...) }, "4L" = { ## time series plot of absolute residuals - if (!is.null(legend.loc)) {legend.loc="topright"} chart.TimeSeries(abs(Residuals), colorset=colorset, xlab="", ylab="Absolute Residuals", main=paste("Absolute Residuals:",i), @@ -202,23 +204,22 @@ main=paste("SACF & PACF - Absolute Residuals:",i)) }, "8L" = { ## histogram of residuals with normal curve overlayed - if(!exists("methods")) { - methods=c("add.density","add.normal","add.rug","add.risk") - } - chart.Histogram(Residuals, methods=methods, - main=paste("Histogram of Residuals:",i), - xlab="Return residuals", colorset=colorset, ...) + methods <- c("add.density","add.normal","add.rug") + chart.Histogram(Residuals, xlab="Return residuals", + methods=methods, colorset=colorset, + main=paste("Histogram of Residuals:",i), ...) }, "9L" = { ## normal qq-plot of residuals - if(!exists("envelope")) {envelope=0.95} - chart.QQPlot(Residuals, envelope=envelope, col=colorset, + chart.QQPlot(Residuals, envelope=0.95, col=colorset, main=paste("QQ-plot of Residuals:",i), ...) + legend(x=legend.loc, col="red", lty="dotted", lwd=1, + legend=c("0.95 confidence envelope")) }, "10L" = { ## Recursive CUSUM test if (!x$fit.method=="OLS") { stop("CUSUM analysis applicable only for 'OLS' fit.method.") } - cusum.rec = efp(formula(fit), type="Rec-CUSUM", data=fit$model) + cusum.rec <- efp(formula(fit), type="Rec-CUSUM", data=fit$model) plot(cusum.rec, main=paste("Recursive CUSUM test:",i), las=las, col=colorset, ...) }, "11L" = { @@ -226,7 +227,7 @@ if (!x$fit.method=="OLS") { stop("CUSUM analysis applicable only for 'OLS' fit.method.") } - cusum.ols = efp(formula(fit), type="OLS-CUSUM", data=fit$model) + cusum.ols <- efp(formula(fit), type="OLS-CUSUM", data=fit$model) plot(cusum.ols, main=paste("OLS-based CUSUM test:",i), las=las, col=colorset, ...) }, "12L" = { @@ -234,7 +235,7 @@ if (!x$fit.method=="OLS") { stop("CUSUM analysis applicable only for 'OLS' fit.method.") } - cusum.est = efp(formula(fit), type="RE", data=fit$model) + cusum.est <- efp(formula(fit), type="RE", data=fit$model) plot(cusum.est, functional=NULL, col=colorset, las=0, main=paste("RE test (Recursive estimates test):",i), ...) }, "13L" = { @@ -243,8 +244,8 @@ rollReg <- function(data.z, formula) { coef(lm(formula, data=as.data.frame(data.z))) } - reg.z = zoo(fit$model, as.Date(rownames(fit$model))) - rollReg.z = rollapply(reg.z, FUN=rollReg, formula(fit), + reg.z <- zoo(fit$model, as.Date(rownames(fit$model))) + rollReg.z <- rollapply(reg.z, FUN=rollReg, formula(fit), width=24, by.column=FALSE, align="right") } else if (x$fit.method=="DLS") { # get decay factor @@ -259,16 +260,16 @@ rollReg.w <- function(data.z, formula, w) { coef(lm(formula, weights=w, data=as.data.frame(data.z))) } - reg.z = zoo(fit$model[-length(fit$model)], + reg.z <- zoo(fit$model[-length(fit$model)], as.Date(rownames(fit$model))) - rollReg.z = rollapply(reg.z, FUN=rollReg.w, formula(fit), w, + rollReg.z <- rollapply(reg.z, FUN=rollReg.w, formula(fit), w, width=24, by.column=FALSE, align="right") } else if (x$fit.method=="Robust") { rollReg.Rob <- function(data.z, formula) { coef(lmRob(formula=formula, data=as.data.frame(data.z))) } - reg.z = zoo(fit$model, as.Date(rownames(fit$model))) - rollReg.z = rollapply(reg.z, width=24, FUN=rollReg.Rob, + reg.z <- zoo(fit$model, as.Date(rownames(fit$model))) + rollReg.z <- rollapply(reg.z, width=24, FUN=rollReg.Rob, formula(fit), by.column=FALSE, align="right") } else if (is.null(x$fit.method)) { @@ -287,17 +288,9 @@ } } else { # start of group asset plots - # extract info from the fitTsfm object - n <- length(x$asset.names) - if (n > max.show) { - cat(paste("Displaying only the first", max.show,"assets, since the - number of assets > 'max.show' =", max.show)) - n <- max.show - } - # plot selection repeat { - if (is.null(which.plot.single)) { + if (is.null(which.plot.group)) { which.plot.group <- menu(c("Factor model coefficients: Alpha", "Factor model coefficients: Betas", @@ -318,7 +311,7 @@ "1L" = { ## Factor model coefficients: Alpha # ylab="Intercept estimate" - barplot(coef(x)[,1], main="Factor model Alpha", + barplot(coef(x)[,1], main="Factor model Alpha (Intercept)", xlab="Assets", col="darkblue", las=las, ...) abline(h=0, lwd=1, lty=1, col=1) @@ -330,8 +323,8 @@ as the number of factors > 'max.show' =", max.show)) k <- max.show } - par(mfrow=c(k/2,2)) - for (i in 2:k+1) { + par(mfrow=c(ceiling(k/2),2)) + for (i in 2:(k+1)) { main=paste("Factor Betas:", colnames(coef(x))[i]) barplot(coef(x)[,i], main=main, col="darkblue", xlab="Assets", ylab="Coefficient estimate", las=las, ...) @@ -340,11 +333,17 @@ par(mfrow=c(1,1)) }, "3L" = { ## Actual and Fitted asset returns - par(mfrow=c(n,1)) + n <- length(x$asset.names) + if (n > max.show) { + cat(paste("Displaying only the first", max.show,"assets, since the + number of assets > 'max.show' =", max.show)) + n <- max.show + } + par(mfrow=c(ceiling(n/2),2)) for (i in 1:n) { plotData <- merge.xts(x$data[,i], fitted(x)[,i]) colnames(plotData) <- c("Actual","Fitted") - main = paste("Factor model asset returns:", x$asset.names[i]) + main <- paste("Factor model asset returns:", x$asset.names[i]) chart.TimeSeries(plotData, colorset=colorset, main=main, xlab="", ylab="Actual and fitted values", legend.loc=legend.loc, pch=NULL, las=las,...) @@ -367,32 +366,29 @@ }, "6L" = { ## Factor Model Residual Correlation - cor.resid <- cor(residuals(x),use="pairwise.complete.obs") - if(!exists("order")) {order="AOE"} - corrplot::corrplot(cor.resid, order=order, ...) + cor.resid <- cor(residuals(x), use="pairwise.complete.obs") + corrplot::corrplot(cor.resid, ...) }, "7L" = { ## Factor Model Return Correlation - cov.fm<- covFm(x) - cor.fm = cov2cor(cov.fm) - if(!exists("order")) {order="AOE"} - corrplot::corrplot(cor.fm, order=order, ...) + cor.fm <- cov2cor(covFm(x)) + corrplot::corrplot(cor.fm, ...) }, # "8L" = { # ## Factor Contribution to SD -# factor.sd.decomp.list = list() +# factor.sd.decomp.list <- list() # for (i in asset.names) { # factor.sd.decomp.list[[i]] = # factorModelSdDecomposition(x$beta[i,], # cov.factors, x$resid.variance[i]) # } # # function to extract contribution to sd from list -# getCSD = function(x) { +# getCSD <- function(x) { # x$cSd.fm # } # # extract contributions to SD from list -# cr.sd = sapply(factor.sd.decomp.list, getCSD) -# rownames(cr.sd) = c(factor.names, "residual") +# cr.sd <- sapply(factor.sd.decomp.list, getCSD) +# rownames(cr.sd) <- c(factor.names, "residual") # # create stacked barchart # barplot(cr.sd, main="Factors' Contribution to SD", # legend.text=T, args.legend=list(x="topleft")) @@ -400,20 +396,20 @@ # }, # "9L"={ # ## Factor Contribution to ES -# factor.es.decomp.list = list() +# factor.es.decomp.list <- list() # if (variable.selection == "lar" || variable.selection == "lasso") { # # for (i in asset.names) { -# idx = which(!is.na(plot.data[,i])) -# alpha = x$alpha[i] -# beta = as.matrix(x$beta[i,]) -# fitted = alpha+as.matrix(plot.data[,factor.names])%*%beta -# residual = plot.data[,i]-fitted -# tmpData = cbind(coredata(plot.data[idx,i]), +# idx <- which(!is.na(plot.data[,i])) +# alpha <- x$alpha[i] +# beta <- as.matrix(x$beta[i,]) +# fitted <- alpha+as.matrix(plot.data[,factor.names])%*%beta +# residual <- plot.data[,i]-fitted +# tmpData <- cbind(coredata(plot.data[idx,i]), # coredata(plot.data[idx,factor.names]), # (residual[idx,]/sqrt(x$resid.variance[i])) ) -# colnames(tmpData)[c(1,length(tmpData))] = c(i, "residual") -# factor.es.decomp.list[[i]] = +# colnames(tmpData)[c(1,length(tmpData))] <- c(i, "residual") +# factor.es.decomp.list[[i]] <- # factorModelEsDecomposition(tmpData, # x$beta[i,], # x$resid.variance[i], tail.prob=0.05) @@ -423,12 +419,12 @@ # # for (i in asset.names) { # # check for missing values in fund data -# idx = which(!is.na(plot.data[,i])) -# tmpData = cbind(coredata(plot.data[idx,i]), +# idx <- which(!is.na(plot.data[,i])) +# tmpData <- cbind(coredata(plot.data[idx,i]), # coredata(plot.data[idx,factor.names]), # residuals(x$asset.fit[[i]])/sqrt(x$resid.variance[i])) -# colnames(tmpData)[c(1,dim(tmpData)[2])] = c(i, "residual") -# factor.es.decomp.list[[i]] = +# colnames(tmpData)[c(1,dim(tmpData)[2])] <- c(i, "residual") +# factor.es.decomp.list[[i]] <- # factorModelEsDecomposition(tmpData, # x$beta[i,], # x$resid.variance[i], tail.prob=0.05, @@ -437,32 +433,32 @@ # } # # # stacked bar charts of percent contributions to SD -# getCETL = function(x) { +# getCETL <- function(x) { # x$cES.fm # } # # report as positive number -# cr.etl = sapply(factor.es.decomp.list, getCETL) -# rownames(cr.etl) = c(factor.names, "residual") +# cr.etl <- sapply(factor.es.decomp.list, getCETL) +# rownames(cr.etl) <- c(factor.names, "residual") # barplot(cr.etl, main="Factors' Contribution to ES", # legend.text=T, args.legend=list(x="topleft")) # }, # "10L" ={ # ## Factor Contribution to VaR -# factor.VaR.decomp.list = list() +# factor.VaR.decomp.list <- list() # # if (variable.selection == "lar" || variable.selection == "lasso") { # # for (i in asset.names) { -# idx = which(!is.na(plot.data[,i])) -# alpha = x$alpha[i] -# beta = as.matrix(x$beta[i,]) -# fitted = alpha+as.matrix(plot.data[,factor.names])%*%beta -# residual = plot.data[,i]-fitted -# tmpData = cbind(coredata(plot.data[idx,i]), +# idx <- which(!is.na(plot.data[,i])) +# alpha <- x$alpha[i] +# beta <- as.matrix(x$beta[i,]) +# fitted <- alpha+as.matrix(plot.data[,factor.names])%*%beta +# residual <- plot.data[,i]-fitted +# tmpData <- cbind(coredata(plot.data[idx,i]), # coredata(plot.data[idx,factor.names]), # (residual[idx,]/sqrt(x$resid.variance[i])) ) -# colnames(tmpData)[c(1,length(tmpData))] = c(i, "residual") -# factor.VaR.decomp.list[[i]] = +# colnames(tmpData)[c(1,length(tmpData))] <- c(i, "residual") +# factor.VaR.decomp.list[[i]] <- # factorModelVaRDecomposition(tmpData, # x$beta[i,], # x$resid.variance[i], tail.prob=0.05,VaR.method=VaR.method) @@ -471,12 +467,12 @@ # } else { # for (i in asset.names) { # # check for missing values in fund data -# idx = which(!is.na(plot.data[,i])) -# tmpData = cbind(coredata(plot.data[idx,i]), +# idx <- which(!is.na(plot.data[,i])) +# tmpData <- cbind(coredata(plot.data[idx,i]), # coredata(plot.data[idx,factor.names]), # residuals(x$asset.fit[[i]])/sqrt(x$resid.variance[i])) -# colnames(tmpData)[c(1,dim(tmpData)[2])] = c(i, "residual") -# factor.VaR.decomp.list[[i]] = +# colnames(tmpData)[c(1,dim(tmpData)[2])] <- c(i, "residual") +# factor.VaR.decomp.list[[i]] <- # factorModelVaRDecomposition(tmpData, # x$beta[i,], # x$resid.variance[i], tail.prob=0.05, @@ -485,12 +481,12 @@ # } # # # stacked bar charts of percent contributions to SD -# getCVaR = function(x) { +# getCVaR <- function(x) { # x$cVaR.fm # } # # report as positive number -# cr.VaR = sapply(factor.VaR.decomp.list, getCVaR) -# rownames(cr.VaR) = c(factor.names, "residual") +# cr.VaR <- sapply(factor.VaR.decomp.list, getCVaR) +# rownames(cr.VaR) <- c(factor.names, "residual") # barplot(cr.VaR, main="Factors' Contribution to VaR", # legend.text=T, args.legend=list(x="topleft")) # }, Modified: pkg/FactorAnalytics/man/covFm.Rd =================================================================== --- pkg/FactorAnalytics/man/covFm.Rd 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/man/covFm.Rd 2014-07-30 00:15:14 UTC (rev 3490) @@ -1,13 +1,22 @@ % Generated by roxygen2 (4.0.1): do not edit by hand \name{covFm} \alias{covFm} +\alias{covFm.tsfm} \title{Covariance Matrix for assets' returns from fitted factor model.} \usage{ covFm(object, ...) + +\method{covFm}{tsfm}(object, use = "pairwise.complete.obs", ...) } \arguments{ \item{object}{fit object of class \code{tsfm}, \code{sfm} or \code{ffm}.} +\item{use}{an optional character string giving a method for computing +covariances in the presence of missing values. This must be (an +abbreviation of) one of the strings "everything", "all.obs", +"complete.obs", "na.or.complete", or "pairwise.complete.obs". Default is +"pairwise.complete.obs".} + \item{...}{optional arguments passed to \code{\link[stats]{cov}}.} } \value{ @@ -35,10 +44,9 @@ where, B is the \code{N x K} matrix of factor betas and \code{D} is a diagonal matrix with \code{sig(i)^2} along the diagonal. -Though method for handling NAs and the method for computing covariance can -be specified via the \dots arguments. As a reasonable default, -\code{use="pairwise.complete.obs"} is used, which restricts the method to -"pearson". +The method for computing covariance can be specified via the \dots +argument. Note that the default of \code{use="pairwise.complete.obs"} for +handling NAs restricts the method to "pearson". } \examples{ \dontrun{ @@ -86,5 +94,8 @@ } \seealso{ \code{\link{fitTsfm}}, \code{\link{fitSfm}}, \code{\link{fitFfm}} + +\code{\link[stats]{cov}} for more details on arguments \code{use} and +\code{method}. } Modified: pkg/FactorAnalytics/man/fitTsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/fitTsfm.Rd 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/man/fitTsfm.Rd 2014-07-30 00:15:14 UTC (rev 3490) @@ -1,7 +1,6 @@ % Generated by roxygen2 (4.0.1): do not edit by hand \name{fitTsfm} \alias{coef.tsfm} -\alias{covFm.tsfm} \alias{fitTsfm} \alias{fitted.tsfm} \alias{residuals.tsfm} @@ -17,8 +16,6 @@ \method{fitted}{tsfm}(object, ...) \method{residuals}{tsfm}(object, ...) - -\method{covFm}{tsfm}(object, ...) } \arguments{ \item{asset.names}{vector containing names of assets, whose returns or @@ -51,7 +48,9 @@ the function \code{\link{fitTsfm.control}}. See the documentation for \code{\link{fitTsfm.control}} for details.} -\item{...}{arguments passed to \code{\link{fitTsfm.control}}} +\item{...}{For \code{fitTsfm}: arguments passed to +\code{\link{fitTsfm.control}}. \cr +For S3 methods: further arguments passed to or from other methods} \item{object}{a fit object of class \code{tsfm} which is returned by \code{fitTsfm}} @@ -151,16 +150,13 @@ fit <- fitTsfm(asset.names=colnames(managers[,(1:6)]), factor.names=colnames(managers[,(7:9)]), mkt.name="SP500 TR", mkt.timing="both", data=managers) -# summary summary(fit) -# fitted values for all assets' returns fitted(fit) -# plot actual vs. fitted over time for HAM1 -# using chart.TimeSeries() function from PerformanceAnalytics package -dataToPlot <- cbind(fitted(fit$asset.fit$HAM1), na.omit(managers$HAM1)) -colnames(dataToPlot) <- c("Fitted","Actual") -chart.TimeSeries(dataToPlot, main="FM fit for HAM1", - colorset=c("black","blue"), legend.loc="bottomleft") +# plot actual returns vs. fitted factor model returns for HAM1 +plot(fit, plot.single=TRUE, asset.name="HAM1", which.plot.single=1, + loop=FALSE) +# group plot; type selected from menu prompt; auto-looped for multiple plots +# plot(fit) # example using "subsets" variable selection fit.sub <- fitTsfm(asset.names=colnames(managers[,(1:6)]), Modified: pkg/FactorAnalytics/man/plot.tsfm.Rd =================================================================== --- pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-29 22:55:01 UTC (rev 3489) +++ pkg/FactorAnalytics/man/plot.tsfm.Rd 2014-07-30 00:15:14 UTC (rev 3490) @@ -5,7 +5,7 @@ \usage{ \method{plot}{tsfm}(x, which.plot.group = NULL, max.show = 6, plot.single = FALSE, asset.name, which.plot.single = NULL, - colorset = (1:12), legend.loc = "bottomright", las = 1, + colorset = (1:12), legend.loc = "topleft", las = 1, VaR.method = "historical", loop = TRUE, ...) } \arguments{ @@ -81,7 +81,8 @@ and the corresponding plot is output. And, the menu is repeated for user convenience in plotting multiple characteristics. Selecting '0' from the menu exits the current \code{plot.tsfm} call. Alternately, setting -\code{loop=FALSE} will exit after plotting any one chosen characteristic. +\code{loop=FALSE} will exit after plotting any one chosen characteristic +without the need for menu selection. For group plots (the default), the first \code{max.show} assets are plotted. For individual plots, \code{asset.name} is necessary if multiple assets @@ -96,18 +97,24 @@ \code{variable.slection="lars"}. } \examples{ -\dontrun{ # load data from the database data(managers) fit.macro <- fitTsfm(asset.names=colnames(managers[,(1:6)]), factor.names=colnames(managers[,(7:8)]), rf.name="US 3m TR", data=managers) -# plot the 1st 4 assets fitted above. -plot(fit.macro, max.show=4) -# plot of an individual asset, "HAM1" -plot(fit.macro, plot.single=TRUE, asset.name="HAM1") + +# plot the factor betas of 1st 4 assets fitted above. +plot(fit.macro, max.show=4, which.plot.group=2, loop=FALSE) +# plot the factor model return correlation, order = hierarchical clustering +plot(fit.macro, which.plot.group=7, loop=FALSE, order="hclust", addrect=3) + +# histogram of residuals from an individual asset's factor model fit +plot(fit.macro, plot.single=TRUE, asset.name="HAM1", which.plot.single=8, + loop=FALSE) + +# group plot; type selected from menu prompt; auto-looped for multiple plots +# plot(fit.macro) } -} \author{ Eric Zivot, Yi-An Chen and Sangeetha Srinivasan } From noreply at r-forge.r-project.org Wed Jul 30 03:38:40 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 30 Jul 2014 03:38:40 +0200 (CEST) Subject: [Returnanalytics-commits] r3491 - in pkg/PortfolioAnalytics: R sandbox Message-ID: <20140730013840.6BC3A18762C@r-forge.r-project.org> Author: rossbennett34 Date: 2014-07-30 03:38:39 +0200 (Wed, 30 Jul 2014) New Revision: 3491 Modified: pkg/PortfolioAnalytics/R/optFUN.R pkg/PortfolioAnalytics/sandbox/leverageQP.R Log: revising leverage QP implementation via ROI. Still not getting same results as quadprog directly Modified: pkg/PortfolioAnalytics/R/optFUN.R =================================================================== --- pkg/PortfolioAnalytics/R/optFUN.R 2014-07-30 00:15:14 UTC (rev 3490) +++ pkg/PortfolioAnalytics/R/optFUN.R 2014-07-30 01:38:39 UTC (rev 3491) @@ -1013,7 +1013,7 @@ Amat <- c(tmp_means, rep(0, 2*N)) dir <- "==" rhs <- target - meq <- N + 1 + # meq <- N + 1 # separate the weights into w, w+, and w- # w - w+ + w- = 0 Modified: pkg/PortfolioAnalytics/sandbox/leverageQP.R =================================================================== --- pkg/PortfolioAnalytics/sandbox/leverageQP.R 2014-07-30 00:15:14 UTC (rev 3490) +++ pkg/PortfolioAnalytics/sandbox/leverageQP.R 2014-07-30 01:38:39 UTC (rev 3491) @@ -6,7 +6,7 @@ library(quadprog) data(edhec) -R <- edhec[, 1:10] +R <- edhec[, 1:4] N <- ncol(R) leverage <- 1.6 @@ -14,6 +14,7 @@ max_sum <- 1.01 min_box <- rep(-0.3, N) max_box <- rep(1, N) +lambda <- 1 R0 <- matrix(0, ncol=ncol(R), nrow=nrow(R)) returns <- cbind(R, R0, R0) @@ -23,61 +24,78 @@ # w - w+ + w- = 0 Amat <- cbind(diag(N), -diag(N), diag(N)) rhs <- rep(0, N) +dir <- rep("==", N) # leverage constraint # w+ + w- <= leverage Amat <- rbind(Amat, c(rep(0, N), rep(-1, N), rep(-1, N))) rhs <- c(rhs, -leverage) +dir <- c(dir, ">=") # w+ >= 0 Amat <- rbind(Amat, cbind(diag(0, N), diag(N), diag(0, N))) rhs <- c(rhs, rep(0, N)) +dir <- c(dir, rep(">=", N)) # w- >= 0 Amat <- rbind(Amat, cbind(diag(0, N), diag(0, N), diag(N))) rhs <- c(rhs, rep(0, N)) +dir <- c(dir, rep(">=", N)) # w^T 1 >= min_sum Amat <- rbind(Amat, c(rep(1, N), rep(0, N), rep(0, N))) rhs <- c(rhs, min_sum) +dir <- c(dir, ">=") # w^T 1 <= max_sum Amat <- rbind(Amat, c(rep(-1, N), rep(0, N), rep(0, N))) rhs <- c(rhs, -max_sum) +dir <- c(dir, ">=") # lower box constraints Amat <- rbind(Amat, cbind(diag(N), diag(0, N), diag(0, N))) rhs <- c(rhs, min_box) +dir <- c(dir, rep(">=", N)) # upper box constraints Amat <- rbind(Amat, cbind(-diag(N), diag(0, N), diag(0, N))) rhs <- c(rhs, -max_box) +dir <- c(dir, rep(">=", N)) sol <- solve.QP(Dmat=V, dvec=rep(0, 3*N), Amat=t(Amat), bvec=rhs, meq=N) sol weights <- sol$solution[1:N] -weights +round(weights, 4) sum(weights) sum(abs(weights)) <= leverage +##### ROI ##### +ROI_objective <- Q_objective(Q=make.positive.definite(2*lambda*V), + L=rep(0, N*3)) -#' This script demonstrates how to solve a constrained portfolio optimization -#' problem to minimize standard deviation. +opt.prob <- OP(objective=ROI_objective, + constraints=L_constraint(L=Amat, dir=dir, rhs=rhs)) -#' Load the package and data -library(PortfolioAnalytics) -data(edhec) -R <- edhec[, 1:10] -funds <- colnames(R) +roi.result <- ROI_solve(x=opt.prob, solver="quadprog") +wts <- roi.result$solution[1:N] +round(wts, 4) +sum(wts) +sum(abs(wts)) <= leverage -#' Construct initial portfolio with basic constraints. -init.portf <- portfolio.spec(assets=funds) -init.portf <- add.constraint(portfolio=init.portf, type="full_investment") -init.portf <- add.constraint(portfolio=init.portf, type="box", min=-0.3, max=1) -init.portf <- add.constraint(portfolio=init.portf, type="leverage_exposure", leverage=1.6) -init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") +# The quadprog and ROI solution should result in the same solution using the +# same Amat, dir, and rhs objects +all.equal(weights, wts) -opt <- optimize.portfolio(R, init.portf, optimize_method="ROI") -opt$weights +# Load the package and data +# funds <- colnames(R) +# Construct initial portfolio with basic constraints. +# init.portf <- portfolio.spec(assets=funds) +# init.portf <- add.constraint(portfolio=init.portf, type="full_investment") +# init.portf <- add.constraint(portfolio=init.portf, type="box", min=-0.3, max=1) +# init.portf <- add.constraint(portfolio=init.portf, type="leverage_exposure", leverage=1.6) +# init.portf <- add.objective(portfolio=init.portf, type="risk", name="StdDev") +# +# opt <- optimize.portfolio(R, init.portf, optimize_method="ROI") +# round(opt$weights, 4) From noreply at r-forge.r-project.org Wed Jul 30 08:08:11 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 30 Jul 2014 08:08:11 +0200 (CEST) Subject: [Returnanalytics-commits] r3492 - pkg/FactorAnalytics Message-ID: <20140730060811.BBE85187632@r-forge.r-project.org> Author: pragnya Date: 2014-07-30 08:08:10 +0200 (Wed, 30 Jul 2014) New Revision: 3492 Modified: pkg/FactorAnalytics/DESCRIPTION Log: Changed PerformanceAnalytics version to stable release 1.1.1 Modified: pkg/FactorAnalytics/DESCRIPTION =================================================================== --- pkg/FactorAnalytics/DESCRIPTION 2014-07-30 01:38:39 UTC (rev 3491) +++ pkg/FactorAnalytics/DESCRIPTION 2014-07-30 06:08:10 UTC (rev 3492) @@ -21,7 +21,7 @@ leaps, lars, lmtest, - PerformanceAnalytics (>= 1.1.3), + PerformanceAnalytics (>= 1.1.1), sn, tseries, strucchange, From noreply at r-forge.r-project.org Wed Jul 30 19:52:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 30 Jul 2014 19:52:41 +0200 (CEST) Subject: [Returnanalytics-commits] r3493 - pkg/FactorAnalytics Message-ID: <20140730175241.50798186D97@r-forge.r-project.org> Author: pragnya Date: 2014-07-30 19:52:41 +0200 (Wed, 30 Jul 2014) New Revision: 3493 Modified: pkg/FactorAnalytics/DESCRIPTION Log: PerformanceAnalytics version changed back to 1.1.0 Modified: pkg/FactorAnalytics/DESCRIPTION =================================================================== --- pkg/FactorAnalytics/DESCRIPTION 2014-07-30 06:08:10 UTC (rev 3492) +++ pkg/FactorAnalytics/DESCRIPTION 2014-07-30 17:52:41 UTC (rev 3493) @@ -2,7 +2,7 @@ Type: Package Title: Factor Analytics Version: 2.0.0.99 -Date: 2014-07-21 +Date: 2014-07-30 Author: Eric Zivot, Yi-An Chen and Sangeetha Srinivasan Maintainer: Sangeetha Srinivasan Description: An R package for the estimation and risk analysis of linear factor @@ -21,7 +21,7 @@ leaps, lars, lmtest, - PerformanceAnalytics (>= 1.1.1), + PerformanceAnalytics (>= 1.1.0), sn, tseries, strucchange,