fAssets/0000755000176000001440000000000012424430504011710 5ustar ripleyusersfAssets/inst/0000755000176000001440000000000012424423203012663 5ustar ripleyusersfAssets/inst/obsolete/0000755000176000001440000000000012424423203014477 5ustar ripleyusersfAssets/inst/obsolete/a-class-fASSETS.R0000644000176000001440000000773312424423203017325 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: SIMULATION AND PARAMETER ESTIMATION: # 'fASSETS' Class representation for "fASSETS" Objects # FUNCTION: DESCRIPTION: # show.fASSETS S4: Print method for an object of class fASSETS # plot.fASSETS S3: Plot method for an object of class fASSETS # summary.fASSETS S3: Summary method for an object of class fASSETS ################################################################################ setClass("fASSETS", # A class implemented by Diethelm Wuertz representation( call = "call", # call: The matched function call method = "character", # method: One of "mn", "msn", "mst" model = "list", # model: A list(mu, Omega, alpha, df) data = "data.frame", # Data: The data records fit = "list", # fit: Results parameter estimation title = "character", # title: A short title string description = "character") # description: A brief description ) # ------------------------------------------------------------------------------ setMethod("show", "fASSETS", function(object) { # A function implemented by Diethelm Wuertz # Description: # Print Method for an object of class fASSETS # Arguments: # x - an object of class fASSETS # FUNCTION: # Title: cat("\nTitle:\n") cat(as.character(object@title), "\n") # Call: cat("\nCall:\n") cat(paste(deparse(object@call), sep = "\n", collapse = "\n"), "\n", sep = "") # Model Parameters: cat("\nModel Parameters:\n") print(object@model) # Description: cat("Description:\n") print(object@description) cat("\n") # Return Value: invisible(object) }) # ------------------------------------------------------------------------------ plot.fASSETS <- function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Descriptions: # Plots a fit from an assets data set or a model # Arguments: # x - an object of class fASSETS # ... - arguments to be passed # Notes: # Library 'sn', is version 0.32-2 (2004-03-13), # (C) 1998-2004 A. Azzalini, GPL # For "fMV" objects have a look in "fMultivar". # FUNCTION: # Transform to a S4 object of class "fMV": object = new("fMV", call = x@call, method = x@method, model = x@model, data = x@data, fit = x@fit, title = x@title, description = x@description) # Use plot method for objects of class "fMV" plot(object, which = which, xlab = "Time", ylab = "Value", ...) # Return value: invisible(x) } # ------------------------------------------------------------------------------ summary.fASSETS = function(object, which = "all", ...) { # A function implemented by Diethelm Wuertz # Descriptions: # Summarizes a fit from an assets data set or a model # Print: print(object, ...) # Plot: plot(object, which = which, ...) # Return value: invisible(object) } ################################################################################ fAssets/inst/obsolete/a-class-fASSETS.Rd0000644000176000001440000000315012424423203017456 0ustar ripleyusers\name{fAssets} \alias{fASSETS} \alias{fASSETS-class} \alias{show,fASSETS-method} \alias{plot.fASSETS} \alias{summary.fASSETS} \title{fAssets class and methods} \description{ fAssets class and methods. } \usage{ \S4method{show}{fASSETS}(object) \method{plot}{fASSETS}(x, which = "ask", \dots) \method{summary}{fASSETS}(object, which = "all", \dots) } \arguments{ \item{object}{ An object of class \code{fASSETS}. } \item{x}{ a numeric matrix of returns or any other rectangular object like a data.frame or a multivariate time series object which can be transformed by the function as.matrix to an object of class matrix. } \item{which}{ which of the five plots should be displayed? \code{which} can be either a character string, "all" (displays all plots) or "ask" (interactively asks which one to display), or a vector of 5 logical values, for those elements which are set TRUE the correponding plot will be displayed. } \item{\dots}{ arguments to be passed. } } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:3] head(LPP) ## Fit a Skew-Student-t Distribution: assetsFit - fit <- assetsFit(LPP) ## fASSETS - class(fit) print(fit) % # plot(fit, 1) ## Show Model Slot: @model print(fit@model) }fAssets/inst/obsolete/assets-modeling.Rd0000644000176000001440000001667512424423203020103 0ustar ripleyusers\name{assets-modeling} \alias{assetsFit} \alias{assetsSim} \title{Modeling of Multivariate Asset Sets} \description{ Fits the parameters to a multivariate normal, skew normal, or (skew) Student-t distribution and allows to simulate artificial asset series. } \usage{ assetsFit(x, method = c("st", "snorm", "norm"), title = NULL, description = NULL, fixed.df = NA) assetsSim(n, dim = 2, model = list(mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = Inf), assetNames = NULL) } \arguments{ \item{x}{ a numeric matrix of returns or any other rectangular object like a data.frame or a multivariate time series object which can be transformed by the function \code{as.matrix} to an object of class \code{matrix}. } \item{n}{ integer value, the number of data records to be simulated. } \item{method}{ a character string, which type of distribution should be fitted? \code{method="st"} denotes a multivariate skew-Student-t distribution, \code{method="snorm"} a multivariate skew-Normal distribution, and \code{method="norm"} a multivariate Normel distribution. By default a multivariate normal distribution will be fitted to the empirical market data. } \item{dim}{ integer value, the dimension (number of columns) of the assets set. } \item{model}{ a list of model parameters: \cr \code{mu} a vector of mean values, one for each asset series, \cr \code{Omega} the covariance matrix of assets, \cr \code{alpha} the skewness vector, and \cr \code{df} the number of degrees of freedom which is a measure for the fatness of the tails (excess kurtosis). \cr For a symmetric distribution \code{alpha} is a vector of zeros. For the normal distributions \code{df} is not used and set to infinity, \code{Inf}. Note that all assets have the same value for \code{df}. } \item{assetNames}{ [assetsSim] - \cr a vector of character strings of length \code{dim} allowing for modifying the names of the individual assets. } \item{title}{ a character string, assigning a title to an \code{"fASSETS"} object. } \item{description}{ a character string, assigning a brief description to an \code{"fASSETS"} object. } \item{fixed.df}{ either \code{NA}, the default, or a numeric value assigning the number of degrees of freedom to the model. In the case that \code{fixed.df=NA} the value of \code{df} will be included in the optimization process, otherwise not. } \item{\dots}{ optional arguments to be passed. } } \value{ \code{assetsFit()} \cr returns a S4 object class of class \code{"fASSETS"}, with the following slots: \item{@call}{ the matched function call. } \item{@data}{ the input data in form of a data.frame. } \item{@description}{ allows for a brief project description. } \item{@fit}{ the results as a list returned from the underlying fitting function. } \item{@method}{ the selected method to fit the distribution, one of \code{"norm"}, \code{"snorm"}, \code{"st"}. } \item{@model}{ the model parameters describing the fitted parameters in form of a list, \code{model=list(mu, Omega, alpha, df}. } \item{@title}{ a title string. } The \code{@fit} slot is a list with the following compontents: (Note, not all are documented here). \item{@fit$dp}{ a list containing the direct parameters beta, Omega, alpha. Here, beta is a matrix of regression coefficients with \code{dim(beta)=c(nrow(X), ncol(y))}, \code{Omega} is a covariance matrix of order \code{dim}, \code{alpha} is a vector of shape parameters of length \code{dim}. } \item{@fit$se}{ a list containing the components beta, alpha, info. Here, beta and alpha are the standard errors for the corresponding point estimates; info is the observed information matrix for the working parameter, as explained below. } \item{fit@optim}{ the list returned by the optimizer \code{optim}; see the documentation of this function for explanation of its components. } Note that the \code{@fit$model} slot can be used as input to the function \code{assetsSim} for simulating a similar portfolio of assets compared with the original portfolio data, usually market assets. \code{assetsSim()} \cr returns a signal series (S4 time Series object) of simulated assets. } \details{ The function \code{assetsFit} for the parameter estimation uses code based on functions from the contributed packages \code{"mtvnorm"} and \code{"sn"} for fitting data to a multivariate Normal, skew-Normal, or skew-Student-t distribution. } \references{ Azzalini A. (1985); \emph{A Class of Distributions Which Includes the Normal Ones}, Scandinavian Journal of Statistics 12, 171--178. Azzalini A. (1986); \emph{Further Results on a Class of Distributions Which Includes the Normal Ones}, Statistica 46, 199--208. Azzalini A., Dalla Valle A. (1996); \emph{The Multivariate Skew-normal Distribution}, Biometrika 83, 715--726. Azzalini A., Capitanio A. (1999); \emph{Statistical Applications of the Multivariate Skew-normal Distribution}, Journal Roy. Statist. Soc. B61, 579--602. Azzalini A., Capitanio A. (2003); \emph{Distributions Generated by Perturbation of Symmetry with Emphasis on a Multivariate Skew-t Distribution}, Journal Roy. Statist. Soc. B65, 367--389. Genz A., Bretz F. (1999); \emph{Numerical Computation of Multivariate t-Probabilities with Application to Power Calculation of Multiple Contrasts}, Journal of Statistical Computation and Simulation 63, 361--378. Genz A. (1992); \emph{Numerical Computation of Multivariate Normal Probabilities}, Journal of Computational and Graphical Statistics 1, 141--149. Genz A. (1993); \emph{Comparison of Methods for the Computation of Multivariate Normal Probabilities}, Computing Science and Statistics 25, 400--405. Hothorn T., Bretz F., Genz A. (2001); \emph{On Multivariate t and Gauss Probabilities in R}, R News 1/2, 27--29. Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \author{ Adelchi Azzalini for R's \code{sn} package, \cr Torsten Hothorn for R's \code{mtvnorm} package, \cr Diethelm Wuertz for the Rmetrics port. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data as Percentual Returns: LPP <- 100 * LPP2005REC[, 1:3] head(LPP) ## assetsFit - # Fit a Skew-Student-t Distribution: fit <- assetsFit(LPP) # Show Model Slot: print(fit@model) ## assetsSim - # Simulate set with same statistical properties: set.seed(1953) LPP.SIM <- assetsSim(n=nrow(LPP), dim=ncol(LPP), model=fit@model) colnames(LPP.SIM) <- colnames(LPP) head(LPP.SIM) } \keyword{models} fAssets/NAMESPACE0000644000176000001440000000123012424423203013121 0ustar ripleyusers################################################################################ ## Exports ################################################################################ exportPattern("^[^\\.]") ################################################################################ ## Imports ################################################################################ import(timeDate) import(timeSeries) import(fBasics) import(fMultivar) import(robustbase) import(MASS) import(ecodist) import(mvnormtest) import(energy) # Only importing what we need from "sn" since it exports a function # called "vech"; as "fBasics" does... importFrom(sn, rmst, rmsn, rmsc) fAssets/R/0000755000176000001440000000000012424423203012107 5ustar ripleyusersfAssets/R/builtin-donostahRobust.R0000644000176000001440000001722512424423203016723 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .cov.donostah Builtin from Package 'robust' # .covRob.control Builtin from Package 'robust' ################################################################################ # Rmetrics: # Note that covRobust is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: robust # Version: 0.3-4 # Date: 2008-07-06 # Title: Insightful Robust Library # Author: Jiahui Wang, # Ruben Zamar , # Alfio Marazzi , # Victor Yohai , # Matias Salibian-Barrera , # Ricardo Maronna , # Eric Zivot , # David Rocke , # Doug Martin , # Kjell Konis . # Maintainer: Kjell Konis # Depends: R (>= 2.6.0), MASS, lattice, robustbase, rrcov, stats # Description: A package of robust methods. # License: GPL # ------------------------------------------------------------------------------ .cov.donostah <- function(x) { control = .covRob.control("donostah") n <- nrow(x) p <- ncol(x) center <- control$center nresamp <- control$nresamp maxres <- control$maxres prob <- control$prob eps <- control$eps if(!control$random.sample) { if(exists(".Random.seed", where = 1)) { random.seed <- get(".Random.seed", pos = 1) on.exit(assign(".Random.seed", random.seed, pos = 1)) } set.seed(21) } if(casefold(nresamp) == "auto") nresamp <- ceiling(log(1 - control$prob)/log(1 - (1 - control$eps)^(p+1))) else if(!is.integer(nresamp)) stop("nresamp must be a nonnegative integer or ", dQuote("auto")) if(nresamp != 0) nresamp <- max(1000, nresamp) if(casefold(maxres) == "auto") maxres <- 2 * nresamp else if(!is.integer(maxres)) stop(sQuote("maxres"), " is not a positive integer") tune <- sqrt(qchisq(control$tune, p)) icent <- 1 locat <- double(p) covmat <- matrix(0.0, p, p) storage.mode(covmat) <- "double" wk <- double(4*n+p) iwork <- integer(4*n+p) nresper <- 0 w <- double(n) z <- double(n) if(length(center) == 1 && !center) center <- rep(0, p) if(length(center) > 1) { if(length(center) != p) stop("the dimension of ", sQuote("center"), " does not match the ", "dimension of ", sQuote("x")) x <- sweep(x, 2, center) icent <- 0 } sdlist <- .Fortran("rlds", n = as.integer(n), p = as.integer(p), nresamp = as.integer(nresamp), x = as.double(x), tune = as.double(tune), wk = as.double(wk), center = as.double(locat), cov = covmat, maxres = as.integer(maxres), nresper = as.integer(nresper), weights = as.double(w), outlyingness = as.double(z), icent = as.integer(icent), iwork = as.integer(iwork), PACKAGE = "fAssets") dist <- mahalanobis(x, center = if(length(center) > 1) rep(0, p) else sdlist$center, cov = sdlist$cov) consistency.correction <- median(dist) / qchisq(0.5, p) sdlist$cov <- sdlist$cov * consistency.correction sdlist$dist <- dist / consistency.correction if(length(center) > 1) sdlist$center <- center # Return Value: list(center = sdlist$center, cov = sdlist$cov) } # ------------------------------------------------------------------------------ .covRob.control <- function(estim, ...) { estim <- casefold(estim) control <- list(...) control$estim <- estim if(estim == "donostah") { if(is.null(control$nresamp)) control$nresamp <- "auto" if(is.null(control$maxres)) control$maxres <- "auto" if(is.null(control$random.sample)) control$random.sample <- FALSE if(is.null(control$center)) control$center <- TRUE if(is.null(control$tune)) control$tune <- 0.95 if(is.null(control$prob)) control$prob <- 0.99 if(is.null(control$eps)) control$eps <- 0.5 control <- control[c( "estim", "nresamp", "maxres", "random.sample", "center", "tune", "prob", "eps")] } else if(estim == "mcd" || estim == "weighted") { ## For backwards compatibility we support the use of quan and ntrial ## to specify alpha and nsamp for estim = "mcd", estim = "weighted" ## and estim = "M". Providing both quan and alpha or both ntrial and ## nsamp will result in an error. if(is.null(control$alpha)) control$alpha <- ifelse(is.null(control$quan), 0.5, control$quan) if(is.null(control$nsamp)) control$nsamp <- ifelse(is.null(control$ntrial), 500, control$ntrial) if(is.null(control$trace)) control$trace <- FALSE if(is.null(control$use.correction)) control$use.correction <- TRUE if(is.null(control$tolSolve)) control$tolSolve <- 1e-14 if(is.null(control$seed)) control <- control[c( "estim", "alpha", "nsamp", "trace", "use.correction", "tolSolve")] else control <- control[c( "estim", "alpha", "nsamp", "seed", "trace", "use.correction", "tolSolve")] } else if(estim == "m") { if(is.null(control$alpha)) control$alpha <- ifelse(is.null(control$quan), 0.5, control$quan) if(is.null(control$nsamp)) control$nsamp <- ifelse(is.null(control$ntrial), 500, control$ntrial) if(is.null(control$trace)) control$trace <- FALSE if(is.null(control$use.correction)) control$use.correction <- TRUE if(is.null(control$tolSolve)) control$tolSolve <- 1e-14 if(is.null(control$seed)) init.control <- control[c( "estim", "alpha", "nsamp", "trace", "use.correction", "tolSolve")] else init.control <- control[c( "estim", "alpha", "nsamp", "seed", "trace", "use.correction", "tolSolve")] init.control$estim = "mcd" control$init.control <- init.control if(is.null(control$r)) control$r <- 0.45 if(is.null(control$arp)) control$arp <- 0.05 if(is.null(control$eps)) control$eps <- 1e-03 if(is.null(control$maxiter)) control$maxiter <- 120 control <- control[c( "estim", "r", "arp", "eps", "maxiter", "init.control")] } else control <- control["estim"] # Return Value: control } ################################################################################ fAssets/R/plot-hist.R0000644000176000001440000001325512424423203014163 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsHistPlot Displays a histograms of a single asset # assetsLogDensityPlot Displays a pdf plot on logarithmic scale ################################################################################ assetsHistPlot = function(x, col = "steelblue", skipZeros = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays a histograms of a single asset # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)) # par(mfrow = c(3,3)); assetsHistPlot(x); par(mfrow = c(1,1)) # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Plot: for (i in 1:n) { X = x[, i] if (skipZeros) X = X[series(X) != 0] histPlot(X, ylab = "Cumulated Returns", col = col[i], ...) } # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsLogDensityPlot = function(x, estimator = c("hubers", "sample", "both"), labels = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays a pdf plot on logarithmic scale # Arguments: # x - an uni- or multivariate return series of class 'timeSeries' # or any other object which can be transformed by the function # 'as.timeSeries()' into an object of class 'timeSeries'. # estimator - the type of estimator to fit the mean and variance # of the density. # doplot - a logical flag, by default TRUE. Should a plot be # displayed? # labels - a logical flag, by default TRUE. Should a default main # title and labels addet to the plot? # ... - # Details: # Returns a pdf plot on a lin-log scale in comparison to a Gaussian # density plot Two type of fits are available: a normal density with # fitted sample mean and sample standard deviation, or a normal # density with Hubers robust mean and standard deviation corfrected # by the bandwidth of the Kernel estimator. # Example: # x = as.timeSeries(data(LPP2005REC)) # par(mfrow=c(3,3)); assetsLogDensityPlot(x, "hubers"); par(mfrow=c(1,1)) # par(mfrow=c(3,3)); assetsLogDensityPlot(x, "sample"); par(mfrow=c(1,1)) # par(mfrow=c(3,3)); assetsLogDensityPlot(x, "both"); par(mfrow=c(1,1)) # FUNCTION: # Settings: if (!is.timeSeries(x)) x = as.timeSeries(x) Units = colnames(x) doplot = TRUE # Select Type: estimator = match.arg(estimator) # Labels: if (labels) { main = "log PDF" xlab = "x" ylab = "log PDF" } else { main = xlab = ylab = "" } X = x for (i in 1:ncol(x)) { # Transform Data: x = as.vector(X[, i]) if (labels) main = Units[i] # Kernel and Histogram Estimators: Density = density(x) Histogram = hist(x, breaks = "FD", plot = FALSE) result = list(density = Density, hist = Histogram) # Plot: if (doplot) { # Plot Frame: plot(Histogram$mids, log(Histogram$density), type = "n", lwd = 5, main = Units[i], xlab = xlab, ylab = ylab, xlim = range(Density$x), ylim = log(range(Density$y)), col = "red", ...) # Plot Density: points(Density$x, log(Density$y), pch = 19, col = "darkgrey", cex = 0.7) # Sample Line Fit: s = seq(min(Density$x), max(Density$x), length = 1001) if (estimator == "sample" || estimator == "both") { lines(s, log(dnorm(s, mean(x), sd(x))), col = "red", lwd = 2) } # Robust Huber Line Fit: if (estimator == "hubers" || estimator == "both") { h = MASS::hubers(x) logDensity = log(dnorm(s, mean = h[[1]], sd = sqrt(h[[2]]^2+Density$bw^2))) minLogDensity = log(min(Density$y)) lines( x = s[logDensity > minLogDensity], y = logDensity[logDensity > minLogDensity], col = "orange", lwd = 2) } # Plot Histogram: points(Histogram$mids, log(Histogram$density), pch = 19, col = "steelblue", ...) # Grid: if (labels) grid() } } # Return Value: invisible(result) } ################################################################################ fAssets/R/builtin-rmtTawny.R0000644000176000001440000002665412424423203015540 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .filter.RMT Returns filtered correlation matrix from RMT # .mp.density.kernel Returns kernel density estimate # .mp.fit.kernel Function for fitting the density # .mp.rho Theoretical density for a set of eigenvalues. # .mp.theory Calculate and plot the theoretical density distribution # .mp.lambdas Generate eigenvalues for theoretical MP distribution # .dmp Density in R notation style ################################################################################ # Rmetrics: # Note that tawny is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: tawny # Title: Provides various portfolio optimization strategies including # random matrix theory and shrinkage estimators # Version: 1.0 # Date: 2009-03-02 # Author: Brian Lee Yung Rowe # Maintainer: Brian Lee Yung Rowe # License: GPL-2 # Modifications done by Diethelm Wuertz # ... works with Rmetrics S4 timeSeries objects # ... using DEoptim (David Ardia) instead of optim # ------------------------------------------------------------------------------ .filter.RMT <- function(h, trace = TRUE, doplot = TRUE) { # Description: # Returns filtered correlation matrix from random matrix theory # Arguments: # h - a multivariate time series object of class timeSeries # Example: # h = 100 * LPP2005.RET; cor = .filter.RMT(h, FALSE, FALSE) # FUNCTION: # Get Data Part: h = getDataPart(h) # .mp.density.kernel() # Calculating eigenvalue distribution mp.hist <- .mp.density.kernel(h, adjust = 0.2, kernel = 'e', doplot = doplot) # .mp.fit.kernel() # Here we use the DEoptim solver. The reason for this is that the # objective function is not convex, there exist a lot of local minima # ... using David Ardia's DEoptim Package # DW: To do: modify .DEoptim for a better stop criterion for Q and sigma mp.result <- .DEoptim( FUN = .mp.fit.kernel, # Empirically, Q < 0 and sigmas < 0.2 are unrealistic lower = c(Q = 0, sigma = 0.2), upper = c(10, 10), control = list(itermax = 200), trace = trace, hist = mp.hist) # The solution Q and Sigma: mp.Q <- mp.result$optim$bestmem[1] mp.sigma <- mp.result$optim$bestmem[2] if (trace) print(c(mp.Q, mp.sigma)) # Plot: if (doplot) rho <- .mp.theory(mp.Q, mp.sigma) # Cleaning eigenvalues: lambda.1 <- mp.hist$values[1] sigma.2 <- sqrt(1 - lambda.1/length(mp.hist$values)) lambda.plus <- sigma.2^2 * (1 + sqrt(1/mp.Q))^2 # Cleaning correlation matrix: ans = .denoise(mp.hist, lambda.plus, h) if (trace) { cat("Upper cutoff (lambda.max) is",lambda.plus,"\n") cat("Variance is", sigma.2, "\n") cat("Greatest eigenvalue is", lambda.1, "\n") } # Return Value: ans } # ------------------------------------------------------------------------------ .mp.density.kernel <- function(h, adjust = 0.2, kernel = 'e', doplot = TRUE, ...) { # Description: # Returns kernel density estimate # Arguments: # h - a multivariate time series object of class timeSeries # adjust, kernel - arguments passed to function density() # FUNCTION: # Compute normalized correlation matrix: e = cov2cor(cov(h/colSds(h))) # Calculate eigenvalues lambda <- eigen(e, symmetric = TRUE, only.values = FALSE) ds <- density(lambda$values, adjust = adjust, kernel = kernel, ...) ds$ adjust <- adjust ds$kernel <- kernel ds$values <- lambda$values ds$vectors <- lambda$vectors # Plot: if(doplot) plot(ds, xlim = c(0, max(ds$values)*1.2), main = 'Eigenvalue Distribution') # Return Value: return(ds) } # ------------------------------------------------------------------------------ .mp.fit.kernel <- function(ps, hist) { # Description: # Function for fitting the density # Arguments: # ps - a numeric vector with two numeric entries, Q and sigma # hist - histogram as returned by the function .mp.density.kernel(h) # Note: # Calls function .mp.rho() # FUNCTION: # Settings: BIG <- 1e14 zeros <- which(hist$y == 0) wholes <- which(hist$y > 0) after <- head(zeros[zeros > wholes[1]], 1) l.plus <- hist$x[after] Q <- ps[1] sigma <- ps[2] rhos <- .mp.rho(Q, sigma, hist$x) # Just use some very large number to prevent it from being used # as optimal score if (max(rhos) == 0) return(BIG) # Scale densities so that the max values of each are about the same. # This is a bit of hand-waving to get the best fit scale <- max(rhos) / max(hist$y) + 0.25 # Shift the densities to get a better fit whole.idx <- head(rhos[rhos > 0], 1) hist$y <- c( rep(0, whole.idx-1), tail(hist$y, length(hist$y) - whole.idx+1)) # Normalize based on amount of density below MP upper limit # This is basically dividing the distance by the area under # the curve, which gives a bias towards larger areas norm.factor <- sum(rhos[hist$x <= l.plus]) # DW: Check this ... hist$y = hist$y[1:length(rhos)] dy <- (rhos - (hist$y * scale)) / norm.factor # Just calculate the distances of densities less than the MP # upper limit dist <- as.numeric(dy %*% dy) if (is.na(dist)) dist = BIG # Return Value: dist } # ------------------------------------------------------------------------------ .mp.rho <- function(Q, sigma, e.values) { # Description: # This provides the theoretical density for a set of eigenvalues. # These are really just points along the x axis for which the # eigenvalue density is desired. # Arguments: # Q, sigma - Marcenko-Pastur distribution parameters. # e.values - can be a vector of eigen values or a single eigen value. # Example: # e.values = seq(-0.5, 4.5, length = 101) # plot(e.values, .mp.rho(2, 1, e.values), type = "h") # points(e.values, .mp.rho(2, 1, e.values), type = "l", col = "red") # FUNCTION: # Get min and max eigenvalues specified by Marcenko-Pastur l.min <- sigma^2 * (1 - sqrt(1/Q))^2 l.max <- sigma^2 * (1 + sqrt(1/Q))^2 # Provide theoretical density: k <- (Q / 2*pi*sigma^2) rho <- k * sqrt(pmax(0, (l.max-e.values)*(e.values-l.min)) ) / e.values rho[is.na(rho)] <- 0 # Return Value: attr(rho, "e.values") <- e.values rho } # ------------------------------------------------------------------------------ .mp.theory <- function(Q, sigma, e.values = NULL, steps = 200) { # Description: # Calculate and plot the theoretical density distribution # Arguments: # Q, sigma - Marcenko-Pastur distribution parameters. # e.values - The eigenvalues to plot the density against. # This can really be any point on the xaxis. # Note: # calls function .mp.lambdas(), .mp.rho() # Example: # FUNCTION: # Plot a range of values if (is.null(e.values)) { e.values <- .mp.lambdas(Q, sigma, steps) } rho <- .mp.rho(Q, sigma, e.values) if (length(e.values) > 1) { l.min <- sigma^2 * (1 - sqrt(1/Q))^2 l.max <- sigma^2 * (1 + sqrt(1/Q))^2 xs <- seq(round(l.min-1), round(l.max+1), (l.max-l.min)/steps) main <- paste('Marcenko-Pastur Distribution for Q',Q,'and sigma',sigma) plot(xs, rho, xlim = c(0, 6), type = 'l', main = main) } # Return Value: rho } # ------------------------------------------------------------------------------ .mp.lambdas <- function(Q, sigma, steps, trace = FALSE) { # Descrption: # Generate eigenvalues for theoretical Marcenko-Pastur distribution # Arguments: # Q, sigma - Marcenko-Pastur distribution parameters # steps - # trace - # FUNCTION: # Min and Max Eigenvalues: l.min <- sigma^2 * (1 - sqrt(1/Q))^2 l.max <- sigma^2 * (1 + sqrt(1/Q))^2 if (trace) { cat("min eigenvalue:", l.min, "\n") cat("max eigenvalue:", l.max, "\n")} evs <- seq(round(l.min-1), round(l.max+1), (l.max-l.min)/steps) evs[evs < l.min] <- l.min evs[evs > l.max] <- l.max if (trace) { # cat("x labels: ", xs, "\n") cat("eigenvalues: ", evs, "\n") } # Return Value: evs } # ------------------------------------------------------------------------------ .denoise <- function(hist, lambda.plus = 1.6, h = NULL) { # Description: # Clean a correlation matrix based on calculated value of lambda.plus # and the computed eigenvalues. # This takes flattened eigenvalues and returns a new cleaned # correlation matrix # Arguments: # e.values - Cleaned eigenvalues # e.vectors - Eigenvectors of correlation matrix of normalized returns # h - non-normalized returns matrix (only used for labels) # FUNCTION: e.values <- hist$values avg <- mean(e.values[e.values < lambda.plus]) e.values[e.values < lambda.plus] <- avg e.vectors <- hist$vectors c.clean <- e.vectors %*% diag(e.values) %*% t(e.vectors) diags <- diag(c.clean) %o% rep(1, nrow(c.clean)) c.clean <- c.clean / sqrt(diags * t(diags)) if (! is.null(h)) { rownames(c.clean) <- colnames(h) colnames(c.clean) <- colnames(h) } # Return Value: c.clean } # ------------------------------------------------------------------------------ .dmp = function(x, Q = 2, sigma = 1) { # Description: # This provides the theoretical density for a set of eigenvalues. # These are really just points along the x axis for which the # eigenvalue density is desired. # Arguments: # x - # Q, sigma - Marcenko-Pastur distribution parameters. # Example: # x = seq(-0.5, 4.5, length = 1001); plot(x, dmp(x, 2, 1), type = "l") # FUNCTION: # Get min and max eigenvalues specified by Marcenko-Pastur l.min <- sigma^2 * (1 - sqrt(1/Q))^2 l.max <- sigma^2 * (1 + sqrt(1/Q))^2 # Provide theoretical density: k <- (Q / 2*pi*sigma^2) rho <- k * sqrt(pmax(0, (l.max-x)*(x-l.min)) ) / x rho[is.na(rho)] <- 0 # Return Value: rho } ################################################################################ fAssets/R/plot-risk.R0000644000176000001440000001120512424423203014155 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsRiskReturnPlot Displays risk-return diagram of assets # assetsNIGShapeTrianglePlot Displays NIG Shape Triangle ################################################################################ assetsRiskReturnPlot <- function(x, col = "steelblue", percentage = FALSE, scale = 252, labels = TRUE, add = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays risk-return giagram of assets # Arguments: # x - a multivariate 'timeSeries' object # Example: # x = 100 * as.timeSeries(data(LPP2005REC)) # assetsRiskReturnPlot(x) # FUNCTION: # Compute Return and Risk: if (percentage) index = 100 else index = 1 # Compute Return and Risk: y = as.matrix(x) # Sample: Risk1 = index*sqrt(scale)* colStdevs(y) Return1 = index*scale*colMeans(y) # Huber(s): mu2 = mu3 = s2 = s3 = NULL for (i in 1:ncol(y)) { MeanSd2 = MASS::huber(y[, i]) mu2 = c(mu2, MeanSd2$mu) s2 = c(s2, MeanSd2$s) # MeanSd3 = MASS::hubers(y[, i]) # mu3 = c(mu3, MeanSd3$mu) # s3 = c(s3, MeanSd3$s) } Risk2 = index*sqrt(scale)*s2 Return2 = index*scale*mu2 # Risk3 = index*sqrt(scale)*s3 # Return3 = index*scale*mu3 # Colors: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Create Graph Frame: riskRange = range(c(Risk1, Risk2)) riskRange[1] = 0 riskRange[2] = riskRange[2] + 0.10*diff(riskRange) returnRange = range(c(Return1, Return2)) returnRange[1] = returnRange[1] - 0.10*diff(returnRange) returnRange[2] = returnRange[2] + 0.10*diff(returnRange) if (labels) { plot(x = riskRange, y = returnRange, xlab = "Risk", ylab = "Return", type = "n") mtext("Sample versus Robust Estimates", line = 0.5, cex = 0.7) } else { plot(x = riskRange, y = returnRange, xlab = "", ylab = "", type = "n") } # Add all Points: colNames = colnames(x) for (i in 1:length(Risk1)) { points(Risk1[i], Return1[i], col = col[i], cex = 1.5, ...) if (add) { points(Risk2[i], Return2[i], col = col[i], cex = 1.1, ...) } text( Risk1[i] + diff(riskRange/50), Return1[i] + diff(returnRange/50), colNames[i], adj = 0, col = col[i]) } if (labels) grid(col = "darkgrey") # Result: result = rbind(Risk1, Risk2, Return1, Return2) # Return Value: invisible(result) } # ------------------------------------------------------------------------------ assetsNIGShapeTrianglePlot <- function(x, labels = TRUE, col = "steelblue", ...) { # A function implemented by Diethelm Wuertz # Description: # Displays NIG Shape Triangle # Arguments: # x - a multivariate 'timeSeries' object # Example: # x = 100 * as.timeSeries(data(LPP2005REC)) # assetsNIGShapeTrianglePlot(x) # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) colNames = colnames(x) # Shape Triangle: for (i in 1:n) { fit = nigFit(100*x[, i], doplot = FALSE, trace = FALSE) nigShapeTriangle(fit, add = as.logical(i-1), labels = labels, col = col[i], ...) par = fit@fit$estimate alpha = par[1] beta = par[2] delta = par[3] mu = par[4] zeta = 1/sqrt(1 + delta * sqrt(alpha^2 - beta^2)) chi = zeta * (beta/alpha) text(chi+0.01, zeta-0.01, colNames[i], adj = 0, col = col[i]) } # Return Value: invisible() } ################################################################################ fAssets/R/assets-distance.R0000644000176000001440000002102712424423203015326 0ustar ripleyusers # This library is free software, you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation, either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library, if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsDist Computes the distances between assets # FUNCTION: DESCRIPTION: # corDist Returns correlation distance measure # kendallDist Returns kendalls correlation distance measure # spearmanDist Returns spearmans correlation distance measure # mutinfoDist Returns mutual information distance measure # FUNCTION: DESCRIPTION: # euclideanDist Returns Euclidean distance measure # maximumDist Returns maximum distance measure # manhattanDist Returns Manhattan distance measure # canberraDist Returns Canberra distance measure # binaryDist Returns binary distance measure # minkowskiDist Returns Minkowsky distance measure # FUNCTION: DESCRIPTION: # braycurtisDist Returns Bray Curtis distance measure # mahalanobisDist Returns Mahalanobis distance measure # jaccardDist Returns Jaccard distance mesaure # sorensenDist Returns Sorensen distance measure ################################################################################ assetsDist <- function(x, method="cor", ...) { fun <- match.fun(paste(method, "Dist", sep="")) if (method == "mutinfo") { ans <- fun(x, ...) } else { ans <- fun(x) } # Return Value: ans } ################################################################################ corDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns correlation distance # Argument: # x - a bivariate- or multivariate 'timeSeries' object # Example: # corDist(matrix(rnorm(100), ncol=5)) # FUNCTION: # Distance: dist <- as.dist(1-cor(x)) # Return Value: dist } # ------------------------------------------------------------------------------ kendallDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Kendal's correlation distance # FUNCTION: # Distance: dist <- as.dist(1-cor(x, method = "kendall")) # Return Value: dist } # ------------------------------------------------------------------------------ spearmanDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Spearman's correlation distance # FUNCTION: # Distance: dist <- as.dist(1-cor(x, method = "spearman")) # Return Value: dist } ############################################################################### # Selected distance measures from contributed R package bioDist: mutinfoDist <- function(x, nbin=10) { # A function implemented by Diethelm Wuertz # Description: # Returns mutual information distance measure # Note: # borrowed from R package bioDist and slightly modified # FUNCTION: # Distance: x <- t(as.matrix(x)) nc <- ncol(x) nr <- nrow(x) clist <- vector("list", length=nr) for(i in 1:nr) clist[[i]] <- cut(x[i,], breaks=nbin) ppfun <- function(pp) { pp <- pp[pp > 0] -sum(pp*log(pp )) } appfun <- function(x,y) { ppfun(table(x)/nc) + ppfun(table(y)/nc) - ppfun(c(table(x, y)/nc)) } mat <- matrix(rep(NA, nr*nr), ncol = nr) for(i in 1:(nr-1)) { for(j in (i+1):nr) { mat[i,j] <- mat[j,i]<- appfun(clist[[i]], clist[[j]]) } } # Distance: mat <- 1 - sqrt(1 - exp(-2*mat)) colnames(mat) <- rownames(mat) <- rownames(x) dist <- as.dist(mat) # Return Value: dist } ################################################################################ # Selected distance functions from base R Package: # "euclidean", "maximum", "manhattan", # "canberra", "binary", "minkowski" euclideanDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Euclidean distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "euclidean") # Return Value: dist } # ------------------------------------------------------------------------------ maximumDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns maximum distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "maximum") # Return Value: dist } # ------------------------------------------------------------------------------ manhattanDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Manhattan distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "manhattan") # Return Value: dist } # ------------------------------------------------------------------------------ canberraDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Canberra distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "canberra") # Return Value: dist } # ------------------------------------------------------------------------------ binaryDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns binary distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "binary") # Return Value: dist } # ------------------------------------------------------------------------------ minkowskiDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Minkowski distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- dist(x, "minkowski") # Return Value: dist } ################################################################################ # Selected distance from contributed R package ecodist: # "bray-curtis", "mahalanobis", "jaccard", "sorensen" # See builtin script: dist-distEcodist.R braycurtisDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- ecodist::bcdist(x) # Return Value: dist } # ------------------------------------------------------------------------------ mahalanobisDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Mahalanobis distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- ecodist::distance(x, "mahalanobis") # Return Value: dist } # ------------------------------------------------------------------------------ jaccardDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns Jaccard's distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- ecodist::distance(x, "jaccard") # Return Value: dist } # ------------------------------------------------------------------------------ sorensenDist <- function(x) { # A function implemented by Diethelm Wuertz # Description: # Returns difference distance measure # FUNCTION: # Distance: x <- t(as.matrix(x)) dist <- ecodist::distance(x, method="sorensen") # Return Value: dist } ################################################################################ fAssets/R/assets-modeling.R0000644000176000001440000000731412424423203015335 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsFit Fits the parameters of a set of assets # assetsSim Simulates a set of assets ################################################################################ assetsFit <- function(x, method = c("st", "sn", "sc"), title = NULL, description = NULL, fixed.df = NA, ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the parameters of a multivariate data set of assets # and returns a list with the values for the mean, the covariance, # the skewness, and the fatness of tails. # Arguments: # x - A multivariate time series, a data frame, or any other # rectangular object of assets which can be converted into # a matrix by the function as.matrix. Optional Dates are # rownames, instrument names are column names. # method - Which type of distribution should be fitted? # a) st - multivariate skew Student-t # b) sn - multivariate skew Normal # b) sc - multivariate skew-Cauchy # # Value: # The function returns a list with the following entries: # mu - Mean values of each asset time series # Omega - Covariance matrix of assets # alpha - Skewness vector # df - Degrees of freedom, measures kurtosis # Notes: # Requires function "msn.mle" and "mst.mle" from R's GPL licensed # contributed package "sn", (C) 1998-2004 A. Azzalini. # The m[method]Fit functions where the "sn" functionality is used # are implemented within the fMultivar package. # The object returned by this function can serve as input for the # function assetsSim(). # FUNCTION: # Settings: assets <- as.matrix(x) method <- match.arg(method) colNames <- colnames(x) # Select Distribution: FUN <- get(paste0("m", method, "Fit")) # Fit Parameters: ans <- FUN(x=x, trace=FALSE, ...) # Return Value: ans } ################################################################################ assetsSim <- function(n, method=c("st", "sn", "sc"), model=list(beta=rep(0, 2), Omega=diag(2), alpha=rep(0, 2), nu=4), assetNames=NULL) { # A function implemented by Diethelm Wuertz # FUNCTION # Match Method: method <- match.arg(method) # Extract Parameters: xi <- as.vector(model$beta) Omega <- model$Omega alpha <- model$alpha nu <- model$nu # Create Random Numbers: if (method == "st") ans <- sn::rmst(n, xi, Omega, alpha, nu) if (method == "sn") ans <- sn::rmsn(n, xi, Omega, alpha) if (method == "sc") ans <- sn::rmsc(n, xi, Omega, alpha) # Add Optional Asset Names: colnames(ans) <- assetNames # Return Value: ans } ############################################################################### fAssets/R/builtin-mstApe.R0000644000176000001440000001525012424423203015132 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .mst Minimum spanning tree # .sortIndexMST # .mstPlot # .nsca ################################################################################ # Rmetrics: # Note that covRobust is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: ape # Version: 2.3 # Date: 2009-03-30 # Title: Analyses of Phylogenetics and Evolution # Author: Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, # Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, # Gangolf Jobb, Christoph Heibl, Daniel Lawson, Vincent Lefort, # Pierre Legendre, Jim Lemon, Yvonnick Noel, Johan Nylander, # Rainer Opgen-Rhein, Korbinian Strimmer, Damien de Vienne # Maintainer: Emmanuel Paradis # Depends: R (>= 2.6.0) # Suggests: gee # Imports: gee, nlme, lattice # ZipData: no # Description: ape provides functions for reading, writing, plotting, and # manipulating phylogenetic trees, analyses of comparative data # in a phylogenetic framework, analyses of diversification and # macroevolution, computing distances from allelic and nucleotide # data, reading nucleotide sequences, and several tools such as # Mantel's test, computation of minimum spanning tree, the # population parameter theta based on various approaches, # nucleotide diversity, generalized skyline plots, estimation of # absolute evolutionary rates and clock-like trees using mean # path lengths, non-parametric rate smoothing and penalized # likelihood, classifying genes in trees using the # Klastorin-Misawa-Tajima approach. Phylogeny estimation can be # done with the NJ, BIONJ, and ME methods. # License: GPL (>= 2) # URL: http://ape.mpl.ird.fr/ # Packaged: Mon Mar 30 08:46:28 2009; paradis # Repository: CRAN # Date/Publication: 2009-03-30 06:56:17 # ------------------------------------------------------------------------------ .mst <- function(X) { # Description: # The function mst finds the minimum spanning tree between # a set of observations using a matrix of pairwise distances. # Authors: # Original Code: Yvonnick Noel, Julien Claude, and Emmanuel Paradis # Source: # Contributed R-packe "ape". # FUNCTION: # Minimum Spanning Tree: if (class(X) == "dist") X = as.matrix(X) n = dim(X)[1] N = matrix(0, n, n) tree = NULL large.value = max(X) + 1 diag(X) = large.value index.i = 1 for (i in 1:(n - 1)) { tree = c(tree, index.i) # calcul les minimum par colonne m = apply(as.matrix(X[, tree]), 2, min) a = .sortIndexMST(X[, tree])[1, ] b = .sortIndexMST(m)[1] index.j = tree[b] index.i = a[b] N[index.i, index.j] = 1 N[index.j, index.i] = 1 for (j in tree) { X[index.i, j] = large.value X[j, index.i] = large.value } } dimnames(N) = dimnames(X) class(N) = "mst" # Return Value: return(N) } # ------------------------------------------------------------------------------ .sortIndexMST <- function(X) { # Function returning an index matrix for an increasing sort if(length(X) == 1) return(1) # sorting a scalar? if(!is.matrix(X)) X = as.matrix(X) # force vector into matrix # n = nrow(X) apply(X, 2, function(v) order(rank(v))) # find the permutation } # ------------------------------------------------------------------------------ .mstPlot <- function (x, graph = "circle", x1 = NULL, x2 = NULL, ...) { # Description: # Plots the minimum spanning tree showing the links # where the observations are identified by their numbers. # FUNCTION: # Plot: n = nrow(x) if (is.null(x1) || is.null(x2)) { if (graph == "circle") { ang = seq(0, 2 * pi, length = n + 1) x1 = cos(ang) x2 = sin(ang) plot(x1, x2, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", bty = "n", ...) } if (graph == ".nsca") { XY = .nsca(x) x1 = XY[, 1] x2 = XY[, 2] xLim = c(min(x1) - 0.25 * diff(range(x1)), max(x1)) plot(XY, type = "n", xlim = xLim, xlab = "", # "\".nsca\" -- axis 1", ylab = "", # "\".nsca\" -- axis 2", xaxt = "n", yaxt = "n", col = "red", ...) # Legend: Names = colnames(x) legendtext = paste(1:length(Names), Names, sep = "-") legendtext = substr(legendtext, 1, 8) legend("topleft", legend = legendtext, bty = "n", cex = 0.8) } } else { plot(x1, x2, type = "n", xlab = deparse(substitute(x1)), ylab = deparse(substitute(x2)), ...) } for (i in 1:n) { w1 = which(x[i, ] == 1) segments(x1[i], x2[i], x1[w1], x2[w1], lwd = 2) } points(x1, x2, pch = 21, col = "red", bg = "black", cex = 4) text(x1, x2, 1:n, col = "white", cex = 0.7) } # ------------------------------------------------------------------------------ .nsca <- function(A) { # FUNCTION: Dr = apply(A, 1, sum) Dc = apply(A, 2, sum) eig.res = eigen(diag(1 / sqrt(Dr)) %*% A %*% diag(1 / sqrt(Dc))) r = diag(1 / Dr) %*% (eig.res$vectors)[, 2:4] # The next line has been changed by EP (20-02-2003), since # it does not work if 'r' has no dimnames already defined # dimnames(r)[[1]] = dimnames(A)[[1]] rownames(r) = rownames(A) # Return Value: r } ################################################################################ fAssets/R/builtin-shrinkTawny.R0000644000176000001440000001777012424423203016233 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .cov.shrink.tawny # .getCorFilter.Shrinkage # .cov.sample.tawny # .cov.prior.cc # .cov.prior.identity # .cor.mean.tawny # .shrinkage.intensity # .shrinkage.p # .shrinkage.r # .shrinkage.c ################################################################################ # Rmetrics: # Note that tawny is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: tawny # Title: Provides various portfolio optimization strategies including # random matrix theory and shrinkage estimators # Version: 1.0 # Date: 2009-03-02 # Author: Brian Lee Yung Rowe # Maintainer: Brian Lee Yung Rowe # License: GPL-2 # # Perform shrinkage on a sample covariance towards a biased covariance # # This performs a covariance shrinkage estimation as specified in Ledoit # and Wolf. Using within the larger framework only requires using the # getCorFilter.Shrinkage function, which handles the work of constructing # a shrinkage estimate of the covariance matrix of returns (and consequently # its corresponding correlation matrix). # ------------------------------------------------------------------------------ .cov.shrink.tawny <- function(returns, sample = NULL, prior.fun = .cov.prior.cc, ...) { # Shrink the sample covariance matrix towards the model covariance # matrix for the given time window. # model - The covariance matrix specified by the model, e.g. single-index, # Barra, or something else # sample - The sample covariance matrix. If the sample covariance is null, # then it will be computed from the returns matrix # Example # S.hat <- .cov.shrink.tawny(ys) # if (.loglevel.tawny() > 0) cat("Shrinking covariance for",last(index(returns)),"\n") if (is.null(sample)) { S <- .cov.sample.tawny(returns) } else { S <- sample } T <- nrow(returns) # F <- .cov.prior.cc(S) F <- prior.fun(S, ...) k <- .shrinkage.intensity(returns, F, S) d <- max(0, min(k/T, 1)) if (.loglevel.tawny() > 0) cat("Got intensity k =", k, "and coefficient d =",d,"\n") S.hat <- d * F + (1 - d) * S S.hat } # ------------------------------------------------------------------------------ .getCorFilter.Shrinkage <- function(prior.fun = .cov.prior.cc, ...) { # Return a correlation matrix generator that is compatible with the # portfolio optimizer # Example # ws <- optimizePortfolio(ys, 100, .getCorFilter.Shrinkage()) # plotPerformance(ys,ws) function(h) return(cov2cor(.cov.shrink.tawny(h, prior.fun=prior.fun, ...))) } # ------------------------------------------------------------------------------ .cov.sample.tawny <- function(returns) { # Calculate the sample covariance matrix from a returns matrix # Returns a T x N returns matrix # p.cov <- .cov.sample.tawny(p) # X is N x T T <- nrow(returns) X <- t(returns) ones <- rep(1,T) S <- (1/T) * X %*% (diag(T) - 1/T * (ones %o% ones) ) %*% t(X) S } # ------------------------------------------------------------------------------ .cov.prior.cc <- function(S) { # Constant correlation target # S is sample covariance r.bar <- .cor.mean.tawny(S) vars <- diag(S) %o% diag(S) F <- r.bar * (vars)^0.5 diag(F) <- diag(S) return(F) } # ------------------------------------------------------------------------------ .cov.prior.identity <- function(S) { # This returns a covariance matrix based on the identity (i.e. no # correlation) # S is sample covariance return(diag(nrow(S))) } # ------------------------------------------------------------------------------ .cor.mean.tawny <- function(S) { # Get mean of correlations from covariance matrix N <- ncol(S) cors <- cov2cor(S) 2 * sum(cors[lower.tri(cors)], na.rm=TRUE) / (N^2 - N) } # ------------------------------------------------------------------------------ .shrinkage.intensity <- function(returns, prior, sample) { # Calculate the optimal shrinkage intensity constant # returns : asset returns T x N # prior : biased estimator p <- .shrinkage.p(returns, sample) r <- .shrinkage.r(returns, sample, p) c <- .shrinkage.c(prior, sample) (p$sum - r) / c } # ------------------------------------------------------------------------------ .shrinkage.p <- function(returns, sample) { # Sum of the asymptotic variances # returns : T x N - Matrix of asset returns # sample : N x N - Sample covariance matrix # Used internally. # S <- .cov.sample.tawny(ys) # ys.p <- .shrinkage.p(ys, S) T <- nrow(returns) N <- ncol(returns) ones <- rep(1,T) means <- t(returns) %*% ones / T z <- returns - matrix(rep(t(means), T), ncol=N, byrow=TRUE) term.1 <- t(z^2) %*% z^2 term.2 <- 2 * sample * (t(z) %*% z) term.3 <- sample^2 phi.mat <- (term.1 - term.2 + term.3) / T phi <- list() phi$sum <- sum(phi.mat) phi$diags <- diag(phi.mat) phi } # ------------------------------------------------------------------------------ .shrinkage.r <- function(returns, sample, pi.est) { # Estimation for rho when using a constant correlation target # returns : stock returns # market : market returns # Example # S <- .cov.sample.tawny(ys) # ys.p <- .shrinkage.p(ys, S) # ys.r <- .shrinkage.r(ys, S, ys.p) N <- ncol(returns) T <- nrow(returns) ones <- rep(1,T) means <- t(returns) %*% ones / T z <- returns - matrix(rep(t(means), T), ncol=N, byrow=TRUE) r.bar <- .cor.mean.tawny(sample) # Asymptotic covariance estimator term.1 <- t(z^3) %*% z term.2 <- diag(sample) * (t(z) %*% z) term.3 <- sample * (t(z^2) %*% matrix(rep(1,N*T), ncol=N)) # This can be simplified to diag(sample) * sample, but this expansion is # a bit more explicit in the intent (unless you're an R guru) term.4 <- (diag(sample) %o% rep(1,N)) * sample script.is <- (term.1 - term.2 - term.3 + term.4) / T # Create matrix of quotients ratios <- (diag(sample) %o% diag(sample)^-1)^0.5 # Sum results rhos <- 0.5 * r.bar * (ratios * script.is + t(ratios) * t(script.is)) # Add in sum of diagonals of pi sum(pi.est$diags, na.rm = TRUE) + sum(rhos[lower.tri(rhos)], na.rm = TRUE) + sum(rhos[upper.tri(rhos)], na.rm = TRUE) } # ------------------------------------------------------------------------------ .shrinkage.c <- function(prior, sample) { # Misspecification of the model covariance matrix squares <- (prior - sample)^2 sum(squares, na.rm = TRUE) } # ------------------------------------------------------------------------------ .loglevel.tawny <- function (new.level = NULL) { if (!is.null(new.level)) { options(log.level = new.level) } if (is.null(getOption("log.level"))) { return(0) } return(getOption("log.level")) } ################################################################################ fAssets/R/assets-lpm.R0000644000176000001440000001074012424423203014324 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsLPM Computes asymmetric lower partial moments # assetsSLPM Computes symmetric lower partial moments ################################################################################ assetsLPM <- function(x, tau=colMeans(x), a=1.5, ...) { # A function implemented by Diethelm Wuertz # Description: # Computes LPM and CLPM from multivariate time series # Arguments: # x - a multivariate time series, a data frame, or any other # rectangular object of assets which can be converted into # a matrix by the function 'as.matrix'. Optional Dates are # rownames, instrument names are column names. # References: # Nawrocki 1991, Optimal Algorithms and Lower Partial Moment: # Ex-Post Results # Lee 2006, The Strengths and Limitations of Risk Measures in # Real Estate: A Review # Note: # The output of this function can be used for portfolio # optimization. LPM stands for lower partial moments. # Example: # LPP <- as.timeSeries(data(LPP2005REC))[, 1:6]; assetsLPM(LPP) # FUNCTION: # Transform Input: x.mat <- as.matrix(x) nCol <- ncol(x) nRow <- nrow(x) Tau <- matrix(rep(tau, nRow), byrow = TRUE, ncol = nCol) TauX <- Tau-x X.max <- ((TauX) + abs(TauX))/2 # Compute Lower Partial Moments: LPM <- colMeans(X.max^a) # Compute co-LPMs: CLPM <- diag(0, nCol) if (a > 1) { for (i in 1:nCol) { for (j in 1:nCol) { CLPM[i, j] <- mean( (X.max[, i])^(a-1) * TauX[, j] ) } CLPM[i, i] <- LPM[i] } } else if (a == 1) { for (i in 1:nCol) { for (j in 1:nCol) { CLPM[i, j] <- mean( sign( X.max[, i]) * TauX[, j] ) } CLPM[i, i] <- LPM[i] } } # Result: ans <- list(mu = LPM, Sigma = CLPM) attr(ans, "control") <- c(a = a, tau = tau) # Return Value: ans } ################################################################################ assetsSLPM <- function(x, tau=colMeans(x), a=1.5, ...) { # A function implemented by Diethelm Wuertz # Description: # Computes LPM and SLPM from multivariate time series # Arguments: # x - a multivariate time series, a data frame, or any other # rectangular object of assets which can be converted into # a matrix by the function 'as.matrix'. Optional Dates are # rownames, instrument names are column names. # References: # Nawrocki 1991, Optimal Algorithms and Lower Partial Moment: # Ex-Post Results # Lee 2006, The Strengths and Limitations of Risk Measures in # Real Estate: A Review # Note: # The output of this function can be used for portfolio # optimization. SLPM stands for symmetric lower partial moments. # Example: # LPP = as.timeSeries(data(LPP2005REC))[, 1:6]; assetsSLPM(LPP) # FUNCTION: # Transform Input: x.mat <- as.matrix(x) nCol <- ncol(x) nRow <- nrow(x) Tau <- matrix(rep(tau, nRow), byrow = TRUE, ncol = nCol) TauX <- Tau-x X.max <- ((TauX) + abs(TauX))/2 # Compute Lower Partial Moments: LPM <- colMeans(X.max^a) # Compute co-SLPMs: SLPM <- LPM^(1/a) %o% LPM^(1/a) * cor(x.mat) # Result: ans <- list(mu = LPM, Sigma = SLPM) attr(ans, "control") <- c(a = a, tau = tau) # Return Value: ans } ################################################################################ fAssets/R/plot-ellipses.R0000644000176000001440000000706312424423203015034 0ustar ripleyusers # This library is free software, you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation, either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library, if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # covEllipsesPlot Displays a covariance ellipses plot ################################################################################ covEllipsesPlot <- function(x = list(), ...) { # Description: # Displays a covariance ellipses plot # Arguments: # x = a list of at least two covariance matrices # Example: # x = as.timeSeries(data(LPP2005REC))[, 1:6] # Cov = cov(x); robustCov = assetsMeanCov(x, "MCD")$Sigma # covEllipsesPlot(list(Cov, robustCov)) # Source: # Partly based on function covfmEllipsesPlot() from # Package: robust 0.2-2, 2006-03-24 # Maintainer: Kjell Konis # Description: A package of robust methods. # License: Insightful Robust Library License (see license.txt) # FUNCTION: # Settings: if (length(x) == 0) stop("Input must be a list of at least 2 covariance matrices!") nModels = length(x) p <- dim(x[[1]])[1] # Graphics Frame: plot(0, 0, xlim = c(0, p+1), ylim = c(0, p+1), type = "n", axes = FALSE, xlab = "", ylab = "", ...) box() # Correlation Ellipses: for(k in 1:nModels) { s = sqrt(diag(x[[k]])) X = x[[k]] / (s %o% s) xCenters = matrix(rep(1:p, p), byrow = TRUE, ncol = p) yCenters = matrix(rep(p:1, p), ncol = p) points = rep((c(0:180, NA) * pi)/90, (p^2 - p) / 2) cors = as.vector(rbind(matrix(X[row(X) < col(X)], nrow = 181, ncol = (p^2 - p)/2, byrow = TRUE), rep(NA, (p^2 - p)/2))) xs = 0.475 * cos(points + acos(cors)/2) + rep(xCenters[row(xCenters) < col(xCenters)], each = 182) ys = 0.475 * cos(points - acos(cors)/2) + rep(yCenters[row(xCenters) < col(xCenters)], each = 182) polygon(x = xs, y = ys, density = 0, col = k) shift = max(0.2, (p - 8)/88 + 0.2) xs = xCenters[row(xCenters) > col(xCenters)] ys = yCenters[row(yCenters) > col(yCenters)] cors = X[row(X) > col(X)] text(xs, ys + (((shift*(nModels - 1))/2) - shift*(k - 1)), labels = round(cors, digits = max(1, floor(20/p))), col = k, cex = min(1, 90/(p^2))) } # Diagonal Line: lines(c(0.5, p+0.5), c(p+0.5, 0.5), lwd = 2) # Correlation - Text: text(x = cbind(1:p, rep(p + 0.7, p)), labels = dimnames(X)[[2]], cex = 1, adj = 0) text(x = cbind(rep(0.5, p), p:1), labels = dimnames(X)[[1]], cex = 1, adj = 1) legend(x = (p+1)/2, y = 0, legend = unlist(paste("-", names(x), "-")), xjust = 0.5, yjust = 0, text.col = 1:nModels, bty = "n") # Return Value: invisible() } ################################################################################ fAssets/R/plot-qqplot.R0000644000176000001440000000506012424423203014527 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsQQNormPlot Displays normal qq-plots of individual assets ################################################################################ assetsQQNormPlot = function(x, col = "steelblue", skipZeros = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays normal qq-plots of individual assets # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # which - an integer value or vector specifying the number(s) # of the assets which are selected to be plotted. # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Plot: for (i in 1:n) { X = x[, i] if (skipZeros) X = X[series(X) != 0] qqnormPlot(X, col = col[i], ...) } # Return Value: invisible() } ################################################################################ assetsHistPairsPlot <- function(x, bins = 30, method = c("square", "hex"), ...) { # A function implemented by Diethelm Wuertz # Description: # Displays bivariate Histogram Plot # FUNCTION: # Match Arguments: method = match.arg(method) # Check: stopifnot(ncol(x) == 2) # Histogram Plot: X = as.vector(x[, 1]) Y = as.vector(x[, 2]) if (method == "square") { ans = squareBinning(x = X, y= Y, bins = bins) } else if (method == "hex") { ans = hexBinning(x = X, y = Y, bins = bins) } # Plot: plot(ans, ...) # Return Value: invisible(ans) } ################################################################################ fAssets/R/assets-selection.R0000644000176000001440000000653012424423203015523 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsSelect Selects similar or dissimilar assets # .hclustSelect Selects due to hierarchical clustering # .kmeansSelect Selects due to k-means clustering ################################################################################ assetsSelect <- function(x, method = c("hclust", "kmeans"), control = NULL, ...) { # A function implemented by Diethelm Wuertz # Description: # Clusters a set of assets # Arguments: # method - which algorithm should be used? # hclust - Hierarchical clustering on a set of dissimilarities # kmeans - k-means clustering on a data matrix # FUNCTION: # Selection: # do not method = match.arg(method) to allow for user specified clustering method <- method[1] # Transform to matrix: if (class(x) == "timeSeries") { x <- as.matrix(x) } # Compose Function: fun <- paste(".", method, "Select", sep = "") FUN <- get(fun) # Cluster: ans <- FUN(x, control, ...) # Return Value: ans } ################################################################################ .hclustSelect <- function(x, control = NULL, ...) { # A function implemented by Diethelm Wuertz # Description: # Hierarchical Clustering # FUNCTION: # Method: if (is.null(control)) control = c(measure = "euclidean", method = "complete") measure = control[1] method = control[2] # hclust: ans = hclust(dist(t(x), method = measure), method = method, ...) class(ans) = c("list", "hclust") # Return Value: ans } ################################################################################ .kmeansSelect <- function(x, control = NULL, ...) { # A function implemented by Diethelm Wuertz # Description: # kmeans Clustering # Note: # centers must be specified by the user! # FUNCTION: # Method: if (is.null(control)) control = c(centers = 5, algorithm = "Hartigan-Wong") centers = as.integer(control[1]) algorithm = control[2] # kmeans: ans = kmeans(x = t(x), centers = centers, algorithm = algorithm, ...) class(ans) = c("list", "kmeans") # Return Value: ans } ################################################################################fAssets/R/builtin-corrgram.R0000644000176000001440000003007212424423203015514 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .col.corrgram # .panel.pts # .panel.pie # .panel.shade # .panel.txt # .panel.ellipse # .corrgram ################################################################################ # Rmetrics: # Note that corrgram is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: corrgram # Type: Package # Title: Plot a correlogram # Version: 0.1 # Date: 2006-11-28 # Author: Kevin Wright # Maintainer: Kevin Wright, # Description: # Calculates correlation of variables and displays the results graphically. # License: GPL version 2 or later. # Packaged: Thu Nov 30 # ------------------------------------------------------------------------------ .col.corrgram = function(ncol) { # Colors to use for the corrgram # Red > White > Blue # colorRampPalette(c("red","salmon","white","royalblue","navy"))(ncol) # colorRampPalette( # c("lightblue", "mistyrose", "lightcyan", "lavender", "cornsilk"))(ncol) # heat.colors(ncol) cm.colors(ncol) } # ------------------------------------------------------------------------------ .panel.pts = function(x, y, ...) { plot.xy(xy.coords(x, y), type = "p", ...) box(col = "lightgray") } # ------------------------------------------------------------------------------ .panel.pie = function(x, y, ...) { # box(col="gray70") # Coordinates of box usr = par()$usr minx = usr[1] #min(x, na.rm=TRUE) maxx = usr[2] #max(x, na.rm=TRUE) miny = usr[3] #min(y, na.rm=TRUE) maxy = usr[4] #max(y, na.rm=TRUE) # Multiply the radius by .97 so the circles do not overlap rx = (maxx-minx)/2 * .97 ry = (maxy-miny)/2 * .97 centerx = (minx+maxx)/2 centery = (miny+maxy)/2 segments = 60 angles = seq(0,2*pi,length=segments) circ = cbind(centerx + cos(angles)*rx, centery + sin(angles)*ry) lines(circ[,1], circ[,2], col = 'gray30',...) # Overlay a colored polygon corr = cor(x, y, use = 'pair') ncol = 14 pal = .col.corrgram(ncol) col.ind = round(ncol*(corr+1)/2) col.pie = pal[col.ind] segments = round(60*abs(corr),0) # Watch out for the case with 0 segments if(segments > 0){ angles = seq(pi/2, pi/2+(2*pi* -corr), length = segments) circ = cbind(centerx + cos(angles)*rx, centery + sin(angles)*ry) circ = rbind(circ, c(centerx, centery), circ[1, ]) polygon(circ[, 1], circ[, 2], col = col.pie) } } # ------------------------------------------------------------------------------ .panel.shade = function(x, y, ...) { r = cor(x, y, use = 'pair') ncol = 14 pal = .col.corrgram(ncol) col.ind = round(ncol*(r+1)/2) usr = par("usr") # Solid fill: rect(usr[1], usr[3], usr[2], usr[4], col = pal[col.ind], border = NA) # Add diagonal lines: rect(usr[1], usr[3], usr[2], usr[4], density = 5, angle = ifelse(r>0, 45, 135), col = "white") # Boounding box needs to plot on top of the shading, so do it last. box(col = 'lightgray') } # ------------------------------------------------------------------------------ .panel.hist = function(x, y, ...) { # A function implemented by Diethelm Wuertz # Settings: r = cor(x, y, use = 'pair') ncol = 14 pal = .col.corrgram(ncol) col.ind = round(ncol*(r+1)/2) usr = par("usr") # Hexagonal Binning: object = hexBinning(x, y, bins = 10) X = object$x Y = object$y rx = min(diff(unique(sort(X)))) ry = min(diff(unique(sort(Y)))) rt = 2 * ry u = c(rx, 0, -rx, -rx, 0, rx) v = c(ry, rt, ry, -ry, -rt, -ry)/3 N = length(col) z = object$z zMin = min(z) zMax = max(z) Z = (z - zMin)/(zMax - zMin) Z = trunc(Z * (N - 1) + 1) for (i in 1:length(X)) { polygon(u + X[i], v + Y[i], col = col[Z[i]], border = "white") } # points(object$xcm, object$ycm, pch = 19, cex = 1/3, col = "black") box(col = 'lightgray') # Return Value: invisible() } # ------------------------------------------------------------------------------ .panel.txt = function(x = 0.5, y = 0.5, txt, cex, font) { text(x, y, txt, cex = cex, font = font) # box(col = "lightgray") } # ------------------------------------------------------------------------------ .panel.minmax = function(x, ...) { # Put the minimum in the lower-left corner and the # maximum in the upper-right corner minx = round(min(x, na.rm = TRUE),2) maxx = round(max(x, na.rm = TRUE),2) text(minx, minx, minx, cex = 1, adj = c(0, 0)) text(maxx, maxx, maxx, cex = 1, adj = c(1, 1)) } # ------------------------------------------------------------------------------ .panel.ellipse = function(x, y, ...) { # Draw an Ellipse: dfn = 2 dfd = length(x)-1 shape = var(cbind(x,y), na.rm = TRUE) keep = (!is.na(x) & !is.na(y)) center = c(mean(x[keep]),mean(y[keep])) radius = sqrt(dfn*qf(.68,dfn,dfd)) segments = 75 angles = seq(0,2*pi,length=segments) unit.circle = cbind(cos(angles),sin(angles)) ellipse.pts = t(center+radius*t(unit.circle%*%chol(shape))) ellx = ellipse.pts[, 1] elly = ellipse.pts[, 2] # Truncate Ellipse at min/max or at Bounding Box usr = par()$usr minx = usr[1] #min(x, na.rm=TRUE) maxx = usr[2] #max(x, na.rm=TRUE) miny = usr[3] #min(y, na.rm=TRUE) maxy = usr[4] #max(y, na.rm=TRUE) ellx = ifelse(ellx < minx, minx, ellx) ellx = ifelse(ellx > maxx, maxx, ellx) elly = ifelse(elly < miny, miny, elly) elly = ifelse(elly > maxy, maxy, elly) # lines(ellx, elly, col = 'gray30', ...) # Polygon: r = cor(x, y, use = 'pair') ncol = 14 pal = .col.corrgram(ncol) col.ind = round(ncol*(r+1)/2) polygon(ellx, elly, col = pal[col.ind]) # Add a lowess line through the ellipse: ok = is.finite(x) & is.finite(y) if (any(ok)) lines(stats::lowess(x[ok], y[ok], f = 2/3, iter = 3), col = "red", ...) box(col = 'lightgray') } # ------------------------------------------------------------------------------ .panel.copula = function (x, y, ...) { # A function Implemented by Diethelm Wuertz R1 = as.vector(x) R2 = as.vector(y) r1 = R1[R1 != 0 & R2 != 0] fit1 = nigFit(r1, doplot = FALSE) estim1 = fit1@fit$estimate p1 = pnig(r1, estim1[1], estim1[2], estim1[3], estim1[4]) r2 = R2[R1 != 0 & R2 != 0] fit2 = nigFit(r2, doplot = FALSE) estim2 = fit2@fit$estimate p2 = pnig(r2, estim2[1], estim2[2], estim2[3], estim2[4]) # Rescale to get plotted x = (max(r1)-min(r1))*p1 + min(r1) y = (max(r2)-min(r2))*p2 + min(r2) plot.xy(xy.coords(x, y), type = "p", pch = 19, cex = 0.5, ...) box(col = "lightgray") } # ---------------------------------------------------------------------------- .corrgram = function (x, labels, panel = .panel.shade, ..., lower.panel = panel, upper.panel = panel, diag.panel = NULL, text.panel = textPanel, label.pos = 0.5, cex.labels = NULL, font.labels = 1, row1attop = TRUE, gap = 1) { textPanel <- function(x = 0.5, y = 0.5, txt, cex, font) text(x, y, txt, cex = cex, font = font) localAxis = function(side, x, y, xpd, bg, col = NULL, main, oma, ...) { ## Explicitly ignore any color argument passed in as ## it was most likely meant for the data points and ## not for the axis. if(side %% 2 == 1) Axis(x, side = side, xpd = NA, ...) else Axis(y, side = side, xpd = NA, ...) } localPlot = function(..., main, oma, font.main, cex.main) plot(...) localLowerPanel = function(..., main, oma, font.main, cex.main) lower.panel(...) localUpperPanel = function(..., main, oma, font.main, cex.main) upper.panel(...) localDiagPanel = function(..., main, oma, font.main, cex.main) diag.panel(...) dots = list(...) nmdots = names(dots) if (!is.matrix(x)) { x = as.data.frame(x) for(i in seq(along=names(x))) { if(is.factor(x[[i]]) || is.logical(x[[i]])) x[[i]] = as.numeric(x[[i]]) if(!is.numeric(unclass(x[[i]]))) stop("non-numeric argument to 'pairs'") } } else if (!is.numeric(x)) { stop("non-numeric argument to 'pairs'") } panel = match.fun(panel) if((has.lower = !is.null(lower.panel)) && !missing(lower.panel)) lower.panel = match.fun(lower.panel) if((has.upper = !is.null(upper.panel)) && !missing(upper.panel)) upper.panel = match.fun(upper.panel) if((has.diag = !is.null( diag.panel)) && !missing( diag.panel)) diag.panel = match.fun(diag.panel) if(row1attop) { tmp = lower.panel lower.panel = upper.panel upper.panel = tmp tmp = has.lower has.lower = has.upper has.upper = tmp } nc = ncol(x) if (nc < 2) stop("only one column in the argument to 'pairs'") has.labs = TRUE if (missing(labels)) { labels = colnames(x) if (is.null(labels)) labels = paste("var", 1:nc) } else if(is.null(labels)) { has.labs = FALSE } oma = if("oma" %in% nmdots) dots$oma else NULL main = if("main" %in% nmdots) dots$main else NULL if (is.null(oma)) { oma = c(4, 4, 4, 4) if (!is.null(main)) oma[3] = 6 } opar = par(mfrow = c(nc, nc), mar = rep.int(gap/2, 4), oma = oma) on.exit(par(opar)) for (i in if(row1attop) 1:nc else nc:1) for (j in 1:nc) { localPlot(x[, j], x[, i], xlab = "", ylab = "", axes = FALSE, type = "n", ...) if(i == j || (i < j && has.lower) || (i > j && has.upper) ) { mfg = par("mfg") if(i == j) { if (has.diag) { localDiagPanel(as.vector(x[, i]), ...) } if (has.labs) { par(usr = c(0, 1, 0, 1)) if(is.null(cex.labels)) { l.wid = strwidth(labels, "user") cex.labels = max(0.8, min(2, .9 / max(l.wid))) } text.panel(0.5, label.pos, labels[i], cex = cex.labels, font = font.labels) } } else if(i < j) { localLowerPanel(as.vector(x[, j]), as.vector(x[, i]), ...) } else { localUpperPanel(as.vector(x[, j]), as.vector(x[, i]), ...) } if (any(par("mfg") != mfg)) stop("the 'panel' function made a new plot") } else { par(new = FALSE) } } if (!is.null(main)) { font.main = if("font.main" %in% nmdots) dots$font.main else par("font.main") cex.main = if("cex.main" %in% nmdots) dots$cex.main else par("cex.main") mtext(main, 3, 3, TRUE, 0.5, cex = cex.main, font = font.main) } invisible(NULL) } ################################################################################ fAssets/R/builtin-DEoptim.R0000644000176000001440000003122712424423203015244 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .DEoptim Differential evolution optimization solver # .deoptimSummary Summary function # .deoptimPlot Plot function ################################################################################ # Rmetrics: # Note that tawny is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: DEoptim # Version: 1.3-0 # Date: 2008-12-03 # Title: Differential Evolution Optimization # Author: David Ardia # Maintainer: David Ardia # Depends: R (>= 2.2.0) # Description: This package provides the DEoptim function which performs # Differential Evolution Optimization (evolutionary algorithm). # License: GPL version 2 or newer # URL: http://perso.unifr.ch/david.ardia # ------------------------------------------------------------------------------ .DEoptim <- function(FUN, lower, upper, control = list(), trace = TRUE, ...) { # Differential Evolution Optimization # David Ardia, 2008-12-03 # DW: trace added # DW: round replaced by signif if (missing(FUN)) stop("'FUN' is missing") FUN <- match.fun(FUN) if (missing(lower) || missing(upper)) stop("'lower' or 'upper' is missing") if (length(lower) != length(upper)) stop("'lower' and 'upper' are not of same length") if (!is.vector(lower)) lower <- as.vector(lower) if (!is.vector(upper)) upper <- as.vector(upper) if (any(lower > upper)) stop("'lower' > 'upper'") if (any(lower == "Inf")) warning("you set a component of 'lower' to 'Inf'. May imply 'NaN' results") if (any(lower == "-Inf")) warning("you set a component of 'lower' to '-Inf'. May imply 'NaN' results") if (any(upper == "Inf")) warning("you set a component of 'upper' to 'Inf'. May imply 'NaN' results") if (any(upper == "-Inf")) warning("you set a component of 'upper' to '-Inf'. May imply 'NaN' results") ## Sub-functions fn.zeros <- function(nr, nc) matrix(rep.int(0, nr * nc), nrow = nr) fn.checkBoundaries <- function(x, lower, upper) { r <- apply(rbind(lower, x), 2, max) apply(rbind(upper, r), 2, min) } d <- length(lower) con <- list(VTR = -Inf, itermax = 200, initial = NULL, storepopfrom = NULL, storepopfreq = 1, NP = 50, F = 0.8, CR = 0.5, strategy = 2, refresh = 10, digits = 4) con[names(control)] <- control if (con$itermax <= 0) { warning("'itermax' <= 0; set to default value 200\n", immediate. = TRUE) con$itermax <- 200 } if (con$NP < 1) { warning("'NP' < 1; set to default value 50\n", immediate. = TRUE) con$NP <- 50 } NP <- con$NP if (con$F < 0 | con$F > 2) { warning("'F' not in [0,2]; set to default value 0.8\n", immediate. = TRUE) con$F <- 0.8 } if (con$CR < 0 | con$CR > 1) { warning("'CR' not in [0,1]; set to default value 0.5\n", immediate. = TRUE) con$CR <- 0.5 } if (con$strategy < 1 | con$strategy > 5) { warning("'strategy' not in {1,...,5}; set to default value 2\n", immediate. = TRUE) con$strategy <- 2 } con$refresh <- floor(con$refresh) if (con$refresh > con$itermax) con$refresh <- 1 if (is.null(con$initial)) { ## Initialize population and some arrays pop <- matrix(rep.int(lower, NP), nrow = NP, byrow = TRUE) + matrix(runif(NP * d), nrow = NP) * matrix(rep.int(upper - lower, NP), nrow = NP, byrow = TRUE) } else{ warning("'initial' population is set by the user\n", immediate. = TRUE) if (!is.matrix(con$initial)){ warning("'initial' must be a matrix; set it to a matrix\n", immediate. = TRUE) pop <- matrix(con$initial, nrow = NP, ncol = d) } else{ warning("'NP' determined by the number of rows of the 'initial' population\n", immediate = TRUE) NP <- nrow(con$initial) pop <- con$initial if (d != ncol(pop)) warning ("modify the length of 'lower' and 'upper' to match the dimension of 'initial'\n", immediate = TRUE) } } if (is.null(con$storepopfrom)) { con$storepopfrom <- con$itermax+1 } con$storepopfreq <- floor(con$storepopfreq) if (con$storepopfreq > con$itermax) con$storepopfreq <- 1 storepopiter <- 1 storepop <- list() ## initialization popold <- fn.zeros(NP,d) ## toggle population val <- rep.int(0,NP) ## create and reset the "cost array" bestmem <- bestmemit <- rep.int(0,d) ## best population member ever and iteration ## Evaluate the best member after initialization nfeval <- NP ## number of function evaluations val <- apply(pop, 1, FUN, ...) if (any(is.nan(val))) stop ("your function returns 'NaN'; modify it or change 'lower' or 'upper' boundaries") if (any(is.na(val))) stop ("your function returns 'NA'; modify it or change 'lower' or 'upper' boundaries") bestval <- bestvalit <- min(val) ibest <- match(bestvalit, val) bestmem <- pop[ibest,] bestmemit <- matrix(bestmem, nrow = 1) ## DE - optimization ## ## popold is the population which has to compete. It is ## static through one iteration. pop is the newly emerging population. pm1 <- pm2 <- pm3 <- pm4 <- pm5 <- fn.zeros(NP,d) ## initialize population matrix 1 - 5 bm <- ui <- mui <- mpo <- fn.zeros(NP,d) rot <- seq(from = 0, by = 1, to = (NP-1))## rotating index array (size NP) rotd <- seq(from = 0, by = 1, to = (d-1)) ## rotating index array (size d) rt <- fn.zeros(NP,NP) ## another rotating index array rtd <- fn.zeros(d,d) ## rotating index array for exponential crossover a1 <- a2 <- a3 <- a4 <- a5 <- fn.zeros(NP,NP) ## index array 1 - 5 ind <- fn.zeros(4,4) iter <- 1 while (iter <= con$itermax & bestval >= con$VTR){ popold <- pop ## save old population ind <- sample(1:4) ## index pointer array a1 <- sample(1:NP) ## shuffle locations and rotate vectors rt <- (rot + ind[1]) %% NP a2 <- a1[rt + 1] rt <- (rot + ind[2]) %% NP a3 <- a2[rt + 1] rt <- (rot + ind[3]) %% NP a4 <- a3[rt + 1] rt <- (rot + ind[4]) %% NP a5 <- a4[rt + 1] pm1 <- popold[a1,] ## shuffled populations 1 - 5 pm2 <- popold[a2,] pm3 <- popold[a3,] pm4 <- popold[a4,] pm5 <- popold[a5,] bm <- matrix(rep.int(bestmemit[iter,], NP), nrow = NP, byrow = TRUE) ## population filled with ## the best member of the last iteration mui <- matrix(runif(NP * d), nrow = NP) < con$CR ## all random numbers < CR are 1, 0 otherwise mpo <- mui < 0.5 if (con$strategy == 1) { ## best / 1 ui <- bm + con$F * (pm1 - pm2) ## differential variation ui <- popold * mpo + ui * mui ## crossover } else if (con$strategy == 2) { ## rand / 1 ui <- pm3 + con$F * (pm1 - pm2) ## differential variation ui <- popold * mpo + ui * mui ## crossover } else if (con$strategy == 3) { ## rand-to-best / 1 ui <- popold + con$F * (bm - popold) + con$F * (pm1 - pm2) ## differential variation ui <- popold * mpo + ui * mui ## crossover } else if (con$strategy == 4) { ## best / 2 ui <- bm + con$F * (pm1 - pm2 + pm3 - pm4) ## differential variation ui <- popold * mpo + ui * mui ## crossover } else { ## rand / 2 ui <- pm5 + con$F * (pm1 - pm2 + pm3 - pm4) ## differential variation ui <- popold * mpo + ui * mui ## crossover } for (i in 1:NP) ui[i,] <- fn.checkBoundaries(ui[i,], lower, upper) ## check whether ## the components are within the boundaries nfeval <- nfeval + NP tempval <- apply(ui, 1, FUN, ...) ## check cost of competitor if (any(is.nan(tempval))) stop ("'your function returns 'NaN'; modify it or change 'lower' or 'upper' boundaries") if (any(is.na(tempval))) stop ("your function returns 'NA'; modify it or change 'lower' or 'upper' boundaries") ichange <- tempval <= val val[ichange] <- tempval[ichange] pop[ichange,] <- ui[ichange,] bestval <- min(val) bestvalit <- c(bestvalit, bestval) ibest <- match(bestval, val) bestmem <- pop[ibest,] bestmemit <- rbind(bestmemit, bestmem) ## keeppop if (iter >= con$storepopfrom & iter %% con$storepopfreq == 0){ storepop[[storepopiter]] <- pop storepopiter <- storepopiter + 1 } ## refresh output if (con$refresh > 0 & iter %% con$refresh == 0) { if (trace) cat("iteration: ", iter, "best member: " , signif(bestmem, con$digits), "best value: ", signif(bestval, con$digits), "\n") } iter <- iter + 1 } if (!is.null(names(lower))) nam <- names(lower) else if (!is.null(names(upper)) & is.null(names(lower))) nam <- names(upper) else nam <- paste("par", 1:length(lower), sep = "") names(lower) <- names(upper) <- names(bestmem) <- nam dimnames(bestmemit) <- list(1:iter, nam) r <- list(optim = list( bestmem = bestmem, bestval = bestval, nfeval = nfeval, iter = iter-1), member = list( lower = lower, upper = upper, bestvalit = bestvalit, bestmemit = bestmemit, pop = pop, storepop = storepop)) attr(r, "class") <- "DEoptim" return(r) } # ------------------------------------------------------------------------------ .deoptimSummary <- function(object, ...) { digits <- max(5, getOption('digits') - 2) z <- object$optim cat("\n***** summary of DEoptim object *****", "\nbest member : ", round(z$bestmem, digits), "\nbest value : ", round(z$bestval, digits), "\nafter : ", round(z$iter), "iterations", "\nFUN evaluated : ", round(z$nfeval), "times", "\n*************************************\n") invisible(z) } # ------------------------------------------------------------------------------ .deoptimPlot <- function(x, plot.type = c("bestmemit","bestvalit"), ...) { z <- x$member n <- length(z$bestvalit) plot.type <- plot.type[1] if (plot.type == "bestmemit"){ npar <- length(z$lower) nam <- names(z$lower) if (npar == 1){ plot(1:n, z$bestmemit, xlab = "iteration", ylab = "value", main = nam, ...) abline(h = c(z$lower, z$upper), col = 'red') } else if (npar == 2){ plot(z$bestmemit[,1], z$bestmemit[,2], xlab = nam[1], ylab = nam[2], ...) abline(h = c(z$lower[1], z$upper[1]), col = 'red') abline(v = c(z$lower[2], z$upper[2]), col = 'red') } else{ par(mfrow = c(npar,1)) for (i in 1:npar){ plot(1:n, z$bestmemit[,i], xlab = "iteration", ylab = "value", main = nam[i], ...) abline(h = c(z$lower[i], z$upper[i]), col = 'red') } } } else plot(1:n, z$bestvalit, xlab = "iteration", ylab = "function value", main = "convergence plot", ...) } ################################################################################ fAssets/R/assets-testing.R0000644000176000001440000000621412424423203015212 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsTest Tests for multivariate Normal Assets # FUNCTION: DESCRIPTION: # mvshapiroTest Multivariate Shapiro Test # mvenergyTest Multivariate E-Statistic (Energy) Test ################################################################################ assetsTest <- function(x, method = c("shapiro", "energy"), Replicates = 99) { # Description: # Tests for multivariate Normal Assets # Example: # mvnormTest(x = assetsSim(100)) # mvnormTest(x = assetsSim(100), method = "e", Replicates = 99) # FUNCTION: # Test: method <- match.arg(method) if (method == "shapiro") { test <- mvshapiroTest(x) } if (method == "energy") { test <- mvenergyTest(x, Replicates = Replicates) } # Return Value: test } # ------------------------------------------------------------------------------ mvshapiroTest <- function(x) { # Description: # Computes Shapiro's normality test for multivariate variables # Requires: # Package: mvnormtest # Version: 0.1-6 # Date: 2005-04-02 # Title: Normality test for multivariate variables # Author: Slawomir Jarek # Maintainer: Slawomir Jarek # Description: Generalization of shapiro-wilk test for # multivariate variables. # License: GPL # Example: # mvshapiroTest(x = assetsSim(100)) # FUNCTION: # Transform: U <- t(as.matrix(x)) # Test test <- mvnormtest::mshapiro.test(U) # Return Value: test } # ------------------------------------------------------------------------------ mvenergyTest <- function(x, Replicates = 99) { # Description: # Computes E-statistics test for multivariate variables # Requires: # Package: energy # Author: Maria L. Rizzo and # Gabor J. Szekely # License: GPL 2.0 or later # Example: # mvenergyTest(x = assetsSim(100), 99) # FUNCTION: # Transform: x <- as.matrix(x) # Test: test <- energy::mvnorm.etest(x, R = Replicates) # Return Value: test } ################################################################################ fAssets/R/assets-arrange.R0000644000176000001440000001430012424423203015147 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsArrange Rearranges the columns in a deta set of assets # FUNCTION: DESCRIPTION: # pcaArrange Returns PCA correlation ordered column names # hclustArrange Returns hierarchical clustered column names # abcArrange Returns sorted column names # orderArrange Returns ordered column names # sampleArrange Returns sampled column names # statsArrange Returns statistically rearranged column names ################################################################################ assetsArrange <- function(x, method = c("pca", "hclust", "abc"), ...) { # A function implemented by Diethelm Wuertz # Description: # Returns ordered column names of a time Series # Arguments: # x - S4 object of class 'timeSeries' # FUNCTION: # Settings: method <- match.arg(method) FUN <- paste(method, "Arrange", sep = "") arrange <- match.fun(FUN) # Return Value: arrange(x, ...) } # ------------------------------------------------------------------------------ pcaArrange <- function(x, robust = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Returns PCA correlation ordered column names # Arguments: # x - S4 object of class 'timeSeries' # Notes: # Requires package "robustbase". # FUNCTION: # Order: if (robust) { x.cor <- robustbase::covMcd(as.matrix(x), cor = TRUE, ...)$cor } else { x.cor <- cor(as.matrix(x), ...) } x.eigen <- eigen(x.cor)$vectors[,1:2] e1 <- x.eigen[, 1] e2 <- x.eigen[, 2] Order <- order(ifelse(e1 > 0, atan(e2/e1), atan(e2/e1)+pi)) ans <- colnames(as.matrix(x))[Order] # Return Value: ans } # ------------------------------------------------------------------------------ hclustArrange <- function(x, method = c("euclidean", "complete"), ...) { # A function implemented by Diethelm Wuertz # Description: # Returns hierarchical clustered column names # Arguments: # x - S4 object of class 'timeSeries' # ... # method - the agglomeration method to be used. This should # be (an unambiguous abbreviation of) one of "ward", "single", # "complete", "average", "mcquitty", "median" or "centroid". # FUNCTION: # Order: Order <- hclust( dist(t(as.matrix(x)), method = method[1]), method = method[2], ...)$order ans <- colnames(as.matrix(x))[Order] # Return Value: ans } # ------------------------------------------------------------------------------ abcArrange <- function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Returns sorted column names of a time Series # Arguments: # x - S4 object of class 'timeSeries' # FUNCTION: # Sort: ans <- sort(colnames(as.matrix(x)), ...) # Return Value: ans } # ------------------------------------------------------------------------------ orderArrange <- function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Returns ordered column names of a time Series # Arguments: # x - S4 object of class 'timeSeries' # FUNCTION: # Order: ans <- order(colnames(as.matrix(x)), ...) # Return Value: ans } # ------------------------------------------------------------------------------ sampleArrange <- function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Returns sampled column names of a time Series # Arguments: # x - S4 object of class 'timeSeries' # FUNCTION: # Sample: ans <- sample(colnames(as.matrix(x)), ...) # Return Value: ans } # ------------------------------------------------------------------------------ statsArrange <- function(x, FUN = colMeans, ...) { # A function implemented by Diethelm Wuertz # Description: # Returns statistically rearranged column names # Arguments: # x - S4 object of class 'timeSeries' # Note: # Example of function Candidates: # colStats calculates column statistics, # colSums calculates column sums, # colMeans calculates column means, # colSds calculates column standard deviations, # colVars calculates column variances, # colSkewness calculates column skewness, # colKurtosis calculates column kurtosis, # colMaxs calculates maximum values in each column, # colMins calculates minimum values in each column, # colProds computes product of all values in each column, # colQuantiles computes quantiles of each column. # FUNCTION: # Apply colStats Function: fun <- match.fun(FUN) Sort <- sort(fun(x, ...)) Order <- names(Sort) ans <- colnames(as.matrix(x)[, Order]) attr(ans, "control") <- Sort # Return Value: ans } ################################################################################ fAssets/R/plot-mst.R0000644000176000001440000000452312424423203014015 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsTreePlot Displays a minimum spanning tree of assets ################################################################################ assetsTreePlot <- function(x, labels = TRUE, title = TRUE, box = TRUE, method = "euclidian", seed = NULL, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays a minimum spanning tree of assets # Arguments: # x - # labels - # title - # box - # method - # seed - # Example: # x = as.timeSeries(data(LPP2005REC))[, 1:6] # .assetsTreePlot(x) # try several radom choices # .assetsTreePlot(x) # .assetsTreePlot(x) # FUNCTION: # Settings: if (title) { Main = substitute(x) } else { Main = "" } # Compute Distance Matrix: Order = NULL if (class(x) == "dist") { DIST = x } else { # Rank Seed: x = series(x) if (is.null(seed)) { Order = sample(1:ncol(x)) x = x[, Order] } DIST = dist(t(x), method[1]) } method = attr(DIST, "method") # Compute Minimum Spanning Tree" MST = .mst(DIST) # Plot Tree: .mstPlot(MST, ".nsca", main = Main, ...) mtext(paste("Distance Method:", method), side = 4, line = 0.1, adj = 0, col = "darkgrey", cex = 0.7) # Return Value: invisible(list(mst = MST, dist = DIST, order = Order)) } ################################################################################ fAssets/R/plot-binning.R0000644000176000001440000000374212424423203014640 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsHistPairsPlot Displays a bivariate histogram plot ################################################################################ assetsHistPairsPlot <- function(x, bins = 30, method = c("square", "hex"), ...) { # A function implemented by Diethelm Wuertz # Description: # Displays bivariate Histogram Plot # Arguments: # x - timeSeries # bins - histogram bins # method - plot method # Example: # x <- 100 * as.timeSeries(data(LPP2005REC))[, c("SBI", "SPI")] # assetsHistPairsPlot(x, bins = 20) # assetsHistPairsPlot(x, bins = 20, method = "hex") # FUNCTION: # Match Arguments: method <- match.arg(method) # Check: stopifnot(ncol(x) == 2) # Histogram Plot: X <- as.vector(x[, 1]) Y <- as.vector(x[, 2]) if (method == "square") { ans <- squareBinning(x = X, y= Y, bins = bins) } else if (method == "hex") { ans <- hexBinning(x = X, y = Y, bins = bins) } # Plot: plot(ans, ...) # Return Value: invisible(ans) } ################################################################################ fAssets/R/builtin-arwMvoutlier.R0000644000176000001440000001020512424423203016374 0ustar ripleyusers # This library is free software, you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation, either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library, if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .cov.arw Energy test for multivariate normality ################################################################################ # Rmetrics: # Note that mvoutlier is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: mvoutlier # Version: 1.4 # Date: 2009-01-21 # Title: Multivariate outlier detection based on robust methods # Author: Moritz Gschwandtner and # Peter Filzmoser # Maintainer: Peter Filzmoser # Depends: R (>= 1.9.0), robustbase, stats # Description: This packages was made for multivariate outlier detection. # License: GPL version 2 or newer # URL: http://www.statistik.tuwien.ac.at/public/filz/ # ------------------------------------------------------------------------------ .cov.arw <- function(x, center, cov, alpha = 0.025, pcrit = NULL) { # Description: # Adaptive reweighted estimator for multivariate location and # scatter with hard-rejection weights and delta = chi2inv(1-d, p) # Arguments # x - Dataset (n x p) # center - Initial location estimator (1 x p) # cov - Initial scatter estimator (p x p) # alpha - Maximum thresholding proportion # (optional scalar, default: alpha = 0.025) # pcrit - critical value for outlier probability # (optional scalar, default values from simulations) # Value: # center - Adaptive location estimator (p x 1) # cov - Adaptive scatter estimator (p x p) # cn - Adaptive threshold (scalar) # w - Weight vector (n x 1) # FUNCTION: # Settings: x <- getDataPart(x) n <- nrow(x) p <- ncol(x) # Critical value for outlier probability based on # simulations for alpha = 0.025 if (missing(pcrit)) { if (p <= 10) pcrit <- (0.24 - 0.003 * p)/sqrt(n) if (p > 10) pcrit <- (0.252 - 0.0018 * p)/sqrt(n) } # Critical value for outlier probability based on # simulations for alpha = 0.025 if (p <= 10) pcrit <- (0.24-0.003*p)/sqrt(n) if (p > 10) pcrit <- (0.252-0.0018*p)/sqrt(n) delta <- qchisq(1 - alpha, p) d2 <- mahalanobis(x, center, cov) d2ord <- sort(d2) dif <- pchisq(d2ord,p) - (0.5:n)/n i <- (d2ord >= delta) & (dif > 0) if (sum(i) == 0) alfan <- 0 else alfan <- max(dif[i]) if (alfan < pcrit) alfan <- 0 if (alfan > 0) cn <- max(d2ord[n-ceiling(n*alfan)], delta) else cn <- Inf w <- d2 < cn if(sum(w) != 0) { center <- apply(x[w, ], 2, mean) c1 <- as.matrix(x - rep(1, n) %*% t(center)) cov <- (t(c1) %*% diag(w) %*% c1) / sum(w) } # Return Value: list(center = center, cov = cov, cn = cn, w = w) } ################################################################################ fAssets/R/builtin-corpcor.R0000644000176000001440000003032112424423203015344 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .cov.shrink Builtin from Package 'corpcor' # .cor.shrink # .varcov # .cov.bagged Builtin from Package 'corpcor' # .cor.bagged # .bag.fun # .robust.cov.boot # .sm2vec # .smindexes # .vec2sm ################################################################################ # Rmetrics: # Note that corpcor is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: corpcor # Version: 1.1.2 # Date: 2005-12-12 # Title: Efficient Estimation of Covariance and (Partial) Correlation # Author: Juliane Schaefer and # Korbinian Strimmer . # Maintainer: Korbinian Strimmer # Depends: R (>= 2.0.0) # Suggests: # Description: This package implements a shrinkage estimator to allow # the efficient inference of large-scale covariance matrices # from small sample data. The resulting estimates are always # positive definite, more accurate than the empirical estimate, # well conditioned, computationally inexpensive, and require # only little a priori modeling. The package also contains # similar functions for inferring correlations and partial # correlations. In addition, it provides functions for fast svd # computation, for computing the pseuoinverse, and # for checking the rank and positive definiteness of a matrix. # License: GPL version 2 or newer # URL: http://www.statistik.lmu.de/~strimmer/software/corpcor/ # Packaged: Mon Dec 12 13:07:22 2005; strimmer # ------------------------------------------------------------------------------ .cov.shrink <- function(x, lambda, verbose = FALSE) { x = as.matrix(x) # Shrinkage correlation coefficients R.star <- .cor.shrink(x, lambda = lambda, verbose=verbose) # Unbiased empirical variances V = apply(x, 2, var) resid.sd = sqrt(V) ans <- sweep(sweep(R.star, 1, resid.sd, "*"), 2, resid.sd, "*") # Return Value: ans } # ------------------------------------------------------------------------------ .cor.shrink <- function(x, lambda, verbose = FALSE) { # Standardize data (and turn x into a matrix) sx <- scale(x) p = dim(sx)[2] if(p == 1) return( as.matrix(1) ) # Estimate variance of empirical correlation coefficients vc = .varcov(sx, type = "unbiased", verbose) # Find optimal lambda: if(missing(lambda)) { offdiagsum.rij.2 = sum(vc$S[lower.tri(vc$S)]^2) offdiagsum.v.rij = sum(vc$var.S[lower.tri(vc$var.S)]) lambda = offdiagsum.v.rij/offdiagsum.rij.2 if(verbose) cat(paste("Estimated shrinkage intensity lambda: ", round(lambda,4), "\n")) } if(lambda > 1) { warning(paste("Overshrinking: lambda set to 1 (allowed range: 0-1)")) lambda = 1 } else if(lambda < 0) { warning(paste("Undershrinking: lambda set to 0 (allowed range: 0-1)")) lambda = 0 } # construct shrinkage estimator R.star = (1-lambda) * vc$S diag(R.star) = rep(1, p) attr(R.star, "lambda") = lambda # Return Value: R.star } # ------------------------------------------------------------------------------ .varcov <- function(x, type = c("unbiased", "ML"), verbose = FALSE) { # Details: # compute the empirical covariance matrix S=cov(x) given a data # matrix x as well as the *variances* associated with the individual # entries S[i,j] x = as.matrix(x) n = dim(x)[1] p = dim(x)[2] # Weights for the "unbiased" and "ML" cases type = match.arg(type) if(type == "unbiased") { h1 = 1/(n-1) h2 = n/(n-1)/(n-1) } if(type == "ML") { h1 = 1/n h2 = (n-1)/n/n } s = matrix(NA, ncol = p, nrow = p) vs = matrix(NA, ncol = p, nrow = p) xc = scale(x, scale=FALSE) # center the data # Diagonal elements: for (i in 1:p) { zii = xc[,i]^2 s[i, i] = sum(zii)*h1 vs[i, i] = var(zii)*h2 } if(p == 1) return(list(S = s, var.S = vs)) if(verbose && p > 50) cat(paste("Computing ... wait for", p, "dots (50 per row):\n")) # Off-diagonal elements for (i in 1:(p-1)) { if(verbose && p > 50) { cat(".") if(i %% 50 == 0) cat(paste(" ", i, "\n")) } for (j in (i+1):p) { zij = xc[,i]*xc[, j] s[i, j] = sum(zij)*h1 s[j, i] = s[i,j] vs[i, j] = var(zij)*h2 vs[j, i] = vs[i, j] } } if(verbose && p > 50) cat(paste(". ", i+1, "\n")) # Return Value: return(list(S = s, var.S = vs)) } ################################################################################ # cov.bagged.R (2004-03-15) # Variance reduced estimators of cov, cor, and pcor # using bootstrap aggregation ("bagging") # Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer # Package: corpcor # Version: 1.1.2 # Date: 2005-12-12 # Title: Efficient Estimation of Covariance and (Partial) Correlation # Author: Juliane Schaefer and # Korbinian Strimmer . # Maintainer: Korbinian Strimmer # Depends: R (>= 2.0.0) # Suggests: # Description: This package implements a shrinkage estimator to allow # the efficient inference of large-scale covariance matrices # from small sample data. The resulting estimates are always # positive definite, more accurate than the empirical estimate, # well conditioned, computationally inexpensive, and require # only little a priori modeling. The package also contains # similar functions for inferring correlations and partial # correlations. In addition, it provides functions for fast svd # computation, for computing the pseuoinverse, and # for checking the rank and positive definiteness of a matrix. # License: GPL version 2 or newer # URL: http://www.statistik.lmu.de/~strimmer/software/corpcor/ # Packaged: Mon Dec 12 13:07:22 2005; strimmer .cov.bagged <- function(x, R = 1000, ...) { vec.out = .bag.fun(cov, x, R = R, diag = TRUE, ...) mat.out = .vec2sm(vec.out, diag = TRUE) # Return Value: mat.out } # ------------------------------------------------------------------------------ .cor.bagged <- function(x, R = 1000, ...) { vec.out = .bag.fun(cor, x, R = R, diag = FALSE, ...) mat.out = .vec2sm(vec.out, diag = FALSE) # Fill diagonal with 1 diag(mat.out) = rep(1, dim(mat.out)[1]) # Return Value: mat.out } # ------------------------------------------------------------------------------ .bag.fun <- function(fun, data, R, diag, ...) { # Number of variables p = dim(data)[2] # Index vector for lower triangle lo = lower.tri(matrix(NA, nrow=p, ncol=p), diag=diag) # bootstrap function .bootFun = function(data, i) { vec = as.vector( fun(data[i,], ...)[lo] ) # if we get NAs flag result as being erroneous if(sum(is.na(vec)) > 0) class(vec) = "try-error" return( vec ) } # Bag variable boot.out = .robust.cov.boot(data = data, statistic = .bootFun, R = R) bag = apply( boot.out$t, 2, mean) # Return Value: bag } # ------------------------------------------------------------------------------ .robust.cov.boot <- function(data, statistic, R) { # Description: # Simple bootstrap function (robust against errors) idx = 1:dim(data)[1] # Determine dimension of statistic repeat { bx = sample(idx, replace = TRUE) val = try(statistic(data, bx)) if(class(val) != "try-error") break } dim.statistic = length(val) output = matrix(nrow = R, ncol = dim.statistic) replicate.count = 0 error.count = 0 while (replicate.count < R) { bx = sample(idx, replace=TRUE) val = try(statistic(data, bx)) # if we get a numerical error we simply repeat the draw .. if(class(val) == "try-error") { error.count = error.count+1 if(error.count > R) stop("Too many errors encountered during the bootstrap.") } else { replicate.count = replicate.count+1 output[replicate.count, ] = val } } if(error.count > 0) { warning(paste(error.count, "out of", R, "bootstrap samples were repeated due to errors.")) } # Result: ans = list(t = output) # Return Value: ans } ################################################################################ # smtools.R (2004-01-15) # Convert symmetric matrix to vector and back # Copyright 2003-04 Korbinian Strimmer # # This file is part of the 'corpcor' library for R and related languages. # It is made available under the terms of the GNU General Public # License, version 2, or at your option, any later version, # incorporated herein by reference. # # This program is distributed in the hope that it will be # useful, but WITHOUT ANY WARRANTY; without even the implied # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. See the GNU General Public License for more # details. # # You should have received a copy of the GNU General Public # License along with this program; if not, write to the Free # Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, # MA 02111-1307, USA .sm2vec = function(m, diag = FALSE) { # Description: # Convert symmetric matrix to vector ans = as.vector(m[lower.tri(m, diag)]) # Return Value: ans } # ------------------------------------------------------------------------------ .smindexes <- function(m, diag = FALSE) { # Descriiption: # Corresponding indexes m.dim = length(diag(m)) if(diag == TRUE) { num.entries = m.dim*(m.dim+1)/2 } else { num.entries = m.dim*(m.dim-1)/2 } index1 = rep(NA, num.entries ) index2 = rep(NA, num.entries ) if(diag == TRUE) { delta = 0 } else { delta = 1 } z = 1 for (i in 1:(m.dim-delta)) { for (j in (i+delta):m.dim) { index1[z] = i index2[z] = j z = z+1 } } ans = cbind(index1, index2) # Return Value: ans } # ------------------------------------------------------------------------------ .vec2sm <- function(vec, diag = FALSE, order = NULL) { # Description: # Convert vector to symmetric matrix # Note: # If diag=FALSE then the diagonal will consist of NAs # dimension of matrix n = (sqrt(1+8*length(vec))+1)/2 if(diag == TRUE) n = n-1 if( ceiling(n) != floor(n) ) stop("Length of vector incompatible with symmetric matrix") # fill lower triangle of matrix m = matrix(NA, nrow = n, ncol = n) lo = lower.tri(m, diag) if(is.null(order)) { m[lo] = vec } else { # sort vector according to order vec.in.order = rep(NA, length(order)) vec.in.order[order] = vec m[lo] = vec.in.order } # symmetrize for (i in 1:(n-1)) { for (j in (i+1):n) { m[i, j] = m[j, i] } } # Return Value: m } ################################################################################ fAssets/R/plot-panels.R0000644000176000001440000002144212424423203014473 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # .txtPanel a diagonal text panel # .minmaxPanel a diagonal minmax text panel # .histPanel a diagonal histogram panel # FUNCTION: DESCRIPTION: # .ptsPanel an off-diagonal points panel # .piePanel an off-diagonal pie panel # .piePtsPanel an off-diagonal pie/points panel # .shadePanel an off-diagonal shade panel # .ellipsePanel an off-diagonal ellipse panel # .cortestPanel an off-diagonal cortest panel # .lowessPanel an off-diagonal lowess panel # .numberPanel an off-diagonal lowess panel ################################################################################ .txtPanel <- function(x = 0.5, y = 0.5, txt, cex, font, col.box = "white") { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Text Panel: text(x, y, txt, cex = cex, font = font) # Add Box: box(col = col.box) } # ------------------------------------------------------------------------------ .minmaxPanel <- function(x, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Put the minimum in the lower-left corner and the # maximum in the upper-right corner minx <- round(min(x, na.rm = TRUE), 2) maxx <- round(max(x, na.rm = TRUE), 2) text(minx, minx, minx, cex = 1, adj = c(0,0)) text(maxx, maxx, maxx, cex = 1, adj = c(1,1)) } # ------------------------------------------------------------------------------ .histPanel <- function(x, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: usr <- par("usr"); on.exit(par(usr)) par(usr = c(usr[1:2], 0, 1.5) ) h <- hist(x, plot = FALSE) breaks <- h$breaks nB <- length(breaks) y <- h$counts y <- y/max(y) rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...) } # ------------------------------------------------------------------------------ .ptsPanel <- function(x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: plot.xy(xy.coords(x, y), type = "p", ...) box(col = col.box) } # ------------------------------------------------------------------------------ .piePanel <- function(x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Coordinates of box: usr <- par()$usr minx <- usr[1] #min(x, na.rm = TRUE) maxx <- usr[2] #max(x, na.rm = TRUE) miny <- usr[3] #min(y, na.rm = TRUE) maxy <- usr[4] #max(y, na.rm = TRUE) # Multiply the radius by 0.97 so the circles do not overlap rx <- (maxx-minx)/2 * 0.97 ry <- (maxy-miny)/2 * 0.97 centerx <- (minx+maxx)/2 centery <- (miny+maxy)/2 segments <- 60 angles <- seq(0, 2*pi, length = segments) circ <- cbind(centerx + cos(angles)*rx, centery + sin(angles)*ry) lines(circ[,1], circ[,2], col = 'gray30',...) # Overlay a colored polygon corr <- cor(x, y, use = 'pair') ncol <- 14 pal <- .col.corrgram(ncol) col.ind <- round(ncol*(corr+1)/2) col.pie <- pal[col.ind] # Watch out for the case with 0 segments: segments <- round(60*abs(corr),0) if(segments > 0) { angles <- seq(pi/2, pi/2+(2*pi* -corr), length=segments) circ <- cbind(centerx + cos(angles)*rx, centery + sin(angles)*ry) circ <- rbind(circ, c(centerx, centery), circ[1, ]) polygon(circ[,1], circ[,2], col = col.pie) } box(col = col.box) } # ------------------------------------------------------------------------------ .piePtsPanel <- function(x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # Example: # x = series(100*as.timeSeries(data(LPP2005REC))[, 1:6]) # pairs(x, tick = FALSE) # FUNCTION: # Pie Panel: .piePanel(x, y, col.box = "white", ...) # Add Points: points(x, y, ...) } # ------------------------------------------------------------------------------ .shadePanel <- function(x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: r <- cor(x, y, use = 'pair') ncol <- 14 pal <- .col.corrgram(ncol) col.ind <- round(ncol*(r+1)/2) usr <- par("usr") # Solid fill: rect(usr[1], usr[3], usr[2], usr[4], col = pal[col.ind], border = NA) # Add diagonal lines: rect(usr[1], usr[3], usr[2], usr[4], density = 5, angle = ifelse(r>0, 45, 135), col="white") # Bounding box needs to plot on top of the shading, so do it last. box(col = col.box) } # ------------------------------------------------------------------------------ .ellipsePanel <- function(x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Draw an ellipse: # box(col="white") dfn <- 2 dfd <- length(x)-1 shape <- var(cbind(x,y),na.rm=TRUE) keep <- (!is.na(x) & !is.na(y)) center <- c(mean(x[keep]),mean(y[keep])) radius <- sqrt(dfn*qf(.68,dfn,dfd)) segments <- 75 angles <- seq(0,2*pi,length=segments) unit.circle <- cbind(cos(angles),sin(angles)) ellipse.pts <- t(center+radius*t(unit.circle%*%chol(shape))) ellx <- ellipse.pts[,1] elly <- ellipse.pts[,2] # Truncate ellipse at min/max or at bounding box usr <- par()$usr minx <- usr[1] #min(x, na.rm=TRUE) maxx <- usr[2] #max(x, na.rm=TRUE) miny <- usr[3] #min(y, na.rm=TRUE) maxy <- usr[4] #max(y, na.rm=TRUE) ellx <- ifelse(ellx < minx, minx, ellx) ellx <- ifelse(ellx > maxx, maxx, ellx) elly <- ifelse(elly < miny, miny, elly) elly <- ifelse(elly > maxy, maxy, elly) lines(ellx, elly, col='gray30',...) # Fill Ellipse: # polygon(ellx, elly, col = "blue", ...) # Add a lowess line through the ellipse ok <- is.finite(x) & is.finite(y) if (any(ok)) lines(stats::lowess(x[ok], y[ok], f = 2/3, iter = 3), col = "red", ...) box(col = col.box) } # ------------------------------------------------------------------------------ .cortestPanel <- function(x, y, cex, col, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: if (missing(col)) col = NULL usr = par("usr") on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) r = abs(cor(x, y)) txt = format(c(r, 0.123456789), digits = 3)[1] test = cor.test(x, y) Signif = symnum(test$p.value, corr = FALSE, na = FALSE, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("*** ", "** ", "* ", ". ", " ")) text(0.5, 0.5, txt, cex = 1, col = NULL, ...) text(0.8, 0.8, Signif, cex = 1.5, col = col, ...) } # ------------------------------------------------------------------------------ .lowessPanel = function (x, y, col.box = "white", ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: points(x, y, ...) ok = is.finite(x) & is.finite(y) if (any(ok)) lines(lowess(x[ok], y[ok]), col = "brown") box(col = col.box) } # ------------------------------------------------------------------------------ .numberPanel <- function(x, y, cex, col, ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: if (missing(col)) col = NULL usr = par("usr") on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) # Correletion Coefficient number = as.character(round(100*cor(x, y))) text(0.5, 0.5, number, cex = 1, col = NULL, ...) } ################################################################################ fAssets/R/plot-stars.R0000644000176000001440000001631412424423203014347 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsStarsPlot Draws segment/star diagrams of asset sets # FUNCTION: DESCRIPTION: # assetsBasicStatsPlot Displays a segment plot of basic return stats # assetsMomentsPlot Displays a segment plot of distribution moments # assetsBoxStatsPlot Displays a segment plot of box plot statistics # assetsNIGFitPlot Displays a segment plot NIG parameter estimates ################################################################################ assetsStarsPlot <- function(x, method = c("segments", "stars"), locOffset = c(0, 0), keyOffset = c(0, 0), ...) { # A function implemented by Diethelm Wuertz # Description: # Draws segment or star diagrams of a multivariate data set. # Arguments # x - a numeric feature matrix of assets. Each column represents # an individual asset. # Example: # x = as.timeSeries(data(LPP2005REC)) # X = basicStats(x)[-(1:2), 1:6] # assetsStarsPlot(X, main = "Basic Statistics", keyOffset = -0.5) # FUNCTION: # Settings: method = match.arg(method) if (method == "segments") draw.segments = TRUE else draw.segments = FALSE # Compute Locations: xCol = ncol(x) yCol = nrow(x) NY = NX = ceiling(sqrt(xCol)) if (NX*NY == xCol) NY = NY + 1 loc = NULL for (nx in 1:NY) for (ny in 1:NX) loc = rbind(loc, c(nx, ny)) loc = loc[1:xCol, ] loc[, 2] = NY + 1 - loc[, 2] loc[, 1] = loc[, 1] - locOffset[1] loc[, 2] = loc[, 2] - locOffset[2] # Stars: palette(rainbow(12, s = 0.6, v = 0.75)) ans = stars(t(x), mar = c(0,0,0,0), #mar = c(4, 2.8, 2.8, 4), locations = loc, len = 0.4, xlim = c(1, NX+0.5), ylim = c(0, NY+1), key.loc = c(NX + 1, 1) + keyOffset, draw.segments = draw.segments, ... ) # box() # Return Value: invisible(ans) } # ------------------------------------------------------------------------------ assetsBasicStatsPlot <- function(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Basic Returns Statistics", descriptionPosition = c(3, 3.50), ...) { # A function Implemented by Diethelm Wuertz # Description: # Displays a segment plot of basic return statistics # Note: # The Default Settings are made for a portfolio with # 7 to 9 assets. # FUNCTION: # Plot: if (par) par(mfrow = c(1, 1), oma = oma, mar = mar) X = basicStats(x)[-(1:2), ] assetsStarsPlot(X, keyOffset = keyOffset, ...) text(titlePosition[1], titlePosition[2], adj = 0, title, cex = 1.25) text(descriptionPosition[1], descriptionPosition[2], adj = 0, description, cex = 1.1) title(main = main) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsMomentsPlot <- function(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Moments Statistics", descriptionPosition = c(3, 3.50), ...) { # A function Implemented by Diethelm Wuertz # Description: # Displays a segment plot of distribution moments # Note: # The Default Settings are made for a portfolio with # 7 to 9 assets. # FUNCTION: # Plot: if(par) par(mfrow = c(1, 1), oma = oma, mar = mar) param = NULL for (i in 1:dim(x)[2]) { X = as.vector(series(x[, i])) fit = c(mean = mean(X), stdev = sd(X), skewness = skewness(X), kurtosis = kurtosis(X)) param = cbind(param, fit) } colnames(param) = colnames(x) assetsStarsPlot(param, keyOffset = keyOffset, ...) text(titlePosition[1], titlePosition[2], adj = 0, title, cex = 1.25) text(descriptionPosition[1], descriptionPosition[2], adj = 0, description, cex = 1.1) title(main = main) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsBoxStatsPlot <- function(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Box Plot Statistics", descriptionPosition = c(3, 3.50), ...) { # A function Implemented by Diethelm Wuertz # Description: # Displays a segment plot of box plot statistics # Note: # The Default Settings are made for a portfolio with # 7 to 9 assets. # FUNCTION: # Plot: if(par) par(mfrow = c(1, 1), oma = oma, mar = mar) bp = assetsBoxPlot(x, plot = FALSE) ans = assetsStarsPlot(abs(bp$stats), keyOffset = keyOffset, ...) text(titlePosition[1], titlePosition[2], adj = 0, title, cex = 1.25) text(descriptionPosition[1], descriptionPosition[2], adj = 0, description, cex = 1.1) title(main = main) # Return Value: invisible(ans) } # ------------------------------------------------------------------------------ assetsNIGFitPlot <- function(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "NIG Parameters", descriptionPosition = c(3, 3.50), ...) { # A function Implemented by Diethelm Wuertz # Description: # Displays a segment plot NIG parameter estimates # Note: # The Default Settings are made for a portfolio with # 7 to 9 assets. # FUNCTION: # Plot: param = NULL for (i in 1:dim(x)[2]) { fit = nigFit(x[, i], doplot = FALSE, trace = FALSE) param = cbind(param, fit@fit$estimate) } if(par) par(mfrow = c(1, 1), oma = oma, mar = mar) colnames(param) = colnames(x) rownames(param) = c("alpha", "beta", "delta", "mu") assetsStarsPlot(param, keyOffset = keyOffset) text(titlePosition[1], titlePosition[2], adj = 0, title, cex = 1.25) text(descriptionPosition[1], descriptionPosition[2], adj = 0, description, cex = 1.1) title(main = main) # Return Value: invisible() } ################################################################################ fAssets/R/plot-pairs.R0000644000176000001440000002046312424423203014331 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsPairsPlot Displays pairs of scatterplots of assets # assetsCorgramPlot Displays pairwise correlations between assets # assetsCorTestPlot Displays and tests pairwise correlations # assetsCorImagePlot Displays an image plot of a correlations ################################################################################ assetsPairsPlot <- function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays pairs of scatterplots of individual assets # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC))[, 1:6] # assetsPairsPlot(x) # FUNCTION: # Settings: x = as.matrix(x) # Pairs Plot: # Suppress warnings for tick = 0 in ... warn = options()$warn options(warn = -1) pairs(x, ...) options(warn = warn) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsCorgramPlot <- function(x, method = c( "pie", "shade"), ...) { # A function implemented by Diethelm Wuertz # Description: # Displays correlations between assets # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC))[, 1:6] # assetsCorgramPlot(x, method = "pie") # assetsCorgramPlot(x, method = "shade") # assetsCorgramPlot(x, method = "hist") # ... has a bug, check # FUNCTION: # Settings: method <<- match.arg(method) stopifnot(is.timeSeries(x)) x = series(x) # Internal Function: .panel.lower = function(x, y, ...) { if (method[1] == "pie") { .panel.pie(x, y, ...) .panel.pts(x, y, ...) } else if (method[1] == "shade") { .panel.shade(x, y, ...) .panel.pts(x, y, ...) } else if (method[1] == "hist") { .panel.shade(x, y, ...) .panel.hist(x, y, ...) } } .panel.upper = function(x, y, ...) { .panel.ellipse(x, y, ...) } # Plot Corellogram - Pies and Ellipses: pairs(x, lower.panel = .panel.lower, upper.panel = .panel.upper, ...) # .corrgram(x, labels = labels, lower.panel = .panel.lower, # upper.panel = .panel.upper, text.panel = .panel.txt, # ...) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsCorTestPlot <- function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays and tests pairwise correlations of assets # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC))[, 1:6] # assetsCorTestPlot(x) # FUNCTION: # Settings: x = as.matrix(x) # Upper Plot Function: cortestPanel <- function(x, y, cex, col, ...) { if (missing(col)) col = NULL usr = par("usr"); on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) r = abs(cor(x, y)) txt = format(c(r, 0.123456789), digits = 3)[1] test = cor.test(x, y) Signif = symnum(test$p.value, corr = FALSE, na = FALSE, cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), symbols = c("*** ", "** ", "* ", ". ", " ")) text(0.5, 0.5, txt, cex = 1, col = NULL, ...) text(0.8, 0.8, Signif, cex = 1.5, col = col, ...) } # Lower Plot Function: lowessPanel = function (x, y, ...) { points(x, y, ...) ok = is.finite(x) & is.finite(y) if (any(ok)) lines(lowess(x[ok], y[ok]), col = "brown") } # Plot: pairs(x, lower.panel = lowessPanel, upper.panel = cortestPanel, ...) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsCorImagePlot <- function(x, labels = TRUE, show = c("cor", "test"), use = c("pearson", "kendall", "spearman"), abbreviate = 3, ...) { # A function implemented by Diethelm Wuertz # Description: # Creates an image plot of a correlations # Arguments: # R - data to be evaluated against its own members # Details: # uses relative colors to indicate the strength of the pairwise # correlation. # Authors: # Sandrine Dudoit, sandrine@stat.berkeley.edu, from "SMA" library # modified by Peter Carl # extended by Diethelm Wuertz # Example: # x = as.timeSeries(data(LPP2005REC)) # assetsCorImagePlot(x[,assetsArrange(x, "hclust")], abbreviate = 5) # FUNCTION: # Settings: R = x # Match Arguments: show = match.arg(show) use = match.arg(use) # Handle Missing Values: R = na.omit(R, ...) # Abbreviate Instrument Names: Names = colnames(R) = substring(colnames(R), 1, abbreviate) # Compute Correlation Matrix: R = as.matrix(R) n = NCOL(R) if (show == "cor") { corr <- cor(R, method = use) if (show == "test") { test = corr*NA for ( i in 1:n) for (j in 1:n) test[i,j] = cor.test(R[,i], R[,j], method = use)$p.value } } else if (show == "robust") { stop("robust: Not Yet Implemented") } else if (show == "shrink") { stop("robust: Not Yet Implemented") } ## compute colors for correlation matrix: corrMatrixcolors <- function (ncolors) { k <- round(ncolors/2) r <- c(rep(0, k), seq(0, 1, length = k)) g <- c(rev(seq(0, 1, length = k)), rep(0, k)) b <- rep(0, 2 * k) res <- (rgb(r,g,b)) res } ## Plot Image: ncolors <- 10*length(unique(as.vector(corr))) image(x = 1:n, y = 1:n, z = corr[, n:1], col = corrMatrixcolors(ncolors), axes = FALSE, main = "", xlab = "", ylab = "", ...) # Add Text Values: if (show == "cor") X = t(corr) else X = t(test) coord = grid2d(1:n, 1:n) for (i in 1:(n*n)) { text(coord$x[i], coord$y[n*n+1-i], round(X[coord$x[i], coord$y[i]], digits = 2), col = "white", cex = 0.7) } # Add Axis Labels: if(labels) { axis(2, at = n:1, labels = Names, las = 2) axis(1, at = 1:n, labels = Names, las = 2) Names = c( pearson = "Pearson", kendall = "Kendall", spearman = "Spearman") if (show == "test") Test = "Test" else Test = "" title( main = paste(Names[use], " Correlation ", Test, " Image", sep = "")) mText = paste("Method:", show) mtext(mText, side = 4, adj = 0, col = "grey", cex = 0.7) } # Add Box: box() # Return Value: invisible() } ################################################################################ fAssets/R/plot-boxplot.R0000644000176000001440000001232012424423203014673 0ustar ripleyusers # This library is free software, you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation, either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library, if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: DESCRIPTION: # assetsBoxPlot Displays a standard box plot # assetsBoxPercentilePlot Displays a side-by-side box-percentile plot ############################################################################### assetsBoxPlot <- function(x, col = "bisque", ...) { # A function Implemented by Diethelm Wuertz # Description: # Displays standard box plots # Arguments: # x - a 'timeSeries' object or any other rectangular object # which cab be transformed by the function as.matrix into # a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)); assetsBoxPlot(x) # FUNCTION: # Settings: x = as.matrix(x) assetNames = colnames(x) # Plot: ans = boxplot(as.data.frame(x), col = col, ...) colnames(ans$stats) = ans$names rownames(ans$stats) = c("lower whisker", "lower hinge", "median", "upper hinge", "upper whisker") # Return Value: invisible(ans) } # ------------------------------------------------------------------------------ assetsBoxPercentilePlot <- function(x, col = "bisque", ...) { # A modified copy from Hmisc # Description: # Displays side-by-side box-percentile plots # Arguments: # x - a 'timeSeries' object or any other rectangular object # which cab be transformed by the function as.matrix into # a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)); assetsBoxPercentilePlot(x) # Details: # Box-percentile plots are similiar to boxplots, except box-percentile # plots supply more information about the univariate distributions. At # any height the width of the irregular "box" is proportional to the # percentile of that height, up to the 50th percentile, and above the # 50th percentile the width is proportional to 100 minus the percentile. # Thus, the width at any given height is proportional to the percent of # observations that are more extreme in that direction. As in boxplots, # the median, 25th and 75th percentiles are marked with line segments # across the box. [Source: Hmisc] # FUNCTION: # Settings: x = as.matrix(x) assetNames = colnames(x) n = ncol(x) all.x = list() for (i in 1:n) all.x[[i]] = as.vector(x[, i]) centers = seq(from = 0, by = 1.2, length = n) ymax = max(sapply(all.x, max, na.rm = TRUE)) ymin = min(sapply(all.x, min, na.rm = TRUE)) xmax = max(centers) + 0.5 xmin = -0.5 # Plot: plot(c(xmin, xmax), c(ymin, ymax), type = "n", xlab = "", ylab = "", xaxt = "n", ...) xpos = NULL for (i in 1:n) { # plot.values = .bpxAssetsPlot(all.x[[i]], centers[i]) y = all.x[[i]] offset = centers[i] y = y[!is.na(y)] n = length(y) delta = 1/(n + 1) prob = seq(delta, 1 - delta, delta) quan = sort(y) med = median(y) q1 = median(y[y < med]) q3 = median(y[y > med]) first.half.p = prob[quan <= med] second.half.p = 1 - prob[quan > med] plotx = c(first.half.p, second.half.p) options(warn = -1) qx = approx(quan, plotx, xout = q1)$y q1.x = c(-qx, qx) + offset qx = approx(quan, plotx, xout = q3)$y options(warn = 0) q3.x = c(-qx, qx) + offset q1.y = c(q1, q1) q3.y = c(q3, q3) med.x = c(-max(first.half.p), max(first.half.p)) + offset med.y = c(med, med) plot.values = list(x1 = (-plotx) + offset, y1 = quan, x2 = plotx + offset, y2 = quan, q1.y = q1.y, q1.x = q1.x, q3.y = q3.y, q3.x = q3.x, med.y = med.y, med.x = med.x) # Continue: xpos = c(xpos, mean(plot.values$med.x)) x.p = c(plot.values$x1, plot.values$x2) y.p = c(plot.values$y1, plot.values$y2) polygon(x.p, y.p, col = col, border = "grey") lines(plot.values$x1, plot.values$y1) lines(plot.values$x2, plot.values$y2) lines(plot.values$q1.x, plot.values$q1.y) lines(plot.values$q3.x, plot.values$q3.y) lines(plot.values$med.x, plot.values$med.y) } axis(side = 1, at = xpos, labels = assetNames) abline(h = 0, lty = 3, col = "black") # Return Value: invisible() } ################################################################################ fAssets/R/assets-outliers.R0000644000176000001440000000562112424423203015404 0ustar ripleyusers # This library is free software, you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation, either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library, if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsOutliers Detects outliers in multivariate assets sets ################################################################################ assetsOutliers <- function (x, center, cov, ...) { # An adapted copy from contributed R package mvoutlier # Description: # Detects outliers in a multivariate set of assets # Arguments: # Source: # The code concerned with the outliers is from R package "mvoutliers" # Moritz Gschwandtner # Peter Filzmoser # References: # P. Filzmoser, R.G. Garrett, and C. Reimann (2005). # Multivariate Outlier Detection in Exploration Geochemistry. # Computers & Geosciences. # FUNCTION: # Check timeSeries Input: stopifnot(is.timeSeries(x)) tS <- x x <- as.matrix(x) # Critical Values: n = nrow(x) p = ncol(x) if (p <= 10) pcrit = (0.240 - 0.0030 * p)/sqrt(n) if (p > 10) pcrit = (0.252 - 0.0018 * p)/sqrt(n) delta <- qchisq(0.975, p) # Compute Mahalanobis Squared Distances: d2 <- mahalanobis(x, center, cov) # Detect Outliers: d2ord <- sort(d2) dif <- pchisq(d2ord, p) - (0.5:n)/n i <- (d2ord >= delta) & (dif > 0) if (sum(i) == 0) alfan = 0 else alfan = max(dif[i]) if (alfan < pcrit) alfan = 0 if (alfan > 0) cn = max(d2ord[n-ceiling(n*alfan)], delta) else cn = Inf w <- d2 < cn m <- apply(x[w, ], 2, mean) c1 <- as.matrix(x - rep(1, n) %*% t(m)) c <- (t(c1) %*% diag(w) %*% c1)/sum(w) # Identify Outliers: outliers <- (1:dim(x)[1])[!w] if (length(outliers) == 0) { outliers <- NA } else { names(outliers) <- rownames(x)[outliers] } # Compose Result: ans <- list( center = m, cov = c, cor = cov2cor(c), quantile = cn, outliers = outliers, series = tS[outliers, ]) # Return Value: ans } ################################################################################ fAssets/R/plot-similarity.R0000644000176000001440000000725412424423203015404 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsDendrogramPlot Displays hierarchical clustering dendrogram # assetsCorEigenPlot Displays ratio of the largest two eigenvalues ################################################################################ assetsDendrogramPlot <- function(x, labels = TRUE, title = TRUE, box = TRUE, method = c(dist = "euclidian", clust = "complete"), ...) { # A function implemented by Diethelm Wuertz # Description: # Displays hierarchical clustering dendrogram # FUNCTION: # Compute Distance Matrix: if (class(x) == "dist") { DIST = x } else { X = t(series(x)) DIST = dist(X, method[1]) } # Hierarchical Clustering: ans = hclust(DIST, method = method[2]) # Plot Dendrogram: if (labels) { plot(ans, xlab = "", main = "", sub = "", ...) mtext(paste( "Distance Method:", method[1], " | ", "Clustering Method:", method[2]), side = 4, line = 0.1, adj = 0, col = "darkgrey") } else { plot(ans, ann = FALSE, ...) } # Add Box: if (box) { box() } # Add Optional Title: if (title) { title(main = "Dendrogram", sub = "", xlab = "", ylab = "Heights") } # Return Value: invisible(list(dist = DIST, hclust = ans)) } # ------------------------------------------------------------------------------ assetsCorEigenPlot <- function(x, labels = TRUE, title = TRUE, box = TRUE, method = c("pearson", "kendall", "spearman"), ...) { # A function implemented by Diethelm Wuertz # Description: # Displays ratio of the largest two eigenvalues # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # assetsCorEigenPlot(x=100*as.timeSeries(data(LPP2005REC))) # FUNCTION: # Settings: stopifnot(is.timeSeries(x)) x = series(x) method = match.arg(method) # Plot: x.cor = cor(x, use = 'pair', method = method) x.eig = eigen(x.cor)$vectors[, 1:2] e1 = x.eig[, 1] e2 = x.eig[, 2] plot(e1, e2, col = 'white', ann = FALSE, xlim = range(e1, e2), ylim = range(e1, e2), ...) abline(h = 0, lty = 3, col = "grey") abline(v = 0, lty = 3, col = "grey") arrows(0, 0, e1, e2, cex = 0.5, col = "steelblue", length = 0.1) text(e1, e2, rownames(x.cor), ...) # Labels: if (labels) { mtext(method, side = 4, adj = 0, cex = 0.7, col = "grey") } # Add Box: if (box) { box() } # Add Title: if(title) { title(main = "Eigenvalue Ratio Plot", sub = "", xlab = "Eigenvalue 1", ylab = "Eigenvalue 2") } # Return Value: invisible() } ################################################################################ fAssets/R/builtin-covRobust.R0000644000176000001440000003141712424423203015672 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: INTERNAL USE: # .cov.nnve Builtin from Package 'covRobust' ################################################################################ # Rmetrics: # Note that covRobust is not available on Debian as of 2009-04-28. # To run these functions under Debian/Rmetrics we have them # implemented here as a builtin. # We also made modifications for tailored usage with Rmetrics. # Package: covRobust # Title: Robust Covariance Estimation via Nearest Neighbor Cleaning # Version: 1.0 # Author: Naisyin Wang and # Adrian Raftery # with contributions from Chris Fraley # Description: The cov.nnve() function for robust covariance estimation # by the nearest neighbor variance estimation (NNVE) method # of Wang and Raftery (2002,JASA) # Maintainer: Naisyin Wang # License: GPL version 2 or newer # Notes: # Wang and Raftery(2002), "Nearest neighbor variance estimation (NNVE): # Robust covariance estimation via nearest neighbor cleaning # (with discussion)", # Journal of the American Statistical Association 97:994-1019 # Available as Technical Report 368 (2000) from # http://www.stat.washington.edu/www/research/report # ------------------------------------------------------------------------------ .cov.nnve = function(datamat, k = 12, pnoise = 0.05, emconv = 0.001, bound = 1.5, extension = TRUE, devsm = 0.01) { # A (modified) copy from coontributed R package covRobust # Description: # Function to perform Nearest Neighbor Variance Estimation # Arguments: # cov - robust covariance estimate # mu - mean # postprob - posterior probability # classification - classification (0 = noise, # otherwise 1) (obtained by rounding postprob) # innc - list of initial nearest-neighbor results (components # are the same as above) # FUNCTION: # Settings: datamat = as.matrix(datamat) d = dim(datamat)[2] n = dim(datamat)[1] pd = dim(datamat)[2] S.mean = apply(datamat, 2, median) S.sd = apply(datamat, 2, mad) # NNC based on original data orgNNC = .cov.nne.nclean.sub(datamat, k, convergence = 0.001, S.mean = S.mean, S.sd = S.sd) nnoise = min(c(sum(1 - orgNNC$z), round(pnoise * n))) knnd = orgNNC$kthNND ord = (n + 1) - rank(knnd) muT = orgNNC$mu1 SigT = orgNNC$Sig1 SigT = (SigT + t(SigT))/2. SigTN = diag(orgNNC$sd1^2) if (nnoise > 6) { ncho = nnoise ncho1 = floor(ncho/2) ncho2 = ncho - ncho1 cho = (1:n)[ord <= ncho1] xcho = datamat[cho, ] ev = eigen(SigT) evv = ev$values minv = max((1:d)[evv > 9.9999999999999998e-13]) if (minv > 2) { vv1 = ev$vectors[, (minv - 1)] vv2 = ev$vectors[, minv] } else { vv1 = ev$vectors[, 1] vv2 = ev$vectors[, 2] } ot = acos(sum(vv1 * vv2)/(sum(vv1^2) * sum(vv2^2))^0.5) for (kk1 in 1:(ncho2)) { pseg = 1/(ncho2 + 1) * kk1 * ot xcho = rbind(xcho, (sin(pseg) * vv1 + cos(pseg) * vv2 + muT)) } } else { nnoise = 3 cho = (1:n)[ord <= nnoise] xcho = datamat[cho, ] } n2 = (dim(xcho))[1] schox = mahalanobis(xcho, muT, SigTN) Nc = matrix(rep(muT, n2), nrow = n2, byrow = TRUE) Ndir = (xcho - Nc)/(schox^0.5) # initial set up ch1 = c(qchisq(0.99, pd), qchisq(1 - 10^(-4), pd)) Xa = seq(ch1[1], ch1[2], length = 6) gap = Xa[2] - Xa[1] initv = diag(orgNNC$Sig1) xa = Xa[1] SaveM = c(xa, orgNNC$mu1, .cov.nne.Mtovec(orgNNC$Sig1)) OldP = orgNNC$probs SaveP = OldP Np = Nc - Ndir * (xa^0.5) updNNC = .cov.nne.nclean.sub(rbind(datamat, Np), k, convergence = 0.001, S.mean = S.mean, S.sd = S.sd) SaveM = rbind(SaveM, c(xa, updNNC$mu1, .cov.nne.Mtovec(updNNC$Sig1))) SaveP = rbind(SaveP, (updNNC$probs)[1:n]) # sda = .cov.nne.Mtovec(orgNNC$Sig1) # sda save the results corresponding to xa = qchisq(.99, pd) stopv = diag(updNNC$Sig1) time1 = 2 while ((time1 <= 6) && (all(stopv < (1 + bound) * initv))) { xa = Xa[time1] Np = Nc - Ndir * (xa^0.5) updNNC = .cov.nne.nclean.sub(rbind(datamat, Np), k, convergence = 0.001, S.mean = S.mean, S.sd = S.sd) SaveM = rbind(SaveM, c(xa, updNNC$mu1, .cov.nne.Mtovec(updNNC$Sig1))) SaveP = rbind(SaveP[2, ], (updNNC$probs)[1:n]) time1 = time1 + 1 stopv = diag(updNNC$Sig1) NULL } # Procedure stop if the added noise cause a "surge" within # the range sdb save the results within the given "range" if (all(stopv < (1 + bound) * initv)) { dSaveM = dim(SaveM)[1] ans = SaveM[dSaveM, ] sdb = SaveM[dSaveM, ] NewP = SaveP[2, ] # adding extension if (extension) { time2 = 1 Fstop = FALSE tpv = stopv while ((time2 < 2) && (all(stopv < (1 + bound) * initv))) { xa = xa + gap startv = stopv Np = Nc - Ndir * (xa^0.5) updNNC = .cov.nne.nclean.sub(rbind(datamat, Np), k, convergence = 0.001, S.mean = S.mean, S.sd = S.sd) SaveM = rbind(SaveM, c(xa, updNNC$mu1, .cov.nne.Mtovec( updNNC$Sig1))) SaveP = rbind(SaveP[2, ], (updNNC$probs)[ 1:n]) stopv = apply(rbind((startv * 2 - tpv), diag( updNNC$Sig1)), 2, mean) tpv = diag(updNNC$Sig1) Fstop = all((abs(stopv - startv) <= ((1+abs(startv)) * devsm))) if (Fstop) time2 = time2 + 1 else time2 = 1 NULL } # Checking the stop criterior at the end of extension if (all(stopv < (1 + bound) * initv)) { dSaveM = dim(SaveM)[1] ans = SaveM[dSaveM, ] NewP = SaveP[2, ] } else { dSaveM = dim(SaveM)[1] ans = SaveM[dSaveM - 1, ] NewP = SaveP[1, ] } } } else { dSaveM = dim(SaveM)[1] ans = SaveM[dSaveM - 1, ] sdb = ans[-1] NewP = SaveP[1, ] } nncvar = .cov.nne.vectoM(ans[ - (1:(1 + pd))], pd) mu = ans[2:(1 + pd)] # Return Value: list(cov = nncvar, mu = mu, postprob = NewP, classification = round(NewP), innc = list(cov = orgNNC$Sig1, mu = orgNNC$mu1, postprob = OldP, classification = round(OldP))) } # ------------------------------------------------------------------------------ .cov.nne.nclean.sub <- function(datamat, k, distances = NULL, convergence = 0.001, S.mean = NULL, S.sd = NULL) { # A (modified) copy from coontributed R package covRobust # Description: # Internal Function called by .cov.nne() # FUNCTION: # The Re-scale NNC function: d = dim(datamat)[2] n = dim(datamat)[1] kthNND = .cov.nne.splusNN(t((t(datamat) - S.mean)/S.sd), k = k) alpha.d = (2 * pi^(d/2))/(d * gamma(d/2)) # Now use kthNND in E-M algorithm, first get starting guesses. delta = rep(0, n) delta[kthNND > (min(kthNND) + diff(range(kthNND))/3)] = 1 p = 0.5 lambda1 = k/(alpha.d * mean((kthNND[delta == 0])^d)) lambda2 = k/(alpha.d * mean((kthNND[delta == 1])^d)) loglik.old = 0 loglik.new = 1 # Iterator starts here ... while (abs(loglik.new - loglik.old)/(1+abs(loglik.new)) > convergence) { # E - step delta = (p * .cov.nne.dDk(kthNND, lambda1, k = k, d = d, alpha.d = alpha.d)) / (p * .cov.nne.dDk(kthNND, lambda1, k = k, d = d, alpha.d = alpha.d) + (1 - p) * .cov.nne.dDk(kthNND, lambda2, k = k, d = d, alpha.d = alpha.d)) # M - step p = sum(delta) / n lambda1 = (k * sum(delta))/(alpha.d * sum((kthNND^d) * delta)) lambda2 = (k * sum((1 - delta)))/(alpha.d * sum((kthNND^d) * (1 - delta))) loglik.old = loglik.new loglik.new = sum( - p * lambda1 * alpha.d * ((kthNND^d) * delta) - (1 - p) * lambda2 * alpha.d * ((kthNND^d) * (1 - delta)) + delta * k * log(lambda1 * alpha.d) + (1 - delta) * k * log(lambda2 * alpha.d)) } # z will be the classifications. 1 = in cluster. 0 = in noise. probs = .cov.nne.dDk(kthNND, lambda1, k = k, d = d, alpha.d = alpha.d) / (.cov.nne.dDk(kthNND, lambda1, k = k, d = d, alpha.d = alpha.d) + .cov.nne.dDk(kthNND, lambda2, k = k, d = d, alpha.d = alpha.d)) mprob = 1. - probs mu1 = apply((probs * datamat), 2, sum)/sum(probs) mu2 = apply((mprob * datamat), 2, sum)/sum(mprob) tpsig1 = t(datamat) - mu1 tpsig2 = t(datamat) - mu2 Sig1 = tpsig1 %*% (probs * t(tpsig1))/sum(probs) Sig2 = tpsig2 %*% (mprob * t(tpsig2))/sum(mprob) sd1 = sqrt(diag(Sig1)) sd2 = sqrt(diag(Sig2)) ans = rbind(mu1, sd1, mu2, sd2) zz = list(z = round(probs), kthNND = kthNND, probs = probs, p = p, mu1 = mu1, mu2 = mu2, sd1 = sd1, sd2 = sd2, lambda1 = lambda1, lambda2 = lambda2, Sig1 = Sig1, Sig2 = Sig2, ans = ans) # Return Value: return(zz) } # ------------------------------------------------------------------------------ .cov.nne.dDk <- function(x, lambda, k, d, alpha.d) { # A (modified) copy from coontributed R package covRobust # Description: # Internal Function called by .cov.nne() # FUNCTION: # Function to perform the Nearest Neighbour cleaning of # find the density of D_k ans = (exp( - lambda * alpha.d * x^d + log(2) + k * log( lambda * alpha.d) + log(x) * (d * k - 1) - log( gamma(k)))) # Return Value: ans } # ------------------------------------------------------------------------------ .cov.nne.splusNN <- function(datamat, k) { # A (modified) copy from coontributed R package covRobust # Description: # Internal Function called by .cov.nne() # FUNCTION: # Nearest-neighbor in S-PLUS n = nrow(datamat) distances = dist(datamat) # This next part sorts through the Splus distance object # and forms kNNd, kth nearest neighbour distance, for each # point. kNNd = rep(0, n) N = (n - 1):0 I = c(0, cumsum(N[-1])) J = c(0, I + n - 1) a = z = NULL for (j in 1:n) { if (j > 1) a = i + I[1:i] if (j < n) z = J[j] + 1:N[j] kNNd[j] = sort(distances[c(a, z)])[k] i = j } # Return Value: kNNd } # ------------------------------------------------------------------------------ .cov.nne.Mtovec <- function(M) { # A (modified) copy from coontributed R package covRobust # Description: # Internal Function called by .cov.nne() # FUNCTION: # Two procedures to link between a symmetric matrix and its vec(.) n = dim(M)[1] d = dim(M)[2] if (abs(n - d) > 0.01) { cat ("The input has to be a square matrix") } else { vec = rep(0, 0) for (i in (1:n)) { for (j in (i:d)) { vec = c(vec, M[i, j]) } } vec } } # ------------------------------------------------------------------------------ .cov.nne.vectoM <- function(vec, d) { # A (modified) copy from coontributed R package covRobust # Description: # Internal Function called by .cov.nne() # FUNCTION: n = length(vec) M = matrix(rep(0, d * d), d, d) L = 1 for (i in 1:d) { for (j in i:d) { M[i, j] = vec[L] L = L + 1 M[j, i] = M[i, j] } } # Return Value: M } ################################################################################ fAssets/R/zzz.R0000644000176000001440000000306012424423203013066 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### .onAttach <- function(libname, pkgname) { # do whatever needs to be done when the package is loaded # some people use it to bombard users with # messages using packageStartupMessage( "\n" ) packageStartupMessage( "Rmetrics Package fAssets" ) packageStartupMessage( "Analysing and Modeling Financial Assets" ) packageStartupMessage( "Copyright (C) 2005-2014 Rmetrics Association Zurich" ) packageStartupMessage( "Educational Software for Financial Engineering and Computational Science" ) packageStartupMessage( "Rmetrics is free software and comes with ABSOLUTELY NO WARRANTY." ) packageStartupMessage( "https://www.rmetrics.org --- Mail to: info@rmetrics.org" ) } ############################################################################### fAssets/R/assets-meancov.R0000644000176000001440000004421412424423203015167 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsMeanCov Estimates mean and variance for a set of assets # FUNCTION: DESCRIPTION: # .covMeanCov uses sample covariance estimation # .mveMeanCov uses "cov.mve" from [MASS] # .mcdMeanCov uses "cov.mcd" from [MASS] # .studentMeanCov uses "cov.trob" from [MASS] # .MCDMeanCov requires "covMcd" from [robustbase] # .OGKMeanCov requires "covOGK" from [robustbase] # .nnveMeanCov uses builtin from [covRobust] # .shrinkMeanCov uses builtin from [corpcor] # .baggedMeanCov uses builtin from [corpcor] # .arwMeanCov uses builtin from [mvoutlier] # .donostahMeanCov uses builtin from [robust] # .bayesSteinMeanCov copy from Alexios Ghalanos # .ledoitWolfMeanCov uses builtin from [tawny] # .rmtMeanCov uses builtin from [tawny] # FUNCTION: DESCRIPTION: # getCenterRob Extracts the robust estimate for the center # getCovRob Extracts the robust estimate for the covariance ################################################################################ assetsMeanCov <- function(x, method = c("cov", "mve", "mcd", "MCD", "OGK", "nnve", "shrink", "bagged"), check = TRUE, force = TRUE, baggedR = 100, sigmamu = scaleTau2, alpha = 1/2, ...) { # A function implemented by Diethelm Wuertz # Description: # Computes robust mean and covariance from multivariate time series # Arguments: # x - a multivariate time series, a data frame, or any other # rectangular object of assets which can be converted into # a matrix by the function 'as.matrix'. Optional Dates are # rownames, instrument names are column names. # method - Which method should be used to compute the covarinace? # method = "cov" sample covariance computation # method = "mve" uses "mve" from [MASS] # method = "mcd" uses "mcd" from [MASS] # method = "MCD" uses "MCD" from [robustbase] # method = "OGK" uses "OGK" from [robustbase] # method = "nnve" uses "nnve" from [covRobust] # method = "shrink" uses "shrinkage" from [corpcor] # method = "bagged" uses "bagging" [corpcor] # alpha - MCD: numeric parameter controlling the size of the subsets # over which the determinant is minimized, i.e., alpha*n observations # are used for computing the determinant. Allowed values are between # 0.5 and 1 and the default is 0.5. # sigma.mu - OGK: a function that computes univariate robust location # and scale estimates. By default it should return a single numeric # value containing the robust scale (standard deviation) estimate. # When mu.too is true, sigmamu() should return a numeric vector of # length 2 containing robust location and scale estimates. See # scaleTau2, s_Qn, s_Sn, s_mad or s_IQR for examples to be used as # sigmamu argument. # Note: # The output of this function can be used for portfolio # optimization. # Example: # DJ = 100 * returns(as.timeSeries(data(DowJones30))) # DJ = DJ[, c("CAT", "IBM", "GE", "JPM")] # Sample Covariance: # assetsMeanCov(DJ, "cov") # MASS: # assetsMeanCov(DJ, "mve") # assetsMeanCov(DJ, "mcd") # require(robustbase) # assetsMeanCov(DJ, "MCD") # assetsMeanCov(DJ, "OGK") # require(covRobust) # assetsMeanCov(DJ, "nnve") # FUNCTION: # Transform Input: x.mat <- as.matrix(x) # Do not use: method = match.arg(method) method <- method[1] N <- ncol(x) assetNames <- colnames(x.mat) # Attribute Control List: control <- c(method = method[1]) user <- TRUE # Compute Classical Covariance: if (method == "cov") { # Classical Covariance Estimation: ans = list(center = colMeans(x.mat), cov = cov(x.mat)) user = FALSE } # From R Package "robustbase": if (method == "MCD" | method == "Mcd") { ans <- robustbase::covMcd(x.mat, alpha = alpha, ...) mu = ans$center Sigma = ans$cov user = FALSE } if (method == "OGK" | method == "Ogk") { ans <- robustbase::covOGK(x.mat, sigmamu = sigmamu, ...) user = FALSE } # [MASS] mve and mcd Routines: if (method == "mve") { ans = MASS::cov.rob(x = x.mat, method = "mve", ...) user = FALSE } if (method == "mcd") { ans = MASS::cov.rob(x = x.mat, method = "mcd", ...) user = FALSE } # [corpcor] Shrinkage and Bagging Routines if (method == "shrink") { fit = .cov.shrink(x = x.mat, ...) ans = list(center = colMeans(x.mat), cov = fit) user = FALSE } if (method == "bagged") { fit = .cov.bagged(x = x.mat, R = baggedR, ...) ans = list(center = colMeans(x.mat), cov = fit) control = c(control, R = as.character(baggedR)) user = FALSE } # Nearest Neighbour Variance Estimation: if (method == "nnve") { fit = .cov.nnve(datamat = x.mat, ...) ans = list(center = colMeans(x.mat), cov = fit$cov) user = FALSE } # User specified estimator: if(user) { fun = match.fun(method[1]) ans = fun(x.mat, ...) } # Result: mu = center = ans$center Sigma = cov = ans$cov # Add Size to Control List: control = c(control, size = as.character(N)) # Add Names for Covariance Matrix to Control List: names(mu) = assetNames colnames(Sigma) = rownames(Sigma) = colNames = assetNames # Check Positive Definiteness: if (check) { result = isPositiveDefinite(Sigma) if(result) { control = c(control, posdef = "TRUE") } else { control = c(control, posdef = "FALSE") } } # Check Positive Definiteness: control = c(control, forced = "FALSE") if (force) { control = c(control, forced = "TRUE") if (!result) Sigma = makePositiveDefinite(Sigma) } # Result: ans = list(center = mu, cov = Sigma, mu = mu, Sigma = Sigma) attr(ans, "control") = control # Return Value: ans } ################################################################################ .covMeanCov <- function(x, ...) { # Description: # Uses sample covariance estimation # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans = list(center = colMeans(x.mat), cov = cov(x.mat)) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .mveMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans <- MASS::cov.rob(x = x.mat, method = "mve") names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .mcdMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans <- MASS::cov.rob(x = x.mat, method = "mcd") names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .studentMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans <- MASS::cov.trob(x, ...) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .MCDMeanCov <- function(x, alpha = 1/2, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans <- robustbase::covMcd(x.mat, alpha = alpha, ...) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .OGKMeanCov <- function(x, sigmamu = scaleTau2, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans <- robustbase::covOGK(x.mat, sigmamu = sigmamu, ...) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .nnveMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) fit = .cov.nnve(datamat = x.mat, ...) ans = list(center = colMeans(x.mat), cov = fit$cov) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .shrinkMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # Note: # Based on a function borrowed from package corpcor # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) fit = .cov.shrink(x = x.mat, ...) ans = list(center = colMeans(x.mat), cov = fit) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .baggedMeanCov <- function(x, baggedR = 100, ...) { # Description: # Arguments: # x - an object of class timeSeries # Note: # Based on a function borrowed from package corpcor # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) fit = .cov.bagged(x = x.mat, R = baggedR, ...) ans = list(center = colMeans(x.mat), cov = fit) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .arwMeanCov <- function(x, ...) { # Description: # Adaptive reweighted estimator for multivariate location and scatter # with hard-rejection weights and delta = chi2inv(1-d,p) # Arguments: # x - an object of class timeSeries # Note: # Based on a function borrowed from package mvoutlier # FUNCTION: # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) fit = .cov.arw(x = x.mat, center = colMeans(x.mat), cov = cov(x),, ...) ans = list(center = fit$center, cov = fit$cov) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .donostahMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # Note: # Based on a function borrowed from package robust # Settings: x.mat = as.matrix(x) N = ncol(x) assetNames = colnames(x) ans = .cov.donostah(x = x.mat) names(ans$center) = assetNames rownames(ans$cov) = colnames(ans$cov) = assetNames # Return Value: ans } # ------------------------------------------------------------------------------ .bayesSteinMeanCov <- function(x, ...) { # Description: # Arguments: # x - an object of class timeSeries # Note: # Based on a function written by Alexios Ghalanos # Bayes Stein estimator # Alexios Ghalanos 2008 # alexios at 4dscape.com # This function encapsulates an example of shrinking the returns # and covariance using Bayes-Stein shrinkage as described in # Jorion, 1986. # Settings: data <- getDataPart(x) mu <- as.matrix(apply(data,2, FUN = function(x) mean(x))) S <- cov(data) k <- dim(data)[2] n <- dim(data)[1] one <- as.matrix(rep(1, k)) a <- solve(S, one) # Constant non informative prior mu.prior <- one * as.numeric(t(mu) %*% a/t(one) %*% a) S.inv <- solve(S) d <- t(mu-mu.prior) %*% S.inv %*% (mu-mu.prior) d <- as.numeric(d) lambda <- (k+2) / d w <- lambda / (n+lambda) mu.pred <- (1-w) * mu + w * mu.prior wc1 <- 1 / (n+lambda) wc2 <- lambda*(n-1) / (n*(n+lambda)*(n-k-2)) wc2 <- wc2 / as.numeric(t(one) %*% a) V.post <- wc1 * S + wc2 * one %*% t(one) V.pred <- S + V.post sigma.post <- sqrt(diag(V.post)) sigma.pred <- sqrt(diag(V.pred)) result <- list( mu = mu, mu.prior = mu.prior, mu.predict = mu.pred, V = S, V.post = V.post, V.pred = V.pred, Sigma = sqrt(diag(S)), Sigma.post = sigma.post, Sigma.predict = sigma.pred) ans = list(center = result$mu.pred[,1], cov = result$V.pred) names(ans$center) = colnames(x) rownames(ans$cov) = colnames(ans$cov) = colnames(x) # Return Value: ans } # ------------------------------------------------------------------------------ .ledoitWolfMeanCov <- function(x, ...) { # Description: # Perform shrinkage on a sample covariance towards a biased covariance # Arguments: # x - an object of class timeSeries # Details: # This performs a covariance shrinkage estimation as specified in # Ledoit and Wolf. Using within the larger framework only requires # using the getCorFilter.Shrinkage function, which handles the work # of constructing a shrinkage estimate of the covariance matrix of # returns (and consequently its corresponding correlation matrix). # Note: # Based on a function borrowed from package tawny # Author: Brian Lee Yung Rowe # Settings: data = getDataPart(x) center = colMeans(data) cov = .cov.shrink.tawny(data, ...) ans = list(center = center, cov = cov) names(ans$center) = colnames(x) rownames(ans$cov) = colnames(ans$cov) = colnames(x) # Return Value: ans } # ------------------------------------------------------------------------------ .rmtMeanCov <- function(x, ...) { # Description: # Perform Random Matrix Theory on correlation matrix # Arguments: # x - an object of class timeSeries # Author: # tawnyBrian Lee Yung Rowe # Note: # Based on a function borrowed from package tawny # Author: Brian Lee Yung Rowe # FUNCTION: # Settings: data = getDataPart(x) center = colMeans(data) cor = .filter.RMT(data, trace = FALSE, doplot = FALSE) g = colSds(data) N = length(g) cov = 0*cor for (i in 1:N) for (j in i:N) cov[i,j] = cov[j,i] = g[i]*cor[i,j]*g[j] ans = list(center = center, cov = cov) names(ans$center) = colnames(x) rownames(ans$cov) = colnames(ans$cov) = colnames(x) # Return Value: ans } ################################################################################ getCenterRob <- function(object) { # Return Value: object$center } # ------------------------------------------------------------------------------ getCovRob <- function(object) { # Return Value: object$cov } ################################################################################ fAssets/R/plot-series.R0000644000176000001440000000707112424423203014505 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # assetsReturnPlot Displays time series of individual assets # assetsCumulatedPlot Displays time series of individual assets # assetsSeriesPlot Displays time series of individual assets ################################################################################ assetsReturnPlot = function(x, col = "steelblue", ...) { # A function implemented by Diethelm Wuertz # Description: # Displays return series of individual assets # Arguments: # x - a timeSeries object of financial returns or any other # rectangular object which can be transformed by the # function as.matrix into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)) # par(mfrow = c(3,3)); assetsReturnPlot(x); par(mfrow = c(1,1)) # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Plot: seriesPlot(x, ylab = "Returns", col = col, ...) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsCumulatedPlot = function(x, col = "steelblue", ...) { # A function implemented by Diethelm Wuertz # Description: # Displays cumulated return series of individual assets # Arguments: # x - a timeSeries object of financial returns or any other # rectangular object which can be transformed by the # function as.matrix into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)) # par(mfrow = c(3,3)); assetsCumulatedPlot(x); par(mfrow = c(1,1)) # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Plot: x = exp(colCumsums(x)) seriesPlot(x, ylab = "Cumulated Returns", col = col, ...) # Return Value: invisible() } # ------------------------------------------------------------------------------ assetsSeriesPlot = function(x, col = "steelblue", ...) { # A function implemented by Diethelm Wuertz # Description: # Displays a derived series of individual assets # Arguments: # x - a timeSeries object or any other rectangular object # which can be transformed by the function as. matrix # into a numeric matrix. # Example: # x = as.timeSeries(data(LPP2005REC)) # dd = drawdowns(x) # par(mfrow = c(3,3)); assetsSeriesPlot(dd); par(mfrow = c(1,1)) # FUNCTION: # Settings: n = ncol(x) if (length(col) == 1) col = rep(col, times = n) # Plot: seriesPlot(x, ylab = "Series", col = col, ...) # Return Value: invisible() } ################################################################################ fAssets/MD50000644000176000001440000000566312424430504012232 0ustar ripleyusersd64e9c04d3ae9a929c64e3f01338c06e *ChangeLog 9b69abb8205f0fa62f2fc739981a29bb *DESCRIPTION a830a4be71a2342f52e769c0e12b7fa2 *NAMESPACE 27298ff70f98d5ebb0740c2994d9f555 *R/assets-arrange.R 8ca18680030776ed0e75d416fa24741f *R/assets-distance.R 911b15b0d0dcfd529c6702574ea9d550 *R/assets-lpm.R 23daab36485f2a87ba3e468fc5713425 *R/assets-meancov.R c39c3fb1fc53b42c82c262b3e5129c85 *R/assets-modeling.R 9a4ba1e59c01ab0915cfe1c57c7772a0 *R/assets-outliers.R 066fce78914e78ef802e7efb692df2a0 *R/assets-selection.R 7669db9310cc70db9a9d4e4232068778 *R/assets-testing.R 31963962bea8a207ba501f123c04a0e2 *R/builtin-DEoptim.R f573257a8fc7e6eb3ebe8b64eacc0ce2 *R/builtin-arwMvoutlier.R 2687ac3481ccf55f8361ab7b9b6ae28a *R/builtin-corpcor.R 8b9c08b997e7e0d830ab7296cbc8eea4 *R/builtin-corrgram.R ac6299cdfe8467717028c284c69da265 *R/builtin-covRobust.R 9889bc2ba9be634a2b9f29f3f9a682fb *R/builtin-donostahRobust.R 2bdfd75a42e5b859192efe652be34239 *R/builtin-mstApe.R 5b4262591b2e4419a100a0a8ba39a029 *R/builtin-rmtTawny.R d3dd2d5cd9e37484c6e52bd031e7ed10 *R/builtin-shrinkTawny.R edf613a305d78b89e6294898bdb16660 *R/plot-binning.R e1c46bf82a06f10dd00dbce41bfff18c *R/plot-boxplot.R d3b3444028cb6d9d8778792a885a3bbc *R/plot-ellipses.R 49c1bd73d830afddc26e58da65f4e39c *R/plot-hist.R 19003188473f404343e50495fb1824f9 *R/plot-mst.R 79950eadee82e84d6bcf95b99e994c3d *R/plot-pairs.R 4064e22c8c4cd03c96143a09ebf1d863 *R/plot-panels.R a5934ed8b6321b4c5a83bec55322563e *R/plot-qqplot.R f9248cd6b9690b88aea83d6c04d08a44 *R/plot-risk.R 7e39197b96d538c1c44fbdcab39e7773 *R/plot-series.R 1e181f17f9bf22e59402bbd3153632eb *R/plot-similarity.R cfa430ac81cdf0f1db84157a1bf42fa0 *R/plot-stars.R 36e56cc83d68f661638c800e572b117d *R/zzz.R 19315d041e09c67af95239453eeb0fc4 *inst/obsolete/a-class-fASSETS.R f6f43f41665281290fcce79bd0550176 *inst/obsolete/a-class-fASSETS.Rd b2b47607848aeeade01121eb71e80507 *inst/obsolete/assets-modeling.Rd e979e9757dd26ea59226ff07d68e40b7 *man/00fAssets-package.Rd f95c49f2d06387b4d7af2c109243a023 *man/assets-arrange.Rd 4c5e500bb8456b353440965ecd8bcb3e *man/assets-distance.Rd d25c73a868a7dff0914ce50066dc72bd *man/assets-lpm.Rd a958040b6239e1076ff2c0590081dcc9 *man/assets-meancov.Rd 681d7867e1213ca60f0031eb6abc4ca5 *man/assets-modeling.Rd b1b8b0a44515016bee6ccb7998b6f7ae *man/assets-outliers.Rd 17d7df53fcd8ace8fd6fd1440a203380 *man/assets-selection.Rd 12d94c2a5b471fc39c2ef8b054e18048 *man/assets-testing.Rd c2e699f81384f4565ac77bf4d4b26299 *man/plot-binning.Rd 5b28d4e2c21325c3ed329bc1ae66519b *man/plot-boxplot.Rd 427fd7ea0655ae8ba16d675056c735b4 *man/plot-ellipses.Rd e0b1821e1d174fafbf28f01c95a0f0dd *man/plot-hist.Rd b01946bfa5b3966f0b248f88aae3363a *man/plot-mst.Rd c5c80fbfe22a80af169257ded9c14ea8 *man/plot-pairs.Rd f89da1a1ed788e5db7d2b9aa5473afca *man/plot-qqplot.Rd faf1609e477041fc0ff4c3fe223a1505 *man/plot-risk.Rd 61d9acf9bb755c4aa84abad40d5ae388 *man/plot-series.Rd 5043bb25c9b09aea6209f46c7fcf970d *man/plot-similarity.Rd a40950d3a224ebdc2e0774d1ba36852c *man/plot-stars.Rd fAssets/DESCRIPTION0000644000176000001440000000156312424430504013423 0ustar ripleyusersPackage: fAssets Title: Rmetrics - Analysing and Modelling Financial Assets Date: 2014-10-30 Version: 3011.83 Author: Rmetrics Core Team, Diethelm Wuertz [aut], Tobias Setz [cre], Yohan Chalabi [ctb] Maintainer: Tobias Setz Description: Environment for teaching "Financial Engineering and Computational Finance". Depends: R (>= 2.15.1), timeDate, timeSeries, fBasics Imports: fMultivar, robustbase, MASS, sn, ecodist, mvnormtest, energy Suggests: methods, mnormt, RUnit Note: SEVERAL PARTS ARE STILL PRELIMINARY AND MAY BE CHANGED IN THE FUTURE. THIS TYPICALLY INCLUDES FUNCTION AND ARGUMENT NAMES, AS WELL AS DEFAULTS FOR ARGUMENTS AND RETURN VALUES. LazyData: yes License: GPL (>= 2) URL: https://www.rmetrics.org Packaged: 2014-10-30 11:52:35 UTC; Tobi NeedsCompilation: no Repository: CRAN Date/Publication: 2014-10-30 13:38:28 fAssets/ChangeLog0000644000176000001440000001515512424423203013467 0ustar ripleyusers ChangeLog Package fAssets 2014-30-10 tsetz * ecodist, mvnormtest and energy are import packages again since otherwise some functions within fPortfolio won't work. 2014-09-17 tsetz * ChangeLog, DESCRIPTION: Updated ChangeLog and DESCRIPTION files after submission to CRAN * NAMESPACE: Updated NAMESPACE; functions with a dot in front are no longer exported. 2012-09-24 chalabi * DESCRIPTION: Updated maintainer field. * NAMESPACE, R/zzz.Deprecated.R: Removed external C call. 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-10-26 chalabi * NAMESPACE: updated NAMESPACE 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2010-04-14 chalabi * NAMESPACE: updated NAMESPACE 2010-04-11 wuertz * R/assets-arrange.R, R/assets-fit.R, R/assets-lpm.R, R/assets-mcr.R, R/assets-meancov.R, R/assets-outliers.R, R/assets-portfolio.R, R/assets-select.R, R/assets-simulate.R, R/assets-test.R, R/assetsArrange.R, R/assetsFit.R, R/assetsLPM.R, R/assetsMCR.R, R/assetsMeanCov.R, R/assetsOutliers.R, R/assetsPfolio.R, R/assetsSelect.R, R/assetsSim.R, R/assetsTest.R: some files renamed for consistency 2010-02-21 dscott * ChangeLog, R/zzz.R, src/Makevars: Minor changes so passes check * ChangeLog, R/plot-pairs.R, R/zzz.R, src/Makevars: minor changes to plot-pairs.R and fixed dll with alteration to zzz.R and src/Makevars 2009-11-22 wuertz * R/stats-distance.R: mutinfo function modified * R/zzz.R, src/ecodist.c: C code modified to work all C programs together * R/stats-distance.R, src/ecodist.c: C Code added ecodist.c * NAMESPACE, R/builtin-ecodist.R, R/stats-distance.R: namespace updated * R/builtin-ecodist.R: function name modified * R/stats-distance.R: code modified * R/builtin-ecodist.R, R/stats-distance.R: distance measures added (undocumented) 2009-10-26 wuertz * man/assetsMCR.Rd: man page examples corrected * NAMESPACE, R/assetsMCR.R, R/assetsPfolio.R, R/zzz.Deprecated.R, man/assetsMCR.Rd: assetsMCR.R and .Rd script added for marginal contribution to covariance risk 2009-09-28 chalabi * DESCRIPTION: updated version number * ChangeLog, DESCRIPTION: updated DESCR and ChangeLog * NAMESPACE: new NAMESPACE structure which should ease maintenance of packages. * DESCRIPTION, NAMESPACE: Merge branch 'devel-timeSeries' Conflicts: pkg/timeSeries/R/base-Extract.R pkg/timeSeries/R/timeSeries.R 2009-05-06 wuertz * R/builtin-shrinkTawny.R: shrink from tawny added als builtin * R/assetsMeanCov.R: Mean Cov functionality extended 2009-05-01 wuertz * R/assetsMeanCov.R, R/builtin-arwMvoutlier.R: hidden robut covariance stimator .arwMeanCov added 2009-04-29 wuertz * R/assetsMeanCov.R: comment added 2009-04-28 wuertz * R/builtin-mst.R, R/builtin-robust.R, man/assetsMeanCov.Rd: new robust cov estimators added * NAMESPACE: namespace new functions added * R/builtin-DEoptim.R, R/builtin-corpcor.R, R/builtin-corrgram.R, R/builtin-covRobust.R, R/builtin-donostahRobust.R, R/builtin-energy.R, R/builtin-mstApe.R, R/builtin-rmtTawny.R, R/builtin-shrinkTawny.R: more information added to builtin function, builtins added for shrink and rmt from tawny and bayes stein from alexios * R/assetsMeanCov.R: bayes stein, ledoit wolf, and rmt covariance estimator added 2009-04-19 chalabi * DESCRIPTION: added explicit version number in Depends field for key packages 2009-04-08 ellis * R/plot-pairs.R: added function to compute color space for correlation matrix plot 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. * DESCRIPTION: updated DESC file 2009-03-13 wuertz * R/assetsTest.R: small fix done * R/assetsTest.R: fixed 2009-02-09 wuertz * NAMESPACE, R/assetsArrange.R, R/assetsMeanCov.R, R/assetsStats.R, R/plot-risk.R, R/plot-stars.R, R/zzz.Deprecated.R, R/zzz.R, inst/unitTests/runit.AssetsMeanCov.R, man/00fAssets-package.Rd, man/VaRModelling.Rd, man/assetsArrange.Rd, man/assetsFit.Rd, man/assetsLPM.Rd, man/assetsMeanCov.Rd, man/assetsOutliers.Rd, man/assetsPfolio.Rd, man/assetsSelect.Rd, man/assetsSim.Rd, man/assetsStats.Rd, man/assetsTest.Rd, man/boxPlot.Rd, man/class-fASSETS.Rd, man/covEllipsesPlot.Rd, man/pairsPlot.Rd, man/plot-binning.Rd, man/plot-boxplot.Rd, man/plot-ellipses.Rd, man/plot-hist.Rd, man/plot-mst.Rd, man/plot-pairs.Rd, man/plot-qqplot.Rd, man/plot-risk.Rd, man/plot-series.Rd, man/plot-similarity.Rd, man/plot-stars.Rd, man/seriesPlot.Rd, man/similarityPlot.Rd, man/starsPlot.Rd: help pages and documentation essentiall improved, all functions, arguments and retur5ned values should now be documented 2009-02-08 wuertz * R/builtin-corrgram.R, R/buitin-corrgram.R: package reorganized, script files * R/assetsArrange.R, R/assetsFit.R, R/assetsLPM.R, R/assetsMeanCov.R, R/assetsOutliers.R, R/assetsPfolio.R, R/assetsSelect.R, R/assetsSim.R, R/assetsStats.R, R/assetsTest.R, R/panel-diagonal.R, R/plot-panels.R, R/plot-qqplot.R, R/zzz.Deprecated.R: script files reorganized * R/panel-diagonal.R, R/plot-panels.R, R/plotPanels.R: reorganization of files * R/assetsFit.R, R/assetsPfolio.R, R/assetsRisk.R, R/class-fASSETS.R, R/plot-binning.R, R/plot-boxplot.R, R/plot-ellipses.R, R/plot-hist.R, R/plot-mst.R, R/plot-pairs.R, R/plot-panels.R, R/plotPanels.R: script files freorganisation * R/VaRModelling.R, R/assetsRisk.R, R/exampleCovData.R, R/fixBinHistogram.R, R/plot-binning.R, R/plot-correlation.R, R/plot-covEllipses.R, R/plot-ellipses.R, R/plot-histPairs.R, R/plot-minSpanTree.R, R/plot-mst.R, R/plot-pairsPanels.R, R/plot-panels.R: files renamed * R/assetsArrange.R, R/assetsFit.R, R/assetsMeanCov.R, R/assetsOutliers.R, R/assetsSelect.R, R/assetsStats.R, R/assetsTest.R, R/builtin-robust.R, R/exampleCovData.R, R/fixBinHistogram.R, R/plot-correlation.R, R/plot-histPairs.R, R/plot-stars.R, R/zzz.Deprecated.R: reorginization of files 2009-01-27 wuertz * R/plot-pairs.R: warnings hidden for pairs() if tick = 0 2009-01-16 chalabi * man/assetsLPM.Rd, man/assetsMeanCov.Rd, man/seriesPlot.Rd: fixed warning with new Rd parser 2009-01-04 wuertz * NAMESPACE, R/assetsMeanCov.R, R/assetsOutliers.R, R/outlierDetection.R, man/assetsMeanCov.Rd, man/assetsOutliers.Rd: internal function .assetsOutlierDetection moved to assetsOutlier, documented and added to NAMESPACE 2009-01-02 wuertz * R/plot-boxplot.R: default abline removed from box plot * R/plot-stars.R: stars plot, plot argument corrected 2008-12-31 wuertz * R/assetsSelect.R, man/assetsSelect.Rd: small modifications fAssets/man/0000755000176000001440000000000012424423203012461 5ustar ripleyusersfAssets/man/plot-risk.Rd0000644000176000001440000000371612424423203014703 0ustar ripleyusers\name{plot-risk} \alias{seriesPlots} \alias{assetsRiskReturnPlot} \alias{assetsNIGShapeTrianglePlot} \title{Assets Risk Plots} \description{ Displays risk plot from asseets. } \usage{ assetsRiskReturnPlot(x, col = "steelblue", percentage = FALSE, scale = 252, labels = TRUE, add = TRUE, \dots) assetsNIGShapeTrianglePlot(x, labels, col = "steelblue", \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{col}{ a character string, defining the color to fill the boxes. } \item{percentage}{ a logical flag. Are the returns given by log or percentual log returns? } \item{scale}{ an integer value, the scale, i..e number of days, in a year. Used by daily data sets. } \item{labels}{ a logical flag, if \code{TRUE} then default labels will be used, otherwise the plots will be displayed without labels and the user can add his own labels. } \item{add}{ a logical flag, defining the color to fill the boxes. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsRiskReturnPlot - # Create Risk/Return Plot: # par(mfrow = c(2, 2)) assetsRiskReturnPlot(LPP) ## assetsNIGShapeTrianglePlot - # Create NIG Shape Triangle Plot: assetsNIGShapeTrianglePlot(LPP) } \keyword{models} fAssets/man/plot-binning.Rd0000644000176000001440000000303412424423203015350 0ustar ripleyusers\name{plot-binning} \alias{binningPlot} \alias{assetsHistPairsPlot} \title{Bivariate Histogram Plots of Assets} \description{ Displays bivariate histogram plots of assets returns. } \usage{ assetsHistPairsPlot(x, bins = 30, method = c("square", "hex"), \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{bins}{ an integer value, the number of bins used for the biariate histogram. } \item{method}{ a character string denoting whic h type of binning should be used, either \code{"squared"} or \code{"hexagonal"}. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsHistPairsPlot - # Create a bivariate Binning Plot: assetsHistPairsPlot - assetsHistPairsPlot(LPP[, c("LMI", "ALT")]) ## assetsHistPairsPlot - # Now with hexagonal Bins: assetsHistPairsPlot(LPP[, c("LMI", "ALT")], method = "hex") grid(col="red") } \keyword{models} fAssets/man/plot-similarity.Rd0000644000176000001440000000476312424423203016124 0ustar ripleyusers\name{plot-similarity} \alias{similarityPlot} \alias{assetsDendrogramPlot} \alias{assetsCorEigenPlot} \title{Assets Similarity Plots} \description{ Displays plots of similariaies and dissimilarities between data sets of assets. } \usage{ assetsDendrogramPlot(x, labels = TRUE, title = TRUE, box = TRUE, method = c(dist = "euclidian", clust = "complete"), \dots) assetsCorEigenPlot(x, labels = TRUE, title = TRUE, box = TRUE, method = c("pearson", "kendall", "spearman"), \dots) } \arguments{ \item{box}{ a logical flag, should a box be added around the plot? By default \code{TRUE}. } \item{labels}{ a logical flag, if \code{TRUE} then default labels will be used, otherwise the plots will be displayed without labels and the user can add his own labels. } \item{method}{ [assetsCorgramPlot] - \cr for the function \code{assetsCorgramPlot} a character string, the type of graph used in the lower panel, for the function \code{assetsCorEigenPlot} a character string, the method used to compute the correlation matrix.\cr [assetsTreePlot] - \cr a character string, the method used to compute the distance matrix, see function \code{dist}. } \item{title}{ a logical flag, should a default title be added? By default \code{TRUE}. } \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{\dots}{ optional arguments to be passed. } } \details{ \code{assetsDendrogramPlot}\cr displays a hierarchical clustering dendrogram, \code{assetsCorEigenPlot}\cr displays ratio plot of the largest two eigenvalues. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsDendrogramPlot - # Display a Dendrogram Plot: assetsDendrogramPlot(LPP) ## assetsCorEigenPlot - # Display a Correlation Eigenvalue Ratio Plot: assetsCorEigenPlot(LPP) } \keyword{models} fAssets/man/plot-boxplot.Rd0000644000176000001440000000256112424423203015417 0ustar ripleyusers\name{plot-boxplot} \alias{boxPlot} \alias{assetsBoxPlot} \alias{assetsBoxPercentilePlot} \title{Displays a Box Plot of Assets} \description{ Displays standard box and box-percentile plots of assets. } \usage{ assetsBoxPlot(x, col = "bisque", \dots) assetsBoxPercentilePlot(x, col = "bisque", \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{col}{ a character string, defining the color to fill the boxes. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## assetsBoxPlot - # Create a Boxplot: assetsBoxPlot - assetsBoxPlot(LPP) ## assetsBoxPercentilePlot - # Create a Box Percentile Plot: assetsBoxPercentilePlot - assetsBoxPercentilePlot(LPP) grid(NA, NULL, col="red") } \keyword{models} fAssets/man/plot-stars.Rd0000644000176000001440000001057512424423203015070 0ustar ripleyusers\name{plot-stars} \alias{starsPlot} \alias{assetsStarsPlot} \alias{assetsBasicStatsPlot} \alias{assetsMomentsPlot} \alias{assetsBoxStatsPlot} \alias{assetsNIGFitPlot} \title{Stars Plots of Assets.} \description{ Displays star plots to compare assets sets. } \usage{ assetsStarsPlot(x, method = c("segments", "stars"), locOffset = c(0, 0), keyOffset = c(0, 0), \dots) assetsBoxStatsPlot(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Box Plot Statistics", descriptionPosition = c(3, 3.50), \dots) assetsBasicStatsPlot(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Basic Returns Statistics", descriptionPosition = c(3, 3.50), \dots) assetsMomentsPlot(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "Moments Statistics", descriptionPosition = c(3, 3.50), \dots) assetsNIGFitPlot(x, par = TRUE, oma = c(0,0,0,0), mar = c(4, 4, 4, 4), keyOffset = c(-0.65, -0.50), main = "Assets Statistics", title = "Assets", titlePosition = c(3, 3.65), description = "NIG Parameters", descriptionPosition = c(3, 3.50), \dots) } \arguments{ \item{description}{ a destription string. } \item{descriptionPosition}{ the position of the description string. } \item{method}{ a character string from to select the plot method. Eiter a \code{"star"} or a \code{"segment"} plot. } \item{keyOffset}{ a numeric vector of lenght two, specifying an offset in the legend with respect to \code{x} and \code{y} direction. } \item{locOffset}{ a numeric vector of lenght two, specifying an offset in the location of the stars/circles with respect to \code{x} and \code{y} direction. } \item{main}{ to set the main title. } \item{mar}{ to set the number of lines of margin to be specified on the four sides of the plot. The default is \code{c(5,4,4,2)+0.1}. } \item{oma}{ to set the size of the outer margins in lines of text. } \item{par}{ a logical flag. Should be internal \code{par()} setting be used? } \item{title}{ a character string, the plot title. } \item{titlePosition}{ the position of the title string. } \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{\dots}{ optional arguments to be passed. } } \details{ \code{assetsStarsPlot}\cr draws segment or star diagrams of data sets, \code{assetsBasicStatsPlot}\cr displays a segment plot of box plot statistics, \code{assetsMomentsPlot}\cr displays a segment plot of distribution moments, \code{assetsBoxStatsPlot}\cr displays a segment plot of box plot statistics, \code{assetsNIGFitPlot}\cr displays a segment plot NIG parameter estimates. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsBasicStatsPlot - # Create a basic Stats Plot: assetsBasicStatsPlot - # par(mfrow = c(1, 1)) assetsBasicStatsPlot(LPP, title = "", description = "") ## assetsMomentsPlot - # Create a Moments Plot: assetsMomentsPlot - assetsMomentsPlot(LPP, title = "", description = "") ## assetsBoxStatsPlot - # Create a Box Stats Plot: assetsBoxStatsPlot - assetsBoxStatsPlot(LPP, title = "", description = "") ## assetsNIGFitPlot - # Create a NIG Fit Plot: assetsNIGFitPlot - assetsNIGFitPlot(LPP[, 7:9], title = "", description = "") } \keyword{models} fAssets/man/plot-series.Rd0000644000176000001440000000256312424423203015224 0ustar ripleyusers\name{plot-series} \alias{seriesPlot} \alias{assetsReturnPlot} \alias{assetsCumulatedPlot} \alias{assetsSeriesPlot} \title{Displays Series Plots of Assets.} \description{ Displays series from sets of assets. } \usage{ assetsReturnPlot(x, col = "steelblue", \dots) assetsCumulatedPlot(x, col = "steelblue", \dots) assetsSeriesPlot(x, col = "steelblue", \dots) } \arguments{ \item{x}{ an object of class \code{timeSeries}. } \item{col}{ a character string, defining the color to fill the boxes. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsReturnPlot - # Create Return Series Plot: # par(mfrow = c(3, 2)) assetsReturnPlot(LPP[, 1:3]) ## assetsCumulatedPlot - # Create Cumulated Price/Index Plot: assetsCumulatedPlot(LPP[, "LPP40"], col = "red") ## assetsSeriesPlot # Crete Time Series Plot: assetsSeriesPlot(LPP[, c("LMI", "ALT")], col = c("orange", "brown")) } \keyword{models} fAssets/man/assets-selection.Rd0000644000176000001440000000525612424423203016245 0ustar ripleyusers\name{assets-selection} \alias{assetsSelect} \title{Selecting Assets from Multivariate Asset Sets} \description{ Selet assets from Multivariate Asset Sets based on clustering. } \usage{ assetsSelect(x, method = c("hclust", "kmeans"), control = NULL, \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{method}{ a character string, which clustering method should be used? Either \code{hclust} for hierarchical clustering of dissimilarities, or \code{kmeans} for k-means clustering. } \item{control}{ a character string with two entries controlling the parameters used in the underlying cluster algorithms. If set to NULL, then default settings are taken: For hierarchical clustering this is \code{method=c(measure="euclidean", method="complete")}, and for kmeans clustering this is \code{method=c(centers=3, algorithm="Hartigan-Wong")}. } \item{\dots}{ optional arguments to be passed. Note, for the k-means algorithm the number of centers has to be specified! } } \value{ if \code{use="hclust"} was selected then the function returns a S3 object of class "hclust", otherwise if \code{use="kmeans"} was selected then the function returns an object of class "kmeans". For details we refer to the help pages of \code{hclust} and \code{kmeans}. } \details{ The function \code{assetsSelect} calls the functions \code{hclust} or \code{kmeans} from R's \code{"stats"} package. \code{hclust} performs a hierarchical cluster analysis on the set of dissimilarities \code{hclust(dist(t(x)))} and \code{kmeans} performs a k-means clustering on the data matrix itself. Note, the hierarchical clustering method has in addition a plot method. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC colnames(LPP) ## assetsSelect - # Hierarchical Clustering: hclust <- assetsSelect(LPP, "hclust") plot(hclust) ## assetsSelect - # kmeans Clustering: assetsSelect(LPP, "kmeans", control = c(centers = 3, algorithm = "Hartigan-Wong")) } \keyword{models} fAssets/man/plot-ellipses.Rd0000644000176000001440000000211612424423203015544 0ustar ripleyusers\name{plot-ellipses} \alias{covEllipsesPlot} \title{Displays a Covariance Ellipses Plot} \description{ Displays a covariance ellipses plot. } \usage{ covEllipsesPlot(x = list(), \dots) } \arguments{ \item{x}{ a list of at least two covariance matrices. } \item{\dots}{ optional arguments to be passed.\cr } } \details{ This plot visualizes the difference between two or more covariance matrices. It is meant to compare different methods of covariance estimation. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## assetsMeanCov - # Compute Robust Covariance Matrix: assetsMeanCov - Cov <- cov(LPP) robustCov <- assetsMeanCov(LPP, "MCD")$Sigma ## covEllipsesPlot - # Create Covariance Ellipse Plot: covEllipsesPlot(list(Cov, robustCov)) } \keyword{models} fAssets/man/plot-mst.Rd0000644000176000001440000000332712424423203014534 0ustar ripleyusers\name{plot-mst} \alias{treePlot} \alias{assetsTreePlot} \title{Assets Tree Plot} \description{ Creates and displays a minimum spanning tree of assets. } \usage{ assetsTreePlot(x, labels = TRUE, title = TRUE, box = TRUE, method = "euclidian", seed = NULL, \dots) } \arguments{ \item{x}{ a multivariate \code{timeSeries} object. } \item{labels}{ a logical flag, if \code{TRUE} then default labels will be used, otherwise the plots will be displayed without labels and the user can add his own labels. } \item{title}{ a logical flag, should a default title be added? By default \code{TRUE}. } \item{box}{ a logical flag, should a box be added around the plot? By default \code{TRUE}. } \item{method}{ a character string, the method used to compute the distance matrix, see function \code{dist}. } \item{seed}{ an integer value setting the seed in the computation of the sample ranks. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## assetsTreePlot(LPP) - # Create Minimum Spanning Tree Graph: assetsTreePlot - # par(mfrow = c(2, 2)) assetsTreePlot(LPP) # new seeds ... for (i in 1:3) assetsTreePlot(LPP) } \keyword{models} fAssets/man/assets-outliers.Rd0000644000176000001440000000312312424423203016115 0ustar ripleyusers\name{assets-outliers} \alias{assetsOutliers} \title{Detection of Outliers in Asset Sets} \description{ Detects multivariate outliers in asset sets. } \usage{ assetsOutliers(x, center, cov, \dots) } \arguments{ \item{x}{ an object of class \code{timeSeries}. } \item{center}{ a numeric vector, a (robust) estimate of the vector of means of the multivariate time series \code{x}. } \item{cov}{ a numeric matrix, a (robust) estimate of the covariance matrix of the multivariate time series \code{x}. } \item{\dots}{ optional arguments to be passed. } } \value{ returns a list with the following entries: the estimate for the location named \code{center}, the estimate for the covariance matrix named \code{cov}, the estimate for the correlation matrix named \code{cor}, the quantile named \code{quantile}, the outliers named \code{outliers}, and the time series named \code{series}. } \author{ Moritz Gschwandtner and Peter Filzmoser for the original R code from package "mvoutliers", \cr Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - LPP <- as.timeSeries(data(LPP2005REC))[, 1:6] colnames(LPP) ## assetsOutliers - assetsOutliers(LPP, colMeans(LPP), cov(LPP)) } \keyword{models} fAssets/man/assets-distance.Rd0000644000176000001440000000710212424423203016042 0ustar ripleyusers\name{assets-distance} \alias{assetsDist} \alias{corDist} \alias{kendallDist} \alias{spearmanDist} \alias{mutinfoDist} \alias{euclideanDist} \alias{maximumDist} \alias{manhattanDist} \alias{canberraDist} \alias{binaryDist} \alias{minkowskiDist} \alias{braycurtisDist} \alias{mahalanobisDist} \alias{jaccardDist} \alias{sorensenDist} \title{Distance Measures} \description{ Allows to measure the distance or similarity between assets. } \usage{ assetsDist(x, method="cor", \dots) corDist(x) kendallDist(x) spearmanDist(x) mutinfoDist(x, nbin=10) euclideanDist(x) maximumDist(x) manhattanDist(x) canberraDist(x) binaryDist(x) minkowskiDist(x) braycurtisDist(x) mahalanobisDist(x) jaccardDist(x) sorensenDist(x) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{dist()} into a distance object. } \item{method}{ a character string, the method from which to compute the distances. Allowed methods include \code{cor}, \code{kendall}, \code{spearman}, \code{mutinfo}, \code{euclidean}, \code{maximum}, \code{manhattan}, \code{canberra}, \code{binary}, \code{minkowski}, \code{braycurtis}, \code{mahalanobis}, \code{jaccard}, \code{difference}, or \code{sorensen}. } \item{nbin}{ an integer value, the number of bins, by default 10. } \item{\dots}{ optional argument to be passed the distance function. } } \value{ an object of class \code{dist}. } \details{ \code{corDist}, \code{kendallDist}, and \code{spearmanDist} call the base \code{cov} function from R. \code{mutinfoDist} calls the function \code{mutinfo} from the contributed R package \code{bioDist}. \code{euclideanDist}, \code{maximumDist}, \code{manhattanDist}, \code{canberraDist}, \code{binaryDist}, and \code{minkowskiDist} are functions build on top of R's base package. \code{braycurtisDist}, \code{mahalanobisDist}, \code{jaccardDist}, and \code{sorensenDist} call functions from the contributed R package \code{ecodist}. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## Returns correlation distance measure corDist(LPP) ## Returns kendalls correlation distance measure kendallDist(LPP) ## Returns spearmans correlation distance measure spearmanDist(LPP) ## Return mutual information distance measure mutinfoDist(LPP) ## Return Euclidean distance measure euclideanDist(LPP) ## Return maximum distance measure maximumDist(LPP) ## Return Manhattan distance measure manhattanDist(LPP) ## Return Canberra distance measure canberraDist(LPP) ## Return binary distance measure binaryDist(LPP) ## Return Minkowsky distance measure minkowskiDist(LPP) ## Return Bray Curtis distance measure braycurtisDist(LPP) ## Return Mahalanobis distance measure # mahalanobisDist(LPP) ## Return Jaccard distance mesaure jaccardDist(LPP) ## Return Sorensen distance measure sorensenDist(LPP) } \keyword{stats} fAssets/man/00fAssets-package.Rd0000644000176000001440000002210012424423203016104 0ustar ripleyusers\name{fAssets-package} \alias{fAssets-package} \alias{fAssets} \docType{package} \title{Analysing and Modelling Financial Assets} \description{ The Rmetrics \code{fAssets} package is a collection of functions to manage, to investigate and to analyze data sets of financial assets from different points of view. } \details{ \tabular{ll}{ Package: \tab fAssets\cr Type: \tab Package\cr Date: \tab 2014\cr License: \tab GPL Version 2 or later\cr Copyright: \tab (c) 1999-2014 Rmetrics Association\cr Repository: \tab R-FORGE\cr URL: \tab \url{https://www.rmetrics.org} } } \keyword{models} \section{1 Introduction}{ The package \code{fAssets} was written to explore and investigate data sets of financial asssets Included are functions to make the the asset selection process easier, to robustify return and covariances for modeling portfolios, to test financial returns for multivariate normality, and to measure in a simple way performance and risk of funds and portfolios. Beside this many functions for graphs and plots, and for a more sophisticated explorative data analysis are provided. They range from simple time series plots to more elaborated statisitical chart tools: histogram, density, boxplots, and QQ plots; pairs,similaries, and covarinace ellipses plots; star plots, and risk/reward graphs. } \section{2 Assets Selection}{ The assets selection chapter containts functions which arrange assets from a data set according to different measaures applying ideas from principal component analysis, from hierarchical clustering, or by a user defined statistical measure: % assets-arrange.R \preformatted{ assetsArrange Rearranges the columns in a data set of assets pcaArrange Returns PCA correlation ordered column names hclustArrange Returns hierarchical clustered column names abcArrange Returns assets sorted by column names orderArrange Returns assets ordered by column names sampleArrange Returns a re-sampled set of assets statsArrange Returns statistically rearranged column names } In addition we have summarized and bundle of distance measure functions to determine the similarity or dissimilarity of individual assets from a set of multivariate financial return series. % assets-distance.R \preformatted{ assetsDist Computes the distances between assets corDist Returns correlation distance measure kendallDist Returns kendalls correlation distance measure spearmanDist Returns spearmans correlation distance measure mutinfoDist Returns mutual information distance measure euclideanDist Returns Euclidean distance measure maximumDist Returns maximum distance measure manhattanDist Returns Manhattan distance measure canberraDist Returns Canberra distance measure binaryDist Returns binary distance measure minkowskiDist Returns Minkowsky distance measure braycurtisDist Returns Bray Curtis distance measure mahalanobisDist Returns Mahalanobis distance measure jaccardDist Returns Jaccard distance mesaure sorensenDist Returns Sorensen distance measure } A last group of functions allows to select assets by concepts from hierarchical or k-means clustering: % assets-selection.R \preformatted{ assetsSelect Selects similar or dissimilar assets .hclustSelect Selects due to hierarchical clustering .kmeansSelect Selects due to k-means clustering } } \section{3 Assets Covariance Robustification}{ We provide several functions to compute robust measures for mean and/or covariance estimates which can be used for example in robustified Markowitz portfolio Optimization. % assets-meancov.R \preformatted{ assetsMeanCov Estimates mean and variance for a set of assets .covMeanCov uses sample covariance estimation .mveMeanCov uses "cov.mve" from [MASS] .mcdMeanCov uses "cov.mcd" from [MASS] .studentMeanCov uses "cov.trob" from [MASS] .MCDMeanCov requires "covMcd" from [robustbase] .OGKMeanCov requires "covOGK" from [robustbase] .nnveMeanCov uses builtin from [covRobust] .shrinkMeanCov uses builtin from [corpcor] .baggedMeanCov uses builtin from [corpcor] .arwMeanCov uses builtin from [mvoutlier] .donostahMeanCov uses builtin from [robust] .bayesSteinMeanCov uses builtin from Alexios Ghalanos .ledoitWolfMeanCov uses builtin from [tawny] .rmtMeanCov uses builtin from [tawny] } An additional function allows to detect outliers from a PCA outlier analysis. % assets-outliers.R \preformatted{ assetsOutliers Detects outliers in multivariate assets sets } } \section{4 Testing Assets for Normality}{ The multivariate Shapiro test and the E-Statistic Energy Test allow to test multivariate Normality of financial returns. % assets-testing.R \preformatted{ assetsTest Tests for multivariate Normal Assets mvshapiroTest Multivariate Shapiro Test mvenergyTest Multivariate E-Statistic (Energy) Test } } \section{5 Lower Partial Moments Measures}{ The computation of Lower partial moments is done by the following two functions: % assets-lpm.R \preformatted{ assetsLPM Computes asymmetric lower partial moments assetsSLPM Computes symmetric lower partial moments } } \section{6 Assets Time Series and Density Plot Functions}{ Dozens of tailored plot functions are included in the \code{fAssets} package. This makes it very easy to visualize properties and to perform an explorative data analysis. Starting from simple time series functions. % plotSeries.R \preformatted{ assetsReturnPlot Displays time series of individual assets assetsCumulatedPlot Displays time series of individual assets assetsSeriesPlot Displays time series of individual assets } we can also explore the distributional properties of the returns by histogram, density, boxplots, and QQ Plots: % plot-hist.R | plot-binning.R | % plot-boxplot.R | % plot-qqplot.R \preformatted{ assetsHistPlot Displays a histograms of a single asset assetsLogDensityPlot Displays a pdf plot on logarithmic scale assetsHistPairsPlot Displays a bivariate histogram plot assetsBoxPlot Displays a standard box plot assetsBoxPercentilePlot Displays a side-by-side box-percentile plot assetsQQNormPlot Displays normal qq-plots of individual assets } } \section{7 Assets Dependency and Structure Plot Functions}{ Corellation and similarities are another source of information about the dependence structure of individual financial returns. The functions which help us to detect those properties in data sets of financial assets include: % plot-pairs.R and plot-panels.R | plot-similaries.R | plot-ellipses.R \preformatted{ assetsPairsPlot Displays pairs of scatterplots of assets assetsCorgramPlot Displays pairwise correlations between assets assetsCorTestPlot Displays and tests pairwise correlations assetsCorImagePlot Displays an image plot of a correlations covEllipsesPlot Displays a covariance ellipses plot assetsDendrogramPlot Displays hierarchical clustering dendrogram assetsCorEigenPlot Displays ratio of the largest two eigenvalues } Beside correlations und dependencies also risk/reward graphs give additional insight into the structure of assets. % plot-risk.R \preformatted{ assetsRiskReturnPlot Displays risk-return diagram of assets assetsNIGShapeTrianglePlot Displays NIG Shape Triangle assetsTreePlot Displays a minimum spanning tree of assets } Statistic visualized by star plots is a very appealing tool for characterization and classification of assets by eye: % plot-stars.R \preformatted{ assetsStarsPlot Draws segment/star diagrams of asset sets assetsBasicStatsPlot Displays a segment plot of basic return stats assetsMomentsPlot Displays a segment plot of distribution moments assetsBoxStatsPlot Displays a segment plot of box plot statistics assetsNIGFitPlot Displays a segment plot NIG parameter estimates } } \section{About Rmetrics:}{ The \code{fAssets} Rmetrics package is written for educational support in teaching "Computational Finance and Financial Engineering" and licensed under the GPL. } \keyword{package} fAssets/man/assets-lpm.Rd0000644000176000001440000000270512424423203015044 0ustar ripleyusers\name{assets-lpm} \alias{assetsLPM} \alias{assetsSLPM} \title{Computation of Lower Partial Moments of Asset Sets} \description{ Computes lower partial moments from a time series of assets. } \usage{ assetsLPM(x, tau, a, \dots) assetsSLPM(x, tau, a, \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{tau}{ the target return. } \item{a}{ the value of the moment. } \item{\dots}{ optional arguments to be passed. } } \value{ returns a list with two entries named \code{mu} and \code{Sigma}. The first denotes the vector of lower partial moments, and the second the co-LPM matrix. Note, that the output of this function can be used as data input for the portfolio functions to compute the LPM efficient frontier. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Percentual Returns: LPP <- 100 * as.timeSeries(data(LPP2005REC))[, 1:6] colnames(LPP) } \keyword{models} fAssets/man/assets-arrange.Rd0000644000176000001440000000472012424423203015672 0ustar ripleyusers\name{assets-arrange} \alias{assetsArrange} \alias{pcaArrange} \alias{hclustArrange} \alias{abcArrange} \alias{orderArrange} \alias{sampleArrange} \alias{statsArrange} \title{Rearranging Assets Columnwise} \description{ Allows to rearrange a set of assets columnwise. } \usage{ assetsArrange(x, method = c("pca", "hclust", "abc"), ...) pcaArrange(x, robust = FALSE, ...) hclustArrange(x, method = c("euclidean", "complete"), ...) abcArrange(x, ...) orderArrange(x, ...) sampleArrange(x, ...) statsArrange(x, FUN = colMeans, ...) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{method}{ a character string, which method should be applied to reaarnage the assests? Either \code{"pca"} which arranges the columns by an eigenvalue decomposition, \code{"hclust"} which arrangtes the columns by hierarchical clustering, \code{"abc"} which arrangtes the columns alphabetically, \code{"order"} which arrangtes the columns by the order function, \code{"sample"} which arranges the columns randomly, or \code{"stats"} which arranges by an statistical strategy. } \item{robust}{ a logical flag. Should robust statistics applied? } \item{FUN}{ function anme of the statistical function to be applied. } \item{\dots}{ optional arguments to be passed. } } \value{ a character vector with the rearranged assets names. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:3] head(LPP) ## assetsArrange - # Arrange Assets Columns: assetsArrange(x=LPP, "pca") assetsArrange(x=LPP, "hclust") assetsArrange(x=LPP, "abc") ## Alternative Usage - pcaArrange(x=LPP, robust=FALSE) pcaArrange(x=LPP, robust=TRUE) hclustArrange(x=LPP, method = c("euclidean", "complete")) abcArrange(x=LPP) orderArrange(x=LPP) sampleArrange(x=LPP) statsArrange(x=LPP, FUN=colMeans) } \keyword{models} fAssets/man/assets-modeling.Rd0000644000176000001440000000552612424423203016056 0ustar ripleyusers\name{assets-modeling} \alias{assetsFit} \alias{assetsSim} \title{Modeling Multivariate Asset Sets} \description{ Fitting and Simulatingassets from multivariate asset sets based on modeling skew normal and related distributions. } \usage{ assetsFit(x, method = c("st", "sn", "sc"), title=NULL, description=NULL, fixed.df=NA, \dots) assetsSim(n, method=c("st", "sn", "sc"), model=list(beta=rep(0, 2), Omega=diag(2), alpha=rep(0, 2), nu=4), assetNames=NULL) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{n}{ a numeric value which represents the number of random vectors to be drawn. } \item{method}{ a character string with the names of the supported distributions: \code{sn} skew normal, \code{st} skew Student-t, and \code{sc} skew Cauchy } \item{model}{ a list with the model parameters. \code{beta} a numeric vector, representing the location, \code{Omega} a symmetric positive-definite matrix (covariance matrix), \code{alpha} a numeric vector which regulates the skew of the density, \code{nu} a positive value representing the degrees of freedom. } \item{fixed.df}{ a logical value, should the degreess of freedom fitted or held fixed? } \item{title}{ an optional project title. } \item{description}{ an option project desctiption. } \item{assetNames}{ a character vector with optional asset names. } \item{\dots}{ optional arguments passed to the underlying functions. } } \value{ \code{assetsFit} returns the fitted parameters, \code{assetsSim} returns a simulated (return) series. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data as Percentual Returns: LPP <- 100 * LPP2005REC[, 1:3] head(LPP) ## assetsFit - # Fit a Skew-Student-t Distribution: fit <- assetsFit(LPP) # Extract the Model: model <- fit@fit$dp # Show Model Slot: print(model) ## assetsSim - # Simulate set with same statistical properties: set.seed(1953) LPP.SIM <- assetsSim(n=nrow(LPP), model=model) colnames(LPP.SIM) <- colnames(LPP) head(LPP.SIM) } \keyword{models} fAssets/man/plot-qqplot.Rd0000644000176000001440000000243612424423203015251 0ustar ripleyusers\name{plot-qqplot} \alias{assetsQQNormPlot} \title{Normal Quantile-Quantile Plots} \description{ Displays a normal quantile-quantile plot } \usage{ assetsQQNormPlot(x, col = "steelblue", skipZeros = FALSE, \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{col}{ a character string, defining the color to fill the boxes. } \item{skipZeros}{ a logical, should zeros be skipped in the histogram plot of the return series? } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC head(LPP) ## assetsQQNormPlot - # Create normal Quantile-Quantile Plot: # par(mfrow = c(2, 2)) assetsQQNormPlot(LPP[, 1:3]) } \keyword{models} fAssets/man/assets-meancov.Rd0000644000176000001440000001206512424423203015704 0ustar ripleyusers\name{assets-meancov} \alias{assetsMeanCov} \alias{getCenterRob} \alias{getCovRob} \title{Estimation of Mean and Covariances of Asset Sets} \description{ Estimates the mean and/or covariance matrix of a time series of assets by traditional and robust methods. } \usage{ assetsMeanCov(x, method = c("cov", "mve", "mcd", "MCD", "OGK", "nnve", "shrink", "bagged"), check = TRUE, force = TRUE, baggedR = 100, sigmamu = scaleTau2, alpha = 1/2, ...) getCenterRob(object) getCovRob(object) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{method}{ a character string, whicht determines how to compute the covariance matix. If \code{method="cov"} is selected then the standard covariance will be computed by R's base function \code{cov}, if \code{method="shrink"} is selected then the covariance will be computed using the shrinkage approach as suggested in Schaefer and Strimmer [2005], if \code{method="bagged"} is selected then the covariance will be calculated from the bootstrap aggregated (bagged) version of the covariance estimator. } \item{check}{ a logical flag. Should the covariance matrix be tested to be positive definite? By default \code{TRUE}. } \item{force}{ a logical flag. Should the covariance matrix be forced to be positive definite? By default \code{TRUE}. } \item{baggedR}{ when \code{methode="bagged"}, an integer value, the number of bootstrap replicates, by default 100. } \item{sigmamu}{ when \code{methode="OGK"}, a function that computes univariate robust location and scale estimates. By default it should return a single numeric value containing the robust scale (standard deviation) estimate. When \code{mu.too} is true (the default), \code{sigmamu()} should return a numeric vector of length 2 containing robust location and scale estimates. See \code{scaleTau2}, \code{s_Qn}, \code{s_Sn}, \code{s_mad} or \code{s_IQR} for examples to be used as \code{sigmamu} argument. For details we refer to the help pages of the R-package \code{robustbase}. } \item{object}{ a list as returned by the function \code{assetsMeanCov}. } \item{alpha}{ when \code{methode="MCD"}, a numeric parameter controlling the size of the subsets over which the determinant is minimized, i.e., \code{alpha*n} observations are used for computing the determinant. Allowed values are between 0.5 and 1 and the default is 0.5. For details we refer to the help pages of the R-package \code{robustbase}. } \item{\dots}{ optional arguments to be passed to the underlying estimators. For details we refer to the manual pages of the functions \code{cov.rob} for arguments \code{"mve"} and \code{"mcd"} in the R package \code{MASS}, to the functions \code{covMcd} and \code{covOGK} in the R package \code{robustbase}. } } \value{ \code{assetsMeanCov} returns a list with for entries named \code{center} \code{cov}, \code{mu} and \code{Sigma}. The list may have a character vector attributed with additional control parameters. \code{getCenterRob} extracts the center from an object as returned by the function \code{assetsMeanCov}. \code{getCovRob} extracts the covariance from an object as returned by the function \code{assetsMeanCov}. } \references{ Breiman L. (1996); \emph{Bagging Predictors}, Machine Learning 24, 123--140. Ledoit O., Wolf. M. (2003); \emph{ImprovedEestimation of the Covariance Matrix of Stock Returns with an Application to Portfolio Selection}, Journal of Empirical Finance 10, 503--621. Schaefer J., Strimmer K. (2005); \emph{A Shrinkage Approach to Large-Scale Covariance Estimation and Implications for Functional Genomics}, Statist. Appl. Genet. Mol. Biol. 4, 32. Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \author{ Juliane Schaefer and Korbinian Strimmer for R's \code{corpcov} package, \cr Diethelm Wuertz for the Rmetrics port. } \examples{ ## LPP - LPP <- as.timeSeries(data(LPP2005REC))[, 1:6] colnames(LPP) ## Sample Covariance Estimation: assetsMeanCov(LPP) ## Shrinked Estimation: shrink <- assetsMeanCov(LPP, "shrink") shrink ## Extract Covariance Matrix: getCovRob(shrink) } \keyword{models} fAssets/man/plot-pairs.Rd0000644000176000001440000000566212424423203015053 0ustar ripleyusers\name{plot-pairs} \alias{pairsPlot} \alias{assetsPairsPlot} \alias{assetsCorgramPlot} \alias{assetsCorTestPlot} \alias{assetsCorImagePlot} \title{Assets Pairs Plot} \description{ Display several aspects of correlation bettween pairs of assets. } \usage{ assetsPairsPlot(x, \dots) assetsCorgramPlot(x, method = c("pie", "shade"), \dots) assetsCorTestPlot(x, \dots) assetsCorImagePlot(x, labels = TRUE, show = c("cor", "test"), use = c("pearson", "kendall", "spearman"), abbreviate = 3, \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{labels}{ a logical flag, if \code{TRUE} then default labels will be used, otherwise the plots will be displayed without labels and the user can add his own labels. } \item{method}{ a character string, the type of graph used in the lower panel. } \item{show}{ a character string, what should be pressented, correlations or results from correlation tests? } \item{use}{ a character string indicating which correlation coefficient or covariance is to be computed. One of \code{"pearson"}, the default, \code{"kendall"}, or \code{"spearman"}. } \item{abbreviate}{ allows to abbreviate strings to at least \code{abbreviate} characters, such that they remain unique, if they were. } \item{\dots}{ optional arguments to be passed. } } \details{ \code{assetsPairsPlot}\cr displays pairs of scatterplots of individual assets, \code{assetsCorgramPlot}\cr displays correlations between assets, \code{assetsCorTestPlot}\cr displays and tests pairwise correlations, \code{assetsCorImagePlot}\cr displays an image plot of a correlations. } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## assetsPairsPlot - # Create Pairs Plot: assetsPairsPlot(LPP) ## assetsCorgramPlot - # Create Corellogram Plot: assetsCorgramPlot(LPP, method = "pie") assetsCorgramPlot(LPP, method = "shade") ## assetsCorTestPlot - # Create Correlation Test Plot: assetsCorTestPlot(LPP) ## assetsCorImagePlot - # Create Correlation Image Plot: assetsCorImagePlot(LPP) } \keyword{models} fAssets/man/assets-testing.Rd0000644000176000001440000000442312424423203015730 0ustar ripleyusers\name{assets-testing} \alias{assetsTest} \alias{mvshapiroTest} \alias{mvenergyTest} \title{Testing Normality of Multivariate Asset Sets} \description{ Tests if the returns of a set of assets are normally distributed. } \usage{ assetsTest(x, method = c("shapiro", "energy"), Replicates = 99) mvshapiroTest(x) mvenergyTest(x, Replicates = 99) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{method}{ a character string, which allows to select the test. If \code{method="shapiro"} then Shapiro's multivariate Normality test will be applied as implemented in R's contributed package \code{mvnormtest}. If \code{method="energy"} then the E-statistic (energy) for testing multivariate Normality will be used as proposed and implemented by Szekely and Rizzo [2005] using parametric bootstrap. } \item{Replicates}{ an integer value, the number of bootstrap replicates, by default 100. This value is only used if \code{method="energy"}. } } \value{ returns an object of class \code{htest}. } \references{ Rizzo M.L. (2002); \emph{A New Rotation Invariant Goodness-of-Fit Test}, PhD dissertation, Bowling Green State University. Szekely G.J., Rizzo, M.L. (2005); \emph{A New Test for Multivariate Normality}, Journal of Multivariate Analysis 93, 58--80. Szekely G.J. (1989); \emph{Potential and Kinetic Energy in Statistics}, Lecture Notes, Budapest Institute of Technology, TechnicalUniversity. Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \author{ Diethelm Wuertz for this Rmetrics port. } \examples{ ## LPP - # Load Swiss Pension Fund Data: LPP <- LPP2005REC[, 1:6] head(LPP) ## assetsTest - # Multivariate Shapiro Test - assetsTest(LPP, "shapiro") ## assetsTest - # Multivariate Energy Test - assetsTest(LPP, "energy") } \keyword{models} fAssets/man/plot-hist.Rd0000644000176000001440000000405212424423203014674 0ustar ripleyusers\name{plot-hist} \alias{histPlot} \alias{assetsHistPlot} \alias{assetsLogDensityPlot} \title{Histogram Plots of Assets} \description{ Displays density of assets returns as a histogram and/or as log density plot. } \usage{ assetsHistPlot(x, col = "steelblue", skipZeros = FALSE, \dots) assetsLogDensityPlot(x, estimator = c("hubers", "sample", "both"), labels = TRUE, \dots) } \arguments{ \item{x}{ any rectangular time series object which can be converted by the function \code{as.matrix()} into a matrix object, e.g. like an object of class \code{timeSeries}, \code{data.frame}, or \code{mts}. } \item{skipZeros}{ a logical, should zeros be skipped in the histogram plot of the return series ? } \item{col}{ a character string, defining the color to fill the boxes. } \item{estimator}{ a character string naming the type of estimator to fit the mean and variance of the normal density. This may be either \code{"huber"}, \code{"sample"}, or \code{"both"}. } \item{labels}{ a logical flag, if \code{TRUE} then default labels will be used, otherwise the plots will be displayed without labels and the user can add his own labels. } \item{\dots}{ optional arguments to be passed. } } \author{ Diethelm Wuertz for the Rmetrics port. } \references{ Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009); \emph{Portfolio Optimization with R/Rmetrics}, Rmetrics eBook, Rmetrics Association and Finance Online, Zurich. } \examples{ ## LPP2005REC - # Load Swiss Pension Fund Data: x <- LPP2005REC head(x) ## assetsHistPlot - # Create Histogram Plot: assetsHistPlot - # par(mfrow = c(2, 2)) assetsHistPlot(x[, 1:4]) ## assetsLogDensityPlot - #Create Log Density Plot: assetsLogDensityPlot - # par(mfrow = c(1, 1)) assetsLogDensityPlot(x[, "ALT"], estimator = "both") } \keyword{models}