From noreply at r-forge.r-project.org  Thu Dec  5 22:39:46 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu,  5 Dec 2013 22:39:46 +0100 (CET)
Subject: [spcopula-commits] r118 - in pkg: . R man
Message-ID: <20131205213946.4FCB0181085@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-12-05 22:39:45 +0100 (Thu, 05 Dec 2013)
New Revision: 118

Added:
   pkg/R/tailDependenceFunctions.R
   pkg/R/tawn3pCopula.R
   pkg/man/tailDepFun.Rd
   pkg/man/tawn3pCopula-class.Rd
   pkg/man/tawn3pCopula.Rd
Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/R/linkingVineCopula.R
   pkg/R/spVineCopula.R
   pkg/R/vineCopulas.R
Log:
- added 3 parameter Tawn Copula
- added parametric and empirical tail dependence functions

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2013-11-27 15:21:31 UTC (rev 117)
+++ pkg/DESCRIPTION	2013-12-05 21:39:45 UTC (rev 118)
@@ -39,4 +39,6 @@
   returnPeriods.R
   spatialGaussianCopula.R
   tawnCopula.R
+  tawn3pCopula.R
+  tailDependenceFunctions.R
   zzz.R

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2013-11-27 15:21:31 UTC (rev 117)
+++ pkg/NAMESPACE	2013-12-05 21:39:45 UTC (rev 118)
@@ -13,6 +13,7 @@
 export(surGumbelCopula, r90GumbelCopula, r270GumbelCopula)
 export(tawnT1Copula, surTawnT1Copula, r90TawnT1Copula, r270TawnT1Copula)
 export(tawnT2Copula, surTawnT2Copula, r90TawnT2Copula, r270TawnT2Copula)
+export(tawn3pCopula)
 export(spCopula, stCopula)
 export(vineCopula, spVineCopula, stVineCopula)
 export(neighbourhood, stNeighbourhood)
@@ -38,6 +39,8 @@
 
 # fitting
 export(fitCorFun, loglikByCopulasLags, fitSpCopula, composeSpCopula)
+export(tailDepFun, lowerTailDepFun, upperTailDepFun)
+export(empTailDepFun, lowerEmpTailDepFun, upperEmpTailDepFun)
 
 # MRP functions
 export(genEmpKenFun, genInvKenFun)

Modified: pkg/R/linkingVineCopula.R
===================================================================
--- pkg/R/linkingVineCopula.R	2013-11-27 15:21:31 UTC (rev 117)
+++ pkg/R/linkingVineCopula.R	2013-12-05 21:39:45 UTC (rev 118)
@@ -172,12 +172,7 @@
   return(matrix(tmp, ncol = 2))
 }
 
-## fit a Copula through fitCopula with BiCopEst
-## -> BB8Copula (collate issues)
 
-
-
-
 # ## transform a fit from VineCopula to a list of copula objects
 # castVineCopula <- function(cdvEst) {
 #   copulas <- NULL

Modified: pkg/R/spVineCopula.R
===================================================================
--- pkg/R/spVineCopula.R	2013-11-27 15:21:31 UTC (rev 117)
+++ pkg/R/spVineCopula.R	2013-12-05 21:39:45 UTC (rev 118)
@@ -132,7 +132,7 @@
   }
   
   return(new("fitCopula", estimate = spVineCop at parameters, var.est = matrix(NA), 
-             method = method, 
+             method = sapply(method,paste,collapse=", "), 
              loglik = sum(l0)+loglik,
              fitting.stats=list(convergence = as.integer(NA)),
              nsample = nrow(data at data), copula=spVineCop))

