fAssets/ 0000755 0001760 0000144 00000000000 12254146510 011712 5 ustar ripley users fAssets/inst/ 0000755 0001760 0000144 00000000000 12251673345 012677 5 ustar ripley users fAssets/inst/COPYRIGHT.html 0000644 0001760 0000144 00000020411 11370220754 015124 0 ustar ripley users
Rmetrics::COPYRIGHT
Rmetrics
Copyrights
2005-12-18 Built 221.10065
________________________________________________________________________________
Copyrights (C) for
R:
see R's copyright and license file
Version R 2.0.0 claims:
- The stub packages from 1.9.x have been removed.
- All the datasets formerly in packages 'base' and 'stats' have
been moved to a new package 'datasets'.
- Package 'graphics' has been split into 'grDevices' (the graphics
devices shared between base and grid graphics) and 'graphics'
(base graphics).
- Packages must have been re-installed for this version, and
library() will enforce this.
- Package names must now be given exactly in library() and
require(), regardless of whether the underlying file system is
case-sensitive or not.
________________________________________________________________________________
for
Rmetrics:
(C) 1999-2005, Diethelm Wuertz, GPL
Diethelm Wuertz
www.rmetrics.org
info@rmetrics.org
________________________________________________________________________________
for non default loaded basic packages part of R's basic distribution
MASS:
Main Package of Venables and Ripley's MASS.
We assume that MASS is available.
Package 'lqs' has been returned to 'MASS'.
S original by Venables & Ripley.
R port by Brian Ripley .
Earlier work by Kurt Hornik and Albrecht Gebhardt.
methods:
Formally defined methods and classes for R objects, plus other
programming tools, as described in the reference "Programming
with Data" (1998), John M. Chambers, Springer NY.
R Development Core Team.
mgcv:
Routines for GAMs and other generalized ridge regression
with multiple smoothing parameter selection by GCV or UBRE.
Also GAMMs by REML or PQL. Includes a gam() function.
Simon Wood
nnet:
Feed-forward Neural Networks and Multinomial Log-Linear Models
Original by Venables & Ripley.
R port by Brian Ripley .
Earlier work by Kurt Hornik and Albrecht Gebhardt.
________________________________________________________________________________
for the code partly included as builtin functions from other R ports:
fBasics:CDHSC.F
GRASS program for distributional testing.
By James Darrell McCauley
Original Fortran Source by Paul Johnson EZ006244@ALCOR.UCDAVIS.EDU>
fBasics:nortest
Five omnibus tests for the composite hypothesis of normality
R-port by Juergen Gross
fBasics:SYMSTB.F
Fast numerical approximation to the Symmetric Stable distribution
and density functions.
By Hu McCulloch
fBasics:tseries
Functions for time series analysis and computational finance.
Compiled by Adrian Trapletti
fCalendar:date
The tiny C program from Terry Therneau is used
R port by Th. Lumley ,
K. Halvorsen , and
Kurt Hornik
fCalendar:holidays
The holiday information was collected from the internet and
governmental sources obtained from a few dozens of websites
fCalendar:libical
Libical is an Open Source implementation of the IETF's
iCalendar Calendaring and Scheduling protocols. (RFC 2445, 2446,
and 2447). It parses iCal components and provides a C API for
manipulating the component properties, parameters, and subcomponents.
fCalendar:vtimezone
Olsen's VTIMEZONE database consists of data files are released under
the GNU General Public License, in keeping with the license options of
libical.
fSeries:bdstest.c
C Program to compute the BDS Test.
Blake LeBaron
fSeries:fracdiff
R functions, help pages and the Fortran Code for the 'fracdiff'
function are included.
S original by Chris Fraley
R-port by Fritz Leisch
since 2003-12: Martin Maechler
fSeries:lmtest
R functions and help pages for the linear modelling tests are included .
Compiled by Torsten Hothorn ,
Achim Zeileis , and
David Mitchell
fSeries:mda
R functions, help pages and the Fortran Code for the 'mars' function
are implemeted.
S original by Trevor Hastie & Robert Tibshirani,
R port by Friedrich Leisch, Kurt Hornik and Brian D. Ripley
fSeries:modreg
Brian Ripley and the R Core Team
fSeries:polspline
R functions, help pages and the C/Fortran Code for the 'polymars'
function are implemented
Charles Kooperberg
fSeries:systemfit
Simultaneous Equation Estimation Package.
R port by Jeff D. Hamann and
Arne Henningsen
fSeries:tseries
Functions for time series analysis and computational finance.
Compiled by Adrian Trapletti
fSeries:UnitrootDistribution:
The program uses the Fortran routine and the tables
from J.G. McKinnon.
fSeries:urca
Unit root and cointegration tests for time series data.
R port by Bernhard Pfaff .
fExtremes:evd
Functions for extreme value distributions.
R port by Alec Stephenson
Function 'fbvpot' by Chris Ferro.
fExtremes:evir
Extreme Values in R
Original S functions (EVIS) by Alexander McNeil
R port by Alec Stephenson
fExtremes:ismev
An Introduction to Statistical Modeling of Extreme Values
Original S functions by Stuart Coles
R port/documentation by Alec Stephenson
fOptions
Option Pricing formulas are implemented along the book and
the Excel spreadsheets of E.G. Haug, "The Complete Guide to Option
Pricing"; documentation is partly taken from www.derivicom.com which
implements a C Library based on Haug. For non-academic and commercial
use we recommend the professional software from "www.derivicom.com".
fOptions:SOBOL.F
ACM Algorithm 659 by P. Bratley and B.L. Fox
Extension on Algorithm 659 by S. Joe and F.Y. Kuo
fOptions:CGAMA.F
Complex gamma and related functions.
Fortran routines by Jianming Jin.
fOptions:CONHYP.F
Confluenet Hypergeometric and related functions.
ACM Algorithm 707 by mark Nardin, W.F. Perger, A. Bhalla
fPortfolio:mvtnorm
Multivariate Normal and T Distribution.
Alan Genz ,
Frank Bretz
R port by Torsten Hothorn
fPortfolio:quadprog
Functions to solve Quadratic Programming Problems.
S original by Berwin A. Turlach
R port by Andreas Weingessel
fPortfolio:sn
The skew-normal and skew-t distributions.
R port by Adelchi Azzalini
fPortfolio:tseries
Functions for time series analysis and computational finance.
Compiled by Adrian Trapletti
fAssets/inst/unitTests/ 0000755 0001760 0000144 00000000000 12251673345 014701 5 ustar ripley users fAssets/inst/unitTests/Makefile 0000644 0001760 0000144 00000000420 11370220754 016326 0 ustar ripley users PKG=fAssets
TOP=../..
SUITE=doRUnit.R
R=R
all: inst test
inst: # Install package -- but where ?? -- will that be in R_LIBS ?
cd ${TOP}/..;\
${R} CMD INSTALL ${PKG}
test: # Run unit tests
export RCMDCHECK=FALSE;\
cd ${TOP}/tests;\
${R} --vanilla --slave < ${SUITE}
fAssets/inst/unitTests/runit.AssetsMeanCov.R 0000644 0001760 0000144 00000003352 11370220754 020673 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: ASSETS STATISTICS:
# assetsMeanCov Estimates mean and variance for a set of assets
################################################################################
test.assetsMeanCov =
function()
{
# Time Series Object:
Data <- as.timeSeries(LPP2005REC)[, 1:6]
# Settings:
class(Data)
# use "cov":
args(assetsMeanCov)
assetsMeanCov(Data)
# use "shrink"
assetsMeanCov(Data, "shrink")
# Return Value:
return()
}
################################################################################
fAssets/inst/unitTests/runit.AssetsFit.R 0000644 0001760 0000144 00000010322 11370220754 020060 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: SIMULATION AND PARAMETER ESTIMATION:
# 'fASSETS' Class representation for "fASSETS" Objects
# assetsSim Simulates a set of artificial assets
# assetsFit Estimates the parameters of set of assets
# method = "norm" assuming a multivariate Normal distribution
# method = "snorm" assuming a multivariate skew-Normal distribution
# method = "st" assuming a multivariate skew-Student-t
# FUNCTION: PRINT, PLOT AND SUMMARY METHOD:
# 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
# FUNCTION: REQUIRED UTILITY FUNCTION:
# .msn.quantities Function from R package sn [part of fMultivar]
################################################################################
test.assetsSim =
function()
{
# assetsSim(n, dim=2, model =
# list(mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim), df=Inf),
# assetNames = NULL)
# Normel Assets:
assetsSim(n = 10, dim = 3)
assetsSim(n = 10, dim = 3,
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0.0, 3), df=Inf))
# Skew Normal Assets:
assetsSim(n = 10, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0.1, 3), df=Inf))
# Student-t Assets:
assetsSim(n = 10, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0.0, 3), df=4))
# Skew Student-t Assets:
assetsSim(n = 10, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0.1, 3), df=4))
# Add Asset Names:
assetsSim(n = 10, dim = 3, assetNames = c("A", "B", "C"))
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsFit =
function()
{
# function (x, method = c("st", "snorm", "norm"), title = NULL,
# description = NULL, fixed.df = NA, ...)
# Normal Assets:
x = assetsSim(n = 1000, dim = 3)
fit = assetsFit(x, "norm")
fit
# Skew Normal Assets:
x = assetsSim(n = 1000, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=c(-0.5, 0 , 0.5), df=Inf))
fit = assetsFit(x, "snorm")
fit
# Student-t Assets:
x = assetsSim(n = 1000, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0, 3), df=4))
fit = assetsFit(x, "st")
fit
# Student-t Assets - Fixed df:
x = assetsSim(n = 1000, dim = 3, model =
list(mu=rep(0, 3), Omega=diag(3), alpha=rep(0, 3), df=4))
fit = assetsFit(x, "st", fixed.df = 4)
fit
par(ask = FALSE)
class(fit)
print(fit)
plot(fit, which = "all") # CHECK X-Label
summary(fit, doplot = FALSE) # CHECK - add doplot
# Return Value:
return()
}
################################################################################
fAssets/inst/unitTests/runit.AssetsSelect.R 0000644 0001760 0000144 00000014754 11370220754 020572 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: ASSETS SELECTION:
# assetsSelect Selects individual assets from a set of assets
# use = "hclust" hierarchical clustering of returns
# use = "kmeans" k-means clustering of returns
################################################################################
test.assetsSelectHClust =
function()
{
if (FALSE) {
# Hierarchical Clustering:
# Select the 4 most dissimilar assets from Berndt's data set
# The data set "berndtInvest" is from Berndt's textbook
# "The Practice of Econometrics". It is a data.frame consisting
# of 18 columns with the following entries:
# [1] %d/%B/%y "CITCRP" "CONED" "CONTIL" "DATGEN" "DEC"
# [7] "DELTA" "GENMIL" "GERBER" "IBM" "MARKET" "MOBIL"
# [13] "PANAM" "PSNH" "TANDY" "TEXACO" "WEYER" "RKFREE"
# The first column holds the date, the 11th the market rate,
# and the last (the 18th) the risk free rate.
# Load the Data and Create an Object of Class 'timeSeries':
data(berndtInvest)
berndtInvest = as.timeSeries(berndtInvest)
class(berndtInvest)
head(berndtInvest)
# Exclude the Date, Market Returns and Interest Rate Columns
# from the data frame, then multiply by 100 for percentual returns ...
allAssets = 100 * berndtInvest[, -c(1, 10, 17)]
class(allAssets)
head(allAssets)
# Graph Frame:
par(mfrow = c(2, 1), cex = 0.7)
# Select the "n" Most Dissimilar Assets from
# Hierarchical Clustering:
n = 4
args(assetsSelect)
clustered = assetsSelect(allAssets, doplot = TRUE)
# Create my Assets Set from the "n" selected Symbols:
myAssets = allAssets[, c(clustered$order[1:n])]
colnames(myAssets)
# Print the Column Return:
mu.vec = colMeans(myAssets)
mu.vec
# or ...
mu.vec = colMeans(series(myAssets))
mu.vec
# Print the Covariance Matrix:
cov.mat = cov(series(myAssets))
cov.mat
# Plot Cumulated Returns of the Assets:
ts.plot(colCumsums(myAssets), col = 1:4)
grid()
legend(0, 250, legend = colnames(myAssets), pch = "----", col = 1:4)
title(main = "Cumulated Returns", ylab = "Cumulated Returns")
abline(h = 0, lty = 3)
}
NA
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsSelectKMeans =
function()
{
# K-Means Clustering:
if (FALSE) {
# Load Data
berndtInvest = as.timeSeries(data(berndtInvest))
allAssets = 100 * berndtInvest[, -c(1, 10, 17)]
allAssets = as.matrix(allAssets)
head(allAssets)
# assetsSelect(x, use = c("hclust", "kmeans"), doplot = TRUE, ...)
clustered = assetsSelect(t(allAssets), use = "kmeans",
centers = 4, doplot = TRUE)
}
NA
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsSelectKMeans =
function()
{
if (FALSE) {
require(cluster)
.assetsSelect =
function (x, k,
use = c("hclust", "kmeans", "agnes", "diana", "pam", "clara"),
doplot = TRUE, control = FALSE, ...)
{
# Settings:
X = as.matrix(x)
use = match.arg(use)
# Hierarchical Clustering:
if (use == "hclust") {
ans = hclust(dist(t(X)), ...)
index = rev(ans$order)[1:k]
if (doplot) plot(ans)
}
if (use == "agnes") {
ans = agnes(t(X), ...)
index = rev(ans$order)[1:k]
if (doplot) plot(ans)
}
if (use == "diana") {
ans = diana(t(X), ...)
index = rev(ans$order)[1:k]
if (doplot) plot(ans)
}
# K-Means Clustering:
if (use == "kmeans") {
ans = kmeans(x = X, centers = k, ...)
Dist = rep(Inf, times = k)
index = rep(NA, times = k)
Center = ans$center
Cluster = ans$cluster
for (i in 1:length(Cluster)) {
j = Cluster[i]
d = as.vector(dist(rbind(Center[j,], X[,i])))
if (d < Dist[j]) {
Dist[j] = d
index[j] = i
}
}
if (doplot) {
plot(t(X), col = ans$cluster)
points(ans$centers, col = 1:k, pch = 8, cex = 2)
}
}
if (use == "pam") {
ans = pam(t(X), k, ...)
index = ans$id.med
if (doplot) plot(ans)
}
if (use == "clara") {
ans = clara(t(X), k, ...)
index = ans$i.med
if (doplot) plot(ans)
}
# Select data and optionally add control:
data = x[, index]
if (control) attr(data, "control")<-ans
# Return Value:
data
}
# Data:
berndtInvest = as.timeSeries(data(berndtInvest))
X = 100 * berndtInvest[, -c(1, 10, 17)]
# Selection:
.assetsSelect(X, 4, "hclust", doplot = FALSE)
.assetsSelect(X, 4, "agnes", doplot = FALSE)
.assetsSelect(X, 4, "diana", doplot = FALSE)
.assetsSelect(X, 4, "kmeans", doplot = FALSE)
.assetsSelect(X, 4, "pam", doplot = FALSE)
.assetsSelect(X, 4, "clara", doplot = FALSE)
}
NA
# Return Value:
return()
}
################################################################################
fAssets/inst/unitTests/runit.AssetsPlots.R 0000644 0001760 0000144 00000013326 11370220754 020446 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: TIME SERIES ASSETS PLOTS:
# assetsSeriesPlot Displays time series of individual assets
# assetsHistPlot Displays histograms of individual assets
# assetsDensityPlot Displays density plots of individual assets
# assetsQQNormPlot Displays normal qq-plots of individual assets
# FUNCTION: DENSITY BOX PLOTS:
# assetsBoxPlot Producess standard box plots
# assetsBoxPercentilePlot Producess side-by-side box-percentile plots
# FUNCTION: BIVARIATE ASSETS PLOTS:
# assetsPairsPlot Displays pairs of scatterplots of assets
# assetsCorgramPlot Displays correlations between assets
# assetsCorTestPlot Displays and tests pairwise correlations
# FUNCTION: BIVARIATE CORRELATION PLOTS:
# assetsCorEigenPlot Displays ratio of the largest two eigenvalues
# *assetsTreePlot Displays minimum spanning tree of assets
# assetsDendogramPlot Displays hierarchical clustering dendogram
# .assetsStarPlot Draws segment diagrams of a multivariate data set
################################################################################
# *moved to Rmetrics addon Package
test.assetsSeriesPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))
par(mfrow = c(3, 3))
par(ask = FALSE)
assetsSeriesPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsHistPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))
par(mfrow = c(3, 3))
par(ask = FALSE)
assetsHistPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsQQNormPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))
par(mfrow = c(3, 3))
par(ask = FALSE)
assetsQQNormPlot(LPP)
# Return Value:
return()
}
################################################################################
test.assetsBoxPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))
par(mfrow = c(3, 3))
par(ask = FALSE)
# Plot:
assetsBoxPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsQQNormPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))
par(mfrow = c(3, 3))
par(ask = FALSE)
# Plot:
assetsBoxPercentilePlot(LPP)
# Return Value:
return()
}
################################################################################
test.assetsPairsPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsPairsPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsCorTestPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsCorTestPlot(LPP)
# Return Value:
return()
}
################################################################################
test.assetsCorgramPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsCorgramPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsCorEigenPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsCorEigenPlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
test.assetsTreePlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsTreePlot(LPP)
# Return Value:
return()
}
# ------------------------------------------------------------------------------
assetsDendogramPlot =
function()
{
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
par(mfrow = c(1, 1))
par(ask = FALSE)
# Plot:
assetsDendrogramPlot(LPP)
# Return Value:
return()
}
################################################################################
fAssets/inst/unitTests/runit.AssetsTests.R 0000644 0001760 0000144 00000003222 11370220754 020441 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: ASSETS NORMALITY TESTS:
# assetsTest TestSuite for multivariate Normal Assets
# mvshapiroTest Multivariate Shapiro Test
################################################################################
test.assetsTest <-
function()
{
# Default Method:
x = assetsSim(100)
assetsTest(x)
# Return Value:
return()
}
################################################################################
fAssets/inst/unitTests/runTests.R 0000644 0001760 0000144 00000004527 11370220754 016654 0 ustar ripley users pkg <- "fAssets"
if(require("RUnit", quietly = TRUE))
{
library(package=pkg, character.only = TRUE)
if(!(exists("path") && file.exists(path)))
path <- system.file("unitTests", package = pkg)
## --- Testing ---
## Define tests
testSuite <- defineTestSuite(name = paste(pkg, "unit testing"),
dirs = path)
if(interactive()) {
cat("Now have RUnit Test Suite 'testSuite' for package '",
pkg, "' :\n", sep='')
str(testSuite)
cat('', "Consider doing",
"\t tests <- runTestSuite(testSuite)", "\nand later",
"\t printTextProtocol(tests)", '', sep = "\n")
} else {
## run from shell / Rscript / R CMD Batch / ...
## Run
tests <- runTestSuite(testSuite)
if(file.access(path, 02) != 0) {
## cannot write to path -> use writable one
tdir <- tempfile(paste(pkg, "unitTests", sep="_"))
dir.create(tdir)
pathReport <- file.path(tdir, "report")
cat("RUnit reports are written into ", tdir, "/report.(txt|html)",
sep = "")
} else {
pathReport <- file.path(path, "report")
}
## Print Results:
printTextProtocol(tests, showDetails = FALSE)
printTextProtocol(tests, showDetails = FALSE,
fileName = paste(pathReport, "Summary.txt", sep = ""))
printTextProtocol(tests, showDetails = TRUE,
fileName = paste(pathReport, ".txt", sep = ""))
## Print HTML Version to a File:
## printHTMLProtocol has problems on Mac OS X
if (Sys.info()["sysname"] != "Darwin")
printHTMLProtocol(tests,
fileName = paste(pathReport, ".html", sep = ""))
## stop() if there are any failures i.e. FALSE to unit test.
## This will cause R CMD check to return error and stop
tmp <- getErrors(tests)
if(tmp$nFail > 0 | tmp$nErr > 0) {
stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail,
", R errors: ", tmp$nErr, ")\n\n", sep=""))
}
}
} else {
cat("R package 'RUnit' cannot be loaded -- no unit tests run\n",
"for package", pkg,"\n")
}
################################################################################
fAssets/inst/unitTests/runit.LowerPartialMoments.R 0000644 0001760 0000144 00000003127 11370220754 022130 0 ustar ripley users
# 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
# Copyrights (C)
# for this R-port:
# 1999 - 2007, Diethelm Wuertz, GPL
# Diethelm Wuertz
# info@rmetrics.org
# www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
# see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
# see Rmetrics's copyright file
################################################################################
# FUNCTION: ASSETS STATISTICS:
# assetsLPM Computes Lower Partial Moments
################################################################################
test.assetsLPM =
function()
{
tS = as.timeSeries(data(LPP2005REC))[, 1:6]
assetsLPM(x = tS, tau = colMeans(tS), a = 1)
# Return Value:
return()
}
################################################################################
fAssets/tests/ 0000755 0001760 0000144 00000000000 12251673345 013064 5 ustar ripley users fAssets/tests/doRUnit.R 0000644 0001760 0000144 00000001636 11370220753 014571 0 ustar ripley users #### doRUnit.R --- Run RUnit tests
####------------------------------------------------------------------------
### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata'
### and the corresponding section in the R Wiki:
### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit
### MM: Vastly changed: This should also be "runnable" for *installed*
## package which has no ./tests/
## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R :
if(require("RUnit", quietly=TRUE)) {
## --- Setup ---
wd <- getwd()
pkg <- sub("\\.Rcheck$", '', basename(dirname(wd)))
library(package=pkg, character.only=TRUE)
path <- system.file("unitTests", package = pkg)
stopifnot(file.exists(path), file.info(path.expand(path))$isdir)
source(file.path(path, "runTests.R"), echo = TRUE)
}
################################################################################
fAssets/src/ 0000755 0001760 0000144 00000000000 12254131717 012504 5 ustar ripley users fAssets/src/Makevars 0000644 0001760 0000144 00000000036 11370220753 014174 0 ustar ripley users PKG_LIBS=$(BLAS_LIBS) $(FLIBS) fAssets/src/ecodist.c 0000644 0001760 0000144 00000046666 12254131720 014316 0 ustar ripley users #include
#include
#include /* for dgemm */
#define RANDIN seed_in((long *)NULL)
#define RANDOUT seed_out((long *)NULL)
#define UNIF unif_rand()
#define S_EVALUATOR
void bootstrap(double *x, double *y, int *n, int *xlen, int *nboot, double *pboot, double *bootcor, int *rarray, int *rmat, double *xdif, double *ydif)
{
int i, j, k, l;
double r;
double nsamp;
double xmean, ymean;
double xsum;
double xxsum, yysum;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
for(i = 0; i < *nboot; i++) {
/* Set up rarray. */
for(j = 0; j < *n; j++) {
r = UNIF;
if(r > *pboot)
rarray[j] = 0;
else rarray[j] = 1;
}
/* Turn rarray into a lower-triangular sampling matrix. */
/* 1 means include, 0 means omit. */
l = 0;
for(j = 1; j < *n; j++) {
for(k = 0; k < j; k++) {
if(rarray[j] == 0 || rarray[k] == 0)
rmat[l] = 0;
else rmat[l] = 1;
l++;
}
}
nsamp = 0;
for(j = 0; j < *xlen; j++) {
nsamp += rmat[j];
}
/* Calculate means for x and y. */
xmean = 0;
ymean = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xmean += x[j];
ymean += y[j];
}
}
xmean = xmean/nsamp;
ymean = ymean/nsamp;
/* Calculate deviations for x and y. */
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xdif[j] = x[j] - xmean;
ydif[j] = y[j] - ymean;
}
else {
xdif[j] = 0;
ydif[j] = 0;
}
}
xsum = 0;
xxsum = 0;
yysum = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xsum += (xdif[j] * ydif[j]);
xxsum += (xdif[j] * xdif[j]);
yysum += (ydif[j] * ydif[j]);
}
}
bootcor[i] = (xsum) / sqrt(xxsum * yysum);
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
/* DW renamed permute to permute2 */
void permute2(double *x, double *y, int *n, int *xlen, int *nperm,
double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[0] = cumsum / *xlen;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[i] = cumsum / *xlen;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void permpart(double *hmat, double *bmat, double *omat, double *y, double *xcor, double *ycor, int *n, int *ncol, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
double bsum;
double w1, w2;
int temp;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[0] = cumsum / *xlen;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert y to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = y[m];
tmat[l * *n + k] = y[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder y. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
y[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate residuals for y */
/* Calculate bmat */
for(k = 0; k < *ncol; k++) {
bmat[k] = 0;
}
for(k = 0; k < *ncol; k++) {
for(l = 0; l < *xlen; l++) {
bmat[k] = bmat[k] + hmat[l * *ncol + k] * y[l];
}
}
/* Calculate ycor (residuals) */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
bsum = 0;
for(l = 0; l < *ncol; l++) {
bsum = bsum + bmat[l] * omat[l * *xlen + k];
}
ycor[k] = y[k] - bsum;
}
/* Standardize residuals so z = r */
w1 = 0;
w2 = 0;
for(k = 0; k < *xlen; k++) {
w1 = w1 + ycor[k];
w2 = w2 + ycor[k] * ycor[k];
}
w1 = w1 / *xlen;
w2 = sqrt(w2 / *xlen - w1 * w1);
for(k = 0; k < *xlen; k++) {
ycor[k] = (ycor[k] - w1) / w2;
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[i] = cumsum / *xlen;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void xbootstrap(double *x, double *y, int *n, int *xlen, int *nboot, double *pboot, double *bootcor, int *rarray, int *rmat, double *xdif, double *ydif)
{
int i, j, k;
double r;
double nsamp;
double xmean, ymean;
double xsum;
double xxsum, yysum;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
for(i = 0; i < *nboot; i++) {
/* Set up rarray. */
for(j = 0; j < *n; j++) {
r = UNIF;
if(r > *pboot)
rarray[j] = 0;
else rarray[j] = 1;
}
/* Turn rarray into a square sampling matrix. */
/* 1 means include, 0 means omit. */
for(j = 0; j < *xlen; j++) {
rmat[j] = 1;
}
for(j = 0; j < *n; j++) {
for(k = 0; k <= j; k++) {
if(rarray[j] == 0 || rarray[k] == 0) {
rmat[j * *n + k] = 0;
rmat[k * *n + j] = 0;
}
}
}
nsamp = 0;
for(j = 0; j < *xlen; j++) {
nsamp += rmat[j];
}
/* Calculate means for x and y. */
xmean = 0;
ymean = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xmean += x[j];
ymean += y[j];
}
}
xmean = xmean/nsamp;
ymean = ymean/nsamp;
/* Calculate deviations for x and y. */
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xdif[j] = x[j] - xmean;
ydif[j] = y[j] - ymean;
}
else {
xdif[j] = 0;
ydif[j] = 0;
}
}
xsum = 0;
xxsum = 0;
yysum = 0;
for(j = 0; j < *xlen; j++) {
if(rmat[j] == 1) {
xsum += (xdif[j] * ydif[j]);
xxsum += (xdif[j] * xdif[j]);
yysum += (ydif[j] * ydif[j]);
}
}
bootcor[i] = (xsum) / sqrt(xxsum * yysum);
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void xpermute(double *x, double *y, int *n, int *xlen, int *nperm,
double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
for(k = 0; k < *n; k++) {
for(l = 0; l <= k; l++) {
x[k * *n + l] = tmat[rarray[k] * *n + rarray[l]];
x[l * *n + k] = tmat[rarray[l] * *n + rarray[k]];
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += x[k] * y[k];
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void xpermpart(double *hmat, double *y, double *xcor, double *ycor, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate residuals for y */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
for(l = 0; l < *xlen; l++) {
ycor[k] = ycor[k] + hmat[k * *xlen + l] * y[l];
}
}
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder y. */
for(k = 0; k < *n; k++) {
for(l = 0; l <= k; l++) {
y[k * *n + l] = tmat[rarray[k] * *n + rarray[l]];
y[l * *n + k] = tmat[rarray[l] * *n + rarray[k]];
}
}
/* Calculate residuals for y */
for(k = 0; k < *xlen; k++) {
ycor[k] = 0;
}
for(k = 0; k < *xlen; k++) {
for(l = 0; l < *xlen; l++) {
ycor[k] = ycor[k] + hmat[k * *xlen + l] * y[l];
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
cumsum += xcor[k] * ycor[k];
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void bcdist(double *x, int *pnrow, int *pncol, double *dist)
{
int i, j, k, l;
int nrow, ncol;
double sumi, sumj;
double minsum;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(i = 0; i < (nrow - 1); i++) {
for(j = (i + 1); j < (nrow); j++) {
minsum = 0;
sumi = 0;
sumj = 0;
for(k = 0; k < ncol; k++) {
if(x[i * ncol + k] < x[j * ncol + k])
minsum += x[i * ncol + k];
else
minsum += x[j * ncol + k];
sumi += x[i * ncol + k];
sumj += x[j * ncol + k];
}
if((sumi + sumj) == 0)
dist[l] = 0;
else
dist[l] = (1 - (2 * minsum) / (sumi + sumj));
l++;
}
}
}
void weight(int *n, double *datadist, double *d1, double *d2, double *w)
{
int i;
double m1, m2;
double w1, w2;
double pi;
pi = 2 * acos(0);
for(i = 0; i < *n * *n; i++) {
if(datadist[i] != 0) {
if(d1[i] < datadist[i])
m1 = d1[i] / datadist[i];
else m1 = 1;
if(d2[i] < datadist[i])
m2 = d2[i] / datadist[i];
else m2 = 1;
}
else {
m1 = 0;
m2 = 0;
}
w1 = 1 - (acos(m1) + acos(m2)) / pi;
if(datadist[i] != 0) {
m1 = d1[i] / datadist[i];
if(m1 > 1)
m1 = 1;
m2 = d2[i] / datadist[i];
if(m2 > 1)
m2 = 1;
}
else {
m1 = 0;
m2 = 0;
}
w2 = 0.75 - (acos(m1) + acos(m2)) / (2 * pi);
if((datadist[i] * datadist[i]) >= (d1[i] * d1[i] + d2[i] * d2[i]))
w1 = 0;
if((datadist[i] * datadist[i]) < (d1[i] * d1[i] + d2[i] * d2[i]))
w2 = 0;
w[i] = w1 + w2;
}
}
void newpermone(double *x, int *dclass, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(dclass[k] == 0) {
cumsum += x[k];
}
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(dclass[k] == 0) {
cumsum += x[k];
}
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void newpermtwo(double *x, double *y, int *n, int *xlen, int *nperm, double *zstats, double *tmat, int *rarray)
{
int i, k, l, m;
double cumsum;
int temp;
float naval = -9999;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Calculate first z-statistic (unpermuted data). */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(x[k] != naval) {
cumsum += x[k] * y[k];
}
}
zstats[0] = cumsum;
/* Start permutation routine */
for(i = 1; i < *nperm; i++) {
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert x to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = x[m];
tmat[l * *n + k] = x[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder x. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
x[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
/* Calculate new sum of products. */
cumsum = 0;
for(k = 0; k < *xlen; k++) {
if(x[k] != naval) {
cumsum += x[k] * y[k];
}
}
zstats[i] = cumsum;
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
void psum(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
dist[l] = thisval + thatval;
l++;
}
}
}
}
void pdiff(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
dist[l] = thisval - thatval;
l++;
}
}
}
}
void jpres(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval > 0) & (thatval > 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jabs(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval == 0) & (thatval == 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jfirst(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval > 0) & (thatval == 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void jsec(double *x, int *pnrow, int *pncol, double *dist)
{
int row1, row2, col1;
int nrow, ncol;
int l;
double thisval, thatval;
l = 0;
nrow = *pnrow;
ncol = *pncol;
for(col1 = 0; col1 < ncol; col1++) {
for(row1 = 0; row1 < nrow; row1++) {
thatval = x[row1 * ncol + col1];
for(row2 = 0; row2 < nrow; row2++) {
thisval = x[row2 * ncol + col1];
if((thisval == 0) & (thatval > 0)) {
dist[l] = 1;
}
else {
dist[l] = 0;
}
l++;
}
}
}
}
void mrmperm(double *x, double *y, int *p, int *nd, int *n, int *nperm, double *r2all, double *ball, double *fall, double *tmat, int *rarray, double *XX, double *XY, double *YY, double *b)
{
int i, k, l;
int m;
int temp;
double SSE=0.0, SSTO=0.0, SSR=0.0;
double r2=0, f=0;
double btemp=0.0;
int bcount = 0;
char *transt = "T", *transn = "N";
double one = 1.0, zero = 0.0;
int onei = 1;
S_EVALUATOR
/* Set random seed using Splus function */
RANDIN;
/* Start permutation routine */
for(i = 0; i < *nperm; i++) {
/* first do the unpermuted values */
/* F77_CALL(dgemm)(transa, transb, &ncx, &ncy, &nrx, &one,
x, &nrx, y, &nry, &zero, z, &ncx); */
/* take crossproduct t(X) %*% Y - WORKS */
F77_CALL(dgemm)(transt, transn,
p, &onei, nd,
&one, x, nd, y, nd,
&zero, XY, p);
/* take crossproduct t(Y) %*% (Y) - WORKS */
F77_CALL(dgemm)(transt, transn,
&onei, &onei, nd,
&one, y, nd, y, nd,
&zero, YY, &onei);
/* calculate regression coefficients XX %*% XY - WORKS */
F77_CALL(dgemm)(transn, transn,
p, &onei, p,
&one, XX, p, XY, p,
&zero, b, p);
/* calculate regression components - WORKS */
F77_CALL(dgemm)(transt, transn,
&onei, &onei, p,
&one, b, p, XY, p,
&zero, &btemp, &onei);
/* SSE - WORKS */
SSE = YY[0] - btemp;
/* SSTO - WORKS */
SSTO = 0;
for(k = 0; k < *nd; k++) {
SSTO = SSTO + y[k];
}
SSTO = YY[0] - (SSTO * SSTO) / *nd;
SSR = SSTO - SSE;
/* calculate R2 - WORKS */
r2 = 1 - SSE / SSTO;
/* calculate F* - WORKS */
f = (SSR / (*p - 1)) / (SSE / (*nd - *p));
r2all[i] = r2;
fall[i] = f;
/* calculate pseudo-t for regression coefficients - WORKS*/
/* b / sqrt(1 - R2) */
for(k=0; k<*p; k++) {
ball[bcount] = b[k] / sqrt(1 - r2);
bcount++;
}
/* permute Y */
/* Set up rarray. */
for(k = 0; k < *n; k++) {
rarray[k] = k;
}
/* Convert y to a full matrix. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
tmat[k * *n + l] = y[m];
tmat[l * *n + k] = y[m];
m++;
}
}
/* Randomize rarray using an Splus function. */
for(k = 0; k < (*n - 1); k++) {
l = *n - k - 1;
m = (int)((float)l * UNIF);
if(m > l) m = l;
temp = rarray[l];
rarray[l] = rarray[m];
rarray[m] = temp;
}
/* Reorder y. */
m = 0;
for(k = 1; k < *n; k++) {
for(l = 0; l < k; l++) {
y[m] = tmat[rarray[k] * *n + rarray[l]];
m++;
}
}
}
/* Reset random seed using an Splus function. */
RANDOUT;
}
fAssets/src/energy.c 0000644 0001760 0000144 00000041146 12254131720 014141 0 ustar ripley users
/*
energy.c: energy package
Author: Maria Rizzo
Created: 4 Jan 2004 for R-1.8.1
Revised: 20 March 2004 (E2, twosampleIEtest added)
Revised: 13 June 2004 (distance() changed, some utilities added)
mvnEstat() computes the E-test of multivariate normality
ksampleEtest() performs the multivariate E-test for equal distributions,
complete version, from data matrix
twosampleIEtest() incomplete version
E2sample() computes the 2-sample E-statistic without creating distance
poisMstat() computes the mean distance test of Poissonity
sumdist() sums the distance matrix without creating the matrix
*/
#include
#include
void mvnEstat(double *y, int *byrow, int *nobs, int *dim, double *stat);
void poisMstat(int *x, int *nx, double *stat);
void ksampleEtest(double *x, int *byrow, int *nsamples, int *sizes, int *dim,
int *R, double *e0, double *e, double *pval);
void twosampleIEtest(double *x, int *byrow, int *sizes, int *dim, int *iN,
int *R, double *e0, double *e, double *pval);
void E2sample(double *x, int *sizes, int *dim, double *stat);
double edist(double **D, int m, int n);
double multisampleE(double **D, int nsamples, int *sizes, int *perm);
double twosampleE(double **D, int m, int n, int *xrows, int *yrows);
double E2(double **x, int *sizes, int *start, int ncol, int *perm);
double Eksample(double *x, int *byrow, int r, int d, int K, int *sizes, int *ix);
void distance(double **bxy, double **D, int N, int d);
void sumdist(double *x, int *byrow, int *nrow, int *ncol, double *lowersum);
double **alloc_matrix(int r, int c);
int **alloc_int_matrix(int r, int c);
void free_matrix(double **matrix, int r, int c);
void free_int_matrix(int **matrix, int r, int c);
void permute(int *J, int n);
void roworder(double *x, int *byrow, int r, int c);
void vector2matrix(double *x, double **y, int N, int d, int isroworder);
void mvnEstat(double *y, int *byrow, int *nobs, int *dim, double *stat)
{
/*
compute E test statistic for multivariate normality
y is *standardized* multivariate sample
best to have y in row order: e.g. y=as.double(t(y))
*/
int d=(*dim), n=(*nobs);
int i, j, k, p, maxterms=2000;
double D=(double)(*dim);
double meanyy, meanyz, meanzz;
double delta, eps=1.0e-7;
double normy, yy, dif, sum, sum0, term;
double lg0, lg1,logak, loggk;
if (*byrow == FALSE)
roworder(y, byrow, n, d);
lg0 = lgammafn(D/2.0);
lg1 = lgammafn((D+1.0)/2.0);
meanzz = 2.0 * exp(lg1 - lg0); /* second mean */
meanyz = 0.0; /* computing the first mean as series */
for (i=0; i eps && k < maxterms) {
sum0 = sum;
logak = (k+1)*log(yy) - lgammafn(k+1) - k*M_LN2 -
log(2*k+1) - log(2*k+2);
loggk = lg1 + lgammafn(k+1.5) - lgammafn(k+D/2+1);
term = exp(logak + loggk);
if (k % 2 == 0)
sum += term;
else
sum -= term;
delta = fabs(sum - sum0);
k++;
}
if (delta < eps)
meanyz += meanzz/M_SQRT2 + M_SQRT_2dPI * sum;
else {
meanyz += normy;
Rf_warning("E|y-Z| did not converge, replaced by %f", normy);
}
}
meanyz /= (double) n;
sumdist(y, byrow, nobs, dim, &meanyy); /* computing third mean */
meanyy *= (2.0/(double)(n*n));
*stat = ((double) n)*(2.0*meanyz - meanzz - meanyy);
return;
}
void poisMstat(int *x, int *nx, double *stat)
{
/* computes the Poisson mean distance statistic */
int i, j, k, n=(*nx);
double eps=1.0e-10;
double cvm, d, lambda, m, q;
double Mcdf1, Mcdf0, Mpdf1, cdf1, cdf0;
lambda = 0;
for (i=0; i 1) Mcdf1 = 1.0;
cdf1 = ppois(i, lambda, TRUE, FALSE); /* MLE of F(i) */
d = Mcdf1 - cdf1;
cvm += d * d * (cdf1 - cdf0);
cdf0 = cdf1;
Mcdf0 = Mcdf1;
}
cvm *= n;
*stat = cvm;
}
void E2sample(double *x, int *sizes, int *dim, double *stat) {
/*
compute test statistic *stat for testing H:F=G
does not store distance matrix
x must be in row order: x=as.double(t(x)) where
x is pooled sample in matrix sum(en) by dim
*/
int m=sizes[0], n=sizes[1], d=(*dim);
int i, j, k, p, q;
double dif, dsum, sumxx, sumxy, sumyy, w;
sumxy = 0.0;
for (i=0; i 0) {
data = alloc_matrix(N, d); /* sample matrix */
vector2matrix(x, data, N, d, *byrow);
distance(data, D, N, d);
free_matrix(data, N, d);
}
else
vector2matrix(x, D, N, N, *byrow);
*e0 = multisampleE(D, K, sizes, perm);
/* bootstrap */
if (B > 0) {
ek = 0;
GetRNGstate();
for (b=0; b N ? N : sizes[0];
I[1] = sizes[1] > N ? N : sizes[1];
if (*byrow == FALSE)
roworder(x, byrow, nrow, ncol);
data = alloc_matrix(nrow, ncol);
vector2matrix(x, data, nrow, ncol, *byrow);
perm = Calloc(nrow, int);
for (i=0; i 0) {
ek = 0;
for (b = 0; b < B; b++) {
permute(perm, nrow);
e[b] = E2(data, I, start, ncol, perm);
if ((*e0) < e[b]) ek++;
}
*pval = (double) ek / (double) B;
}
Free(data);
Free(perm);
return;
}
void sumdist(double *x, int *byrow, int *nrow, int *ncol, double *lowersum)
{
/*
sum all pairwise distances between rows of x
equivalent to this in R: h <- sum(dist(x))
x must be in row order: x=as.double(t(x))
*/
int i, j, k, p, q, n=(*nrow), d=(*ncol);
double sum, dsum, dif;
if (*byrow == FALSE)
roworder(x, byrow, n, d);
sum = 0.0;
for (i=1; i,
# 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.R 0000644 0001760 0000144 00000012776 11370220753 014176 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000026654 11370220753 015544 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000010750 11370220753 014165 0 ustar ripley users
# 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/stats-distance.R 0000644 0001760 0000144 00000013214 11370220753 015165 0 ustar ripley users
# 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:
# .corDist
# .kendallDist
# .spearmanDist
# .mutinfoDist
# FUNCTION:
# .euclideanDist
# .maximumDist
# .manhattanDist
# .canberraDist
# .binaryDist
# .minkowskiDist
# FUNCTION:
# .braycurtisDist
# .mahalanobisDist
# .jaccardDist
# .differenceDist
# .sorensenDist
################################################################################
.corDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
x = t(as.matrix(x))
dist = as.dist(1-cor(x))
# Return Value:
dist
}
.kendallDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
x = t(as.matrix(x))
dist = as.dist(1-cor(x, method = "kendall"))
# Return Value:
dist
}
.spearmanDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
x = t(as.matrix(x))
dist = as.dist(1-cor(x, method = "spearman"))
# Return Value:
dist
}
.mutinfoDist <-
function(x, nbin=10)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# borrowed from R package bioDist and slightly modified
# Distance:
x <- 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]])
}
}
mat = 1 - sqrt(1 - exp(-2*mat))
colnames(mat) = rownames(mat) = rownames(x)
dist = as.dist(mat)
# Return Value:
dist
}
################################################################################
# from base R:
# "euclidean", "maximum", "manhattan",
# "canberra", "binary", "minkowski"
.euclideanDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = dist(x, "euclidean")
# Return Value:
dist
}
.maximumDist <-
function(x)
{
# FUNCTION:
# A function implemented by Diethelm Wuertz
# Distance:
dist = dist(x, "maximum")
# Return Value:
dist
}
.manhattanDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = dist(x, "manhattan")
# Return Value:
dist
}
.canberraDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = dist(x, "canberra")
# Return Value:
dist
}
.binaryDist <-
function(x)
{
# Distance:
dist = dist(x, "binary")
# Return Value:
dist
}
.minkowskiDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = dist(x, "minkowski")
# Return Value:
dist
}
################################################################################
# from ecodist:
# "euclidean", "bray-curtis", "manhattan",
# "mahalanobis", "jaccard", "difference"
# "sorensen"
.braycurtisDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "bray-curtis")
# Return Value:
dist
}
.mahalanobisDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "mahalanobis")
# Return Value:
dist
}
.jaccardDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "jaccard")
# Return Value:
dist
}
.differenceDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "difference")
# Return Value:
dist
}
.mahalanobisDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "mahalanobis")
# Return Value:
dist
}
.sorensenDist <-
function(x)
{
# A function implemented by Diethelm Wuertz
# FUNCTION:
# Distance:
dist = .ecodist(x, "sorensen")
# Return Value:
dist
}
################################################################################
fAssets/R/builtin-mstApe.R 0000644 0001760 0000144 00000015250 11370220753 015136 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000017771 11370220753 016240 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000005236 11370220753 014334 0 ustar ripley users
# 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
################################################################################
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.
# Note:
# The output of this function can be used for portfolio
# optimization.
# 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
}
################################################################################
fAssets/R/plot-ellipses.R 0000644 0001760 0000144 00000007062 11370220753 015037 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000005060 11370220753 014533 0 ustar ripley users
# 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/builtin-ecodist.R 0000644 0001760 0000144 00000016527 11370220753 015347 0 ustar ripley users
# 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:
# distance
################################################################################
# Rmetrics:
# Note that ecodist is not available on Debian as of 2009-09-28.
# To run these functions under Debian/Rmetrics we have them
# implemented here as a builtin.
# Package: ecodist
# Version: 1.2.2
# Date: 2008-12-15
# Title: Dissimilarity-based functions for ecological analysis
# Author: Sarah Goslee and Dean Urban
# Maintainer: Sarah Goslee
# Depends: stats
# Description: Dissimilarity-based analysis functions including
# ordination and Mantel test functions, intended for use with
# spatial and community data.
# License: GPL version 2 or newer
# Packaged: Mon Dec 15 09:01:37 2008
# distance <-
.ecodist <-
function(x, method="euclidean")
{
# calculates similarity and dissimilarity coefficients
# as described in Legendre and Legendre 1998
# returns lower-triangle
###
# Sarah Goslee
# 2 March 2006
# revised 31 March 2008
# bug-fix 15 December 2008
###
# uses clever matrix math to calculate the pieces needed
# by dissimilarity matrices, to make it easy to add new
# indices.
###
# to add a new metric:
# add it to the commented list below
# add it to the end of the METHODS <- c(...) list
# add the code at the appropriate point at the bottom of
# the function
# 1: euclidean
# 2: bray-curtis
# 3: manhattan
# 4: mahalanobis
# 5: jaccard
# 6: simple difference
# 7: sorensen
pairedsum <- function(x)
{
### paired sums
### returns an N by N by P matrix containing each
### combination of
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("psum",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
paireddiff <- function(x)
{
### paired differences
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("pdiff",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
jointpresence <- function(x)
{
### joint count of presences
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("jpres",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
jointabsence <- function(x)
{
### joint count of absences
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("jabs",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
firstonly <- function(x)
{
### present only in first sample
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("jfirst",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
secondonly <- function(x)
{
### present only in second sample
N <- nrow(x)
P <- ncol(x)
A <- numeric(N * N * P)
A <- .C("jsec",
as.double(as.vector(t(x))),
as.integer(N),
as.integer(P),
A = as.double(A),
PACKAGE = "fAssets")$A
A <- array(A, dim=c(N, N, P))
A
}
x <- as.matrix(x)
## code borrowed from dist()
METHODS <- c(
"euclidean", "bray-curtis", "manhattan",
"mahalanobis", "jaccard", "difference",
"sorensen")
method <- pmatch(method, METHODS)
if (is.na(method))
stop("invalid distance method")
if (method == -1)
stop("ambiguous distance method")
N <- nrow(x)
P <- ncol(x)
if(method == 1)
{
# Euclidean distance
A <- paireddiff(x)
D <- sqrt(apply(A, 1:2, function(x)sum(x * x)))
}
if(method == 2)
{
# Bray-Curtis distance
A <- paireddiff(x)
A <- apply(A, 1:2, function(x)sum(abs(x)))
B <- pairedsum(x)
B <- apply(B, 1:2, sum)
D <- A / B
}
if(method == 3)
{
# unstandardized manhattan distance
A <- paireddiff(x)
D <- apply(A, 1:2, function(x)sum(abs(x)))
}
if(method == 4)
{
# pairwise Mahalanobis distance
# same as mahal()
icov <- solve(cov(x))
A <- paireddiff(x)
A1 <- apply(A, 1, function(z)(z %*% icov %*% t(z)))
D <- A1[seq(1, N*N, by=(N+1)), ]
}
if(method == 5)
{
# Jaccard distance
A <- jointpresence(x)
A <- apply(A, 1:2, sum)
B <- firstonly(x)
B <- apply(B, 1:2, sum)
C <- secondonly(x)
C <- apply(C, 1:2, sum)
D <- 1 - A / (A + B + C)
}
if(method == 6)
{
# simple difference, NOT symmetric
D <- paireddiff(x)[,,1, drop=TRUE]
}
if(method == 7)
{
# Sorensen distance
A <- jointpresence(x)
A <- apply(A, 1:2, sum)
B <- firstonly(x)
B <- apply(B, 1:2, sum)
C <- secondonly(x)
C <- apply(C, 1:2, sum)
D <- 1 - (2*A) / (2*A + B + C)
}
## Make the results lower triangular
D <- D[col(D) < row(D)]
## give the results attributes similar to dist()
attr(D, "Size") <- N
attr(D, "Labels") <- rownames(x)
attr(D, "Diag") <- FALSE
attr(D, "Upper") <- FALSE
attr(D, "method") <- METHODS[method]
class(D) <- "dist"
D
}
################################################################################
fAssets/R/builtin-corrgram.R 0000644 0001760 0000144 00000030072 11370220753 015520 0 ustar ripley users
# 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/zzz.Deprecated.R 0000644 0001760 0000144 00000047624 12157313044 015147 0 ustar ripley users
# 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:
# .assetsStats Computes statistics of monthly assets sets
# FUNCTION: DESCRIPTION:
# .dutchPortfolioData Example Data from Engel's Diploma Thesis
# .usPortfolioData Annual US Economics Portfolio Data
# .sm132PortfolioData Example from Scherer, Martin: Chapter 1.32
# .worldIndexData A data set of World Indexes
# FUNCTION: SIMILARITY PLOTS:
# fixBinHistogram Returns histogram with fixed bins
################################################################################
.assetsStats <-
function(x)
{
# A function implemented by Diethelm Wuertz
# Description:
# Computes benchmark statistics for a data set of assets with
# monthly data records.
# Details:
# The computed statistics values are:
# records - number of records (length of time series)
# paMean - annualized (pa, per annum) Mean of Returns
# paAve - annualized Average of Returns
# paVola - annualized Volatility (standard Deviation)
# paSkew - Skewness of Returns
# paKurt - Kurtosis of Returns
# maxDD - maximum Drawdown
# TUW - Time under Water
# mMaxLoss - Monthly maximum Loss
# mVaR - Monthly 99% Value-at-Risk
# mModVaR - Monthly 99% Modified Value-at-Risk
# mSharpe - Monthly Sharpe Ratio
# mModSharpe - Monthly Modified Sharpe Ratio
# skPrice - Skewness/Kurtosis Price
# The statistics are implemented based on the formulas from
# "Extreme Metrics". They reflect risk measures as used in
# the hedge fund software from "www.AlternativeSoft.com".
# Arguments:
# x - asset data set, a matrix (or vector) where the rows
# are numbered by "time", and the columns belong to the
# individual assets. Monthly values are expected.
# Value:
# The function returns a data frame with the values of the
# 12 statistics for each asset.
# Reference:
# "ExtremeMetrics Software", Help Document, Alternative Software,
# March 2003, 4 pages.
# Example:
# FUNCTION:
# If x is a vector, make it a matrix:
statistics = 14
if (is.null(dim(x))) {
n = 1
x = matrix(x, length(x))
result = matrix(rep(0, times = statistics), ncol = 1) }
else {
n = dim(x)[2]
result = matrix(rep(0, times = statistics*n), ncol = n) }
# Give Names to Result Matrix:
stat.names = c(
"Records", "paMean", "paAve", "paVola",
"paSkew", "paKurt", "maxDD", "TUW",
"mMaxLoss", "mVaR", "mModVaR", "mSharpe",
"mModSharpe", "skPrice")
dimnames(result) = list(stat.names, dimnames(x)[[2]])
# Loop over all Assets:
for (i in 1:n) {
r = x[, i]
# Number of Records:
result[1, i] = length(r)
# Annualized mean from monthly returns:
result[2, i] = annualizedMean = (1 + mean(r))^12 - 1
# Annualized mean from monthly returns:
result[3, i] = annualizedAverage = mean(r)*sqrt(12)
# Annualized volatility from monthly returns:
result[4, i] = annualizedVolatility = sqrt(var(r))
# Annualized skewness from monthly returns:
result[5, i] = annualizedSkewness = skewness(r)
# Annualized Kurtosis from monthly returns:
result[6, i] = annualizedKurtosis = kurtosis(r)
# Maximum Drawdown of of monthly returns:
result[7, i] = maxDrawdown = max(cummax(cumsum(r)) - cumsum(r))
# Time-Under-Water of monthly returns:
result[8, i] = timeUnderWater =
max(diff(which (diff(cummax(cumsum(r))) != 0)))
# Maximum Loss of monthly returns:
result[9, i] = maxMonthlyLoss = min(r)
# Monthly Value at Risk:
zc = 2.33
result[10, i] = monthlyVaR = annualizedMean -
zc * annualizedVolatility
# Monthly Modified Value at Risk:
p = 0.99; s = annualizedSkewness; k = annualizedKurtosis
zcf = zc + (zc*zc-1)*s/6 + zc*(zc*zc-3)*k/24 + zc*(2*zc*zc-5)*s*s/36
result[11, i] = monthlyModVaR = annualizedMean -
zcf * annualizedVolatility
# Monthly Sharpe Ratio:
result[12, i] = monthlySharpeRatio =
annualizedMean/annualizedVolatility
# Monthly Modified Sharpe Ratio:
result[13, i] = monthlyModSharpeRatio = annualizedMean/monthlyModVaR
# Skewness Kurtosis Price:
result[14, i] = skewnesskurtosisPrice = annualizedMean *
( monthlyModVaR/monthlyVaR - 1) }
# Result:
ans = as.data.frame(round(result, digits = 3))
# Return Value:
ans
}
################################################################################
.dutchPortfolioData =
function()
{ # A function implemented by Rmetrics
# Description:
# Example Portfolio Data from Engels
# Example:
# engelsPortfolioData()
# FUNCTION:
# Mean Returns:
mu = c(0.266, 0.274, 0.162, 0.519, 0.394, 0.231, 0.277) / 1000
names(mu) = c(
"Elsevier", "Fortis", "Getronics", "Heineken",
"Philips", "RoyalDutch", "Unilever")
# Variance-Covariance Risk:
Sigma = c(
0.345, 0.150, 0.183, 0.088, 0.186, 0.090, 0.095,
0.150, 0.399, 0.204, 0.107, 0.236, 0.130, 0.127,
0.183, 0.204, 1.754, 0.075, 0.325, 0.110, 0.091,
0.088, 0.107, 0.075, 0.243, 0.096, 0.064, 0.086,
0.186, 0.236, 0.325, 0.096, 0.734, 0.147, 0.114,
0.090, 0.130, 0.110, 0.064, 0.147, 0.221, 0.093,
0.095, 0.127, 0.091, 0.086, 0.114, 0.093, 0.219)
Sigma = matrix(Sigma, ncol = 7)
colnames(Sigma) = rownames(Sigma) = names(mu)
# Return Value:
list(mu = mu, Sigma = Sigma)
}
# ------------------------------------------------------------------------------
.usPortfolioData =
function()
{ # A function implemented by Rmetrics
# Description:
# Annual US Economics Portfolio Data
# Example:
# usPortfolioData()
# list(mu = round(mean(usPortfolioData()),5),
# Sigma = round(var(usPortfolioData()), 5))
# FUNCTION:
# Units:
Units = c("TBills3m", "LongBonds", "SP500", "Wilshire5000",
"NASDAQComp", "LehmanBonds", "EAFE", "Gold")
# Time Series Object:
tS = as.timeSeries(as.data.frame(matrix(c(
19731231,1.075,0.942,0.852,0.815,0.698,1.023,0.851,1.677,
19741231,1.084,1.020,0.735,0.716,0.662,1.002,0.768,1.722,
19751231,1.061,1.056,1.371,1.385,1.318,1.123,1.354,0.760,
19761231,1.052,1.175,1.236,1.266,1.280,1.156,1.025,0.960,
19771231,1.055,1.002,0.926,0.974,1.093,1.030,1.181,1.200,
19781231,1.077,0.982,1.064,1.093,1.146,1.012,1.326,1.295,
19791231,1.109,0.978,1.184,1.256,1.307,1.023,1.048,2.212,
19801231,1.127,0.947,1.323,1.337,1.367,1.031,1.226,1.296,
19811231,1.156,1.003,0.949,0.963,0.990,1.073,0.977,0.688,
19821231,1.117,1.465,1.215,1.187,1.213,1.311,0.981,1.084,
19831231,1.092,0.985,1.224,1.235,1.217,1.080,1.237,0.872,
19841231,1.103,1.159,1.061,1.030,0.903,1.150,1.074,0.825,
19851231,1.080,1.366,1.316,1.326,1.333,1.213,1.562,1.006,
19861231,1.063,1.309,1.186,1.161,1.086,1.156,1.694,1.216,
19871231,1.061,0.925,1.052,1.023,0.959,1.023,1.246,1.244,
19881231,1.071,1.086,1.165,1.179,1.165,1.076,1.283,0.861,
19891231,1.087,1.212,1.316,1.292,1.204,1.142,1.105,0.977,
19901231,1.080,1.054,0.968,0.938,0.830,1.083,0.766,0.922,
19911231,1.057,1.193,1.304,1.342,1.594,1.161,1.121,0.958,
19921231,1.036,1.079,1.076,1.090,1.174,1.076,0.878,0.926,
19931231,1.031,1.217,1.100,1.113,1.162,1.110,1.326,1.146,
19941231,1.045,0.889,1.012,0.999,0.968,0.965,1.078,0.990),
byrow = TRUE, ncol = 9)))
colnames(tS)<-Units
# Return Value:
tS
}
# ------------------------------------------------------------------------------
.sm132PortfolioData =
function()
{
# A function implemented by Rmetrics
# Description:
# Example from Scherer, Martin: "Modern Portfolio Omtimization":
# Cheapter 1.32
# FUNCTION:
corr = matrix(data =
c( 1, 0.4, 0.5, 0.5, 0.4, 0.1, 0.1, 0.1,
0.4, 1.0, 0.3, 0.3, 0.1, 0.4, 0.1, 0.1,
0.5, 0.3, 1.0, 0.7, 0.1, 0.1, 0.5, 0.1,
0.5, 0.3, 0.7, 1.0, 0.1, 0.1, 0.1, 0.5,
0.4, 0.1, 0.1, 0.1, 1.0, 0.0, 0.0, 0.0,
0.1, 0.4, 0.1, 0.1, 0.0, 1.0, 0.0, 0.0,
0.1, 0.1, 0.5, 0.1, 0.0, 0.0, 1.0, 0.2,
0.1, 0.1, 0.1, 0.5, 0.0, 0.0, 0.2, 1.0),
nrow = 8, ncol = 8)
vol = diag(c(17, 21, 22, 20, 8, 8, 8, 8))
Cov = vol %*% corr %*% vol
# Average return
mu = c(3, 4, 5, 6, 0.25, 0.5, 0.75, 1)
# Return value:
list(mu = mu, Sigma = Cov)
}
# ------------------------------------------------------------------------------
.worldIndexData =
function()
{
# Description:
# A data set of World Indexs contributed by Dominik Locher
# Units:
Units = c("Asia", "EasternEurope", "FarEast", "LatinAmerica")
# Time Series Object:
x = c(
20070327,370.04,302.41,326.56,3100.66,
20070326,370.37,304.79,327.06,3128.91,
20070325,369.54,302.25,326.03,3124.70,
20070324,369.54,302.25,326.03,3124.70,
20070323,369.54,302.25,326.03,3124.70,
20070322,369.75,298.95,326.26,3129.17,
20070321,365.46,292.45,322.84,3116.79,
20070320,362.57,289.46,320.86,3034.35,
20070319,360.93,292.24,319.81,2990.89,
20070318,357.70,287.29,317.28,2938.57,
20070317,357.70,287.29,317.28,2938.57,
20070316,357.70,287.29,317.28,2938.57,
20070315,357.74,285.52,317.04,2962.38,
20070314,353.26,281.37,312.66,2936.81,
20070313,362.26,285.91,320.23,2930.81,
20070312,362.09,286.35,320.47,3014.71,
20070311,357.45,288.41,315.81,3004.10,
20070310,357.45,288.41,315.81,3004.10,
20070309,357.45,288.41,315.81,3004.10,
20070308,357.38,281.80,315.42,2964.89,
20070307,350.68,278.35,310.37,2901.26,
20070306,349.63,278.58,308.97,2910.81,
20070305,342.19,273.38,302.54,2797.08,
20070304,357.72,282.62,316.19,2880.75,
20070303,357.72,282.62,316.19,2880.75,
20070302,357.72,282.62,316.19,2880.75,
20070301,359.75,280.80,317.25,2925.88,
20070228,363.46,290.20,321.72,2957.57,
20070227,372.72,297.04,329.05,2933.25,
20070226,377.55,308.41,333.45,3143.55,
20070225,378.21,304.53,334.12,3152.57,
20070224,378.21,304.53,334.12,3152.57,
20070223,378.21,304.53,334.12,3152.57,
20070222,379.11,303.81,334.01,3198.17,
20070221,378.44,300.74,332.64,3166.70,
20070220,377.83,300.17,331.72,3157.26,
20070219,377.94,303.03,331.21,3166.05,
20070218,378.26,301.19,331.53,3162.13,
20070217,378.26,301.19,331.53,3162.13,
20070216,378.26,301.19,331.53,3162.13,
20070215,377.28,299.89,330.64,3172.06,
20070214,372.47,301.38,327.11,3172.37,
20070213,368.75,295.28,323.16,3112.62,
20070212,372.40,289.73,326.33,3049.67,
20070211,376.56,297.99,329.20,3081.50,
20070210,376.56,297.99,329.20,3081.50,
20070209,376.56,297.99,329.20,3081.50,
20070208,376.37,298.04,328.56,3111.51,
20070207,376.14,305.12,328.39,3111.97,
20070206,374.87,306.71,327.71,3123.29,
20070205,372.22,304.55,324.90,3105.70,
20070204,370.91,302.47,324.03,3096.00,
20070203,370.91,302.47,324.03,3096.00,
20070202,370.91,302.47,324.03,3096.00,
20070201,366.10,302.61,319.70,3080.11,
20070131,362.92,296.93,317.05,3041.84,
20070130,365.45,293.86,319.34,2994.49,
20070129,363.99,293.20,317.87,2959.63,
20070128,365.73,295.87,319.48,3008.45,
20070127,365.73,295.87,319.48,3008.45,
20070126,365.73,295.87,319.48,3008.45,
20070125,371.24,299.37,325.03,3031.37,
20070124,372.54,298.33,326.91,3050.37,
20070123,367.71,297.63,322.26,3005.14,
20070122,368.07,297.03,322.01,2965.56,
20070121,366.07,292.74,320.23,2954.21,
20070120,366.07,292.74,320.23,2954.21,
20070119,366.07,292.74,320.23,2954.21,
20070118,368.51,289.85,322.62,2901.66,
20070117,366.67,288.32,320.87,2926.80,
20070116,367.78,292.91,322.15,2908.26,
20070115,366.66,296.45,320.98,2933.52,
20070114,361.66,288.98,316.46,2926.08,
20070113,361.66,288.98,316.46,2926.08,
20070112,361.66,288.98,316.46,2926.08,
20070111,354.97,290.37,311.21,2902.35,
20070110,354.90,285.22,311.93,2859.72,
20070109,361.15,288.23,317.46,2849.87,
20070108,362.10,304.41,318.23,2903.84,
20070107,367.47,304.32,322.78,2880.09,
20070106,367.47,304.32,322.78,2880.09,
20070105,367.47,304.32,322.78,2880.09,
20070104,370.65,307.56,325.92,2968.18,
20070103,376.06,310.53,331.11,3002.63,
20070102,377.21,311.52,332.33,3039.15,
20070101,371.46,309.43,327.07,2995.67,
20061231,371.46,309.43,327.07,2995.67,
20061230,371.46,309.43,327.07,2995.67,
20061229,371.46,309.43,327.07,2995.67,
20061228,370.18,307.74,325.65,2981.90,
20061227,368.11,304.17,323.63,2975.56,
20061226,363.36,300.91,319.54,2926.69,
20061225,362.36,301.54,319.41,2902.57,
20061224,362.60,302.53,319.65,2902.57,
20061223,362.60,302.53,319.65,2902.57,
20061222,362.60,302.53,319.65,2902.57,
20061221,361.54,304.50,318.98,2910.08,
20061220,361.98,304.64,319.70,2918.35,
20061219,356.34,300.35,313.84,2917.11,
20061218,363.09,306.87,319.50,2936.06,
20061217,360.37,306.83,317.06,2942.70,
20061216,360.37,306.83,317.06,2942.70,
20061215,360.37,306.83,317.06,2942.70,
20061214,358.11,305.14,315.26,2938.00,
20061213,352.99,302.33,311.23,2903.05,
20061212,352.75,304.36,311.64,2890.34,
20061211,356.43,305.03,314.04,2907.91,
20061210,358.28,308.42,314.60,2895.92,
20061209,358.28,308.42,314.60,2895.92,
20061208,358.28,308.42,314.60,2895.92,
20061207,363.08,308.81,318.78,2889.90,
20061206,363.95,308.24,319.82,2891.55,
20061205,362.05,308.20,317.71,2887.74,
20061204,359.44,303.24,315.40,2836.95,
20061203,360.01,300.45,316.12,2780.48,
20061202,360.01,300.45,316.12,2780.48,
20061201,360.01,300.45,316.12,2780.48,
20061130,358.40,299.50,315.12,2804.62,
20061129,354.34,296.95,311.25,2789.24,
20061128,350.48,288.78,307.40,2726.65,
20061127,356.66,287.56,312.97,2732.92,
20061126,354.96,287.21,311.34,2782.22,
20061125,354.96,287.21,311.34,2782.22,
20061124,354.96,287.21,311.34,2782.22,
20061123,354.65,285.92,311.04,2791.43,
20061122,353.85,284.78,310.34,2787.78,
20061121,349.05,284.25,305.82,2767.77,
20061120,347.46,278.95,304.95,2740.54,
20061119,348.12,281.08,305.55,2735.42,
20061118,348.12,281.08,305.55,2735.42,
20061117,348.12,281.08,305.55,2735.42,
20061116,348.96,285.75,306.06,2761.74,
20061115,347.24,283.87,304.79,2766.90,
20061114,346.29,284.29,303.74,2760.15,
20061113,343.74,283.69,301.17,2721.09,
20061112,343.78,284.11,301.32,2733.62,
20061111,343.78,284.11,301.32,2733.62,
20061110,343.78,284.11,301.32,2733.62,
20061109,343.01,283.30,300.81,2750.00,
20061108,339.56,280.29,297.78,2750.76,
20061107,340.64,282.54,298.59,2739.01,
20061106,337.81,277.43,295.87,2743.48,
20061105,338.56,275.49,296.72,2687.33,
20061104,338.56,275.49,296.72,2687.33,
20061103,338.56,275.49,296.72,2687.33,
20061102,336.80,272.81,295.09,2666.32,
20061101,333.81,277.98,292.27,2673.55,
20061031,331.68,270.93,290.50,2663.66,
20061030,330.43,266.78,288.86,2619.44,
20061029,331.79,274.60,290.85,2667.38,
20061028,331.79,274.60,290.85,2667.38,
20061027,331.79,274.60,290.85,2667.38,
20061026,331.41,276.15,291.20,2698.02,
20061025,329.05,275.38,289.16,2688.38,
20061024,328.31,272.69,288.43,2668.66,
20061023,326.76,271.96,286.86,2654.76,
20061022,328.10,274.18,287.91,2637.77,
20061021,328.10,274.18,287.91,2637.77,
20061020,328.10,274.18,287.91,2637.77,
20061019,326.66,277.17,286.40,2651.84,
20061018,327.51,274.63,286.91,2636.09,
20061017,328.14,270.77,287.48,2619.25,
20061016,329.36,271.73,288.66,2649.86,
20061015,326.89,273.78,286.76,2625.68,
20061014,326.89,273.78,286.76,2625.68,
20061013,326.89,273.78,286.76,2625.68,
20061012,322.28,267.06,282.92,2579.95,
20061011,320.70,267.86,282.06,2558.04,
20061010,320.94,266.72,282.39,2573.41,
20061009,319.22,268.07,280.62,2547.12,
20061008,323.44,262.86,284.71,2530.23,
20061007,323.44,262.86,284.71,2530.23,
20061006,323.44,262.86,284.71,2530.23,
20061005,323.43,265.18,284.83,2535.34,
20061004,320.04,259.29,282.16,2505.77,
20061003,323.99,256.38,285.66,2449.38,
20061002,323.89,261.75,285.40,2482.37,
20061001,322.90,260.28,284.41,2473.06,
20060930,322.90,260.28,284.41,2473.06,
20060929,322.90,260.28,284.41,2473.06)
tS = as.timeSeries(data.frame(matrix(x, byrow = TRUE, ncol = 5)))
tS = returns(rev(tS))
colnames(tS)<-Units
# Return Value:
tS
}
################################################################################
## .hist <-
## function (x, nbins)
## {
## # A function implemented by Diethelm Wuertz
## # Description:
## # Returns histogram with fixed bins
## # FUNCTION:
## # Classes:
## nclass = nbins + 1
## n = length(x)
## xname = paste(deparse(substitute(x), 500), collapse = "\n")
## # Breaks:
## breaks = seq(min(x), max(x), length = nclass)
## nB = length(breaks)
## h = diff(breaks)
## # Compute Counts:
## counts = .C("bincount", as.double(x), as.integer(n), as.double(breaks),
## as.integer(nB), counts = integer(nB - 1), right = FALSE,
## include = TRUE, naok = FALSE, NAOK = FALSE, DUP = FALSE,
## PACKAGE = "base")$counts
## dens = counts/(n * h)
## mids = 0.5 * (breaks[-1] + breaks[-nB])
## # Histogram:
## r = structure(list(breaks = breaks, counts = counts, intensities = dens,
## density = dens, mids = mids, xname = xname, equidist = TRUE),
## class = "histogram")
## }
################################################################################
fAssets/R/builtin-DEoptim.R 0000644 0001760 0000144 00000031227 11370220753 015250 0 ustar ripley users
# 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-arrange.R 0000644 0001760 0000144 00000013770 12251705102 015160 0 ustar ripley users
# 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
# .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'
# FUNCTION:
# Order:
if (robust) {
x.cor = 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/assets-simulate.R 0000644 0001760 0000144 00000006415 11370220753 015367 0 ustar ripley users
# 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:
# assetsSim Simulates a set of artificial assets
################################################################################
assetsSim <-
function(n, dim = 2, model = list(mu = rep(0, dim), Omega = diag(dim),
alpha = rep(0, dim), df = Inf), assetNames = NULL)
{
# A function implemented by Diethelm Wuertz
# Description:
# Simulates a multivariate set of asset log-returns distributed
# according to a Normal, skew-Normal, or skew Student-t Distribution
# Function.
# Arguments:
# n - the number of data records to be simulated
# dim - the dimension number, i.e. the number of assets to be simulated
# model - a list with the model parameters:
# mu - the numeric vector of mean values of each asset time series
# Omega - the covariance matrix of assets
# alpha - the skewness vector
# df - the degrees of freedom, a measures for the kurtosis
# assetNames - a string vector of asset names, by default NULL
# which creates asset names as "V1", "V2", ..., "Vd", where
# d denotes the dimension
# Notes:
# Requires function "msn.quantities" from R's GPL licensed
# contributed package "sn", (C) 1998-2004 A. Azzalini.
# The model can also be the value returned by model slot from
# function assetsFit().
# Example:
# assetsSim(n=25)
# assetsSim(n=25, assetNames = c("RETURN-1", "RETURN-2")
# assetsSim(n=25, list(mu=c(0,0), Omega=diag(2), alpha=c(0,0), df=4))
# FUNCTION:
# Dimensions:
d = length(model$alpha)
if ( length(model$mu) != d | any(dim(model$Omega) != c(d, d)))
stop("dimensions of arguments do not match")
# Adapted from contributed R package "sn:rmsn"
Z = msn.quantities(model$mu, model$Omega, model$alpha)
y = matrix(rnorm(n * d), n, d) %*% chol(Z$Psi)
abs.y0 = matrix(rep(abs(rnorm(n)), d), ncol = d)
z = Z$delta * t(abs.y0) + sqrt(1 - Z$delta^2) * t(y)
# Select:
if (model$df == Inf) {
ans = t(model$mu + Z$omega * z)
} else {
x = rchisq(n, model$df)/model$df
z = t(model$mu + Z$omega * z)
ans = t(model$mu + t(sqrt(x) * z))
}
# Dimnames:
dimnames(ans)[[2]] = assetNames
# Return Value:
as.data.frame(ans)
}
################################################################################
fAssets/R/builtin-energy.R 0000644 0001760 0000144 00000004703 11370220753 015177 0 ustar ripley users
# 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:
# .mvnorme Energy test for multivariate normality
################################################################################
# Rmetrics:
# Note that energy 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: energy
# Title: E-statistics (energy statistics)
# Version: 1.1-0
# Date: 2008-04-07
# Author: Maria L. Rizzo and Gabor J. Szekely
# Description: E-statistics (energy) tests and statistics for
# comparing distributions:
# multivariate normality,
# multivariate k-sample test for equal distributions,
# hierarchical clustering by e-distances,
# multivariate independence tests,
# distance correlation,
# goodness-of-fit tests.
# Energy-statistics concept based on a generalization of
# Newton's potential energy is due to Gabor J. Szekely.
# Maintainer: Maria Rizzo
# Depends: boot
# License: GPL (>= 2)
# ------------------------------------------------------------------------------
.mvnorm.e <-
function(x)
{
# FUNCTION:
z <- scale(x, scale = FALSE)
ev <- eigen(var(x), symmetric = TRUE)
P <- ev$vectors
y <- z %*% (P %*% diag(1 / sqrt(ev$values)) %*% t(P))
e <- .C("mvnEstat", y = as.double(t(y)), byrow = as.integer(TRUE),
nobs = as.integer(nrow(x)), dim = as.integer(ncol(x)),
stat = as.double(0), PACKAGE = "fAssets")$stat
# Return Value:
e
}
################################################################################
fAssets/R/plot-mst.R 0000644 0001760 0000144 00000004523 11370220753 014021 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000003666 11370220753 014651 0 ustar ripley users
# 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 -
# bins -
# 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.R 0000644 0001760 0000144 00000010205 11370220753 016400 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000030317 11370220753 015355 0 ustar ripley users
# 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.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.R 0000644 0001760 0000144 00000021442 11370220753 014477 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000016276 11370220753 014362 0 ustar ripley users
# 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 a multivariate data
# FUNCTION: DESCRIPTION:
# assetsBasicStatsPlot Displays a segment plot of basic return statistics
# 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.R 0000644 0001760 0000144 00000021100 11370220753 014322 0 ustar ripley users
# 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, labels = TRUE, ...)
{
# 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.
# labels - a logical flag. Should default labels be printed?
# Not implemented.
# 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, labels = TRUE, 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.
# labels - a logical flag. Should default labels be printed?
# Not implemented.
# Added in call to .corrgram by DJS, 20/02/2010
# 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:
.corrgram(x, labels = labels,
lower.panel = .panel.lower,
upper.panel = .panel.upper,
text.panel = .panel.txt, ...)
# Return Value:
invisible()
}
# ------------------------------------------------------------------------------
assetsCorTestPlot <-
function(x, labels = TRUE, ...)
{
# 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.
# labels - a logical flag. Should default labels be printed?
# Not implemented.
# 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/assets-fit.R 0000644 0001760 0000144 00000025215 11370220753 014325 0 ustar ripley users
# 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
# .mvnormFit Fits a multivariate Normal distribution
# .mvsnormFit Fits a multivariate skew-Normal distribution
# .mvstFit Fits a multivariate skew-Student-t distribution
################################################################################
assetsFit =
function(x, method = c("st", "snorm", "norm"), 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.
# type - Which type of distribution should be fitted?
# a) norm - multivariate Normal
# b) snorm - multivariate skew-Normal
# c) st - multivariate skew-Student-t
# 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" ans "mst.mle" from R's GPL licensed
# contributed package "sn", (C) 1998-2004 A. Azzalini.
# The list returned by this function can serve as input for the
# function assetsSim().
# FUNCTION:
# Settings:
assets = as.matrix(x)
method = method[1]
colNames = colnames(x)
# Normal Distribution:
if (method == "norm") {
# Fit Normal:
fit = list()
mu = apply(assets, 2, mean)
Omega = cov(assets)
alpha = rep(0, times = length(mu))
df = Inf
}
# Skew-Normal Distribution:
if (method == "snorm") {
# Fit skew-Normal:
fit = mvFit(assets, method = "snorm", ...)
mu = as.vector(fit@fit$dp$beta)
Omega = fit@fit$dp$Omega
alpha = as.vector(fit@fit$dp$alpha)
df = Inf
fit = fit@fit
}
# Skew-Student-t Distribution:
if (method == "st") {
# Fit skew-Student:
fit = mvFit(assets, method = "st", fixed.df = fixed.df, ...)
mu = as.vector(fit@fit$beta)
Omega = fit@fit$dp$Omega
alpha = as.vector(fit@fit$dp$alpha)
df = fit@fit$dp$df
fit = fit@fit
}
# Add Names:
names(mu) = colNames
names(alpha) = colNames
rownames(Omega) = colNames
colnames(Omega) = colNames
# Add Title:
if (is.null(title))
title = paste("Fitted Asset Data Model: ", method)
# Add Description:
if (is.null(description))
description = description()
# Return Value:
new("fASSETS",
call = as.call(match.call()),
method = as.character(method),
model = list(mu = mu, Omega = Omega, alpha = alpha, df = df),
data = as.data.frame(x),
fit = as.list(fit),
title = as.character(title),
description = as.character(description)
)
}
################################################################################
.mvnormFit =
function(x, title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits a multivariate Normal distribution
# 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.
# type - Which type of distribution should be fitted?
# a) norm - multivariate Normal
# b) snorm - multivariate skew-Normal
# c) st - multivariate skew-Student-t
# Value:
# The function returns a list with the following entries:
# mu - Mean values of each asset time series
# Omega - Covariance matrix of assets
# Notes:
# Requires function "msn.mle" ans "mst.mle" from R's GPL licensed
# contributed package "sn", (C) 1998-2004 A. Azzalini.
# The list returned by this function can serve as input for the
# function assetsSim().
# FUNCTION:
# Settings:
assets = as.matrix(x)
method = method[1]
colNames = colnames(x)
# Fit mvNormal:
fit = list()
mu = apply(assets, 2, mean)
Omega = cov(assets)
alpha = rep(0, times = length(mu))
df = Inf
# Add Names:
names(mu) = colNames
names(alpha) = colNames
rownames(Omega) = colNames
colnames(Omega) = colNames
# Add Title:
if (is.null(title))
title = paste("Fitted Asset Data Model: ", method)
# Add Description:
if (is.null(description))
description = description()
# Return Value:
new("fASSETS",
call = as.call(match.call()),
method = as.character(method),
model = list(mu = mu, Omega = Omega, alpha = alpha, df = df),
data = as.data.frame(x),
fit = as.list(fit),
title = as.character(title),
description = as.character(description)
)
}
# ------------------------------------------------------------------------------
mvsnormFit =
function(x, title = NULL, description = NULL, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits a multivariate skew-Normal distribution
# 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.
# type - Which type of distribution should be fitted?
# a) norm - multivariate Normal
# b) snorm - multivariate skew-Normal
# c) st - multivariate skew-Student-t
# 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
# Notes:
# Requires function "msn.mle" ans "mst.mle" from R's GPL licensed
# contributed package "sn", (C) 1998-2004 A. Azzalini.
# The list returned by this function can serve as input for the
# function assetsSim().
# FUNCTION:
# Settings:
assets = as.matrix(x)
method = method[1]
colNames = colnames(x)
# Fit skew-Normal:
fit = mvFit(assets, method = "snorm", ...)
mu = as.vector(fit@fit$dp$beta)
Omega = fit@fit$dp$Omega
alpha = as.vector(fit@fit$dp$alpha)
df = Inf
fit = fit@fit
# Add Names:
names(mu) = colNames
names(alpha) = colNames
rownames(Omega) = colNames
colnames(Omega) = colNames
# Add Title:
if (is.null(title))
title = paste("Fitted Asset Data Model: ", method)
# Add Description:
if (is.null(description))
description = description()
# Return Value:
new("fASSETS",
call = as.call(match.call()),
method = as.character(method),
model = list(mu = mu, Omega = Omega, alpha = alpha, df = df),
data = as.data.frame(x),
fit = as.list(fit),
title = as.character(title),
description = as.character(description)
)
}
# ------------------------------------------------------------------------------
.mvstFit =
function(x, title = NULL, description = NULL, fixed.df = NA, ...)
{
# A function implemented by Diethelm Wuertz
# Description:
# Fits a multivariate skew-Student-t distribution
# 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.
# type - Which type of distribution should be fitted?
# a) norm - multivariate Normal
# b) snorm - multivariate skew-Normal
# c) st - multivariate skew-Student-t
# 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" ans "mst.mle" from R's GPL licensed
# contributed package "sn", (C) 1998-2004 A. Azzalini.
# The list returned by this function can serve as input for the
# function assetsSim().
# FUNCTION:
# Settings:
assets = as.matrix(x)
method = method[1]
colNames = colnames(x)
# Fit skew-Student:
fit = mvFit(assets, method = "st", fixed.df = fixed.df, ...)
mu = as.vector(fit@fit$beta)
Omega = fit@fit$dp$Omega
alpha = as.vector(fit@fit$dp$alpha)
df = fit@fit$dp$df
fit = fit@fit
# Add Names:
names(mu) = colNames
names(alpha) = colNames
rownames(Omega) = colNames
colnames(Omega) = colNames
# Add Title:
if (is.null(title))
title = paste("Fitted Asset Data Model: ", method)
# Add Description:
if (is.null(description))
description = description()
# Return Value:
new("fASSETS",
call = as.call(match.call()),
method = as.character(method),
model = list(mu = mu, Omega = Omega, alpha = alpha, df = df),
data = as.data.frame(x),
fit = as.list(fit),
title = as.character(title),
description = as.character(description)
)
}
################################################################################
fAssets/R/assets-test.R 0000644 0001760 0000144 00000012031 11370220753 014512 0 ustar ripley users
# 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
# .mvshapiroTest Multivariate Shapiro Test
# .mvenergyTest Multivariate E-Statistic (Energy) Test
################################################################################
assetsTest =
function(x, method = c("shapiro", "energy"), Replicates = 100,
title = NULL, description = NULL)
{
# 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, title = NULL, description = NULL)
{
# Description:
# Computes Shapiro's normality test for multivariate variables
# Note:
# Reimplemented function, doesn't require the contributed R package
# mvnormtest
# Author:
# Slawomir Jarek
# License: GPL
# Source:
# 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.
# Example:
# .mvshapiroTest(x = assetsSim(100))
# FUNCTION:
# Transform:
U = t(as.matrix(x))
# Test:
n = ncol(U)
if (n < 3 || n > 5000) stop("sample size must be between 3 and 5000")
rng = range(U)
rng = rng[2] - rng[1]
if (rng == 0)
stop("all `U[]' are identical")
Us = apply(U, 1, mean)
R = U-Us
M.1 = solve(R %*% t(R), tol = 1e-18)
Rmax = diag(t(R) %*% M.1 %*% R)
C = M.1 %*% R[, which.max(Rmax)]
Z = t(C) %*% U
test = shapiro.test(Z)
names(test$p.value) = ""
class(test) = "list"
# Add title and description:
if (is.null(title)) title = "Multivariate Shapiro Test"
if (is.null(description)) description = description()
# Return Value:
new("fHTEST",
call = match.call(),
data = list(x = x),
test = test,
title = title,
description = description)
}
# ------------------------------------------------------------------------------
.mvenergyTest =
function(x, Replicates = 99, title = NULL, description = NULL)
{
# Description:
# Computes E-statistics test for multivariate variables
# Note:
# Reimplemented function, doesn't require the contributed
# R package energy, we only use the C Program here.
# Source:
# Maria L. Rizzo and
# Gabor J. Szekely
# License: GPL 2.0 or later
# Example:
# .mvenergyTest(x = assetsSim(100), 99)
# FUNCTION:
# Transform:
if (class(x) == "timeSeries") x = series(x)
x = as.matrix(x)
# Test:
R = Replicates
# RVs:
n <- nrow(x)
d <- ncol(x)
ran.gen = function(x, y) return(matrix(rnorm(n * d), nrow = n, ncol = d))
# Parametric Mini Boot:
strata = rep(1, n)
n <- nrow(x)
temp.str <- strata
strata <- tapply(1:n, as.numeric(strata))
t0 <- .mvnorm.e(x)
lt0 <- length(t0)
t.star <- matrix(NA, sum(R), lt0)
pred.i <- NULL
for(r in 1:R) t.star[r, ] <- .mvnorm.e(ran.gen(x, NULL))
# Result:
test <- list(
statistic = c("E-Statistic" = t0),
p.value = 1 - mean(t.star < t0),
method = "Energy Test",
data.name = paste("x, obs ", n, ", dim ", d, ", reps ", R, sep = ""))
names(test$p.value) = ""
class(test) = "list"
# Add:
if (is.null(title)) title = test$method
if (is.null(description)) description = description()
# Return Value:
new("fHTEST",
call = match.call(),
data = list(x = x),
test = test,
title = title,
description = description)
}
################################################################################
fAssets/R/plot-boxplot.R 0000644 0001760 0000144 00000012247 11370220753 014707 0 ustar ripley users
# 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
################################################################################
# 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.R 0000644 0001760 0000144 00000005602 11370220753 015407 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000007254 11370220753 015410 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000031417 11370220753 015676 0 ustar ripley users
# 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.R 0000644 0001760 0000144 00000003020 12251674146 013076 0 ustar ripley users
# 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
## ################################################################################
## .First.lib =
## function(lib, pkg)
## {
## ### # Startup Mesage and Desription:
## ### MSG <- if(getRversion() >= "2.5") packageStartupMessage else message
## ### dsc <- packageDescription(pkg)
## ### if(interactive() || getOption("verbose")) {
## ### # not in test scripts
## ### MSG(sprintf("Rmetrics Package %s (%s) loaded.", pkg, dsc$Version))
## ### }
## setRmetricsOptions(.x.save = NA)
## }
.onLoad <- function(libname, pkgname) setRmetricsOptions(.x.save = NA)
if(!exists("Sys.setenv", mode = "function")) # pre R-2.5.0, use "old form"
Sys.setenv <- Sys.putenv
################################################################################
fAssets/R/assets-meancov.R 0000644 0001760 0000144 00000043076 11370220753 015200 0 ustar ripley users
# 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 = scaleTau2, ...)
user = FALSE
}
# [MASS] mve and mcd Routines:
if (method == "mve") {
# require(MASS)
ans = MASS::cov.rob(x = x.mat, method = "mve")
user = FALSE
}
if (method == "mcd") {
# require(MASS)
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 = scaleTau2, ...)
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.R 0000644 0001760 0000144 00000007071 11370220753 014511 0 ustar ripley users
# 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/R/class-fASSETS.R 0000644 0001760 0000144 00000007721 11370220753 014520 0 ustar ripley users
# 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/R/assets-select.R 0000644 0001760 0000144 00000006340 11370220753 015020 0 ustar ripley users
# 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 = match.fun(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/MD5 0000644 0001760 0000144 00000007754 12254146510 012237 0 ustar ripley users adff068b78722ea3921d0015604b8082 *ChangeLog
a08c0eb0e9567000fb73a131884ffe5d *DESCRIPTION
b033a7b3f6deac4b50f65333297566bc *NAMESPACE
1359e468ede8a51a1d24f656c1d704d6 *R/assets-arrange.R
9dbed515b79c57ef6591e2c4ae112d6b *R/assets-fit.R
0cc744f0b627b20f7c4b8ef3893323b2 *R/assets-lpm.R
1cc90c11d4c31b171d91096e80fdbd9f *R/assets-mcr.R
fc137624c0534df616f1ab7f543fadb5 *R/assets-meancov.R
86a4a54059922fab478f002fc9866079 *R/assets-outliers.R
56df94c1a06b03961a37a7ea7e6e073c *R/assets-portfolio.R
7ecc26d8d6a160ad62d6797a95072b4c *R/assets-select.R
63c107670a288d666aac1e9832822ee4 *R/assets-simulate.R
0c35719e3673be4a2728754338bd6fbf *R/assets-test.R
31963962bea8a207ba501f123c04a0e2 *R/builtin-DEoptim.R
f573257a8fc7e6eb3ebe8b64eacc0ce2 *R/builtin-arwMvoutlier.R
5246456a49bc0834d905113ada7d207b *R/builtin-corpcor.R
8b9c08b997e7e0d830ab7296cbc8eea4 *R/builtin-corrgram.R
ac6299cdfe8467717028c284c69da265 *R/builtin-covRobust.R
9889bc2ba9be634a2b9f29f3f9a682fb *R/builtin-donostahRobust.R
60b5bbdb35369e05dd055402faafe397 *R/builtin-ecodist.R
eac428f89af108d95b02d670a729c5fa *R/builtin-energy.R
2bdfd75a42e5b859192efe652be34239 *R/builtin-mstApe.R
5b4262591b2e4419a100a0a8ba39a029 *R/builtin-rmtTawny.R
a0406ec5b5409bb44dd52a1b84c9db58 *R/builtin-shrinkTawny.R
12c33103982050308a93a9f459b2e71e *R/class-fASSETS.R
5eb9c6e068549c54803862b54a928e05 *R/plot-binning.R
bab842e1a7eef3c4327a83c91743b6fe *R/plot-boxplot.R
babbd395b31ed9ba83c3acf6b1336614 *R/plot-ellipses.R
94685adbd1dcb83f4483b64bc3831a38 *R/plot-hist.R
19003188473f404343e50495fb1824f9 *R/plot-mst.R
e78a8f8420c1b1d1292155fd6904fd83 *R/plot-pairs.R
4064e22c8c4cd03c96143a09ebf1d863 *R/plot-panels.R
a5934ed8b6321b4c5a83bec55322563e *R/plot-qqplot.R
b0970b505f1e0b15e1f6208cd9ff06fc *R/plot-risk.R
7e39197b96d538c1c44fbdcab39e7773 *R/plot-series.R
1e181f17f9bf22e59402bbd3153632eb *R/plot-similarity.R
e7af5f1290411e8c3a6f30e66db0d0af *R/plot-stars.R
85854f76a2caaec474a7dcccae508ae3 *R/stats-distance.R
489dd5049c648353724393e7dd6f2ab3 *R/zzz.Deprecated.R
0313c8d9c92521def68e862d7cb01f84 *R/zzz.R
6042b9c5e5bec3ecc1b6959cd2858b64 *inst/COPYRIGHT.html
7d215d06e1f0f0794a63a29b7a8b7935 *inst/unitTests/Makefile
d11a67f141f4eef8cb4d3f24d66bd5d6 *inst/unitTests/runTests.R
2bd25e3404bc4640cbd56d5fade0899c *inst/unitTests/runit.AssetsFit.R
d8e6cb81482240804a1993f789894d65 *inst/unitTests/runit.AssetsMeanCov.R
86d6d79a41057e41f34bcc184e2476de *inst/unitTests/runit.AssetsPlots.R
f4f0d316b9b71062619c5e089d41b798 *inst/unitTests/runit.AssetsSelect.R
1fe17670137e36b52e7a9e9caf46a021 *inst/unitTests/runit.AssetsTests.R
57afd3f50fe97e70d3398074a2cf408c *inst/unitTests/runit.LowerPartialMoments.R
fd9a8572ff1bf7c579828811f391572d *man/00fAssets-package.Rd
3452cc11df57dae3bc32fc405c496b2c *man/assetsArrange.Rd
4a32199421f9dec71a3b41370724fc6f *man/assetsFit.Rd
62f9da699232821ded513b1270d63633 *man/assetsLPM.Rd
eda0293c9d377ce56f0c1081d75fa15f *man/assetsMCR.Rd
ed16cf26a8275a3f0d223716444959c4 *man/assetsMeanCov.Rd
3e5a8fcb45666327ff0d8cf33800b822 *man/assetsOutliers.Rd
929fbb072be2ef58526467eb4d4f9b90 *man/assetsPfolio.Rd
4e35a41e88825a646c8899f6d4286c54 *man/assetsSelect.Rd
52450aa784ba295d9c138b716813fae8 *man/assetsSim.Rd
0cad2b9cf5f5c210820732cb23cf20d4 *man/assetsTest.Rd
95b044331ae5e1c566a2126df92d6dcc *man/class-fASSETS.Rd
ffdacc06ed47634d2573dc65a14136dd *man/plot-binning.Rd
2db0e64a1e667bd5f26244ad866df0fb *man/plot-boxplot.Rd
e6f29eba4795f58fd09d4b01ddc39508 *man/plot-ellipses.Rd
aec6c13e84a1096d08220d425c5eec1d *man/plot-hist.Rd
0903f8cd9b38c5c7ba56824d4131cd74 *man/plot-mst.Rd
805d632b80e2e8f8da8c5c3d94dfc431 *man/plot-pairs.Rd
c4f265a109ff4657f6ec59726c44366e *man/plot-qqplot.Rd
db15ac0a3bb9c6f433286b7593d4e679 *man/plot-risk.Rd
e4d38743d705c07b14e84d10d0bbc64b *man/plot-series.Rd
1148425a4430f8c3ea914a18d88f9f5c *man/plot-similarity.Rd
42e3c47f85165de162d9bd624f36e6ad *man/plot-stars.Rd
f407709493ecda7ebf27420ef6bc556a *src/Makevars
6f7a409f4219ce1394bf16c7ce3a0f2f *src/ecodist.c
b4f61bb5bcfa23efe41ce5f84a3218fb *src/energy.c
6b26e5955f3e973aed8c110a80aee475 *tests/doRUnit.R
fAssets/DESCRIPTION 0000644 0001760 0000144 00000001515 12254146510 013422 0 ustar ripley users Package: fAssets
Version: 3002.80
Revision: 5530
Date: 2013-12-17
Title: Rmetrics - Assets Selection and Modelling
Author: Diethelm Wuertz and many others, see the SOURCE file
Depends: R (>= 2.6.0), timeDate, timeSeries, fBasics, fCopulae (>=
2100.77)
Imports: methods, sn, MASS, robustbase
Suggests: RUnit
Maintainer: Yohan Chalabi
Description: Environment for teaching "Financial Engineering and
Computational Finance"
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: http://www.rmetrics.org
Packaged: 2013-12-17 20:28:00 UTC; yohan
NeedsCompilation: yes
Repository: CRAN
Date/Publication: 2013-12-17 23:16:40
fAssets/ChangeLog 0000644 0001760 0000144 00000014560 12254131717 013475 0 ustar ripley users 2013-12-10 chalabi
* DESCRIPTION, R/assets-arrange.R, R/zzz.R:
2012-09-24 chalabi
* ChangeLog, DESCRIPTION: Updated ChangeLog and DESC files
* 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/ 0000755 0001760 0000144 00000000000 12251673345 012475 5 ustar ripley users fAssets/man/plot-risk.Rd 0000644 0001760 0000144 00000003554 11370220754 014710 0 ustar ripley users \name{riskPlots}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsRiskReturnPlot -
# par(mfrow = c(2, 2))
assetsRiskReturnPlot(LPP)
## assetsNIGShapeTrianglePlot -
assetsNIGShapeTrianglePlot(LPP)
}
\keyword{models}
fAssets/man/plot-binning.Rd 0000644 0001760 0000144 00000002564 11370220754 015364 0 ustar ripley users \name{binningPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsHistPairsPlot -
assetsHistPairsPlot(LPP[, c("LMI", "ALT")])
assetsHistPairsPlot(LPP[, c("LMI", "ALT")], method = "hex")
}
\keyword{models}
fAssets/man/class-fASSETS.Rd 0000644 0001760 0000144 00000003256 11370220754 015236 0 ustar ripley users \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 -
LPP = as.timeSeries(data(LPP2005REC))[, 1:3]
colnames(LPP)
## assetsFit -
# Fit a Skew-Student-t Distribution:
fit = assetsFit(LPP)
## fASSETS -
class(fit)
print(fit)
plot(fit, 1)
## @model
# Show Model Slot:
print(fit@model)
} fAssets/man/plot-similarity.Rd 0000644 0001760 0000144 00000004601 11370220754 016120 0 ustar ripley users \name{similarityPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsDendrogramPlot -
assetsDendrogramPlot(LPP)
## assetsCorEigenPlot -
assetsCorEigenPlot(LPP)
}
\keyword{models}
fAssets/man/assetsMeanCov.Rd 0000644 0001760 0000144 00000011617 11370220754 015536 0 ustar ripley users \name{assetsMeanCov}
\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/assetsArrange.Rd 0000644 0001760 0000144 00000002750 11370220754 015563 0 ustar ripley users \name{assetsArrange}
\alias{assetsArrange}
\title{Rearranging Assets Columnwise}
\description{
Allows to rearrange a set of assets columnwise.
}
\usage{
assetsArrange(x, method = c("pca", "hclust", "abc"), ...)
}
\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,
or \code{"abc"} which arrangtes the columns alphabetically.
}
\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{
## lppData -
lppData = as.timeSeries(data(LPP2005REC))
## assetsArrange -
assetsArrange(lppData, "pca")
assetsArrange(lppData, "hclust")
assetsArrange(lppData, "abc")
}
\keyword{models}
fAssets/man/plot-boxplot.Rd 0000644 0001760 0000144 00000002324 11370220754 015421 0 ustar ripley users \name{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 -
LPP = as.timeSeries(data(LPP2005REC))
head(LPP)
## assetsBoxPlot -
assetsBoxPlot(LPP)
## assetsBoxPercentilePlot -
assetsBoxPercentilePlot(LPP)
}
\keyword{models}
fAssets/man/plot-stars.Rd 0000644 0001760 0000144 00000010234 11370220754 015065 0 ustar ripley users \name{starsPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsBasicStatsPlot -
# par(mfrow = c(1, 1))
assetsBasicStatsPlot(LPP,
title = "", description = "")
## assetsMomentsPlot -
assetsMomentsPlot(LPP,
title = "", description = "")
## assetsBoxStatsPlot -
assetsBoxStatsPlot(LPP,
title = "", description = "")
## assetsNIGFitPlot -
assetsNIGFitPlot(LPP[, 7:9],
title = "", description = "")
}
\keyword{models}
fAssets/man/assetsPfolio.Rd 0000644 0001760 0000144 00000015713 11370220754 015437 0 ustar ripley users \name{assetsPfolio}
\alias{assetsPfolio}
\alias{pfolioVaR}
\alias{pfolioCVaR}
\alias{pfolioCVaRplus}
\alias{lambdaCVaR}
\alias{pfolioMaxLoss}
\alias{pfolioReturn}
\alias{pfolioTargetReturn}
\alias{pfolioTargetRisk}
\alias{pfolioSigma}
\alias{pfolioHist}
\title{Risk and Related Measures for Portfolios}
\description{
Computes Value-at-Risk and related measures
for a portfolio of assets.
The functions are:
\tabular{ll}{
\code{pfolioVaR} \tab computes Value-at-Risk for a portfolio of assets, \cr
\code{pfolioCVaRplus} \tab computes Value-at-Risk+ for a portfolio of assets, \cr
\code{pfolioCVaR} \tab computes Conditional Value-at-Risk for a PF of assets, \cr
\code{lambdaCVaR} \tab computes CVaR's atomic split value lambda, \cr
\code{pfolioMaxLoss} \tab computes Maximum Loss for a portfolio of assets, \cr
\code{pfolioReturn} \tab computes return values of a portfolio, \cr
\code{pfolioTargetReturn} \tab computes the target return of a portfolio, \cr
\code{pfolioTargetRisk} \tab computes the target risk of a portfolio, \cr
\code{pfolioHist} \tab plots a histogram of the returns of a portfolio. }
}
\usage{
pfolioVaR(x, weights = NULL, alpha = 0.05)
pfolioCVaRplus(x, weights = NULL, alpha = 0.05)
pfolioCVaR(x, weights = NULL, alpha = 0.05)
lambdaCVaR(n, alpha = 0.05)
pfolioMaxLoss(x, weights = NULL)
pfolioReturn(x, weights = NULL)
pfolioTargetReturn(x, weights = NULL)
pfolioTargetRisk(x, weights = NULL)
pfolioHist(x, weights = NULL, alpha = 0.05, range = NULL, details = TRUE, \dots)
}
\arguments{
\item{x}{
a 'timeSeries' object, data frame or any other rectangular
object which can be expressed as a matrix. The first
dimension is the number of observations, we call it \code{n},
and the second is the number of assets in the data set,
we call it \code{dim}.
}
\item{weights}{
usually a numeric vector which has the length of the number of
assets. The weights measures the normalized weights of the
individual assets. By default \code{NULL}, then an equally
weighted set of assets is assumed.
}
\item{alpha}{
a numeric value, the confidence interval, by default 0.05.
}
\item{details}{
a logical value, should details be printed?
}
\item{n}{
the number of observation from which the CVaR's atomic split
value \code{lambda=1-floor(alpha*n)/(alpha*n)} will be
evaluated.
}
\item{range}{
a numeric vector of two elements limiting the plot range of
the histogram. This is quite useful if one likes to compare
several plots on the same scale. If \code{range=NULL}, the
default value, then the range will be selected automatically.
}
\item{\dots}{
optional arguments to be passet to the function \code{hist}.
}
}
\details{
The percentile measures of loss (or reward) are defined in the
following way: Let \eqn{f(x ,y)} be a loss functions depending
upon a decision vector \eqn{x = (x_1, ..., x_n )} and a random
vector \eqn{y = (y_1, ..., y_m)}, then
\emph{pfolioVaR} is the alpha-percentile of the loss distribution, a
smallest value such that the probability that losses exceed or
are equal to this value is greater or equal to alpha.
\emph{pfolioCVaRplus} or "CVaR+" or the "upper CVaR" are the expected
losses strictly exceeding VaR. This is also also called "Mean
Excess Loss" and "Expected Shortfall".
\emph{pfolioCVaR} is a weighted average of VaR and CVaRplus defined as
\eqn{CVaR = lambda*VaR + (1-lambda)} CVaRplus, for
\eqn{0 <= lambda <= 1}.
Note, CVaR is convex, but VaR and CVaRplus may be non-convex. The
following inequalities are valid: \eqn{VaR <= CVaR <= CVaRplus}.
}
\value{
\code{pfolioVaR}
\cr
returns the value of risk, VaR, for a portfolio of assets, a
numeric value.
\cr
\code{pfolioCVaRplus}
\cr
returns the conditional value of risk plus, CVaRplus, for a
portfolio of assets, a numeric value.
\cr
\code{pfolioCVaR}
\cr
returns the conditional value of risk, CVaR, for a portfolio
of assets, a numeric value.
\cr
\code{lambdaCVaR}
\cr
returns CVaR's atomic split value \code{lambda}, a numeric value.
\cr
\code{pfolioMaxLoss}
\cr
returns the maximum loss value of the portfolio, a numeric value.
\cr
\code{pfolioReturn}
\cr
returns the total portfolio return computed from the set of
assets \code{x}, a numeric vector.
\cr
\code{pfolioTargetReturn}
\cr
returns the total return or target return computed from the set of
assets \code{x} and weights \code{weights}, a numeric value.
\cr
\code{pfolioTargetRisk}
\cr
returns the total risk (Sigma) or target risk computed from the set
of assets \code{x} and \code{weights} via the formual
\code{sqrt(weights \%*\% cov(x) \%*\% weights)}, a numeric value.
\cr
\code{pfolioHist}
\cr
plots a histogram of portfolio returns and adds the values
for the VaR (blue), for the CVaRplus (red), and for the
maximum loss (green) to the histogram plot. The function
invisibly returns a list with the following elements: VaR,
VaRplus, maxLoss, mean, and sd. If \code{details} is \code{TRUE},
then the result is printed.
}
\references{
Uryasev S. (2000);
\emph{Conditional Value-at-Risk (CVaR): Algorithms and Applications},
Risk Management and Financial Engineering Lab, University of Florida
Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009);
\emph{Portfolio Optimization with R/Rmetrics},
Rmetrics eBook, Rmetrics Association and Finance Online, Zurich.
}
\examples{
## assetsSim -
myAssets = 100/12 * assetsSim(n = 120, dim = 4)
# Plot Cumulated Returns of the Assets:
prices = apply(myAssets, 2, FUN = cumsum)
par(mfrow = c(2, 1), cex = 0.7)
ts.plot(prices, col = 1:4, ylim = c(-300, 300))
legend(0, 300, legend = colnames(myAssets), pch = "----", col = 1:4)
title(main = "Cumulated Returns", ylab = "Cumulated Returns")
abline(h = 0, lty = 3)
## pfolioCVaR -
equalWeights = rep(1/4, 4)
alpha = 0.10
# Value at Risk:
pfolioVaR(myAssets, equalWeights, alpha)
# Conditional Value at Risk Plus:
pfolioCVaRplus(myAssets, equalWeights, alpha)
# Conditional Value at Risk Plus:
pfolioCVaR(myAssets, equalWeights, alpha)
# Lambda - Atomic Split Value:
lambdaCVaR(120, alpha)
## pfolioHist -
# Maximum Loss Value of the Portfolio
pfolioMaxLoss(myAssets, equalWeights)
# Compute Portfolio Returns:
r = pfolioReturn(myAssets, equalWeights)
head(r)
# Target Return and Target Risk:
pfolioTargetReturn(myAssets, equalWeights)
pfolioTargetRisk(myAssets, equalWeights)
# Plot:
pfolioHist(myAssets, equalWeights, alpha, n = 20)
}
\keyword{math}
fAssets/man/assetsFit.Rd 0000644 0001760 0000144 00000014314 11370220754 014725 0 ustar ripley users \name{assetsFit}
\alias{assetsFit}
\alias{mvsnormFit} % FIXME
\title{Fitting of Multivariate Asset Sets}
\description{
Fits the parameters to a multivariate normal,
skew normal, or (skew) Student-t distribution.
}
\usage{
assetsFit(x, method = c("st", "snorm", "norm"), title = NULL,
description = NULL, fixed.df = NA, \dots)
}
\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{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{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.
}
\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{
## LPP -
# Percentual Returns:
LPP = 100 * as.timeSeries(data(LPP2005REC))[, 1:6]
colnames(LPP)
## assetsFit -
# Fit a Skew-Student-t Distribution:
fit = assetsFit(LPP)
print(fit)
# Show Model Slot:
print(fit@model)
## assetsSim -
# Simulate set with same statistical properties:
set.seed(1953)
lppSim = assetsSim(n = nrow(LPP), dim = ncol(LPP), model = fit@model)
colnames(lppSim) <- colnames(LPP)
rownames(lppSim) <- rownames(LPP)
head(lppSim)
}
\keyword{models}
fAssets/man/plot-series.Rd 0000644 0001760 0000144 00000002357 11370220754 015232 0 ustar ripley users \name{seriesPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsReturnPlot -
# par(mfrow = c(3,2))
assetsReturnPlot(LPP[, 1:3])
## assetsCumulatedPlot -
assetsCumulatedPlot(LPP[, "LPP40"],
col = "red")
## assetsSeriesPlot
assetsSeriesPlot(LPP[, c("LMI", "ALT")],
col =c("orange", "brown"))
}
\keyword{models}
fAssets/man/assetsLPM.Rd 0000644 0001760 0000144 00000002640 11370220753 014631 0 ustar ripley users \name{assetsLPM}
\alias{assetsLPM}
\title{Computation of Lower Partial Moments of Asset Sets}
\description{
Computes assymmetric lower partial moments from a time
series of assets.
}
\usage{
assetsLPM(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 -
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
# Lower Partial Moments:
assetsLPM(LPP)
}
\keyword{models}
fAssets/man/assetsTest.Rd 0000644 0001760 0000144 00000004644 11370220754 015127 0 ustar ripley users \name{assetsTest}
\alias{assetsTest}
\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 = 100,
title = NULL, description = 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{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"}.
}
\item{title}{
a character string, assigning a title to an
\code{"fASSETS"} object.
}
\item{description}{
a character string, assigning a brief description to the
returned object.
}
}
\value{
returns an object of class \code{fHTEST}.
}
\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 -
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
colnames(LPP)
# Multivariate Shapiro Test:
assetsTest(LPP, "shapiro")
# Multivariate Energy Test:
assetsTest(LPP, "energy")
}
\keyword{models}
fAssets/man/plot-ellipses.Rd 0000644 0001760 0000144 00000001730 11370220754 015552 0 ustar ripley users \name{covEllipsesPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))[, 1:6]
head(LPP)
## cov -
Cov = cov(LPP)
robustCov = assetsMeanCov(LPP, "MCD")$Sigma
## covEllipsesPlot -
covEllipsesPlot(list(Cov, robustCov))
}
\keyword{models}
fAssets/man/plot-mst.Rd 0000644 0001760 0000144 00000003161 11370220754 014535 0 ustar ripley users \name{treePlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsTreePlot -
# par(mfrow = c(2, 2))
assetsTreePlot(LPP)
# new seeds ...
for (i in 1:3) assetsTreePlot(LPP)
}
\keyword{models}
fAssets/man/00fAssets-package.Rd 0000644 0001760 0000144 00000001200 11370220754 016107 0 ustar ripley users \name{fAssets-package}
\alias{fAssets}
\docType{package}
\title{Assets Modelling}
\description{
The Rmetrics "fAssets" package is a very powerful collection
of functions to investigate and analyze data sets of financial
assets from different points ov view.
}
\details{
\tabular{ll}{
Package: \tab fAssets\cr
Type: \tab Package\cr
Date: \tab 2009\cr
License: \tab GPL Version 2 or later\cr
Copyright: \tab (c) 1999-2008 Diethelm Wuertz and Rmetrics Association\cr
URL: \tab \url{http://www.rmetrics.org}
}
}
\keyword{models}
fAssets/man/assetsSim.Rd 0000644 0001760 0000144 00000007630 11370220754 014736 0 ustar ripley users \name{assetsSim}
\alias{assetsSim}
\title{Simulating Multivariate Asset Sets}
\description{
Simulates multivariate artificial data sets of assets,
from a multivariate normal, skew normal, or (skew)
Student-t distribution.
}
\usage{
assetsSim(n, dim = 2, model = list(mu = rep(0, dim), Omega = diag(dim),
alpha = rep(0, dim), df = Inf), assetNames = NULL)
}
\arguments{
\item{n}{
integer value, the number of data records to be simulated.
}
\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.
}
}
\value{
\code{assetsSim()}
\cr
returns a data.frame of simulated assets.
}
\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.
}
\seealso{
\code{MultivariateDistribution}.
}
\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{
## LPP -
# Percentual Returns:
LPP = 100 * as.timeSeries(data(LPP2005REC))[, 1:3]
colnames(LPP)
## assetsFit -
# Fit a Skew-Student-t Distribution:
fit = assetsFit(LPP)
print(fit)
# Show Model Slot:
print(fit@model)
## assetsSim -
# Simulate set with same statistical properties:
set.seed(1953)
lppSim = assetsSim(n = nrow(LPP), dim = ncol(LPP), model = fit@model)
colnames(lppSim) <- colnames(LPP)
rownames(lppSim) <- rownames(LPP)
head(lppSim)
head(as.timeSeries(lppSim))
}
\keyword{models}
fAssets/man/plot-qqplot.Rd 0000644 0001760 0000144 00000002331 11370220754 015250 0 ustar ripley users \name{assetsQQNormPlot}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsQQNormPlot -
# par(mfrow = c(2, 2))
assetsQQNormPlot(LPP[, 1:3])
}
\keyword{models}
fAssets/man/plot-pairs.Rd 0000644 0001760 0000144 00000005332 11370220754 015052 0 ustar ripley users \name{pairsPlot}
\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, labels = TRUE, \dots)
assetsCorgramPlot(x, labels = TRUE,
method = c("pie", "shade"), \dots)
assetsCorTestPlot(x, labels = TRUE, \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 -
LPP = as.timeSeries(data(LPP2005REC))
## assetsPairsPlot -
assetsPairsPlot(LPP[, 1:6])
## assetsCorgramPlot -
assetsCorgramPlot(LPP[, 1:6], method = "pie")
assetsCorgramPlot(LPP[, 1:6], method = "shade")
## assetsCorTestPlot -
assetsCorTestPlot(LPP[, 1:6])
## assetsCorImagePlot -
assetsCorImagePlot(LPP[, 1:6])
}
\keyword{models}
fAssets/man/assetsSelect.Rd 0000644 0001760 0000144 00000005224 11370220754 015422 0 ustar ripley users \name{assetsSelect}
\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 -
LPP = as.timeSeries(data(LPP2005REC))
colnames(LPP)
## assetsSelect -
# hclust 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-hist.Rd 0000644 0001760 0000144 00000003656 11370220754 014712 0 ustar ripley users \name{histPlot}
\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 -
x = as.timeSeries(data(LPP2005REC))
## assetsHistPlot -
# par(mfrow = c(2, 2))
assetsHistPlot(x[, 1:4])
## assetsLogDensityPlot -
# par(mfrow = c(1, 1))
assetsLogDensityPlot(x[, "ALT"], estimator = "both")
}
\keyword{models}
fAssets/man/assetsOutliers.Rd 0000644 0001760 0000144 00000003100 11370220754 016000 0 ustar ripley users \name{assetsOutliers}
\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]
## assetsOutliers -
assetsOutliers(LPP, colMeans(LPP), cov(LPP))
}
\keyword{models}
fAssets/man/assetsMCR.Rd 0000644 0001760 0000144 00000006760 11370220754 014632 0 ustar ripley users \name{assetsMCR}
\alias{assetsMCR}
\alias{covarRisk}
\alias{mcr}
\alias{mcrBeta}
\alias{riskContributions}
\alias{riskBudgets}
\title{Marginal Contributions to Covariance Risk}
\description{
Computes marginal contributions to covariance risk and related
measures for a portfolio of assets.
The functions are:
\tabular{ll}{
\code{covarRisk} \tab Computes covariance risk, \cr
\code{mcr} \tab computes marginal contribution to covariance risk, \cr
\code{mcrBeta} \tab computes beta, the rescaled mcr to covariance risk, \cr
\code{riskConstributions} \tab computes covariance risk contributions, \cr
\code{riskBudgets} \tab computes covariance risk budgets. }
}
\usage{
covarRisk(data, weights = NULL, FUN = "cov", ...)
mcr(data, weights = NULL, FUN = "cov", ...)
mcrBeta(data, weights = NULL, FUN = "cov", ...)
riskContributions(data, weights = NULL, FUN = "cov", ...)
riskBudgets(data, weights = NULL, FUN = "cov", ...)
}
\arguments{
\item{data}{
a multivariate 'timeSeries' object.
}
\item{weights}{
usually a numeric vector which has the length of the number of
assets. The vector measures the weights of the individual assets.
By default \code{NULL}, then an equally weighted set of assets
is assumed.
}
\item{FUN}{
the name of the covariance estimator function which returns the
covariance matrix. By default, the sample covariance estimator.
}
\item{\dots}{
optional arguments to be passet to the function \code{FUN}.
}
}
\value{
\code{covarRisk}
\cr
returns the covariance risk (standard deviation), a numeric value.
\cr
\code{mcr}
\cr
returns the marginal contributions to covariance risk for a
portfolio of assets, a numeric value of the same length as the
number of assets.
\cr
\code{mcrBeta}
\cr
returns the marginal contributions to beta for a
portfolio of assets, a numeric value of the same length as the
number of assets.
\cr
\code{riskContributions}
\cr
returns the risk contributions to covariance risk for a
portfolio of assets, a numeric value of the same length as the
number of assets.
\cr
\code{riskBudgets}
\cr
returns the risk budgets to covariance risk for a
portfolio of assets, a numeric value of the same length as the
number of assets.
}
\references{
Goldberg L., Hayes M.Y., Menchero J., Mitra. I, (2009);
\emph{Extreme Risk Management},
Working Paper, MSCI Barra.
Scherer B., (2004);
\emph{Portfolio Construction and Risk Budgeting},
Risk Books, Haymarket House.
%Wuertz, D., Chalabi, Y., Chen W., Ellis A. (2009);
% \emph{Portfolio Optimization with R/Rmetrics},
% Rmetrics eBook, Rmetrics Association and Finance Online, Zurich.
}
\examples{
## covarRisk -
# Covariance Risk
# Sigma = sqrt(W' COV W)
set.seed(4711)
data = assetsSim(100, 6)
covarRisk(data)
## mcr -
# Marginal contribution to Covariance Risk
# MCR = d Sigma / d W_i
mcr(data)
## mcrBeta -
# Marginal Beta
# beta = MCR / Sigma
mcrBeta(data)
## riskContributions -
# Marginal Risk Contributions
# RC = Sum_i ( W_i MCR )
riskContributions(data)
sum(riskContributions(data)) - covarRisk(data)
## riskBudgets -
# Marginal Risk Budgets
# RB = RC / Sigma
riskBudgets(data)
sum(riskBudgets(data))
}
\keyword{math}