[Vinecopula-commits] r114 - / pkg pkg/R pkg/inst pkg/src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mo Aug 10 08:52:47 CEST 2015
Author: ben_graeler
Date: 2015-08-10 08:52:47 +0200 (Mon, 10 Aug 2015)
New Revision: 114
Modified:
/
pkg/DESCRIPTION
pkg/R/0_prep_object.R
pkg/R/BB6copula.R
pkg/R/BiCopCDF.r
pkg/R/joeBiCopula.R
pkg/inst/ChangeLog
pkg/src/evCopula.c
Log:
- use c-code instead of R-code for Tawn copulas, remove redundant c-code of Tawn copulas
Property changes on:
___________________________________________________________________
Modified: svn:ignore
- .Rproj.user
.Rhistory
.RData
VineCopula.Rproj
BiCop vignette
+ .Rproj.user
.Rhistory
.RData
VineCopula.Rproj
BiCop vignette
RVineCor2pcor_Ben.r
TawnCdfComp_diffIndep.png
TawnTestData.RData
Tawn_CDF_test_script.R
Tawn_test_script.R
VineCopula_1.4.tar.gz
vinecopula.Rproj
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2015-08-06 18:44:35 UTC (rev 113)
+++ pkg/DESCRIPTION 2015-08-10 06:52:47 UTC (rev 114)
@@ -1,13 +1,13 @@
-Package: VineCopula
-Type: Package
-Title: Statistical Inference of Vine Copulas
-Version: 1.7
-Date: 2015-08-03
-Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt
-Maintainer: Tobias Erhardt <tobias.erhardt at tum.de>
-Depends: R (>= 2.11.0)
-Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), methods, copula, ADGofTest, lattice
-Suggests: CDVine, TSP
-Description: Tools for bivariate exploratory data analysis, bivariate copula selection and (vine) tree construction are provided. Vine copula models can be estimated either sequentially or by joint maximum likelihood estimation. Sampling algorithms and plotting methods are included. Data is assumed to lie in the unit hypercube (so-called copula data). For C- and D-vines links to the package 'CDVine' are provided.
-License: GPL (>= 2)
-LazyLoad: yes
+Package: VineCopula
+Type: Package
+Title: Statistical Inference of Vine Copulas
+Version: 1.7
+Date: 2015-08-10
+Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt
+Maintainer: Tobias Erhardt <tobias.erhardt at tum.de>
+Depends: R (>= 2.11.0)
+Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), methods, copula, ADGofTest, lattice
+Suggests: CDVine, TSP
+Description: Tools for bivariate exploratory data analysis, bivariate copula selection and (vine) tree construction are provided. Vine copula models can be estimated either sequentially or by joint maximum likelihood estimation. Sampling algorithms and plotting methods are included. Data is assumed to lie in the unit hypercube (so-called copula data). For C- and D-vines links to the package 'CDVine' are provided.
+License: GPL (>= 2)
+LazyLoad: yes
Modified: pkg/R/0_prep_object.R
===================================================================
--- pkg/R/0_prep_object.R 2015-08-06 18:44:35 UTC (rev 113)
+++ pkg/R/0_prep_object.R 2015-08-10 06:52:47 UTC (rev 114)
@@ -1,347 +1,347 @@
-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
-setGeneric("fitCopula", fitCopula)
-
-####################### 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))
-}
-
-# 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 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)
-}
-
-# 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]]
-}
-
-# 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]]
-}
-
-## for Tawn
-# TawnC(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out)
-linkVineCop.CDFtawn <- 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
-
- if (fam == 104) {
- par3 <- 1
- res <- .C("TawnC",
- as.double(u1),
- as.double(u2),
- as.integer(n),
- as.double(param[1]),
- as.double(param[2]),
- as.double(par3),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 114) {
- par3 <- 1
- res <- u1 + u2 - 1 + .C("TawnC",
- as.double(1-u1),
- as.double(1-u2),
- as.integer(n),
- as.double(param[1]),
- as.double(param[2]),
- as.double(par3),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 124) {
- par3 <- 1
- res <- u2 - .C("TawnC",
- as.double(1-u1),
- as.double(u2),
- as.integer(n),
- as.double(-param[1]),
- as.double(param[2]),
- as.double(par3),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 134) {
- par3 <- 1
- res <- u1 - .C("TawnC",
- as.double(u1),
- as.double(1-u2),
- as.integer(n),
- as.double(-param[1]),
- as.double(param[2]),
- as.double(par3),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 204) {
- par2 <- 1
- res <- .C("TawnC",
- as.double(u1),
- as.double(u2),
- as.integer(n),
- as.double(param[1]),
- as.double(par2),
- as.double(param[2]),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 214) {
- par2 <- 1
- res <- u1 + u2 - 1 + .C("TawnC",
- as.double(1-u1),
- as.double(1-u2),
- as.integer(n),
- as.double(param[1]),
- as.double(par2),
- as.double(param[2]),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 224) {
- par2 <- 1
- res <- u2 - .C("TawnC",
- as.double(1-u1),
- as.double(u2),
- as.integer(n),
- as.double(-param[1]),
- as.double(par2),
- as.double(param[2]),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- if (fam == 234) {
- par2 <- 1
- res <- u1 - .C("TawnC",
- as.double(u1),
- as.double(1-u2),
- as.integer(n),
- as.double(-param[1]),
- as.double(par2),
- as.double(param[2]),
- as.double(rep(0, n)),
- PACKAGE = "VineCopula")[[7]]
- }
- return(res)
-}
-
-## 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]]
-}
-
-
-## 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))
-}
-
-## 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])
-}
-
-## get parameter from Kendall's tau (only for one parameter families)
-linkVineCop.iTau <- function(copula, 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]))
-}
-
-setGeneric("dduCopula", function(u, copula, ...) standardGeneric("dduCopula"))
+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
+setGeneric("fitCopula", fitCopula)
+
+####################### 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))
+}
+
+# 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 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)
+}
+
+# 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]]
+}
+
+# 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]]
+}
+
+## for Tawn
+# TawnC(double* u, double* v, int* n, double* par, double* par2, double* par3, double* out)
+linkVineCop.CDFtawn <- 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
+
+ if (fam == 104) {
+ par3 <- 1
+ res <- .C("TawnC",
+ as.double(u1),
+ as.double(u2),
+ as.integer(n),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(par3),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 114) {
+ par3 <- 1
+ res <- u1 + u2 - 1 + .C("TawnC",
+ as.double(1-u1),
+ as.double(1-u2),
+ as.integer(n),
+ as.double(param[1]),
+ as.double(param[2]),
+ as.double(par3),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 124) {
+ par3 <- 1
+ res <- u2 - .C("TawnC",
+ as.double(1-u1),
+ as.double(u2),
+ as.integer(n),
+ as.double(-param[1]),
+ as.double(param[2]),
+ as.double(par3),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 134) {
+ par3 <- 1
+ res <- u1 - .C("TawnC",
+ as.double(u1),
+ as.double(1-u2),
+ as.integer(n),
+ as.double(-param[1]),
+ as.double(param[2]),
+ as.double(par3),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 204) {
+ par2 <- 1
+ res <- .C("TawnC",
+ as.double(u1),
+ as.double(u2),
+ as.integer(n),
+ as.double(param[1]),
+ as.double(par2),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 214) {
+ par2 <- 1
+ res <- u1 + u2 - 1 + .C("TawnC",
+ as.double(1-u1),
+ as.double(1-u2),
+ as.integer(n),
+ as.double(param[1]),
+ as.double(par2),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 224) {
+ par2 <- 1
+ res <- u2 - .C("TawnC",
+ as.double(1-u1),
+ as.double(u2),
+ as.integer(n),
+ as.double(-param[1]),
+ as.double(par2),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ if (fam == 234) {
+ par2 <- 1
+ res <- u1 - .C("TawnC",
+ as.double(u1),
+ as.double(1-u2),
+ as.integer(n),
+ as.double(-param[1]),
+ as.double(par2),
+ as.double(param[2]),
+ as.double(rep(0, n)),
+ PACKAGE = "VineCopula")[[7]]
+ }
+ return(res)
+}
+
+## 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]]
+}
+
+
+## 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))
+}
+
+## 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])
+}
+
+## get parameter from Kendall's tau (only for one parameter families)
+linkVineCop.iTau <- function(copula, 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]))
+}
+
+setGeneric("dduCopula", function(u, copula, ...) standardGeneric("dduCopula"))
setGeneric("ddvCopula", function(u, copula, ...) standardGeneric("ddvCopula"))
\ No newline at end of file
Modified: pkg/R/BB6copula.R
===================================================================
--- pkg/R/BB6copula.R 2015-08-06 18:44:35 UTC (rev 113)
+++ pkg/R/BB6copula.R 2015-08-10 06:52:47 UTC (rev 114)
@@ -1,246 +1,246 @@
-#####################
-## ##
-## the BB6 copulas ##
-## ##
-#####################
-# Joe, H., (1997). Multivariate Models and Dependence Concepts. Monogra. Stat. Appl. Probab. 73, London: Chapman and Hall.
-
-validBB6Copula = function(object) {
- if (object at dimension != 2)
- return("Only BB6 copulas of dimension 2 are supported.")
- param <- object at parameters
- upper <- object at param.upbnd
- lower <- object at param.lowbnd
- if (length(param) != length(upper))
- return("Parameter and upper bound have non-equal length")
- if (length(param) != length(lower))
- return("Parameter and lower bound have non-equal length")
- if (any(is.na(param) | param >= upper | param < lower))
- return("Parameter value out of bound.")
- else return (TRUE)
-}
-
-setClass("BB6Copula",
- representation = representation("copula", family="numeric"),
- validity = validBB6Copula,
- contains = list("copula")
-)
-
-# constructor
-BB6Copula <- function (param=c(1,1)) {
- if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1)))
- stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).")
- new("BB6Copula", dimension = as.integer(2), parameters = param,
- param.names = c("theta", "delta"), param.lowbnd = c(1, 1), param.upbnd = c(Inf, Inf),
- family=8, fullname = "BB6 copula family. Number 8 in VineCopula.")
-}
-
-## density ##
-setMethod("dCopula", signature("numeric","BB6Copula"),
- function(u, copula, log) {
- linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log)
- })
-setMethod("dCopula", signature("matrix","BB6Copula"), function(u, copula, log) linkVineCop.PDF(u, copula, log))
-
-## jcdf ##
-setMethod("pCopula", signature("numeric","BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("pCopula", signature("matrix","BB6Copula"), linkVineCop.CDF)
-
-## partial derivatives ##
-# ddu
-setMethod("dduCopula", signature("numeric","BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("dduCopula", signature("matrix","BB6Copula"), linkVineCop.ddu)
-
-# ddv
-setMethod("ddvCopula", signature("numeric","BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("ddvCopula", signature("matrix","BB6Copula"), linkVineCop.ddv)
-
-## random number generater ??
-setMethod("rCopula", signature("numeric","BB6Copula"), linkVineCop.r)
-
-setMethod("tau",signature("BB6Copula"),linkVineCop.tau)
-setMethod("tailIndex",signature("BB6Copula"),linkVineCop.tailIndex)
-
-#########################
-## BB6 survival copula ##
-#########################
-
-setClass("surBB6Copula",
- representation = representation("copula", family="numeric"),
- validity = validBB6Copula,
- contains = list("copula")
-)
-
-# constructor
-surBB6Copula <- function (param=c(1,1)) {
- if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1)))
- stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).")
- new("surBB6Copula", dimension = as.integer(2), parameters = param,
- param.names = c("theta", "delta"), param.lowbnd = c(1, 1), param.upbnd = c(Inf, Inf),
- family=18, fullname = "Survival BB6 copula family. Number 18 in VineCopula.")
-}
-
-## density ##
-setMethod("dCopula", signature("numeric","surBB6Copula"),
- function(u, copula, log) {
- linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log)
- })
-setMethod("dCopula", signature("matrix","surBB6Copula"), linkVineCop.PDF)
-
-## jcdf ##
-setMethod("pCopula", signature("numeric","surBB6Copula"),
- function(u, copula, ...) {
- linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("pCopula", signature("matrix","surBB6Copula"), linkVineCop.surCDF)
-
-## partial derivatives ##
-# ddu
-setMethod("dduCopula", signature("numeric","surBB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("dduCopula", signature("matrix","surBB6Copula"), linkVineCop.ddu)
-
-# ddv
-setMethod("ddvCopula", signature("numeric","surBB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("ddvCopula", signature("matrix","surBB6Copula"), linkVineCop.ddv)
-
-## random number generator
-setMethod("rCopula", signature("numeric","surBB6Copula"), linkVineCop.r)
-
-setMethod("tau",signature("surBB6Copula"),linkVineCop.tau)
-setMethod("tailIndex",signature("surBB6Copula"),linkVineCop.tailIndex)
-
-#######################
-## BB6 copula 90 deg ##
-#######################
-
-validRotBB6Copula = function(object) {
- if (object at dimension != 2)
- return("Only BB6 copulas of dimension 2 are supported.")
- param <- object at parameters
- upper <- object at param.upbnd
- lower <- object at param.lowbnd
- if (length(param) != length(upper))
- return("Parameter and upper bound have non-equal length")
- if (length(param) != length(lower))
- return("Parameter and lower bound have non-equal length")
- else return (TRUE)
-}
-
-setClass("r90BB6Copula",
- representation = representation("copula", family="numeric"),
- validity = validRotBB6Copula,
- contains = list("copula")
-)
-
-# constructor
-r90BB6Copula <- function (param=c(-1,-1)) {
- if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf)))
- stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].")
- new("r90BB6Copula", dimension = as.integer(2), parameters = param,
- param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, -1),
- family=28, fullname = "90 deg rotated BB6 copula family. Number 28 in VineCopula.")
-}
-
-## density ##
-setMethod("dCopula", signature("numeric","r90BB6Copula"),
- function(u, copula, log) {
- linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula,log)
- })
-setMethod("dCopula", signature("matrix","r90BB6Copula"), linkVineCop.PDF)
-
-## jcdf ##
-setMethod("pCopula", signature("numeric","r90BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("pCopula", signature("matrix","r90BB6Copula"), linkVineCop.r90CDF)
-
-## partial derivatives ##
-# ddu
-setMethod("dduCopula", signature("numeric","r90BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("dduCopula", signature("matrix","r90BB6Copula"), linkVineCop.ddu)
-
-## ddv
-setMethod("ddvCopula", signature("numeric","r90BB6Copula"),
- function(u, copula, ...) {
- linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula)
- })
-setMethod("ddvCopula", signature("matrix","r90BB6Copula"), linkVineCop.ddv)
-
-## random number generator
-setMethod("rCopula", signature("numeric","r90BB6Copula"), linkVineCop.r)
-
-setMethod("tau",signature("r90BB6Copula"),linkVineCop.tau)
-setMethod("tailIndex",signature("r90BB6Copula"),linkVineCop.tailIndex)
-
-###########################
-## BB6 copula 270 degree ##
-###########################
-
-setClass("r270BB6Copula",
- representation = representation("copula", family="numeric"),
- validity = validRotBB6Copula,
- contains = list("copula")
-)
-
-# constructor
-r270BB6Copula <- function (param=c(-1,-1)) {
- if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf)))
- stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].")
- new("r270BB6Copula", dimension = as.integer(2), parameters = param,
- param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, -1),
- family=38, fullname = "270 deg rotated BB6 copula family. Number 38 in VineCopula.")
-}
-
-## density ##
-setMethod("dCopula", signature("numeric","r270BB6Copula"),
- function(u, copula, log) {
- linkVineCop.PDF(matrix(u,ncol=copula at dimension, log),copula)
- })
-setMethod("dCopula", signature("matrix","r270BB6Copula"), linkVineCop.PDF)
-
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/vinecopula -r 114
Mehr Informationen über die Mailingliste Vinecopula-commits