Added: pkg/R/tailDependenceFunctions.R
===================================================================
--- pkg/R/tailDependenceFunctions.R	                        (rev 0)
+++ pkg/R/tailDependenceFunctions.R	2013-12-05 21:39:45 UTC (rev 118)
@@ -0,0 +1,39 @@
+# adopted from http://www.r-bloggers.com/copulas-and-tail-dependence-part-1/, 04.11.2013
+
+lowerEmpTailDepFun <- function(u) {
+  empFun <- function(x) sum((u[,1]<=x)&(u[,2]<=x))/sum(u[,1]<=x)
+  function(x) sapply(x,empFun)
+}
+
+upperEmpTailDepFun <- function(u) {
+  empFun <- function(x) sum((u[,1]>=x)&(u[,2]>=x))/sum(u[,1]>=x)
+  function(x) sapply(x,empFun)
+}
+
+empTailDepFun <- function(u) {
+  function(z) {
+    res <- z
+    res[z>0.5] <- upperEmpTailDepFun(u)(z[z>0.5])
+    res[z<=0.5] <- lowerEmpTailDepFun(u)(z[z<=0.5])
+    return(res)
+  }
+}
+
+##
+
+lowerTailDepFun <- function(copula) {
+  function(z) pCopula(cbind(z,z),copula)/z
+}
+
+upperTailDepFun <- function(copula) {
+  function(z) (1-2*z+pCopula(cbind(z,z),copula))/(1-z)
+}
+
+tailDepFun <- function(copula) {
+  function(z) {
+    res <- z
+    res[z>0.5] <- upperTailDepFun(copula)(z[z>0.5])
+    res[z<=0.5] <- lowerTailDepFun(copula)(z[z<=0.5])
+    return(res)
+  }
+}
\ No newline at end of file

