[Returnanalytics-commits] r2423 - in pkg/FactorAnalytics: R data man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jun 25 00:10:52 CEST 2013
Author: chenyian
Date: 2013-06-25 00:10:52 +0200 (Tue, 25 Jun 2013)
New Revision: 2423
Removed:
pkg/FactorAnalytics/R/plot.MacroFactorModel.r
pkg/FactorAnalytics/R/print.MacroFactorModel.r
pkg/FactorAnalytics/R/summary.MacroFactorModel.r
Modified:
pkg/FactorAnalytics/R/
pkg/FactorAnalytics/R/fitFundamentalFactorModel.R
pkg/FactorAnalytics/data/stock.RDATA
pkg/FactorAnalytics/man/fitFundamentalFactorModel.Rd
Log:
change input of fitFundamentalFactorModel.R, making it easier to use. The input now requires panel data. Once user defines asset variables, time variables, return variable and exposure variables. The function will take care of the rest.
Property changes on: pkg/FactorAnalytics/R
___________________________________________________________________
Modified: svn:ignore
- covEWMA.R
+ covEWMA.R
plot.MacroFactorModel.r
print.MacroFactorModel.r
summary.MacroFactorModel.r
Modified: pkg/FactorAnalytics/R/fitFundamentalFactorModel.R
===================================================================
--- pkg/FactorAnalytics/R/fitFundamentalFactorModel.R 2013-06-24 21:46:41 UTC (rev 2422)
+++ pkg/FactorAnalytics/R/fitFundamentalFactorModel.R 2013-06-24 22:10:52 UTC (rev 2423)
@@ -14,12 +14,10 @@
#' Insightful robust library ported to R and robustbase Basic robust statistics
#' package for R
#'
-#' @param fulldata data.frame, fulldata contains returns, dates, and exposures
-#' which is stacked by dates.
-#' @param timedates a vector of Dates specifying the date range for the model
-#' fitting
-#' @param exposures a character vector of exposure names for the factor model
-#' @param assets a list of PERMNOs to be used for the factor model
+#' @param data data.frame, data must have \emph{assetvar}, \emph{returnvar}, \emph{datevar}
+#' , and exposure.names. Generally, data is panel data setup, so it needs firm variabales
+#' and time variables.
+#' @param exposure.names a character vector of exposure names for the factor model
#' @param wls logical flag, TRUE for weighted least squares, FALSE for ordinary
#' least squares
#' @param regression A character string, "robust" for regression via lmRob,
@@ -37,33 +35,25 @@
#' the data.
#' @param assetvar A character string giving the name of the asset variable in
#' the data.
-#' @param tickersvar A character string giving the name of the ticker variable
-#' in the data.
#' @return an S3 object containing
#' \itemize{
#' \item cov.returns A "list" object contains covariance information for
#' asset returns, includes covariance, mean and eigenvalus.
-#' \item cov.factor.rets An object of class "cov" or "covRob" which
+#' \item cov.factor Anobject of class "cov" or "covRob" which
#' contains the covariance matrix of the factor returns (including intercept).
#' \item cov.resids An object of class "cov" or "covRob" which contains
#' the covariance matrix of the residuals, if "full.resid.cov" is TRUE. NULL
#' if "full.resid.cov" is FALSE.
-#' \item resid.varianceb A vector of variances estimated from the OLS
+#' \item resid.variance A vector of variances estimated from the OLS
#' residuals for each asset. If "wls" is TRUE, these are the weights used in
#' the weighted least squares regressions. If "cov = robust" these values are
#' computed with "scale.tau". Otherwise they are computed with "var".
-#' \item factor.rets A "zoo" object containing the times series of
+#' \item factor.rets A "xts" object containing the times series of
#' estimated factor returns and intercepts.
-#' \item resids A "zoo" object containing the time series of residuals
+#' \item resids A "xts" object containing the time series of residuals
#' for each asset.
-#' \item tstats A "zoo" object containing the time series of t-statistics
+#' \item tstats A "xts" object containing the time series of t-statistics
#' for each exposure.
-#' \item returns.data A "data.frame" object containing the returns data
-#' for the assets in the factor model, including RETURN, DATE,PERMNO.
-#' \item exposure.data A "data.frame" object containing the data for the
-#' variables in the factor model, including DATE, PERMNO.
-#' \item assets A character vector of PERMNOs used in the model
-#' \item tickers A character vector of tickers used in the model
#' \item call function call
#' }
#' @author Guy Yullen and Yi-An Chen
@@ -73,39 +63,68 @@
#' # BARRA type factor model
#' data(stock)
#' # there are 447 assets
-#' assets = unique(fulldata[,"PERMNO"])
-#' timedates = as.Date(unique(fulldata[,"DATE"]))
-#' exposures <- exposures.names <- c("BOOK2MARKET", "LOG.MARKETCAP")
-#' test.fit <- fitFundamentalFactorModel(fulldata=fulldata, timedates=timedates, exposures=exposures,covariance="classic", assets=assets,full.resid.cov=TRUE,
-#' regression="classic",wls=TRUE)
-#' names(test.fit)
-#' test.fit$cov.returns
-#' test.fit$cov.factor.rets
-#' test.fit$factor.rets
+#' exposure.names <- c("BOOK2MARKET", "LOG.MARKETCAP")
+#' ttest.fit <- fitFundamentalFactorModel(data=data,exposure.names=exposure.names,
+#' datevar = "DATE", returnsvar = "RETURN",
+#' assetvar = "TICKER", wls = TRUE,
+#' regression = "classic",
+#' covariance = "classic", full.resid.cov = TRUE,
+#' robust.scale = TRUE)
#'
+#' names(test.fit)
+#' test.fit$cov.returns
+#' test.fit$cov.resids
+#' names(test.fit$cov.factor)
+#' test.fit$cov.factor$cov
+#' test.fit$factor
+#' test.fit$resid.variance
+#' test.fit$resids
+#' test.fit$tstats
+#' test.fit$call
+#'
#' # BARRA type Industry Factor Model
-#' exposures <- exposures.names <- c("GICS.SECTOR")
+#' exposure.names <- c("GICS.SECTOR")
#' # the rest keep the same
-#' test.fit <- fitFundamentalFactorModel(fulldata=fulldata, timedates=timedates, exposures=exposures,
-#' covariance="classic", assets=assets,full.resid.cov=TRUE,
-#' regression="classic",wls=TRUE)
+#' test.fit2 <- fitFundamentalFactorModel(data=data,exposure.names=exposure.names,
+#' datevar = "DATE", returnsvar = "RETURN",
+#' assetvar = "TICKER", wls = TRUE,
+#' regression = "classic",
+#' covariance = "classic", full.resid.cov = TRUE,
+#' robust.scale = TRUE)
+#'
+#' names(test.fit2)
+#' test.fit2$cov.returns
+#' test.fit2$cov.resids
+#' names(test.fit2$cov.factor)
+#' test.fit2$cov.factor$cov
+#' test.fit2$factor
+#' test.fit2$resid.variance
+#' test.fit2$resids
+#' test.fit2$tstats
+#' test.fit2$call
+#'
+#'
+#'
#' }
#'
+
+
fitFundamentalFactorModel <-
-function (fulldata, timedates, exposures, assets, wls = FALSE, regression = "classic",
- covariance = "classic", full.resid.cov = TRUE, robust.scale = FALSE,
- datevar = "DATE", assetvar = "PERMNO", returnsvar = "RETURN",
- tickersvar = "TICKER.x") {
+function(data,exposure.names, datevar, returnsvar, assetvar,
+ wls = TRUE, regression = "classic",
+ covariance = "classic", full.resid.cov = TRUE, robust.scale = FALSE) {
-require(zoo)
+require(xts)
require(robust)
- # if (dim(dataArray)[1] < 2)
- # stop("At least two time points, t and t-1, are needed for fitting the factor model.")
+assets = unique(data[,assetvar])
+timedates = as.Date(unique(data[,datevar]))
+
+
if (length(timedates) < 2)
stop("At least two time points, t and t-1, are needed for fitting the factor model.")
- if (!is(exposures, "vector") || !is.character(exposures))
+ if (!is(exposure.names, "vector") || !is.character(exposure.names))
stop("exposure argument invalid---must be character vector.")
if (!is(assets, "vector") || !is.character(assets))
stop("assets argument invalid---must be character vector.")
@@ -120,34 +139,34 @@
stop("covariance must one of 'robust', 'classic'.")
this.call <- match.call()
- if (match(returnsvar, exposures, FALSE))
+ if (match(returnsvar, exposure.names, FALSE))
stop(paste(returnsvar, "cannot be used as an exposure."))
-
+ assets = unique(data[,assetvar])
+ timedates = as.Date(unique(data[,datevar]))
numTimePoints <- length(timedates)
- numExposures <- length(exposures)
+ numExposures <- length(exposure.names)
numAssets <- length(assets)
- tickers <- fulldata[1:numAssets,tickersvar]
- # dim(fulldata)
- # [1] 42912 117
- # dimnames(fulldata)
- # PERMNO" "DATE" "RETURN" "TICKER.x" "BOOK2MARKET" "TICKER.y"
- # check if exposures are numeric, if not, create exposures. factors by dummy variables
- which.numeric <- sapply(fulldata[, exposures, drop = FALSE],is.numeric)
- exposures.numeric <- exposures[which.numeric]
+ # tickers <- data[1:numAssets,tickersvar]
+
+
+
+ # check if exposure.names are numeric, if not, create exposures. factors by dummy variables
+ which.numeric <- sapply(data[, exposure.names, drop = FALSE],is.numeric)
+ exposures.numeric <- exposure.names[which.numeric]
# industry factor model
- exposures.factor <- exposures[!which.numeric]
+ exposures.factor <- exposure.names[!which.numeric]
if (length(exposures.factor) > 1) {
stop("Only one nonnumeric variable can be used at this time.")
}
- regression.formula <- paste("~", paste(exposures, collapse = "+"))
+ regression.formula <- paste("~", paste(exposure.names, collapse = "+"))
# "~ BOOK2MARKET"
if (length(exposures.factor)) {
regression.formula <- paste(regression.formula, "- 1")
- fulldata[, exposures.factor] <- as.factor(fulldata[,
+ data[, exposures.factor] <- as.factor(data[,
exposures.factor])
- exposuresToRecode <- names(fulldata[, exposures, drop = FALSE])[!which.numeric]
+ exposuresToRecode <- names(data[, exposure.names, drop = FALSE])[!which.numeric]
contrasts.list <- lapply(seq(length(exposuresToRecode)),
function(i) function(n, m) contr.treatment(n, contrasts = FALSE))
names(contrasts.list) <- exposuresToRecode
@@ -241,55 +260,55 @@
if (!wls) {
if (regression == "robust") {
# ols.robust
- FE.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = ols.robust, modelterms = regression.formula,
conlist = contrasts.list)
} else {
# ols.classic
- FE.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = ols.classic, modelterms = regression.formula,
conlist = contrasts.list)
}
} else {
if (regression == "robust") {
# wls.robust
- E.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ resids <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = function(xdf, modelterms, conlist) {
lmRob(modelterms, data = xdf, contrasts = conlist,
control = lmRob.control(mxr = 200, mxf = 200,
mxs = 200))$resid
}, modelterms = regression.formula, conlist = contrasts.list)
- E.hat <- apply(E.hat, 1, unlist)
+ resids <- apply(resids, 1, unlist)
weights <- if (covariance == "robust")
- apply(E.hat, 1, scaleTau2)^2
- else apply(E.hat, 1, var)
- FE.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ apply(resids, 1, scaleTau2)^2
+ else apply(resids, 1, var)
+ FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = wls.robust, modelterms = regression.formula,
conlist = contrasts.list, w = weights)
} else {
# wls.classic
- E.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ resids <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = function(xdf, modelterms, conlist) {
lm(formula = modelterms, data = xdf, contrasts = conlist,
singular.ok = TRUE)$resid
},
modelterms = regression.formula, conlist = contrasts.list)
- E.hat <- apply(E.hat, 1, unlist)
+ resids <- apply(resids, 1, unlist)
weights <- if (covariance == "robust")
- apply(E.hat, 1, scaleTau2)^2
- else apply(E.hat, 1, var)
- FE.hat <- by(data = fulldata, INDICES = as.numeric(fulldata[[datevar]]),
+ apply(resids, 1, scaleTau2)^2
+ else apply(resids, 1, var)
+ FE.hat <- by(data = data, INDICES = as.numeric(data[[datevar]]),
FUN = wls.classic, modelterms = regression.formula,
conlist = contrasts.list, w = weights)
}
}
# if there is industry dummy variables
if (length(exposures.factor)) {
- numCoefs <- length(exposures.numeric) + length(levels(fulldata[,
+ numCoefs <- length(exposures.numeric) + length(levels(data[,
exposures.factor]))
ncols <- 1 + 2 * numCoefs + numAssets
fnames <- c(exposures.numeric, paste(exposures.factor,
- levels(fulldata[, exposures.factor]), sep = ""))
+ levels(data[, exposures.factor]), sep = ""))
cnames <- c("numCoefs", fnames, paste("t", fnames, sep = "."),
assets)
} else {
@@ -318,7 +337,7 @@
timedates <- as.Date(as.numeric(dimnames(FE.hat)[[1]]), origin = "1970-01-01")
coefs.names <- colnames(FE.hat.mat)[2:(1 + numCoefs)]
# estimated factors ordered by time
- f.hat <- zoo(x = FE.hat.mat[, 2:(1 + numCoefs)], order.by = timedates)
+ f.hat <- xts(x = FE.hat.mat[, 2:(1 + numCoefs)], order.by = timedates)
# check for outlier
gomat <- apply(coredata(f.hat), 2, function(x) abs(x - median(x,
na.rm = TRUE)) > 4 * mad(x, na.rm = TRUE))
@@ -327,30 +346,30 @@
for (i in which(apply(gomat, 1, any, na.rm = TRUE))) print(f.hat[i,
gomat[i, ], drop = FALSE])
}
- tstats <- zoo(x = FE.hat.mat[, (2 + nc):(1 + 2 * nc)], order.by = timedates)
+ tstats <- xts(x = FE.hat.mat[, (2 + nc):(1 + 2 * nc)], order.by = timedates)
# residuals for every asset ordered by time
- E.hat <- zoo(x = FE.hat.mat[, (2 + 2 * numCoefs):(1 + 2 *
+ resids <- xts(x = FE.hat.mat[, (2 + 2 * numCoefs):(1 + 2 *
numCoefs + numAssets)], order.by = timedates)
- colnames(E.hat) <- tickers
- if (covariance == "robust") {
+
+if (covariance == "robust") {
if (kappa(na.exclude(coredata(f.hat))) < 1e+10) {
- Cov.facrets <- covRob(coredata(f.hat), estim = "pairwiseGK",
+ Cov.factors <- covRob(coredata(f.hat), estim = "pairwiseGK",
distance = FALSE, na.action = na.omit)
} else {
cat("Covariance matrix of factor returns is singular.\n")
- Cov.facrets <- covRob(coredata(f.hat), distance = FALSE,
+ Cov.factors <- covRob(coredata(f.hat), distance = FALSE,
na.action = na.omit)
}
- resid.vars <- apply(coredata(E.hat), 2, scaleTau2, na.rm = T)^2
+ resid.vars <- apply(coredata(resids), 2, scaleTau2, na.rm = T)^2
D.hat <- if (full.resid.cov)
- covOGK(coredata(E.hat), sigmamu = scaleTau2, n.iter = 1)
+ covOGK(coredata(resids), sigmamu = scaleTau2, n.iter = 1)
else
diag(resid.vars)
} else {
- Cov.facrets <- covClassic(coredata(f.hat), distance = FALSE,na.action = na.omit)
- resid.vars <- apply(coredata(E.hat), 2, var, na.rm = TRUE)
+ Cov.factors <- covClassic(coredata(f.hat), distance = FALSE,na.action = na.omit)
+ resid.vars <- apply(coredata(resids), 2, var, na.rm = TRUE)
D.hat <- if (full.resid.cov)
- covClassic(coredata(E.hat), distance = FALSE, na.action = na.omit)
+ covClassic(coredata(resids), distance = FALSE, na.action = na.omit)
else
diag(resid.vars)
}
@@ -359,39 +378,32 @@
colnames <- coefs.names
B.final[, match("(Intercept)", colnames, 0)] <- 1
numeric.columns <- match(exposures.numeric, colnames, 0)
- B.final[, numeric.columns] <- as.matrix(fulldata[as.numeric(fulldata[[datevar]]) ==
+ B.final[, numeric.columns] <- as.matrix(data[as.numeric(data[[datevar]]) ==
timedates[numTimePoints], exposures.numeric])
if (length(exposures.factor))
B.final[, grep(exposures.factor, x = colnames)][cbind(seq(numAssets),
- as.numeric(fulldata[fulldata[[datevar]] == timedates[numTimePoints],
+ as.numeric(data[data[[datevar]] == timedates[numTimePoints],
exposures.factor]))] <- 1
- cov.returns <- B.final %*% Cov.facrets$cov %*% t(B.final) +
+ cov.returns <- B.final %*% Cov.factors$cov %*% t(B.final) +
if (full.resid.cov)
D.hat$cov
else D.hat
- dimnames(cov.returns) <- list(tickers, tickers)
- mean.cov.returns = tapply(fulldata[[returnsvar]],fulldata[[assetvar]], mean)
- dimnames(mean.cov.returns) = list(tickers)
+ mean.cov.returns = tapply(data[[returnsvar]],data[[assetvar]], mean)
Cov.returns <- list(cov = cov.returns, mean=mean.cov.returns, eigenvalues = eigen(cov.returns,
only.values = TRUE, symmetric = TRUE)$values)
if (full.resid.cov) {
Cov.resids <- D.hat
- dimnames(Cov.resids$cov) <- list(tickers, tickers)
}
else {
Cov.resids <- NULL
}
output <- list(cov.returns = Cov.returns,
- cov.factor.rets = Cov.facrets,
+ cov.factor = Cov.factors,
cov.resids = Cov.resids,
resid.variance = resid.vars,
factor.rets = f.hat,
- resids = E.hat,
- tstats = tstats,
- returns.data = fulldata[,c(datevar, assetvar, returnsvar)],
- exposure.data = fulldata[,c(datevar, assetvar, exposures)],
- assets = assets,
- tickers = tickers,
+ resids = resids,
+ tstats = tstats,
call = this.call)
class(output) <- "FundamentalFactorModel"
return(output)
Deleted: pkg/FactorAnalytics/R/plot.MacroFactorModel.r
===================================================================
--- pkg/FactorAnalytics/R/plot.MacroFactorModel.r 2013-06-24 21:46:41 UTC (rev 2422)
+++ pkg/FactorAnalytics/R/plot.MacroFactorModel.r 2013-06-24 22:10:52 UTC (rev 2423)
@@ -1,393 +0,0 @@
-#' plot MacrofactorModel object.
-#'
-#' Generic function of plot method for fitMacroeconomicFactorModel. Either plot
-#' all fit models or choose a single asset to plot.
-#'
-#'
-#' @param fit.macro fit object created by fitMacroeconomicFactorModel.
-#' @param colorset Defualt colorset is c(1:12).
-#' @param legend.loc plot legend or not. Defualt is \code{NULL}.
-#' @param which.plot integer indicating which plot to create: "none" will
-#' create a menu to choose. Defualt is none. 1 = "Fitted factor returns", 2 =
-#' "R square", 3 = "Variance of Residuals", 4 = "FM Correlation", 5 = "Factor
-#' Contributions to SD", 6 = "Factor Contributions to ES", 7 = "Factor
-#' Contributions to VaR"
-#' @param max.show Maximum assets to plot. Default is 6.
-#' @param plot.single Plot a single asset of lm class. Defualt is FALSE.
-#' @param fundName Name of the asset to be plotted.
-#' @param which.plot.single integer indicating which plot to create: "none"
-#' will create a menu to choose. Defualt is none. 1 = time series plot of
-#' actual and fitted values 2 = time series plot of residuals with standard
-#' error bands 3 = time series plot of squared residuals 4 = time series plot
-#' of absolute residuals 5 = SACF and PACF of residuals 6 = SACF and PACF of
-#' squared residuals 7 = SACF and PACF of absolute residuals 8 = histogram of
-#' residuals with normal curve overlayed 9 = normal qq-plot of residuals 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 24 month window
-#' @author Eric Zivot and Yi-An Chen.
-#' @examples
-#'
-#' \dontrun{
-#' # load data from the database
-#' data(managers.df)
-#' ret.assets = managers.df[,(1:6)]
-#' factors = managers.df[,(7:9)]
-#' # fit the factor model with OLS
-#' fit <- fitMacroeconomicFactorModel(ret.assets,factors,fit.method="OLS",
-#' variable.selection="all subsets")
-#' # plot of all assets and show only first 4 assets.
-#' plot(fit.macro,max.show=4)
-#' # single plot of HAM1 asset
-#' plot(fit.macro, plot.single=TRUE, fundName="HAM1")
-#' }
-#'
- plot.MacroFactorModel <-
- function(fit.macro,colorset=c(1:12),legend.loc=NULL,
- which.plot=c("none","1L","2L","3L","4L","5L","6L","7L"),max.show=6,
- plot.single=FALSE, fundName,which.plot.single=c("none","1L","2L","3L","4L","5L","6L",
- "7L","8L","9L","10L","11L","12L","13L")) {
- require(zoo)
- require(PerformanceAnalytics)
- require(strucchange)
-
- if (plot.single==TRUE) {
- ## inputs:
- ## fit.macro lm object summarizing factor model fit. It is assumed that
- ## time series date information is included in the names component
- ## of the residuals, fitted and model components of the object.
- ## fundName charater. The name of the single asset to be ploted.
- ## which.plot.single integer indicating which plot to create:
- ## 1 time series plot of actual and fitted values
- ## 2 time series plot of residuals with standard error bands
- ## 3 time series plot of squared residuals
- ## 4 time series plot of absolute residuals
- ## 5 SACF and PACF of residuals
- ## 6 SACF and PACF of squared residuals
- ## 7 SACF and PACF of absolute residuals
- ## 8 histogram of residuals with normal curve overlayed
- ## 9 normal qq-plot of residuals
- ## 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 24 month window
- which.plot.single<-which.plot.single[1]
- fit.lm = fit.macro$asset.fit[[fundName]]
-
- if (!(class(fit.lm) == "lm"))
- stop("Must pass a valid lm object")
-
- ## extract information from lm object
-
- factorNames = colnames(fit.lm$model)[-1]
- fit.formula = as.formula(paste(fundName,"~", 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)
-
-
- if (which.plot.single=="none")
- 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 24 month window"),
- title="\nMake a plot selection (or 0 to exit):\n")
- switch(which.plot.single,
- "1L" = {
- ## time series plot of actual and fitted values
- plot(actual.z, main=fundName, 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 residuals with standard error bands
- plot(residuals.z, main=fundName, 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" = {
- ## time series plot of squared residuals
- plot(residuals.z^2, main=fundName, ylab="Squared residual", lwd=2, col="black")
- abline(h=0)
- legend(x="topleft", legend="Squared Residuals", lwd=2, col="black")
- },
- "4L" = {
- ## time series plot of absolute residuals
- plot(abs(residuals.z), main=fundName, ylab="Absolute residual", lwd=2, col="black")
- abline(h=0)
- legend(x="topleft", legend="Absolute Residuals", lwd=2, col="black")
- },
- "5L" = {
- ## SACF and PACF of residuals
- chart.ACFplus(residuals.z, main=paste("Residuals: ", fundName, sep=""))
- },
- "6L" = {
- ## SACF and PACF of squared residuals
- chart.ACFplus(residuals.z^2, main=paste("Residuals^2: ", fundName, sep=""))
- },
- "7L" = {
- ## SACF and PACF of absolute residuals
- chart.ACFplus(abs(residuals.z), main=paste("|Residuals|: ", fundName, sep=""))
- },
- "8L" = {
- ## histogram of residuals with normal curve overlayed
- chart.Histogram(residuals.z, methods="add.normal", main=paste("Residuals: ", fundName, sep=""))
- },
- "9L" = {
- ## normal qq-plot of residuals
- chart.QQPlot(residuals.z, envelope=0.95, main=paste("Residuals: ", fundName, sep=""))
- },
- "10L"= {
- ## CUSUM plot of recursive residuals
- if (as.character(fit.macro$call["fit.method"]) == "OLS") {
- cusum.rec = efp(fit.formula, type="Rec-CUSUM", data=fit.lm$model)
- plot(cusum.rec, sub=fundName)
- } else
- stop("CUMSUM applies only on OLS method")
- },
- "11L"= {
- ## CUSUM plot of OLS residuals
- if (as.character(fit.macro$call["fit.method"]) == "OLS") {
- cusum.ols = efp(fit.formula, type="OLS-CUSUM", data=fit.lm$model)
- plot(cusum.ols, sub=fundName)
- } else
- stop("CUMSUM applies only on OLS method")
- },
- "12L"= {
- ## CUSUM plot of recursive estimates relative to full sample estimates
- if (as.character(fit.macro$call["fit.method"]) == "OLS") {
- cusum.est = efp(fit.formula, type="fluctuation", data=fit.lm$model)
- plot(cusum.est, functional=NULL, sub=fundName)
- } else
- stop("CUMSUM applies only on OLS method")
- },
- "13L"= {
- ## rolling regression over 24 month window
- if (as.character(fit.macro$call["fit.method"]) == "OLS") {
- rollReg <- function(data.z, formula) {
- coef(lm(formula, data = as.data.frame(data.z)))
- }
- 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:", fundName, sep=" "))
- } else if (as.character(fit.macro$call["fit.method"]) == "DLS") {
- decay.factor <- as.numeric(as.character(fit.macro$call["decay.factor"]))
- t.length <- 24
- w <- rep(decay.factor^(t.length-1),t.length)
- for (k in 2:t.length) {
- w[k] = w[k-1]/decay.factor
- }
- w <- w/sum(w)
- rollReg <- function(data.z, formula,w) {
- coef(lm(formula,weight=w, data = as.data.frame(data.z)))
- }
- reg.z = zoo(fit.lm$model[-length(fit.lm$model)], as.Date(rownames(fit.lm$model)))
- factorNames = colnames(fit.lm$model)[c(-1,-length(fit.lm$model))]
- fit.formula = as.formula(paste(fundName,"~", paste(factorNames, collapse="+"), sep=" "))
- rollReg.z = rollapply(reg.z, FUN=rollReg, fit.formula,w, width=24, by.column = FALSE,
- align="right")
- plot(rollReg.z, main=paste("24-month rolling regression estimates:", fundName, sep=" "))
- }
- },
- invisible()
- )
-
-
-
- } else {
- which.plot<-which.plot[1]
-
- if(which.plot=='none')
- which.plot<-menu(c("Fitted factor returns",
- "R square",
- "Variance of Residuals",
- "FM Correlation",
- "Factor Contributions to SD",
- "Factor Contributions to ES",
- "Factor Contributions to VaR"),
- title="Factor Analytics Plot \nMake a plot selection (or 0 to exit):\n")
-
- variable.selection = fit.macro$variable.selection
- manager.names = colnames(fit.macro$ret.assets)
- factor.names = colnames(fit.macro$factors)
- managers.df = cbind(fit.macro$ret.assets,fit.macro$factors)
- cov.factors = var(fit.macro$factors)
- n <- length(manager.names)
-
- switch(which.plot,
-
- "1L" = {
- if (n >= max.show) {
- cat(paste("numbers of assets are greater than",max.show,", show only first",
- max.show,"assets",sep=" "))
- n <- max.show
- }
- par(mfrow=c(n/2,2))
- if (variable.selection == "lar" || variable.selection == "lasso") {
- for (i in 1:n) {
- alpha = fit.macro$alpha.vec[i]
- beta = as.matrix(fit.macro$beta.mat[i,])
- fitted = alpha+as.matrix(fit.macro$factors)%*%beta
- dataToPlot = cbind(fitted, na.omit(fit.macro$ret.assets[,i]))
- colnames(dataToPlot) = c("Fitted","Actual")
- main = paste("Factor Model fit for",manager.names[i],seq="")
- chart.TimeSeries(dataToPlot,colorset = colorset, legend.loc = legend.loc,main=main)
- }
- } else {
- for (i in 1:n) {
- dataToPlot = cbind(fitted(fit.macro$asset.fit[[i]]), na.omit(fit.macro$ret.assets[,i]))
- colnames(dataToPlot) = c("Fitted","Actual")
- main = paste("Factor Model fit for",manager.names[i],seq="")
- chart.TimeSeries(dataToPlot,colorset = colorset, legend.loc = legend.loc,main=main)
- }
- }
- par(mfrow=c(1,1))
- },
- "2L" ={
- barplot(fit.macro$r2.vec)
- },
- "3L" = {
- barplot(fit.macro$residVars.vec)
- },
-
- "4L" = {
- cov.fm<- factorModelCovariance(fit.macro$beta.mat,var(fit.macro$factors),fit.macro$residVars.vec)
- cor.fm = cov2cor(cov.fm)
- rownames(cor.fm) = colnames(cor.fm)
- ord <- order(cor.fm[1,])
- ordered.cor.fm <- cor.fm[ord, ord]
- plotcorr(ordered.cor.fm, col=cm.colors(11)[5*ordered.cor.fm + 6])
- },
- "5L" = {
- factor.sd.decomp.list = list()
- for (i in manager.names) {
- factor.sd.decomp.list[[i]] =
- factorModelSdDecomposition(fit.macro$beta.mat[i,],
- cov.factors, fit.macro$residVars.vec[i])
- }
- # function to extract contribution to sd from list
- getCSD = function(x) {
- x$cr.fm
- }
- # extract contributions to SD from list
- cr.sd = sapply(factor.sd.decomp.list, getCSD)
- rownames(cr.sd) = c(factor.names, "residual")
- # create stacked barchart
- barplot(cr.sd, main="Factor Contributions to SD",
- legend.text=T, args.legend=list(x="topleft"),
- col=c(1:50) )
-
- },
- "6L"={
- factor.es.decomp.list = list()
- if (variable.selection == "lar" || variable.selection == "lasso") {
-
- for (i in manager.names) {
- idx = which(!is.na(managers.df[,i]))
- alpha = fit.macro$alpha.vec[i]
- beta = as.matrix(fit.macro$beta.mat[i,])
- fitted = alpha+as.matrix(fit.macro$factors)%*%beta
- residual = fit.macro$ret.assets[,i]-fitted
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/returnanalytics -r 2423
More information about the Returnanalytics-commits
mailing list