[Vinecopula-commits] r77 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Di Jan 20 19:18:31 CET 2015
Author: etobi
Date: 2015-01-20 19:18:31 +0100 (Tue, 20 Jan 2015)
New Revision: 77
Added:
pkg/R/as.copuladata.R
pkg/R/pairs.R
pkg/man/as.copuladata.Rd
pkg/man/pairs.copuladata.Rd
Modified:
pkg/NAMESPACE
pkg/R/BiCopMetaContour.r
Log:
* BiCopMetaContour.r: comments, aesthetics
* new functions: as.copuladata (coerce to class copuladata) and pairs.copuladata (pairs plots for objects of class copuladata)
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2015-01-20 11:27:38 UTC (rev 76)
+++ pkg/NAMESPACE 2015-01-20 18:18:31 UTC (rev 77)
@@ -61,6 +61,9 @@
export(RVinePar2Beta)
export(BetaMatrix)
+export(as.copuladata)
+export(pairs.copuladata)
+
# compatibility to copula
export(fitCopula)
export(dduCopula,ddvCopula)
@@ -90,5 +93,9 @@
S3method(print, RVineMatrix)
+S3method(as.copuladata, data.frame)
+S3method(as.copuladata, matrix)
+S3method(as.copuladata, list)
+S3method(pairs, copuladata)
useDynLib("VineCopula")
\ No newline at end of file
Modified: pkg/R/BiCopMetaContour.r
===================================================================
--- pkg/R/BiCopMetaContour.r 2015-01-20 11:27:38 UTC (rev 76)
+++ pkg/R/BiCopMetaContour.r 2015-01-20 18:18:31 UTC (rev 77)
@@ -433,7 +433,7 @@
pdf=con*tem*exp(-tem+tem1+tem2)/sm
return(pdf)
}
- else if(copula==42) # 2-parametric asymmetric copula (thanks to Benedikt Gräler)
+ else if(copula==42) # 2-parametric asymmetric copula (thanks to Benedikt Gr?ler)
{
a=param[1]
b=param[2]
@@ -567,23 +567,25 @@
BiCopMetaContour <- function(u1=NULL, u2=NULL, bw=1, size=100, levels=c(0.01,0.05,0.1,0.15,0.2),
family="emp", par=0, par2=0, PLOT=TRUE, margins="norm", margins.par=0, xylim=NA, ...)
{
+
+ ## sanity checks
if((is.null(u1)==TRUE || is.null(u2)==TRUE) && family=="emp") stop("'u1' and/or 'u2' not set or of length zero.")
- if(is.null(u1)==FALSE && (any(u1>1) || any(u1<0))) stop("Data has be in the interval [0,1].")
- if(is.null(u2)==FALSE && (any(u2>1) || any(u2<0))) stop("Data has be in the interval [0,1].")
+ if(is.null(u1)==FALSE && (any(u1>1) || any(u1<0))) stop("Data has to be in the interval [0,1].")
+ if(is.null(u2)==FALSE && (any(u2>1) || any(u2<0))) stop("Data has to be in the interval [0,1].")
#if(length(u1)!=length(u2)) stop("Lengths of 'u1' and 'u2' do not match.")
if(!(family %in% c(0,1,2,3,4,5,6,7,8,9,10,13,14,16,17,18,19,20,23,24,26,27,28,29,30,33,34,36,37,38,39,40,41,42,51,52,61,62,71,72,104,114,124,134,204,214,224,234, "emp"))) stop("Copula family not implemented.")
if(c(2,7,8,9,10,17,18,19,20,27,28,29,30,37,38,39,40,42,52,62,72,104,114,124,134,204,214,224,234) %in% family && par2==0) stop("For t-, BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.")
if(c(1,3,4,5,6,11,13,14,16,23,24,26,33,34,36,41,51,61,71) %in% family && length(par)<1) stop("'par' not set.")
- # size sollte nicht zu gross sein
+ ## Limits for size parameter
if(size>1000) stop("Size parameter should not be greater than 1000. Otherwise computational time and memory space are too large.")
if(size<50) stop("Size parameter should not be smaller than 50.")
- # bw richtig
+ ## limits bandwidth parameter
if(bw<1) stop("The bandwidth parameter 'bw' should be greater or equal to 1.")
if(bw>5) stop("The bandwidth parameter 'bw' should not be greater than 5.")
- # Parameterbereiche abfragen
+ ## sanity checks for pair-copula parameters
if((family==1 || family==2) && abs(par[1])>=1) stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).")
if(family==2 && par2<=2) stop("The degrees of freedom parameter of the t-copula has to be larger than 2.")
if((family==3 || family==13) && par<=0) stop("The parameter of the Clayton copula has to be positive.")
@@ -635,7 +637,7 @@
if(is.null(u1) && is.null(u2) && family!="emp")
{
- # theoretischer contourplot
+ # margins for theoretical contour plot
u1=runif(1000)
u2=runif(1000)
}
@@ -646,68 +648,67 @@
{
x1 <- qnorm(p=u1)
x2 <- qnorm(p=u2)
- if(is.na(xylim)) xylim=c(-3,3)
+ if(any(is.na(xylim))) xylim=c(-3,3)
}
else if(margins=="t")
{
x1 <- qt(p=u1, df=margins.par)
x2 <- qt(p=u2, df=margins.par)
- if(is.na(xylim)) xylim=c(-3,3)
+ if(any(is.na(xylim))) xylim=c(-3,3)
}
else if(margins=="exp")
{
x1=qexp(p=u1, rate=margins.par)
x2=qexp(p=u2, rate=margins.par)
- if(is.na(xylim)) xylim=c(0,5)
+ if(any(is.na(xylim))) xylim=c(0,5)
}
else if(margins=="gamma")
{
x1=qgamma(p=u1, shape=margins.par[1], scale=margins.par[2])
x2=qgamma(p=u2, shape=margins.par[1], scale=margins.par[2])
- if(is.na(xylim)) xylim=c(0,5)
+ if(any(is.na(xylim))) xylim=c(0,5)
}
else if(margins=="unif")
{
x1=u1
x2=u2
- if(is.na(xylim)) xylim=c(0,1)
+ if(any(is.na(xylim))) xylim=c(0,1)
}
x <- y <- seq(from=xylim[1], to=xylim[2], length.out=size)
- if(family!="emp")
- {
- if(family %in% c(2,7,8,9,10,17,18,19,20,27,28,29,30,37,38,39,40,42,52,62,72,104,114,124,134,204,214,224,234))
- z <- matrix(data=meta.dens(x1=rep(x=x, each=size), x2=rep(x=y, times=size), param=c(par,par2), copula=family,
- margins=margins, margins.par=margins.par), nrow=size, byrow=TRUE)
- else
- z <- matrix(data=meta.dens(x1=rep(x=x, each=size), x2=rep(x=y, times=size), param=par, copula=family,
- margins=margins, margins.par=margins.par), nrow=size, byrow=TRUE)
- }
- else #empirical
- {
- bw1 <- bw * bandwidth.nrd(x1)
- bw2 <- bw * bandwidth.nrd(x2)
-
- kd.est <- kde2d(x=x1, y=x2, h=c(bw1, bw2), n=size)
-
- x <- kd.est$x
- y <- kd.est$y
- z <- kd.est$z
- }
+ if(family!="emp") {
+ ## theoretical contours
+ if(family %in% c(2,7,8,9,10,17,18,19,20,27,28,29,30,37,38,39,40,42,52,62,72,104,114,124,134,204,214,224,234))
+ z <- matrix(data=meta.dens(x1=rep(x=x, each=size), x2=rep(x=y, times=size), param=c(par,par2), copula=family,
+ margins=margins, margins.par=margins.par), nrow=size, byrow=TRUE)
+ else
+ z <- matrix(data=meta.dens(x1=rep(x=x, each=size), x2=rep(x=y, times=size), param=par, copula=family,
+ margins=margins, margins.par=margins.par), nrow=size, byrow=TRUE)
+ } else {
+ ## empirical contours
+ bw1 <- bw * bandwidth.nrd(x1)
+ bw2 <- bw * bandwidth.nrd(x2)
+
+ ## 2-dimensional kernel density estimation
+ kd.est <- kde2d(x=x1, y=x2, h=c(bw1, bw2), n=size)
+
+ x <- kd.est$x
+ y <- kd.est$y
+ z <- kd.est$z
+ }
- if(PLOT)
- {
- contour(x=x, y=y, z=z, levels=levels,ylim=xylim,xlim=xylim, ...)
- }
- else
- {
- out=list()
- out$x=x
- out$y=y
- out$z=z
-
- return(out)
- }
+ if(PLOT){
+ ## plot contour lines
+ contour(x=x, y=y, z=z, levels=levels,ylim=xylim,xlim=xylim, ...)
+ } else {
+ ## output bivarate meta density z(x,y)
+ out=list()
+ out$x=x
+ out$y=y
+ out$z=z
+
+ return(out)
+ }
}
Added: pkg/R/as.copuladata.R
===================================================================
--- pkg/R/as.copuladata.R (rev 0)
+++ pkg/R/as.copuladata.R 2015-01-20 18:18:31 UTC (rev 77)
@@ -0,0 +1,32 @@
+as.copuladata <- function(data){
+ ## generic function for coercion to 'copuladata'
+ UseMethod("as.copuladata", data)
+}
+
+as.copuladata.data.frame <- function(data){
+ ## coercion of 'data.frame' to 'copuladata'
+ if(any(sapply(data, mode)!="numeric")) stop("Data has to be numeric.")
+ if(any(data>1 || data<0)) stop("Data has to be in the interval [0,1].")
+ class(data) <- append("copuladata", class(data))
+ return(data)
+}
+
+as.copuladata.matrix <- function(data){
+ ## coercion of 'matrix' to 'copuladata'
+ if(mode(data)!="numeric") stop("Data has to be numeric.")
+ if(any(data>1 || data<0)) stop("Data has to be in the interval [0,1].")
+ data <- data.frame(data)
+ class(data) <- append("copuladata", class(data))
+ return(data)
+}
+
+as.copuladata.list <- function(data){
+ ## coercion of 'list' to 'copuladata'
+ if(any(sapply(data, mode)!="numeric")) stop("Data has to be numeric.")
+ if(any(sapply(data, length)!=length(data[[1]]))) stop("All list entries have to be of same length.")
+ data <- data.frame(data)
+ if(any(data>1 || data<0)) stop("Data has to be in the interval [0,1].")
+ class(data) <- append("copuladata", class(data))
+ return(data)
+}
+
Added: pkg/R/pairs.R
===================================================================
--- pkg/R/pairs.R (rev 0)
+++ pkg/R/pairs.R 2015-01-20 18:18:31 UTC (rev 77)
@@ -0,0 +1,60 @@
+pairs.copuladata <- function(x, labels = names(x), ...,
+ label.pos = 0.85, cex.labels = 1, gap = 0, axes = FALSE,
+ pch = ".", col = "grey", cex.points = 1,
+ method.cor = "kendall", col.cor = "red", digits.cor = 2, cex.cor = 1,
+ bw = 2, size = 100, levels = seq(0.01, 0.2, length.out = 30),
+ margins = "norm", margins.par = 0, xylim = NA,
+ col.contour = terrain.colors(length(levels)),
+ col.hist = "grey"){
+ ## pairs plot for 'copuladata'
+
+ ## labeling of axes
+ if(axes){
+ xaxt <- "s"
+ yaxt <- "s"
+ } else {
+ xaxt <- "n"
+ yaxt <- "n"
+ }
+
+ ## lower panel: empirical contour plot
+ lower.panel.copuladata <- function(x, y, lower.bw = bw, lower.size = size,
+ lower.levels = levels, lower.margins = margins,
+ lower.margins.par = margins.par, lower.xylim = xylim,
+ col = col.contour, ...){
+ op <- par(usr = c(-3, 3, -3, 3), new = TRUE)
+ BiCopMetaContour(x, y, bw = lower.bw, size = lower.size,
+ levels = lower.levels, axes = FALSE,
+ margins = lower.margins, margins.par = lower.margins.par,
+ xylim = lower.xylim, col = col, drawlabels = FALSE, ...)
+ on.exit(par(op))
+ }
+
+ ## upper panel: scatter plot (copula data) and correlation
+ upper.panel.copuladata <- function(x, y, method=method.cor, upper.pch = pch, upper.col = col,
+ upper.col.text = col.cor, upper.cex = cex.points,
+ upper.digits = digits.cor, upper.cex.cor = cex.cor, ...){
+ op <- par(usr = c(0, 1, 0, 1), new = TRUE)
+ plot(x, y, pch = upper.pch, cex = upper.cex, col = upper.col, axes=FALSE, ...)
+ r <- cor(x, y, method = method)
+ txt <- format(r, digits = upper.digits, nsmall = upper.digits)[1]
+ text(0.5, 0.5, txt, cex = upper.cex.cor + abs(r)*3, col = upper.col.text)
+ on.exit(par(op))
+ }
+
+ ## diagonal panel: histograms (copula data)
+ diag.panel.copuladata <- function(x, diag.col=col.hist, ...){
+ op <- par(usr = c(0, 1, 0, 1.6), new = TRUE)
+ hist(x, freq = FALSE, add = TRUE, col = diag.col, border = "black", main = "")
+ abline(h = 1, col = "black", lty=3)
+ on.exit(par(op))
+ }
+
+ ## pairs plot (with panel functions as defined above)
+ pairs.default(x, labels = labels, ...,
+ lower.panel = lower.panel.copuladata,
+ upper.panel = upper.panel.copuladata,
+ diag.panel = diag.panel.copuladata,
+ label.pos = label.pos, cex.labels = cex.labels,
+ gap = gap, xaxt=xaxt, yaxt=yaxt)
+}
\ No newline at end of file
Added: pkg/man/as.copuladata.Rd
===================================================================
--- pkg/man/as.copuladata.Rd (rev 0)
+++ pkg/man/as.copuladata.Rd 2015-01-20 18:18:31 UTC (rev 77)
@@ -0,0 +1,39 @@
+\name{as.copuladata}
+\alias{as.copuladata}
+\alias{as.copuladata.data.frame}
+\alias{as.copuladata.matrix}
+\alias{as.copuladata.list}
+
+\title{
+Copula Data Objects
+}
+
+\description{
+The function \code{as.copuladata} coerces an object (\code{data.frame}, \code{matrix}, \code{list}) to a \code{copuladata} object.
+}
+
+\usage{
+as.copuladata(data)
+}
+
+\arguments{
+ \item{data}{Either a \code{data.frame}, a \code{matrix} or a \code{list} containing copula data (i.e. data with uniform margins on [0,1]). The \code{list} elements have to be vectors of identical length.}
+}
+
+\author{Tobias Erhardt}
+
+\seealso{\code{\link{pobs}}, \code{\link{pairs.copuladata}}}
+
+\examples{
+ data(daxreturns)
+
+ data <- as(daxreturns, "matrix")
+ class(as.copuladata(data))
+
+ data <- as(daxreturns, "data.frame")
+ class(as.copuladata(data))
+
+ data <- as(daxreturns, "list")
+ names(data) <- names(daxreturns)
+ class(as.copuladata(data))
+}
Added: pkg/man/pairs.copuladata.Rd
===================================================================
--- pkg/man/pairs.copuladata.Rd (rev 0)
+++ pkg/man/pairs.copuladata.Rd 2015-01-20 18:18:31 UTC (rev 77)
@@ -0,0 +1,82 @@
+\name{pairs.copuladata}
+\alias{pairs.copuladata}
+
+\title{Pairs Plot of Copula Data}
+
+\description{
+ This function provides pair plots for copula data. It plots bivariate contour plots on the lower panel, scatter plots and correlations on the upper panel and histograms on the diagonal panel.
+}
+
+\usage{
+\method{pairs}{copuladata}(x, labels = names(x), ...,
+ label.pos = 0.85, cex.labels = 1, gap = 0, axes = FALSE,
+ pch = ".", col = "grey", cex.points = 1,
+ method.cor = "kendall", col.cor = "red", digits.cor = 2, cex.cor = 1,
+ bw = 2, size = 100, levels = seq(0.01, 0.2, length.out = 30),
+ margins = "norm", margins.par = 0, xylim = NA,
+ col.contour = terrain.colors(length(levels)),
+ col.hist = "grey")
+}
+
+\arguments{
+ \item{x}{\code{copuladata} object.}
+ \item{labels}{variable names/labels.}
+ \item{\dots}{other graphical parameters (see \code{\link[graphics]{par}}).}
+ \item{label.pos}{y position of labels in the diagonal panel; default: \code{label.pos = 0.85}.}
+ \item{cex.labels}{magnification to be used for the labels of the diagonal panel; default: \code{cex.labels = 1}.}
+ \item{gap}{distance between subplots, in margin lines; default: \code{gap = 0}.}
+ \item{axes}{a logical value indicating whether both axes should be drawn on the plot; default: \code{axes = FALSE}.}
+ \item{pch}{plotting characters/symbols to be used for the points of the scatter plots; default: \code{pch = "."}.}
+ \item{col}{colour to be used for the points of the scatter plots; default: \code{col = "grey"}.}
+ \item{cex.points}{magnification to be used for the points of the scatter plots; default: \code{cex.points = 1}.}
+ \item{method.cor}{a character string indicating which correlation coefficients are computed. One of \code{pearson}, \code{kendall} (default), or \code{spearman}}
+ \item{col.cor}{colour to be used for the correlation coefficients in the scatter plots; default: \code{col.cor = "red"}.}
+ \item{digits.cor}{digits to be used for the correlation coefficients in the scatter plots; default: \code{digits.cor = 2}.}
+ \item{cex.cor}{magnification to be used for the correlation coefficients in the scatter plots; default: \code{cex.cor = 1}.}
+ \item{bw}{bandwidth to be used for the contour plots (smoothing factor; default: \code{bw = 1}).}
+ \item{size}{number of grid points to be used for the contour plots; default: \code{size = 100}.}
+ \item{levels}{vector of contour levels to be used for the contour plots.
+ For Gaussian, Student t or exponential margins the default value (\code{levels = seq(0.01, 0.2, length.out = 30)}) typically is a good choice.
+ For uniform margins we recommend\cr
+ \code{levels = seq(0.1, 1.5, length.out = 30)}\cr
+ and for Gamma margins\cr
+ \code{levels = seq(0.005, 0.09, length.out = 30)}.}
+ \item{margins}{character; margins for the contour plots. Possible margins are:\cr
+ \code{"norm"} = standard normal margins (default)\cr
+ \code{"t"} = Student t margins with degrees of freedom as specified by \code{margins.par}\cr
+ \code{"gamma"} = Gamma margins with shape and scale as specified by \code{margins.par}\cr
+ \code{"exp"} = Exponential margins with rate as specified by \code{margins.par}\cr
+ \code{"unif"} = uniform margins}
+ \item{margins.par}{parameter(s) of the distribution of the margins (of the contour plots) if necessary (default: \code{margins.par = 0}), i.e.,
+ \itemize{
+ \item a positive real number for the degrees of freedom of Student t margins (see \code{\link{dt}}),
+ \item a 2-dimensional vector of positive real numbers for the shape and scale parameters of Gamma margins (see \code{\link{dgamma}}),
+ \item a positive real number for the rate parameter of exponential margins (see \code{\link{dexp}}).
+ }}
+ \item{xylim}{2-dimensional vector of the x- and y-limits to be used for the contour plots.
+ By default (\code{xylim = NA}) standard limits for the selected margins are used.}
+ \item{col.contour}{colour to be used for the contour plots; default: \code{col.contour = terrain.colors(length(levels))}.}
+ \item{col.hist}{colour to be used for histograms of the diagonal panel; default: \code{col.hist = "grey"}.}
+}
+
+\author{Tobias Erhardt}
+
+\seealso{\code{\link[graphics]{pairs}}, \code{\link{as.copuladata}}, \code{\link{BiCopMetaContour}}}
+
+\examples{
+ data(daxreturns)
+
+ data <- as.copuladata(daxreturns)
+
+ ## pairs plot with default settings
+ pairs(data[1:5])
+
+ ## pairs plot with custom settings
+ nlevels <- 20
+ pairs(data[1:5], cex.labels = 2, gap = 1,
+ pch = 20, col = "black", cex.points = 0.5,
+ method.cor = "spearman", col.cor = "green", digits.cor = 3, cex.cor = 1.5,
+ bw = 1.5, levels = seq(0.01, 0.2, length.out = nlevels),
+ margins = "t", margins.par = 5, xylim = c(-1,2),
+ col.contour = heat.colors(nlevels), col.hist = "white")
+}
Mehr Informationen über die Mailingliste Vinecopula-commits