Added: pkg/R/tawn3pCopula.R
===================================================================
--- pkg/R/tawn3pCopula.R	                        (rev 0)
+++ pkg/R/tawn3pCopula.R	2013-12-05 21:39:45 UTC (rev 118)
@@ -0,0 +1,128 @@
+#######################################
+## tawn copula with all 3 parameters ##
+#######################################
+
+setClass("tawn3pCopula", representation(exprdist = "expression"),
+         contains = "evCopula")
+
+Atawn3p <- function(t, param = c(0.9302082, 1, 8.355008)) {
+  alpha <- param[1]
+  beta  <- param[2]
+  theta <- param[3]
+  (1-beta)*(t) + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta)
+
+}
+
+ATawn <- function(copula, w) {
+  Atawn3p(w,copula at parameters)
+}
+
+setMethod("A",signature("tawn3pCopula"),ATawn)
+
+dAduTawn <- function(copula, w) {
+  alpha <- copula at parameters[1]
+  beta  <- copula at parameters[2]
+  theta <- copula at parameters[3]
+
+  # 1st derivative
+  p1 <- (alpha*(alpha*(-(w-1)))^(theta-1)-beta*(beta*w)^(theta-1)) 
+  p2 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-1)
+  
+  # 2nd derivative
+  p3 <- (alpha*(-(w-1)))^(theta-2)
+  p4 <- (beta*w)^(theta-2)
+  p5 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-2)
+  
+  data.frame(der1=alpha-beta-p1*p2,
+             der2=alpha^2*beta^2*(theta-1)*p3*p4*p5)
+}
+
+setMethod("dAdu",signature("tawn3pCopula"),dAduTawn)
+
+tawn3pCopula <- function (param = c(0.5, 0.5, 2)) {
+  # A(t) = (1-beta)*t + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta)
+  # C(u1,u2) = exp(log(u1*u2) * A(log(u2)/log(u1*u2)))
+  #          = u1*u2 + exp(A(log(u2)/log(u1*u2)))
+
+  cdf <- expression(exp(log(u1*u2)*((1-beta)*(log(u2)/log(u1*u2)) +
+                                    (1-alpha)*(1-log(u2)/log(u1*u2)) +
+                                    ((alpha*(1-log(u2)/log(u1*u2)))^theta+(beta*log(u2)/log(u1*u2))^theta)^(1/theta))))
+  dCdU1 <- D(cdf, "u1")
+  pdf <- D(dCdU1, "u2")
+  
+  new("tawn3pCopula", dimension = 2L, exprdist = c(cdf = cdf, pdf = pdf),
+      parameters = param, param.names = c("alpha", "beta", "theta"), 
+      param.lowbnd = c(0,0,1), param.upbnd = c(1,1,Inf), 
+      fullname = "Tawn copula family with three parameters; Extreme value copula")
+}
+
+dtawn3pCopula <- function(u, copula, log=FALSE, ...) {
+  dim <- copula at dimension
+  for (i in 1:dim) {
+    assign(paste("u", i, sep=""), u[,i])
+  }
+  alpha <- copula at parameters[1]
+  beta  <- copula at parameters[2]
+  theta <- copula at parameters[3]
+  
+  val <- c(eval(copula at exprdist$pdf))
+  ## improve log-case
+  if(log) 
+    log(val) 
+  else 
+    val
+}
+
+setMethod("dCopula", signature("matrix", "tawn3pCopula"), dtawn3pCopula)
+setMethod("dCopula", signature("numeric", "tawn3pCopula"),dtawn3pCopula)
+
+ptawn3pCopula <- function(u, copula, ...) {
+  dim <- copula at dimension
+  for (i in 1:dim) {
+    assign(paste("u", i, sep=""), u[,i])
+  }
+  alpha <- copula at parameters[1]
+  beta <-  copula at parameters[2]
+  theta <-copula at parameters[3]
+  
+  val <- c(eval(copula at exprdist$cdf))
+}
+
+setMethod("pCopula", signature("matrix", "tawn3pCopula"),  ptawn3pCopula)
+setMethod("pCopula", signature("numeric", "tawn3pCopula"), ptawn3pCopula)
+
+setMethod("rCopula", signature("numeric", "tawn3pCopula"),
+          function(n, copula, ...) {
+            copula:::revCopula(n, copula, ...)[,2:1]
+          })
+
+fitTawn3pCop <- function(copula, data, method = c("mpl", "ml", "itau", "irho"), 
+                         start = NULL, lower = NULL, upper = NULL, optim.method = "BFGS", 
+                         optim.control = list(maxit = 1000), estimate.variance = FALSE, 
+                         hideWarnings = TRUE) {
+  if(is.null(start))
+    start <- copula at parameters
+  
+  # copied from copula::fitCopula
+  if (!is.matrix(data)) {
+    warning("coercing 'data' to a matrix.")
+    data <- as.matrix(data)
+    stopifnot(is.matrix(data))
+  }
+  
+  cat(match.arg(method))
+  
+  res <- switch(match.arg(method), 
+               ml = copula:::fitCopula.ml(copula, data, start, lower, upper, 
+                                          optim.method, optim.control, 
+                                          estimate.variance, hideWarnings),
+               mpl = copula:::fitCopula.mpl(copula, data, start, lower, upper, 
+                                            optim.method, optim.control, 
+                                            estimate.variance, hideWarnings),
+               itau = copula:::fitCopula.itau(copula, data, estimate.variance),
+               irho = copula:::fitCopula.irho(copula, data, estimate.variance))
+  cat(match.arg(method))
+  return(res)
+}
+            
+setMethod("fitCopula", signature("tawn3pCopula"), fitTawn3pCop)
\ No newline at end of file

Modified: pkg/R/vineCopulas.R
===================================================================
--- pkg/R/vineCopulas.R	2013-11-27 15:21:31 UTC (rev 117)
+++ pkg/R/vineCopulas.R	2013-12-05 21:39:45 UTC (rev 118)
@@ -43,9 +43,9 @@
 
 ## density ##
 
