[Vinecopula-commits] r81 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fr Feb 20 12:46:27 CET 2015
Author: tnagler
Date: 2015-02-20 12:46:26 +0100 (Fri, 20 Feb 2015)
New Revision: 81
Modified:
pkg/R/0_prep_object.R
pkg/R/AD.R
pkg/R/BetaMatrix.r
pkg/R/BiCopCDF.r
pkg/R/BiCopChiPlot.r
pkg/R/BiCopDeriv.r
pkg/R/BiCopDeriv2.r
pkg/R/BiCopEst.r
pkg/R/BiCopGofTest.r
pkg/R/BiCopHfunc.r
pkg/R/BiCopHfuncDeriv.r
pkg/R/BiCopHfuncDeriv2.r
pkg/R/BiCopIndTest.r
pkg/R/BiCopLambda.r
pkg/R/BiCopMetaContour.r
pkg/R/BiCopName.r
pkg/R/BiCopPDF.r
pkg/R/BiCopPar2Beta.r
pkg/R/BiCopPar2TailDep.r
pkg/R/BiCopPar2Tau.r
pkg/R/BiCopSelect.r
pkg/R/BiCopSim.R
pkg/R/BiCopTau2Par.r
pkg/R/BiCopVuongClarke.r
pkg/R/C2RVine.r
pkg/R/ChatZj.R
pkg/R/CvM.R
pkg/R/D2RVine.r
pkg/R/Fhat.R
pkg/R/KS.R
pkg/R/RVineAIC.r
pkg/R/RVineClarkeTest.R
pkg/R/RVineCopSelect.r
pkg/R/RVineGofTest3.r
pkg/R/RVineGrad.r
pkg/R/RVineHessian.r
pkg/R/RVineLogLik.r
pkg/R/RVineMLE.R
pkg/R/RVineMatrix.R
pkg/R/RVinePIT.r
pkg/R/RVinePar2Beta.r
pkg/R/RVinePar2Tau.r
pkg/R/RVinePartialcorr.R
pkg/R/RVineSeqEst.R
pkg/R/RVineSim.R
pkg/R/RVineStdError.r
pkg/R/RVineStructureSelect.r
pkg/R/RVineTreePlot.r
pkg/R/RVineVuongTest.R
pkg/R/TauMatrix.r
pkg/R/as.copuladata.R
pkg/R/gof_ECP.r
pkg/R/gof_PIT.r
pkg/R/gof_White.r
pkg/R/pairs.R
Log:
prettier code (with formatR package)
Modified: pkg/R/0_prep_object.R
===================================================================
--- pkg/R/0_prep_object.R 2015-01-28 09:34:49 UTC (rev 80)
+++ pkg/R/0_prep_object.R 2015-02-20 11:46:26 UTC (rev 81)
@@ -1,204 +1,237 @@
-copulaFromFamilyIndex <- function(family, par, par2=0) {
- constr <- switch(paste("fam",family,sep=""),
- fam0 = function(par) indepCopula(),
- fam1 = function(par) normalCopula(par[1]),
- fam2 = function(par) tCopula(par[1],df=par[2]),
- fam3 = function(par) claytonCopula(par[1]),
- fam4 = function(par) gumbelCopula(par[1]),
- fam5 = function(par) frankCopula(par[1]),
- fam6 = function(par) joeBiCopula(par[1]),
- fam7 = BB1Copula,
- fam8 = BB6Copula,
- fam9 = BB7Copula,
- fam10 = BB8Copula,
- fam13 = function(par) surClaytonCopula(par[1]),
- fam14 = function(par) surGumbelCopula(par[1]),
- fam16 = function(par) surJoeBiCopula(par[1]),
- fam17 = surBB1Copula,
- fam18 = surBB6Copula,
- fam19 = surBB7Copula,
- fam20 = surBB8Copula,
- fam23 = function(par) r90ClaytonCopula(par[1]),
- fam24 = function(par) r90GumbelCopula(par[1]),
- fam26 = function(par) r90JoeBiCopula(par[1]),
- fam27 = r90BB1Copula,
- fam28 = r90BB6Copula,
- fam29 = r90BB7Copula,
- fam30 = r90BB8Copula,
- fam33 = function(par) r270ClaytonCopula(par[1]),
- fam34 = function(par) r270GumbelCopula(par[1]),
- fam36 = function(par) r270JoeBiCopula(par[1]),
- fam37 = r270BB1Copula,
- fam38 = r270BB6Copula,
- fam39 = r270BB7Copula,
- fam40 = r270BB8Copula,
- fam104 = tawnT1Copula,
- fam114 = surTawnT1Copula,
- fam124 = r90TawnT1Copula,
- fam134 = r270TawnT1Copula,
- fam204 = tawnT2Copula,
- fam214 = surTawnT2Copula,
- fam224 = r90TawnT2Copula,
- fam234 = r270TawnT2Copula)
- constr(c(par,par2))
+copulaFromFamilyIndex <- function(family, par, par2 = 0) {
+ constr <- switch(paste("fam", family, sep = ""),
+ fam0 = function(par) indepCopula(),
+ fam1 = function(par) normalCopula(par[1]),
+ fam2 = function(par) tCopula(par[1], df = par[2]),
+ fam3 = function(par) claytonCopula(par[1]),
+ fam4 = function(par) gumbelCopula(par[1]),
+ fam5 = function(par) frankCopula(par[1]),
+ fam6 = function(par) joeBiCopula(par[1]),
+ fam7 = BB1Copula,
+ fam8 = BB6Copula,
+ fam9 = BB7Copula,
+ fam10 = BB8Copula,
+ fam13 = function(par) surClaytonCopula(par[1]),
+ fam14 = function(par) surGumbelCopula(par[1]),
+ fam16 = function(par) surJoeBiCopula(par[1]),
+ fam17 = surBB1Copula,
+ fam18 = surBB6Copula,
+ fam19 = surBB7Copula,
+ fam20 = surBB8Copula,
+ fam23 = function(par) r90ClaytonCopula(par[1]),
+ fam24 = function(par) r90GumbelCopula(par[1]),
+ fam26 = function(par) r90JoeBiCopula(par[1]),
+ fam27 = r90BB1Copula,
+ fam28 = r90BB6Copula,
+ fam29 = r90BB7Copula,
+ fam30 = r90BB8Copula,
+ fam33 = function(par) r270ClaytonCopula(par[1]),
+ fam34 = function(par) r270GumbelCopula(par[1]),
+ fam36 = function(par) r270JoeBiCopula(par[1]),
+ fam37 = r270BB1Copula,
+ fam38 = r270BB6Copula,
+ fam39 = r270BB7Copula,
+ fam40 = r270BB8Copula,
+ fam104 = tawnT1Copula,
+ fam114 = surTawnT1Copula,
+ fam124 = r90TawnT1Copula,
+ fam134 = r270TawnT1Copula,
+ fam204 = tawnT2Copula,
+ fam214 = surTawnT2Copula,
+ fam224 = r90TawnT2Copula,
+ fam234 = r270TawnT2Copula)
+ constr(c(par, par2))
}
-# generic fitting
-## make fitCopula from copula generic
+# generic fitting make fitCopula from copula generic
setGeneric("fitCopula", fitCopula)
-#########################################################
-## generic wrapper functions to the VineCopula package ##
-#########################################################
+####################### generic wrapper functions to the VineCopula package ##
# density from BiCopPDF
-linkVineCop.PDF <- function (u, copula, log=FALSE) {
- param <- copula at parameters
-
- if(length(param)==1)
- param <- c(param,0)
- n <- nrow(u)
- fam <- copula at family
-
-# coplik = RLL_mod_separate(fam, n, u, param)[[7]]
- coplik = .C("LL_mod_seperate", as.integer(fam), as.integer(n), as.double(u[,1]),
- as.double(u[,2]), as.double(param[1]), as.double(param[2]),
- as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]]
- if(log)
- return(coplik)
- else
- return(exp(coplik))
+linkVineCop.PDF <- function(u, copula, log = FALSE) {
+ param <- copula at parameters
+
+ if (length(param) == 1)
+ param <- c(param, 0)
+ n <- nrow(u)
+ fam <- copula at family
+
+ # coplik = RLL_mod_separate(fam, n, u, param)[[7]]
+ coplik <- .C("LL_mod_seperate",
+ as.integer(fam),
+ as.integer(n),
+ as.double(u[, 1]),
+ as.double(u[, 2]),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ if (log) return(coplik) else return(exp(coplik))
}
# cdf from BiCopCDF
-# for "standard" copulas: family %in% c(3:10)
-linkVineCop.CDF <- function (u, copula) {
- param <- copula at parameters
- if (!is.matrix(u)) u <- matrix(u, ncol = 2)
- n <- nrow(u)
- fam <- copula at family
-
- res <- .C("archCDF", as.double(u[,1]), as.double(u[,2]), as.integer(n), as.double(param),
- as.integer(fam), as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]]
- return(res)
+# for 'standard' copulas: family %in% c(3:10)
+linkVineCop.CDF <- function(u, copula) {
+ param <- copula at parameters
+ if (!is.matrix(u)) u <- matrix(u, ncol = 2)
+ n <- nrow(u)
+ fam <- copula at family
+
+ res <- .C("archCDF",
+ as.double(u[, 1]),
+ as.double(u[, 2]),
+ as.integer(n),
+ as.double(param),
+ as.integer(fam),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[6]]
+ return(res)
}
# for survival copulas: family %in% c(13, 14, 16:20)
-linkVineCop.surCDF <- function (u, copula) {
- param <- copula at parameters
- if (!is.matrix(u)) u <- matrix(u, ncol = 2)
- u1 <- u[,1]
- u2 <- u[,2]
- n <- nrow(u)
- fam <- copula at family
-
- res <- u1 + u2 - 1 + .C("archCDF", as.double(1 - u1), as.double(1 - u2), as.integer(n),
- as.double(param), as.integer(fam - 10), as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[6]]
- return(res)
+linkVineCop.surCDF <- function(u, copula) {
+ param <- copula at parameters
+ if (!is.matrix(u)) u <- matrix(u, ncol = 2)
+ u1 <- u[, 1]
+ u2 <- u[, 2]
+ n <- nrow(u)
+ fam <- copula at family
+
+ res <- u1 + u2 - 1 + .C("archCDF",
+ as.double(1 - u1),
+ as.double(1 - u2),
+ as.integer(n),
+ as.double(param),
+ as.integer(fam - 10),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[6]]
+ return(res)
}
# for 90 deg rotated copulas: family %in% c(23, 24, 26:30)
-linkVineCop.r90CDF <- function (u, copula) {
- param <- copula at parameters
- if (!is.matrix(u)) u <- matrix(u, ncol = 2)
- u1 <- u[,1]
- u2 <- u[,2]
- n <- nrow(u)
- fam <- copula at family
-
- u2 - .C("archCDF", as.double(1 - u1), as.double(u2), as.integer(n),
- as.double(-param), as.integer(fam - 20), as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[6]]
+linkVineCop.r90CDF <- function(u, copula) {
+ param <- copula at parameters
+ if (!is.matrix(u)) u <- matrix(u, ncol = 2)
+ u1 <- u[, 1]
+ u2 <- u[, 2]
+ n <- nrow(u)
+ fam <- copula at family
+
+ u2 - .C("archCDF",
+ as.double(1 - u1),
+ as.double(u2),
+ as.integer(n),
+ as.double(-param),
+ as.integer(fam - 20),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[6]]
}
# for 270 deg rotated copulas: family %in% c(33, 34, 36:40)
-linkVineCop.r270CDF <- function (u, copula) {
- param <- copula at parameters
- if (!is.matrix(u)) u <- matrix(u, ncol = 2)
- u1 <- u[,1]
- u2 <- u[,2]
- n <- nrow(u)
- fam <- copula at family
-
- u1 - .C("archCDF", as.double(u1), as.double(1 - u2), as.integer(n),
- as.double(-param), as.integer(fam - 30), as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[6]]
+linkVineCop.r270CDF <- function(u, copula) {
+ param <- copula at parameters
+ if (!is.matrix(u)) u <- matrix(u, ncol = 2)
+ u1 <- u[, 1]
+ u2 <- u[, 2]
+ n <- nrow(u)
+ fam <- copula at family
+
+ u1 - .C("archCDF",
+ as.double(u1),
+ as.double(1 - u2),
+ as.integer(n),
+ as.double(-param),
+ as.integer(fam - 30),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[6]]
}
-## derivtives/h-function from BiCopHfunc
-# ddu
-linkVineCop.ddu <- function (u, copula) {
- param <- copula at parameters
-
- if(length(param)==1)
- param <- c(param,0)
-
- u <- matrix(u, ncol = 2)
- n <- nrow(u)
- fam <- copula at family
-
- .C("Hfunc1", as.integer(fam), as.integer(n), as.double(u[,2]), as.double(u[,1]),
- as.double(param[1]), as.double(param[2]), as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
+## derivtives/h-function from BiCopHfunc ddu
+linkVineCop.ddu <- function(u, copula) {
+ param <- copula at parameters
+
+ if (length(param) == 1) param <- c(param, 0)
+
+ u <- matrix(u, ncol = 2)
+ n <- nrow(u)
+ fam <- copula at family
+
+ .C("Hfunc1",
+ as.integer(fam),
+ as.integer(n),
+ as.double(u[, 2]),
+ as.double(u[, 1]),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
}
# ddv
-linkVineCop.ddv <- function (u, copula) {
- param <- copula at parameters
-
- if(length(param)==1)
- param <- c(param,0)
-
- u <- matrix(u, ncol = 2)
- n <- nrow(u)
- fam <- copula at family
-
- .C("Hfunc2", as.integer(fam), as.integer(n), as.double(u[,1]), as.double(u[,2]),
- as.double(param[1]), as.double(param[2]), as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
+linkVineCop.ddv <- function(u, copula) {
+ param <- copula at parameters
+
+ if (length(param) == 1) param <- c(param, 0)
+
+ u <- matrix(u, ncol = 2)
+ n <- nrow(u)
+ fam <- copula at family
+
+ .C("Hfunc2",
+ as.integer(fam),
+ as.integer(n),
+ as.double(u[, 1]),
+ as.double(u[, 2]),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
}
## random numbers from VineCopulaSim
-linkVineCop.r <- function (n, copula){
- param <- copula at parameters
-
- if(length(param)==1)
- param <- c(param,0)
-
- fam <- copula at family
- if(is.na(param[2])) param <- c(param,0)
-
- res <- .C("pcc", as.integer(n), as.integer(2), as.integer(fam), as.integer(1),
- as.double(param[1]), as.double(param[2]), as.double(rep(0, n * 2)),
- PACKAGE = "VineCopula")[[7]]
-
- return(matrix(res, ncol = 2))
+linkVineCop.r <- function(n, copula) {
+ param <- copula at parameters
+
+ if (length(param) == 1) param <- c(param, 0)
+
+ fam <- copula at family
+ if (is.na(param[2])) param <- c(param, 0)
+
+ res <- .C("pcc",
+ as.integer(n),
+ as.integer(2),
+ as.integer(fam),
+ as.integer(1),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(rep(0, n * 2)),
+ PACKAGE = "VineCopula")[[7]]
+
+ return(matrix(res, ncol = 2))
}
## Kendall's tau
linkVineCop.tau <- function(copula) {
- param <- copula at parameters
- if(length(param)==1)
- param <- c(param,0)
-
- BiCopPar2Tau(copula at family, param[1], param[2])
+ param <- copula at parameters
+ if (length(param) == 1) param <- c(param, 0)
+
+ BiCopPar2Tau(copula at family, param[1], param[2])
}
## get parameter from Kendall's tau (only for one parameter families)
linkVineCop.iTau <- function(copula, tau) {
- BiCopTau2Par(copula at family, tau)
+ BiCopTau2Par(copula at family, tau)
}
## tailIndex
linkVineCop.tailIndex <- function(copula) {
- param <- copula at parameters
- if(length(param)==1)
- param <- c(param,0)
-
- unlist(BiCopPar2TailDep(copula at family, param[1], param[2]))
+ param <- copula at parameters
+ if (length(param) == 1) param <- c(param, 0)
+
+ unlist(BiCopPar2TailDep(copula at family, param[1], param[2]))
}
setGeneric("dduCopula", function(u, copula, ...) standardGeneric("dduCopula"))
Modified: pkg/R/AD.R
===================================================================
--- pkg/R/AD.R 2015-01-28 09:34:49 UTC (rev 80)
+++ pkg/R/AD.R 2015-02-20 11:46:26 UTC (rev 81)
@@ -1,20 +1,17 @@
-"AD" =
-function(cdf=NULL)
-{
- # Cumulative distribution function test:
- # Function that computes the Anderson-Darling test statistic
- #--------------------------------------------------------------------------
- # INPUT:
- # cdf CDF for which to compute AD test
- # OUTPUT:
- # AD Anderson-Darling test statistic
- #--------------------------------------------------------------------------
- # Author: Daniel Berg <daniel at danielberg.no>
- # Date: 27.03.2006
- # Version: 1.0.1
- #--------------------------------------------------------------------------
- n = length(cdf)
- AD = .C("ADtest",as.double(cdf),as.integer(n),as.double(0),PACKAGE='VineCopula')[[3]]
- AD
-}
-
+"AD" <- function(cdf = NULL) {
+ # Cumulative distribution function test: Function that computes the
+ # Anderson-Darling test statistic
+ # --------------------------------------------------------------------------
+ # INPUT: cdf CDF for which to compute AD test OUTPUT:
+ # AD Anderson-Darling test statistic
+ # --------------------------------------------------------------------------
+ # Author: Daniel Berg <daniel at danielberg.no> Date: 27.03.2006 Version: 1.0.1
+ # --------------------------------------------------------------------------
+ n <- length(cdf)
+ AD <- .C("ADtest",
+ as.double(cdf),
+ as.integer(n),
+ as.double(0),
+ PACKAGE = "VineCopula")[[3]]
+ AD
+}
Modified: pkg/R/BetaMatrix.r
===================================================================
--- pkg/R/BetaMatrix.r 2015-01-28 09:34:49 UTC (rev 80)
+++ pkg/R/BetaMatrix.r 2015-02-20 11:46:26 UTC (rev 81)
@@ -1,48 +1,45 @@
-BetaMatrix<-function(data)
-{
- d<-dim(data)[2]
-
- betahat=matrix(1,d,d)
- for(i in 1:(d-1))
- {
- u1=data[,i]
- for(j in (i+1):d)
- {
- u2=data[,j]
- betahat[i,j]<-betaFunc(u1,u2,1/2,1/2)
- betahat[j,i]=betahat[i,j]
- }
- }
-
-return(betahat)
+BetaMatrix <- function(data) {
+ d <- dim(data)[2]
+
+ betahat <- matrix(1, d, d)
+ for (i in 1:(d - 1)) {
+ u1 <- data[, i]
+ for (j in (i + 1):d) {
+ u2 <- data[, j]
+ betahat[i, j] <- betaFunc(u1, u2, 1/2, 1/2)
+ betahat[j, i] <- betahat[i, j]
+ }
+ }
+
+ return(betahat)
}
# empirical copula
-empcop<-function(u1,u2,u,v)
-{
- n=length(u1)
- a<-which(u1<u)
- b<-which(u2<v)
- sc<-intersect(a,b)
- return(1/n*length(sc))
+empcop <- function(u1, u2, u, v) {
+ n <- length(u1)
+ a <- which(u1 < u)
+ b <- which(u2 < v)
+ sc <- intersect(a, b)
+ return(1/n * length(sc))
}
# survival copula
-survivalcop<-function(u1,u2,u,v)
-{
- n=length(u1)
- a<-which(u1>u)
- b<-which(u2>v)
- sc<-intersect(a,b)
- return(1/n*length(sc))
+survivalcop <- function(u1, u2, u, v) {
+ n <- length(u1)
+ a <- which(u1 > u)
+ b <- which(u2 > v)
+ sc <- intersect(a, b)
+ return(1/n * length(sc))
}
# h_d
-h<-function(u,v) (min(u,v)+min(1-u)-u*v-(1-u)*(1-v))^-1
+h <- function(u, v) (min(u, v) + min(1 - u) - u * v - (1 - u) * (1 - v))^-1
# g_d
-g<-function(u,v) (u*v)+(1-u)*(1-v)
+g <- function(u, v) (u * v) + (1 - u) * (1 - v)
# beta
-betaFunc<-function(u1,u2,u,v) h(u,v)*(empcop(u1,u2,u,v)+survivalcop(u1,u2,u,v)-g(u,v))
\ No newline at end of file
+betaFunc <- function(u1, u2, u, v) {
+ h(u, v) * (empcop(u1, u2, u, v) + survivalcop(u1, u2, u, v) - g(u, v))
+}
Modified: pkg/R/BiCopCDF.r
===================================================================
--- pkg/R/BiCopCDF.r 2015-01-28 09:34:49 UTC (rev 80)
+++ pkg/R/BiCopCDF.r 2015-02-20 11:46:26 UTC (rev 81)
@@ -1,127 +1,185 @@
-BiCopCDF <- function(u1, u2, family, par, par2 = 0){
-
- ## sanity checks
- if(is.null(u1)==TRUE || is.null(u2)==TRUE) stop("u1 and/or u2 are not set or have length zero.")
- if(any(u1>1) || any(u1<0)) stop("Data has be in the interval [0,1].")
- if(any(u2>1) || any(u2<0)) stop("Data has be in the interval [0,1].")
- if(length(u1)!=length(u2)) stop("Lengths of 'u1' and 'u2' do not match.")
- if(family==2) stop("The CDF of the t-copula is not implemented.")
- if(!(family %in% c(0,1,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,51,61,71,104,114,124,134,204,214,224,234))) stop("Copula family not implemented.")
- if(family %in% c(7,8,9,10,17,18,19,20,27,28,29,30,37,38,39,40,104,114,124,134,204,214,224,234) && par2==0) stop("For BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.")
- if(family %in% c(1,3,4,5,6,13,14,16,23,24,26,33,34,36,41,51,61,71) && length(par)<1) stop("'par' not set.")
-
- if((family==1) && abs(par[1])>=1) stop("The parameter of the Gaussian 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.")
- if((family==4 || family==14) && par<1) stop("The parameter of the Gumbel copula has to be in the interval [1,oo).")
- if((family==6 || family==16) && par<=1) stop("The parameter of the Joe copula has to be in the interval (1,oo).")
- if(family==5 && par==0) stop("The parameter of the Frank copula has to be unequal to 0.")
- if((family==7 || family==17) && par<=0) stop("The first parameter of the BB1 copula has to be positive.")
- if((family==7 || family==17) && par2<1) stop("The second parameter of the BB1 copula has to be in the interval [1,oo).")
- if((family==8 || family==18) && par<=0) stop("The first parameter of the BB6 copula has to be in the interval [1,oo).")
- if((family==8 || family==18) && par2<1) stop("The second parameter of the BB6 copula has to be in the interval [1,oo).")
- if((family==9 || family==19) && par<1) stop("The first parameter of the BB7 copula has to be in the interval [1,oo).")
- if((family==9 || family==19) && par2<=0) stop("The second parameter of the BB7 copula has to be positive.")
- if((family==10 || family==20) && par<1) stop("The first parameter of the BB8 copula has to be in the interval [1,oo).")
- if((family==10 || family==20) && (par2<=0 || par2>1)) stop("The second parameter of the BB8 copula has to be in the interval (0,1].")
- if((family==23 || family==33) && par>=0) stop("The parameter of the rotated Clayton copula has to be negative.")
- if((family==24 || family==34) && par>-1) stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].")
- if((family==26 || family==36) && par>=-1) stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).")
- if((family==27 || family==37) && par>=0) stop("The first parameter of the rotated BB1 copula has to be negative.")
- if((family==27 || family==37) && par2>-1) stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].")
- if((family==28 || family==38) && par>=0) stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
- if((family==28 || family==38) && par2>-1) stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
- if((family==29 || family==39) && par>-1) stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].")
- if((family==29 || family==39) && par2>=0) stop("The second parameter of the rotated BB7 copula has to be negative.")
- if((family==30 || family==40) && par>-1) stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].")
- if((family==30 || family==40) && (par2>=0 || par2<(-1))) stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).")
- if((family==41 || family==51) && par<=0) stop("The parameter of the reflection asymmetric copula has to be positive.")
- if((family==61 || family==71) && par>=0) stop("The parameter of the rotated reflection asymmetric copula has to be negative.")
- if ((family==104 || family==114 || family==204 || family==214) && par<1) stop("Please choose 'par' of the Tawn copula in [1,oo).")
- if ((family==104 || family==114 || family==204 || family==214) && (par2<0 || par2>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].")
- if ((family==124 || family==134 || family==224 || family==234) && par>-1) stop("Please choose 'par' of the Tawn copula in (-oo,-1].")
- if ((family==124 || family==134 || family==224 || family==234) && (par2<0 || par2>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].")
-
- res = rep(NA, length(u1))
-
- ## CDFs for the different families
- if(family == 0){
- res = u1*u2
- }else if(family == 1){
- cdf = function(u,v) pmvnorm(upper=c(qnorm(u),qnorm(v)), corr=matrix(c(1,par,par,1),2,2))
- res = mapply(cdf, u1, u2, SIMPLIFY=TRUE)
- #}else if(family == 2){
-# par2=round(par2)
- # cdf = function(u,v) pmvt(upper=c(qt(u,df=par2),qt(v,df=par2)), corr=matrix(c(1,par,par,1),2,2), df=par2)
- # res = mapply(cdf, u1, u2, SIMPLIFY=TRUE)
- }else if(family %in% c(3:10,41)){
- res = .C("archCDF",as.double(u1),as.double(u2),as.integer(length(u1)),as.double(c(par,par2)),as.integer(family),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]]
- }else if(family %in% c(13,14,16:20,51)){
- res = u1+u2-1+.C("archCDF",as.double(1-u1),as.double(1-u2),as.integer(length(u1)),as.double(c(par,par2)),as.integer(family-10),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]]
- }else if(family %in% c(23,24,26:30,61)){
- res = u2-.C("archCDF",as.double(1-u1),as.double(u2),as.integer(length(u1)),as.double(c(-par,-par2)),as.integer(family-20),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]]
- }else if(family %in% c(33,34,36:40,71)){
- res = u1-.C("archCDF",as.double(u1),as.double(1-u2),as.integer(length(u1)),as.double(c(-par,-par2)),as.integer(family-30),as.double(rep(0,length(u1))),PACKAGE='VineCopula')[[6]]
- }else if(family %in% c(104,114,124,134,204,214,224,234)){# maybe replace by C-Code
- ## auxiliary functions ###
- ta <- function(t,par,par2,par3){(par2*t)^par+(par3*(1-t))^par}
- ######## Pickands A
- A <- function(t,par,par2,par3){
- (1-par3)*(1-t)+(1-par2)*t+ta(t,par,par2,par3)^(1/par)
- }
+BiCopCDF <- function(u1, u2, family, par, par2 = 0) {
- w <- function(u1,u2){
- log(u2)/log(u1*u2)
+ ## sanity checks
+ if (is.null(u1) == TRUE || is.null(u2) == TRUE)
+ stop("u1 and/or u2 are not set or have length zero.")
+ if (any(u1 > 1) || any(u1 < 0))
+ stop("Data has be in the interval [0,1].")
+ if (any(u2 > 1) || any(u2 < 0))
+ stop("Data has be in the interval [0,1].")
+ if (length(u1) != length(u2))
+ stop("Lengths of 'u1' and 'u2' do not match.")
+ if (family == 2)
+ stop("The CDF of the t-copula is not implemented.")
+ if (!(family %in% c(0, 1, 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,
+ 51, 61, 71, 104, 114, 124, 134, 204, 214, 224, 234)))
+ stop("Copula family not implemented.")
+ if (family %in% c(7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40,
+ 104, 114, 124, 134, 204, 214, 224, 234) && par2 == 0)
+ stop("For BB1, BB6, BB7, BB8 and Tawn copulas, 'par2' must be set.")
+ if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36, 41, 51,
+ 61, 71) && length(par) < 1)
+ stop("'par' not set.")
+
+ if ((family == 1) && abs(par[1]) >= 1)
+ stop("The parameter of the Gaussian 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.")
+ if ((family == 4 || family == 14) && par < 1)
+ stop("The parameter of the Gumbel copula has to be in the interval [1,oo).")
+ if ((family == 6 || family == 16) && par <= 1)
+ stop("The parameter of the Joe copula has to be in the interval (1,oo).")
+ if (family == 5 && par == 0)
+ stop("The parameter of the Frank copula has to be unequal to 0.")
+ if ((family == 7 || family == 17) && par <= 0)
+ stop("The first parameter of the BB1 copula has to be positive.")
+ if ((family == 7 || family == 17) && par2 < 1)
+ stop("The second parameter of the BB1 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par <= 0)
+ stop("The first parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 8 || family == 18) && par2 < 1)
+ stop("The second parameter of the BB6 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par < 1)
+ stop("The first parameter of the BB7 copula has to be in the interval [1,oo).")
+ if ((family == 9 || family == 19) && par2 <= 0)
+ stop("The second parameter of the BB7 copula has to be positive.")
+ if ((family == 10 || family == 20) && par < 1)
+ stop("The first parameter of the BB8 copula has to be in the interval [1,oo).")
+ if ((family == 10 || family == 20) && (par2 <= 0 || par2 > 1))
+ stop("The second parameter of the BB8 copula has to be in the interval (0,1].")
+ if ((family == 23 || family == 33) && par >= 0)
+ stop("The parameter of the rotated Clayton copula has to be negative.")
+ if ((family == 24 || family == 34) && par > -1)
+ stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].")
+ if ((family == 26 || family == 36) && par >= -1)
+ stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).")
+ if ((family == 27 || family == 37) && par >= 0)
+ stop("The first parameter of the rotated BB1 copula has to be negative.")
+ if ((family == 27 || family == 37) && par2 > -1)
+ stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par >= 0)
+ stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 28 || family == 38) && par2 > -1)
+ stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par > -1)
+ stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].")
+ if ((family == 29 || family == 39) && par2 >= 0)
+ stop("The second parameter of the rotated BB7 copula has to be negative.")
+ if ((family == 30 || family == 40) && par > -1)
+ stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].")
+ if ((family == 30 || family == 40) && (par2 >= 0 || par2 < (-1)))
+ stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).")
+ if ((family == 41 || family == 51) && par <= 0)
+ stop("The parameter of the reflection asymmetric copula has to be positive.")
+ if ((family == 61 || family == 71) && par >= 0)
+ stop("The parameter of the rotated reflection asymmetric copula has to be negative.")
+ if ((family == 104 || family == 114 || family == 204 || family == 214) && par < 1)
+ stop("Please choose 'par' of the Tawn copula in [1,oo).")
+ if ((family == 104 || family == 114 || family == 204 || family == 214) && (par2 < 0 || par2 > 1))
+ stop("Please choose 'par2' of the Tawn copula in [0,1].")
+ if ((family == 124 || family == 134 || family == 224 || family == 234) && par > -1)
+ stop("Please choose 'par' of the Tawn copula in (-oo,-1].")
+ if ((family == 124 || family == 134 || family == 224 || family == 234) && (par2 < 0 || par2 > 1))
+ stop("Please choose 'par2' of the Tawn copula in [0,1].")
+
+ res <- rep(NA, length(u1))
+
+ ## CDFs for the different families
+ if (family == 0) {
+ res <- u1 * u2
+ } else if (family == 1) {
+ cdf <- function(u, v) pmvnorm(upper = c(qnorm(u), qnorm(v)),
+ corr = matrix(c(1, par, par, 1), 2, 2))
+ res <- mapply(cdf, u1, u2, SIMPLIFY = TRUE)
+ # }else if(family == 2){ par2=round(par2) cdf = function(u,v)
+ # pmvt(upper=c(qt(u,df=par2),qt(v,df=par2)), corr=matrix(c(1,par,par,1),2,2),
+ # df=par2) res = mapply(cdf, u1, u2, SIMPLIFY=TRUE)
+ } else if (family %in% c(3:10, 41)) {
+ res <- .C("archCDF",
+ as.double(u1),
+ as.double(u2),
+ as.integer(length(u1)),
+ as.double(c(par, par2)),
+ as.integer(family),
+ as.double(rep(0, length(u1))),
+ PACKAGE = "VineCopula")[[6]]
+ } else if (family %in% c(13, 14, 16:20, 51)) {
+ res <- u1 + u2 - 1 + .C("archCDF",
+ as.double(1 - u1),
+ as.double(1 - u2),
+ as.integer(length(u1)),
+ as.double(c(par, par2)),
+ as.integer(family - 10),
+ as.double(rep(0, length(u1))),
+ PACKAGE = "VineCopula")[[6]]
+ } else if (family %in% c(23, 24, 26:30, 61)) {
+ res <- u2 - .C("archCDF",
+ as.double(1 - u1),
+ as.double(u2),
+ as.integer(length(u1)),
+ as.double(c(-par, -par2)),
+ as.integer(family - 20),
+ as.double(rep(0, length(u1))),
+ PACKAGE = "VineCopula")[[6]]
+ } else if (family %in% c(33, 34, 36:40, 71)) {
+ res <- u1 - .C("archCDF",
+ as.double(u1),
+ as.double(1 - u2),
+ as.integer(length(u1)),
+ as.double(c(-par, -par2)),
+ as.integer(family - 30),
+ as.double(rep(0, length(u1))),
+ PACKAGE = "VineCopula")[[6]]
+ } else if (family %in% c(104, 114, 124, 134, 204, 214, 224, 234)) {
+ # maybe replace by C-Code auxiliary functions ###
+ ta <- function(t, par, par2, par3) {
+ (par2 * t)^par + (par3 * (1 - t))^par
+ }
+ ######## Pickands A
+ A <- function(t, par, par2, par3) {
+ (1 - par3) * (1 - t) + (1 - par2) * t + ta(t, par, par2, par3)^(1/par)
+ }
+
+ w <- function(u1, u2) {
+ log(u2)/log(u1 * u2)
+ }
+ C <- function(u, v, par, par2, par3) {
+ (u1 * u2)^A(w(u1, u2), par, par2, par3)
+ }
+
+ if (family == 104) {
+ par3 <- 1
+ res <- C(u1, u2, par, par2, par3)
+ } else if (family == 114) {
+ par3 <- 1
+ res <- u1 + u2 - 1 + C(1 - u1, 1 - u2, par, par2, par3)
+ } else if (family == 124) {
+ par3 <- 1
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vinecopula -r 81
Mehr Informationen über die Mailingliste Vinecopula-commits