-dRVine <- function(u, copula, log=F) {
+dRVine <- function(u, copula, log=FALSE) {
   RVM <- copula at RVM
-  vineLoglik <- RVineLogLik(u, RVM, separate=T)$loglik
+  vineLoglik <- RVineLogLik(u, RVM, separate=TRUE)$loglik
   if(log)
     return(vineLoglik)
   else
@@ -89,14 +89,18 @@
 # fitting using RVine
 fitVineCop <- function(copula, data, method) {
   stopifnot(copula at dimension==ncol(data))
+  if(!is.null(method[["familyset"]]))
+    familyset <- method[["familyset"]]
+  else
+    familyset <- NA
   if("StructureSelect" %in% method)
-    vineCop <- vineCopula(RVineStructureSelect(data, indeptest="indeptest" %in% method))
+    vineCop <- vineCopula(RVineStructureSelect(data, familyset, indeptest="indeptest" %in% method))
   else
-    vineCop <- vineCopula(RVineCopSelect(data, Matrix=copula at RVM$Matrix, 
+    vineCop <- vineCopula(RVineCopSelect(data, familyset, copula at RVM$Matrix, 
                                          indeptest="indeptest" %in% method))
   
   return(new("fitCopula", estimate = vineCop at parameters, var.est = matrix(NA), 
-             method = method, 
+             method = sapply(method,paste,collapse=", "), 
              loglik = RVineLogLik(data, vineCop at RVM)$loglik,
              fitting.stats=list(convergence = as.integer(NA)),
              nsample = nrow(data), copula=vineCop))

Added: pkg/man/tailDepFun.Rd
===================================================================
--- pkg/man/tailDepFun.Rd	                        (rev 0)
+++ pkg/man/tailDepFun.Rd	2013-12-05 21:39:45 UTC (rev 118)
@@ -0,0 +1,70 @@
+\name{tailDepFun}
+\alias{tailDepFun}
+\alias{lowerTailDepFun}
+\alias{upperTailDepFun}
+
+\alias{empTailDepFun}
+\alias{lowerEmpTailDepFun}
+\alias{upperEmpTailDepFun}
+
+\title{
+Tail dependence functions
+}
+\description{
+Functions returning a (empirical) tail dependence function for a copula (sample). The tail dependence functions can be upper, lower or joint, where values below 0.5 are calculated from the lower tail dependence function and values larger 0.5 for the upper tail dependence function.
+}
+\usage{
+tailDepFun(copula)
+lowerTailDepFun(copula)
+upperTailDepFun(copula)
+
+empTailDepFun(u)
+lowerEmpTailDepFun(u)
+upperEmpTailDepFun(u)
+}
+
+\arguments{
+  \item{copula}{
+an object of class \code{\linkS4class{copula}}
+}
+  \item{u}{
+a bivariate sample on (0,1)
+}
+}
+
+\value{
+A function taking arguments from the unit interval (0,1) and returning the corresponding tail index.
+}
+\references{
+Inspired by: \url{http://www.r-bloggers.com/copulas-and-tail-dependence-part-1/}
+}
+\author{
+Benedikt Graeler
+}
+
+\examples{
+data(simulatedTriples)
+X <- rankTransform(triples[,c(1,3)])
+  
+tdfEmp <- empTailDepFun(X)
+plot(tdfEmp,ylim=c(0,1),
+     ylab="tail dependence index")  
+abline(v=0.5, col="grey")
+
+smplTau <- cor(X,method="kendall")[1,2]
+
+# Gauss
+tdfGauss <- tailDepFun(normalCopula(sin(smplTau*pi/2)))
+curve(tdfGauss,add=TRUE,col="blue")
+
+# survival Gumbel
+tdfGumbel <- tailDepFun(surGumbelCopula(1/(1-smplTau)))
+curve(tdfGumbel,add=TRUE,col="darkgreen")
+
+# survival BB6 copula
+tdfBB6 <- tailDepFun(surBB6Copula(c(4.65,2.28)))
+curve(tdfBB6,add=TRUE,col="red")
+
+legend("bottomleft",c("empircal","Gauss","surv. Gumbel","surv. BB6"),
+       col=c("black","blue","darkgreen","red"),lty=1)
+}
\ No newline at end of file

Added: pkg/man/tawn3pCopula-class.Rd
===================================================================
--- pkg/man/tawn3pCopula-class.Rd	                        (rev 0)
+++ pkg/man/tawn3pCopula-class.Rd	2013-12-05 21:39:45 UTC (rev 118)
@@ -0,0 +1,60 @@
+\name{tawn3pCopula-class}
+\Rdversion{1.1}
+\docType{class}
+\alias{tawn3pCopula-class}
+\alias{A,tawn3pCopula-method}
+\alias{dAdu,tawn3pCopula-method}
+\alias{dCopula,matrix,tawn3pCopula-method}
+\alias{dCopula,numeric,tawn3pCopula-method}
+\alias{fitCopula,tawn3pCopula-method}
+\alias{pCopula,matrix,tawn3pCopula-method}
+\alias{pCopula,numeric,tawn3pCopula-method}
+\alias{rCopula,numeric,tawn3pCopula-method}
+
+\title{Class \code{"tawn3pCopula"}}
+\description{
+S4-Class representing the three parameter Tawn Copula family. 
+}
+\section{Objects from the Class}{
+Objects can be created by calls of the form \code{new("tawn3pCopula", ...)} or more likely with the help of the constructor \code{\link{tawn3pCopula}}.
+}
+\section{Slots}{
+  \describe{
+    \item{\code{exprdist}:}{Object of class \code{"expression"} defining the cdf and pdf of the copula.}
+    \item{\code{dimension}:}{Object of class \code{"integer"} defining the dimension (currently fixed at 2.) }
+    \item{\code{parameters}:}{Object of class \code{"numeric"} providing the three parameters. }
+    \item{\code{param.names}:}{Object of class \code{"character"} giving the names of the parameters. }
+    \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} defining the lower bounds of the three parameters. }
+    \item{\code{param.upbnd}:}{Object of class \code{"numeric"} defining the upper bounds of the three parameters. }
+    \item{\code{fullname}:}{Object of class \code{"character"} providing a descriptive name for the copula family.}
+  }
+}
+\section{Extends}{
+Class \code{"\linkS4class{evCopula}"}, directly.
+Class \code{"\linkS4class{copula}"}, by class "evCopula", distance 2.
+Class \code{"\linkS4class{Copula}"}, by class "evCopula", distance 3.
+}
+\section{Methods}{
+  \describe{
+    \item{A}{\code{signature(copula = "tawn3pCopula")}: ... }
+    \item{dAdu}{\code{signature(copula = "tawn3pCopula")}: ... }
+    \item{dCopula}{\code{signature(u = "matrix", copula = "tawn3pCopula")}: ... }
+    \item{dCopula}{\code{signature(u = "numeric", copula = "tawn3pCopula")}: ... }
+    \item{fitCopula}{\code{signature(copula = "tawn3pCopula")}: ... }
+    \item{pCopula}{\code{signature(u = "matrix", copula = "tawn3pCopula")}: ... }
+    \item{pCopula}{\code{signature(u = "numeric", copula = "tawn3pCopula")}: ... }
+    \item{rCopula}{\code{signature(n = "numeric", copula = "tawn3pCopula")}: ... }
+	 }
+}
+
+\author{
+Benedikt Graeler
+}
+
+\seealso{
+\code{\linkS4class{tawnCopula}} for a symmetric one parameter, \code{\linkS4class{tawnT1Copula}} and \code{\linkS4class{tawnT2Copula}} for asymmetric two-parameter sub-families of the Tawn copula family. 
+}
+\examples{
+showClass("tawn3pCopula")
+}
+\keyword{classes}

Added: pkg/man/tawn3pCopula.Rd
===================================================================
--- pkg/man/tawn3pCopula.Rd	                        (rev 0)
+++ pkg/man/tawn3pCopula.Rd	2013-12-05 21:39:45 UTC (rev 118)
@@ -0,0 +1,42 @@
+\name{tawn3pCopula}
+\alias{tawn3pCopula}
+
+\title{
+Tawn Copula Family constructor using all three parameters
+}
+\description{
+Constructor of the Tawn Copula family with three parameters allowing for asymmetric copula families.
+}
+\usage{
+tawn3pCopula(param = c(0.5, 0.5, 2))
+}
+
+\arguments{
+  \item{param}{
+  The vector defining the three parameters of the Tawn Copula.
+}
+}
+\details{
+Pickand's dependece function is given through: 
+A(t) = (1-beta)*t + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta)
+}
+\value{
+An instance of the \code{\linkS4class{tawn3pCopula}} class.
+}
+
+\author{
+Benedikt Graeler
+}
+
+\seealso{
+\code{\link{tawnCopula}} for a symmetric one parameter, \code{\link{tawnT1Copula}} and \code{\link{tawnT2Copula}} for asymmetric two-parameter sub-families of the Tawn copula family. 
+}
+
+\examples{
+persp(tawn3pCopula(c(0.4,0.9,4)), dCopula)
+persp(tawn3pCopula(c(0.4,0.9,4)), pCopula)
+
+}
+
+\keyword{ copula }
+\keyword{ distribution }


From noreply at r-forge.r-project.org  Wed Dec 18 10:22:32 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 18 Dec 2013 10:22:32 +0100 (CET)
Subject: [spcopula-commits] r119 - in pkg: demo man
Message-ID: <20131218092232.B8154186852@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-12-18 10:22:32 +0100 (Wed, 18 Dec 2013)
New Revision: 119

Added:
   pkg/demo/tailDepFunctions.R
Modified:
   pkg/demo/00Index
   pkg/man/tailDepFun.Rd
Log:
- added demo on tail dependece functions

Modified: pkg/demo/00Index
===================================================================
--- pkg/demo/00Index	2013-12-05 21:39:45 UTC (rev 118)
+++ pkg/demo/00Index	2013-12-18 09:22:32 UTC (rev 119)
@@ -2,3 +2,4 @@
 spCopula		A demo illustrating the estiamtion of a single spatial tree vine copula for a SpatialPointsDataFrame.
 pureSpVineCopula  	A demo illustrating the estiamtion of a pure spatial vine copula for a SpatialPointsDataFrame.
 stVineCopFit    A demo corresponding to the vignette estimating a spatio-temporal vine copula.
+tailDepFunctions    A demo illustrating the empirical tail dependece function with parametric parametric tail dependence functions for different families of copulas.

Added: pkg/demo/tailDepFunctions.R
===================================================================
--- pkg/demo/tailDepFunctions.R	                        (rev 0)
+++ pkg/demo/tailDepFunctions.R	2013-12-18 09:22:32 UTC (rev 119)
@@ -0,0 +1,26 @@
+library(spcopula)
+data(simulatedTriples)
+
+rtPair <- 1-as.matrix(rankTransform(triples[,c(1,3)]))
+
+plot(rtPair,asp=1)
+
+tdfEmp <- empTailDepFun(rtPair)
+plot(tdfEmp,ylim=c(0,1), ylab="tail index", xlab="u")
+abline(v=0.5, col="grey")
+
+gaussCop <- fitCopula(normalCopula(0), rtPair)@copula
+tdfGauss <- tailDepFun(gaussCop)
+curve(tdfGauss, add=T,col="green",n=500)
+
+gumbelCop <- fitCopula(gumbelCopula(2),rtPair)@copula
+tdfGumbel <- tailDepFun(gumbelCop)
+curve(tdfGumbel,add=T, col="blue",n=500)
+
+BB6Cop <- fitCopula(BB6Copula(), rtPair)@copula
+tdfBB6 <- tailDepFun(BB6Cop)
+curve(tdfBB6, add=T,col="red",n=500)
+
+legend("bottomright",
+       c("empirical", "Gaussian", "Gumbel", "BB6"),
+       col=c("black", "green", "blue", "red"), lty=1)
\ No newline at end of file

Modified: pkg/man/tailDepFun.Rd
===================================================================
--- pkg/man/tailDepFun.Rd	2013-12-05 21:39:45 UTC (rev 118)
+++ pkg/man/tailDepFun.Rd	2013-12-18 09:22:32 UTC (rev 119)
@@ -36,7 +36,7 @@
 A function taking arguments from the unit interval (0,1) and returning the corresponding tail index.
 }
 \references{
-Inspired by: \url{http://www.r-bloggers.com/copulas-and-tail-dependence-part-1/}
+Inspired by: \url{http://freakonometrics.blog.free.fr/index.php?post/2012/09/11/Copulas-and-statistical-inference}
 }
 \author{
 Benedikt Graeler
@@ -67,4 +67,4 @@
 
 legend("bottomleft",c("empircal","Gauss","surv. Gumbel","surv. BB6"),
        col=c("black","blue","darkgreen","red"),lty=1)
-}
\ No newline at end of file
+} 
\ No newline at end of file